3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
48 #if defined(HAS_SETGROUPS)
55 # include <sys/pstat.h>
58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
61 Signal_t Perl_csighandler(int sig);
65 /* Missing protos on LynxOS */
66 void setruid(uid_t id);
67 void seteuid(uid_t id);
68 void setrgid(uid_t id);
69 void setegid(uid_t id);
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 /* MGS is typedef'ed to struct magic_state in perl.h */
84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
89 PERL_ARGS_ASSERT_SAVE_MAGIC;
91 assert(SvMAGICAL(sv));
92 /* Turning READONLY off for a copy-on-write scalar (including shared
93 hash keys) is a bad idea. */
95 sv_force_normal_flags(sv, 0);
97 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
99 mgs = SSPTR(mgs_ix, MGS*);
101 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
102 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
106 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
107 /* No public flags are set, so promote any private flags to public. */
108 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
113 =for apidoc mg_magical
115 Turns on the magical status of an SV. See C<sv_magic>.
121 Perl_mg_magical(pTHX_ SV *sv)
124 PERL_ARGS_ASSERT_MG_MAGICAL;
126 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
127 const MGVTBL* const vtbl = mg->mg_virtual;
129 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
133 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
140 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
143 S_is_container_magic(const MAGIC *mg)
146 switch (mg->mg_type) {
149 case PERL_MAGIC_regex_global:
150 case PERL_MAGIC_nkeys:
151 #ifdef USE_LOCALE_COLLATE
152 case PERL_MAGIC_collxfrm:
155 case PERL_MAGIC_taint:
157 case PERL_MAGIC_vstring:
158 case PERL_MAGIC_utf8:
159 case PERL_MAGIC_substr:
160 case PERL_MAGIC_defelem:
161 case PERL_MAGIC_arylen:
163 case PERL_MAGIC_backref:
164 case PERL_MAGIC_arylen_p:
165 case PERL_MAGIC_rhash:
166 case PERL_MAGIC_symtab:
176 Do magic after a value is retrieved from the SV. See C<sv_magic>.
182 Perl_mg_get(pTHX_ SV *sv)
185 const I32 mgs_ix = SSNEW(sizeof(MGS));
186 const bool was_temp = (bool)SvTEMP(sv);
188 MAGIC *newmg, *head, *cur, *mg;
189 /* guard against sv having being freed midway by holding a private
192 PERL_ARGS_ASSERT_MG_GET;
194 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
195 cause the SV's buffer to get stolen (and maybe other stuff).
198 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
203 save_magic(mgs_ix, sv);
205 /* We must call svt_get(sv, mg) for each valid entry in the linked
206 list of magic. svt_get() may delete the current entry, add new
207 magic to the head of the list, or upgrade the SV. AMS 20010810 */
209 newmg = cur = head = mg = SvMAGIC(sv);
211 const MGVTBL * const vtbl = mg->mg_virtual;
213 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
214 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
216 /* guard against magic having been deleted - eg FETCH calling
221 /* Don't restore the flags for this entry if it was deleted. */
222 if (mg->mg_flags & MGf_GSKIP)
223 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
226 mg = mg->mg_moremagic;
229 /* Have we finished with the new entries we saw? Start again
230 where we left off (unless there are more new entries). */
238 /* Were any new entries added? */
239 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
246 restore_magic(INT2PTR(void *, (IV)mgs_ix));
248 if (SvREFCNT(sv) == 1) {
249 /* We hold the last reference to this SV, which implies that the
250 SV was deleted as a side effect of the routines we called. */
259 Do magic after a value is assigned to the SV. See C<sv_magic>.
265 Perl_mg_set(pTHX_ SV *sv)
268 const I32 mgs_ix = SSNEW(sizeof(MGS));
272 PERL_ARGS_ASSERT_MG_SET;
274 save_magic(mgs_ix, sv);
276 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
277 const MGVTBL* vtbl = mg->mg_virtual;
278 nextmg = mg->mg_moremagic; /* it may delete itself */
279 if (mg->mg_flags & MGf_GSKIP) {
280 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
281 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
283 if (PL_localizing == 2 && !S_is_container_magic(mg))
285 if (vtbl && vtbl->svt_set)
286 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
289 restore_magic(INT2PTR(void*, (IV)mgs_ix));
294 =for apidoc mg_length
296 Report on the SV's length. See C<sv_magic>.
302 Perl_mg_length(pTHX_ SV *sv)
308 PERL_ARGS_ASSERT_MG_LENGTH;
310 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
311 const MGVTBL * const vtbl = mg->mg_virtual;
312 if (vtbl && vtbl->svt_len) {
313 const I32 mgs_ix = SSNEW(sizeof(MGS));
314 save_magic(mgs_ix, sv);
315 /* omit MGf_GSKIP -- not changed here */
316 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
317 restore_magic(INT2PTR(void*, (IV)mgs_ix));
323 /* You can't know whether it's UTF-8 until you get the string again...
325 const U8 *s = (U8*)SvPV_const(sv, len);
328 len = utf8_length(s, s + len);
335 Perl_mg_size(pTHX_ SV *sv)
339 PERL_ARGS_ASSERT_MG_SIZE;
341 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
342 const MGVTBL* const vtbl = mg->mg_virtual;
343 if (vtbl && vtbl->svt_len) {
344 const I32 mgs_ix = SSNEW(sizeof(MGS));
346 save_magic(mgs_ix, sv);
347 /* omit MGf_GSKIP -- not changed here */
348 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
349 restore_magic(INT2PTR(void*, (IV)mgs_ix));
356 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
360 Perl_croak(aTHX_ "Size magic not implemented");
369 Clear something magical that the SV represents. See C<sv_magic>.
375 Perl_mg_clear(pTHX_ SV *sv)
377 const I32 mgs_ix = SSNEW(sizeof(MGS));
380 PERL_ARGS_ASSERT_MG_CLEAR;
382 save_magic(mgs_ix, sv);
384 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
385 const MGVTBL* const vtbl = mg->mg_virtual;
386 /* omit GSKIP -- never set here */
388 if (vtbl && vtbl->svt_clear)
389 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
392 restore_magic(INT2PTR(void*, (IV)mgs_ix));
399 Finds the magic pointer for type matching the SV. See C<sv_magic>.
405 Perl_mg_find(pTHX_ const SV *sv, int type)
410 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
411 if (mg->mg_type == type)
421 Copies the magic from one SV to another. See C<sv_magic>.
427 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
432 PERL_ARGS_ASSERT_MG_COPY;
434 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
435 const MGVTBL* const vtbl = mg->mg_virtual;
436 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
437 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
440 const char type = mg->mg_type;
441 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
443 (type == PERL_MAGIC_tied)
445 : (type == PERL_MAGIC_regdata && mg->mg_obj)
448 toLOWER(type), key, klen);
457 =for apidoc mg_localize
459 Copy some of the magic from an existing SV to new localized version of
460 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
461 doesn't (eg taint, pos).
467 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
472 PERL_ARGS_ASSERT_MG_LOCALIZE;
474 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
475 const MGVTBL* const vtbl = mg->mg_virtual;
476 if (!S_is_container_magic(mg))
479 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
480 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
482 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
483 mg->mg_ptr, mg->mg_len);
485 /* container types should remain read-only across localization */
486 SvFLAGS(nsv) |= SvREADONLY(sv);
489 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
490 SvFLAGS(nsv) |= SvMAGICAL(sv);
500 Free any magic storage used by the SV. See C<sv_magic>.
506 Perl_mg_free(pTHX_ SV *sv)
511 PERL_ARGS_ASSERT_MG_FREE;
513 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
514 const MGVTBL* const vtbl = mg->mg_virtual;
515 moremagic = mg->mg_moremagic;
516 if (vtbl && vtbl->svt_free)
517 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
518 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
519 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
520 Safefree(mg->mg_ptr);
521 else if (mg->mg_len == HEf_SVKEY)
522 SvREFCNT_dec((SV*)mg->mg_ptr);
524 if (mg->mg_flags & MGf_REFCOUNTED)
525 SvREFCNT_dec(mg->mg_obj);
527 SvMAGIC_set(sv, moremagic);
529 SvMAGIC_set(sv, NULL);
536 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
541 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
544 register const REGEXP * const rx = PM_GETRE(PL_curpm);
546 if (mg->mg_obj) { /* @+ */
547 /* return the number possible */
548 return RX_NPARENS(rx);
550 I32 paren = RX_LASTPAREN(rx);
552 /* return the last filled */
554 && (RX_OFFS(rx)[paren].start == -1
555 || RX_OFFS(rx)[paren].end == -1) )
566 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
570 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
573 register const REGEXP * const rx = PM_GETRE(PL_curpm);
575 register const I32 paren = mg->mg_len;
580 if (paren <= (I32)RX_NPARENS(rx) &&
581 (s = RX_OFFS(rx)[paren].start) != -1 &&
582 (t = RX_OFFS(rx)[paren].end) != -1)
585 if (mg->mg_obj) /* @+ */
590 if (i > 0 && RX_MATCH_UTF8(rx)) {
591 const char * const b = RX_SUBBEG(rx);
593 i = utf8_length((U8*)b, (U8*)(b+i));
604 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
606 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
609 Perl_croak(aTHX_ PL_no_modify);
610 NORETURN_FUNCTION_END;
614 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
619 register const REGEXP * rx;
620 const char * const remaining = mg->mg_ptr + 1;
622 PERL_ARGS_ASSERT_MAGIC_LEN;
624 switch (*mg->mg_ptr) {
626 if (*remaining == '\0') { /* ^P */
628 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
630 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
634 case '\015': /* $^MATCH */
635 if (strEQ(remaining, "ATCH")) {
642 paren = RX_BUFF_IDX_PREMATCH;
646 paren = RX_BUFF_IDX_POSTMATCH;
650 paren = RX_BUFF_IDX_FULLMATCH;
652 case '1': case '2': case '3': case '4':
653 case '5': case '6': case '7': case '8': case '9':
654 paren = atoi(mg->mg_ptr);
656 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
658 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
661 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
664 if (ckWARN(WARN_UNINITIALIZED))
669 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
670 paren = RX_LASTPAREN(rx);
675 case '\016': /* ^N */
676 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
677 paren = RX_LASTCLOSEPAREN(rx);
684 if (!SvPOK(sv) && SvNIOK(sv)) {
692 #define SvRTRIM(sv) STMT_START { \
694 STRLEN len = SvCUR(sv); \
695 char * const p = SvPVX(sv); \
696 while (len > 0 && isSPACE(p[len-1])) \
698 SvCUR_set(sv, len); \
704 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
706 PERL_ARGS_ASSERT_EMULATE_COP_IO;
708 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
709 sv_setsv(sv, &PL_sv_undef);
713 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
714 SV *const value = Perl_refcounted_he_fetch(aTHX_
716 0, "open<", 5, 0, 0);
721 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
722 SV *const value = Perl_refcounted_he_fetch(aTHX_
724 0, "open>", 5, 0, 0);
732 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
736 register char *s = NULL;
738 const char * const remaining = mg->mg_ptr + 1;
739 const char nextchar = *remaining;
741 PERL_ARGS_ASSERT_MAGIC_GET;
743 switch (*mg->mg_ptr) {
744 case '\001': /* ^A */
745 sv_setsv(sv, PL_bodytarget);
747 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
748 if (nextchar == '\0') {
749 sv_setiv(sv, (IV)PL_minus_c);
751 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
752 sv_setiv(sv, (IV)STATUS_NATIVE);
756 case '\004': /* ^D */
757 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
759 case '\005': /* ^E */
760 if (nextchar == '\0') {
761 #if defined(MACOS_TRADITIONAL)
765 sv_setnv(sv,(double)gMacPerl_OSErr);
766 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
770 # include <descrip.h>
771 # include <starlet.h>
773 $DESCRIPTOR(msgdsc,msg);
774 sv_setnv(sv,(NV) vaxc$errno);
775 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
776 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
781 if (!(_emx_env & 0x200)) { /* Under DOS */
782 sv_setnv(sv, (NV)errno);
783 sv_setpv(sv, errno ? Strerror(errno) : "");
785 if (errno != errno_isOS2) {
786 const int tmp = _syserrno();
787 if (tmp) /* 2nd call to _syserrno() makes it 0 */
790 sv_setnv(sv, (NV)Perl_rc);
791 sv_setpv(sv, os2error(Perl_rc));
795 const DWORD dwErr = GetLastError();
796 sv_setnv(sv, (NV)dwErr);
798 PerlProc_GetOSError(sv, dwErr);
801 sv_setpvn(sv, "", 0);
806 const int saveerrno = errno;
807 sv_setnv(sv, (NV)errno);
808 sv_setpv(sv, errno ? Strerror(errno) : "");
813 SvNOK_on(sv); /* what a wonderful hack! */
815 else if (strEQ(remaining, "NCODING"))
816 sv_setsv(sv, PL_encoding);
818 case '\006': /* ^F */
819 sv_setiv(sv, (IV)PL_maxsysfd);
821 case '\010': /* ^H */
822 sv_setiv(sv, (IV)PL_hints);
824 case '\011': /* ^I */ /* NOT \t in EBCDIC */
825 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
827 case '\017': /* ^O & ^OPEN */
828 if (nextchar == '\0') {
829 sv_setpv(sv, PL_osname);
832 else if (strEQ(remaining, "PEN")) {
833 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
837 if (nextchar == '\0') { /* ^P */
838 sv_setiv(sv, (IV)PL_perldb);
839 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
840 goto do_prematch_fetch;
841 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
842 goto do_postmatch_fetch;
845 case '\023': /* ^S */
846 if (nextchar == '\0') {
847 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
850 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
855 case '\024': /* ^T */
856 if (nextchar == '\0') {
858 sv_setnv(sv, PL_basetime);
860 sv_setiv(sv, (IV)PL_basetime);
863 else if (strEQ(remaining, "AINT"))
864 sv_setiv(sv, PL_tainting
865 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
868 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
869 if (strEQ(remaining, "NICODE"))
870 sv_setuv(sv, (UV) PL_unicode);
871 else if (strEQ(remaining, "TF8LOCALE"))
872 sv_setuv(sv, (UV) PL_utf8locale);
873 else if (strEQ(remaining, "TF8CACHE"))
874 sv_setiv(sv, (IV) PL_utf8cache);
876 case '\027': /* ^W & $^WARNING_BITS */
877 if (nextchar == '\0')
878 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
879 else if (strEQ(remaining, "ARNING_BITS")) {
880 if (PL_compiling.cop_warnings == pWARN_NONE) {
881 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
883 else if (PL_compiling.cop_warnings == pWARN_STD) {
886 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
890 else if (PL_compiling.cop_warnings == pWARN_ALL) {
891 /* Get the bit mask for $warnings::Bits{all}, because
892 * it could have been extended by warnings::register */
893 HV * const bits=get_hv("warnings::Bits", FALSE);
895 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
897 sv_setsv(sv, *bits_all);
900 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
904 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
905 *PL_compiling.cop_warnings);
910 case '\015': /* $^MATCH */
911 if (strEQ(remaining, "ATCH")) {
912 case '1': case '2': case '3': case '4':
913 case '5': case '6': case '7': case '8': case '9': case '&':
914 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
916 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
917 * XXX Does the new way break anything?
919 paren = atoi(mg->mg_ptr); /* $& is in [0] */
920 CALLREG_NUMBUF_FETCH(rx,paren,sv);
923 sv_setsv(sv,&PL_sv_undef);
927 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
928 if (RX_LASTPAREN(rx)) {
929 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
933 sv_setsv(sv,&PL_sv_undef);
935 case '\016': /* ^N */
936 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
937 if (RX_LASTCLOSEPAREN(rx)) {
938 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
943 sv_setsv(sv,&PL_sv_undef);
947 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
948 CALLREG_NUMBUF_FETCH(rx,-2,sv);
951 sv_setsv(sv,&PL_sv_undef);
955 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
956 CALLREG_NUMBUF_FETCH(rx,-1,sv);
959 sv_setsv(sv,&PL_sv_undef);
962 if (GvIO(PL_last_in_gv)) {
963 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
968 sv_setiv(sv, (IV)STATUS_CURRENT);
969 #ifdef COMPLEX_STATUS
970 LvTARGOFF(sv) = PL_statusvalue;
971 LvTARGLEN(sv) = PL_statusvalue_vms;
976 if (GvIOp(PL_defoutgv))
977 s = IoTOP_NAME(GvIOp(PL_defoutgv));
981 sv_setpv(sv,GvENAME(PL_defoutgv));
982 sv_catpvs(sv,"_TOP");
986 if (GvIOp(PL_defoutgv))
987 s = IoFMT_NAME(GvIOp(PL_defoutgv));
989 s = GvENAME(PL_defoutgv);
993 if (GvIOp(PL_defoutgv))
994 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
997 if (GvIOp(PL_defoutgv))
998 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1001 if (GvIOp(PL_defoutgv))
1002 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1009 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1012 if (GvIOp(PL_defoutgv))
1013 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1019 sv_copypv(sv, PL_ors_sv);
1023 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1024 sv_setpv(sv, errno ? Strerror(errno) : "");
1027 const int saveerrno = errno;
1028 sv_setnv(sv, (NV)errno);
1030 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1031 sv_setpv(sv, os2error(Perl_rc));
1034 sv_setpv(sv, errno ? Strerror(errno) : "");
1039 SvNOK_on(sv); /* what a wonderful hack! */
1042 sv_setiv(sv, (IV)PL_uid);
1045 sv_setiv(sv, (IV)PL_euid);
1048 sv_setiv(sv, (IV)PL_gid);
1051 sv_setiv(sv, (IV)PL_egid);
1053 #ifdef HAS_GETGROUPS
1055 Groups_t *gary = NULL;
1056 I32 i, num_groups = getgroups(0, gary);
1057 Newx(gary, num_groups, Groups_t);
1058 num_groups = getgroups(num_groups, gary);
1059 for (i = 0; i < num_groups; i++)
1060 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1063 (void)SvIOK_on(sv); /* what a wonderful hack! */
1066 #ifndef MACOS_TRADITIONAL
1075 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1077 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1079 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1081 if (uf && uf->uf_val)
1082 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1087 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1090 STRLEN len = 0, klen;
1091 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1092 const char * const ptr = MgPV_const(mg,klen);
1095 PERL_ARGS_ASSERT_MAGIC_SETENV;
1097 #ifdef DYNAMIC_ENV_FETCH
1098 /* We just undefd an environment var. Is a replacement */
1099 /* waiting in the wings? */
1101 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1103 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1107 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1108 /* And you'll never guess what the dog had */
1109 /* in its mouth... */
1111 MgTAINTEDDIR_off(mg);
1113 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1114 char pathbuf[256], eltbuf[256], *cp, *elt;
1118 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1120 do { /* DCL$PATH may be a search list */
1121 while (1) { /* as may dev portion of any element */
1122 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1123 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1124 cando_by_name(S_IWUSR,0,elt) ) {
1125 MgTAINTEDDIR_on(mg);
1129 if ((cp = strchr(elt, ':')) != NULL)
1131 if (my_trnlnm(elt, eltbuf, j++))
1137 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1140 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1141 const char * const strend = s + len;
1143 while (s < strend) {
1147 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1148 const char path_sep = '|';
1150 const char path_sep = ':';
1152 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1153 s, strend, path_sep, &i);
1155 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1157 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1159 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1161 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1162 MgTAINTEDDIR_on(mg);
1168 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1174 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1176 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1177 PERL_UNUSED_ARG(sv);
1178 my_setenv(MgPV_nolen_const(mg),NULL);
1183 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1186 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1187 PERL_UNUSED_ARG(mg);
1189 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1191 if (PL_localizing) {
1194 hv_iterinit((HV*)sv);
1195 while ((entry = hv_iternext((HV*)sv))) {
1197 my_setenv(hv_iterkey(entry, &keylen),
1198 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1206 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1209 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1210 PERL_UNUSED_ARG(sv);
1211 PERL_UNUSED_ARG(mg);
1213 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1221 #ifdef HAS_SIGPROCMASK
1223 restore_sigmask(pTHX_ SV *save_sv)
1225 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1226 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1230 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1233 /* Are we fetching a signal entry? */
1234 const I32 i = whichsig(MgPV_nolen_const(mg));
1236 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1240 sv_setsv(sv,PL_psig_ptr[i]);
1242 Sighandler_t sigstate = rsignal_state(i);
1243 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1244 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1247 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1248 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1251 /* cache state so we don't fetch it again */
1252 if(sigstate == (Sighandler_t) SIG_IGN)
1253 sv_setpvs(sv,"IGNORE");
1255 sv_setsv(sv,&PL_sv_undef);
1256 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1263 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1265 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1266 * refactoring might be in order.
1269 register const char * const s = MgPV_nolen_const(mg);
1270 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1271 PERL_UNUSED_ARG(sv);
1274 if (strEQ(s,"__DIE__"))
1276 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1279 SV *const to_dec = *svp;
1281 SvREFCNT_dec(to_dec);
1285 /* Are we clearing a signal entry? */
1286 const I32 i = whichsig(s);
1288 #ifdef HAS_SIGPROCMASK
1291 /* Avoid having the signal arrive at a bad time, if possible. */
1294 sigprocmask(SIG_BLOCK, &set, &save);
1296 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1297 SAVEFREESV(save_sv);
1298 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1301 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1302 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1304 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1305 PL_sig_defaulting[i] = 1;
1306 (void)rsignal(i, PL_csighandlerp);
1308 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1310 if(PL_psig_name[i]) {
1311 SvREFCNT_dec(PL_psig_name[i]);
1314 if(PL_psig_ptr[i]) {
1315 SV * const to_dec=PL_psig_ptr[i];
1318 SvREFCNT_dec(to_dec);
1328 * The signal handling nomenclature has gotten a bit confusing since the advent of
1329 * safe signals. S_raise_signal only raises signals by analogy with what the
1330 * underlying system's signal mechanism does. It might be more proper to say that
1331 * it defers signals that have already been raised and caught.
1333 * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
1334 * in the sense of being on the system's signal queue in between raising and delivery.
1335 * They are only pending on Perl's deferral list, i.e., they track deferred signals
1336 * awaiting delivery after the current Perl opcode completes and say nothing about
1337 * signals raised but not yet caught in the underlying signal implementation.
1340 #ifndef SIG_PENDING_DIE_COUNT
1341 # define SIG_PENDING_DIE_COUNT 120
1345 S_raise_signal(pTHX_ int sig)
1348 /* Set a flag to say this signal is pending */
1349 PL_psig_pend[sig]++;
1350 /* And one to say _a_ signal is pending */
1351 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1352 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1353 (unsigned long)SIG_PENDING_DIE_COUNT);
1357 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1358 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1360 Perl_csighandler(int sig)
1363 #ifdef PERL_GET_SIG_CONTEXT
1364 dTHXa(PERL_GET_SIG_CONTEXT);
1368 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1370 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1371 (void) rsignal(sig, PL_csighandlerp);
1372 if (PL_sig_ignoring[sig]) return;
1374 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1375 if (PL_sig_defaulting[sig])
1376 #ifdef KILL_BY_SIGPRC
1377 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1382 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1394 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1395 /* Call the perl level handler now--
1396 * with risk we may be in malloc() etc. */
1397 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1398 (*PL_sighandlerp)(sig, NULL, NULL);
1400 (*PL_sighandlerp)(sig);
1403 S_raise_signal(aTHX_ sig);
1406 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1408 Perl_csighandler_init(void)
1411 if (PL_sig_handlers_initted) return;
1413 for (sig = 1; sig < SIG_SIZE; sig++) {
1414 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1416 PL_sig_defaulting[sig] = 1;
1417 (void) rsignal(sig, PL_csighandlerp);
1419 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1420 PL_sig_ignoring[sig] = 0;
1423 PL_sig_handlers_initted = 1;
1428 Perl_despatch_signals(pTHX)
1433 for (sig = 1; sig < SIG_SIZE; sig++) {
1434 if (PL_psig_pend[sig]) {
1435 PERL_BLOCKSIG_ADD(set, sig);
1436 PL_psig_pend[sig] = 0;
1437 PERL_BLOCKSIG_BLOCK(set);
1438 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1439 (*PL_sighandlerp)(sig, NULL, NULL);
1441 (*PL_sighandlerp)(sig);
1443 PERL_BLOCKSIG_UNBLOCK(set);
1449 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1454 /* Need to be careful with SvREFCNT_dec(), because that can have side
1455 * effects (due to closures). We must make sure that the new disposition
1456 * is in place before it is called.
1460 #ifdef HAS_SIGPROCMASK
1464 register const char *s = MgPV_const(mg,len);
1466 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1469 if (strEQ(s,"__DIE__"))
1471 else if (strEQ(s,"__WARN__"))
1474 Perl_croak(aTHX_ "No such hook: %s", s);
1477 if (*svp != PERL_WARNHOOK_FATAL)
1483 i = whichsig(s); /* ...no, a brick */
1485 if (ckWARN(WARN_SIGNAL))
1486 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1489 #ifdef HAS_SIGPROCMASK
1490 /* Avoid having the signal arrive at a bad time, if possible. */
1493 sigprocmask(SIG_BLOCK, &set, &save);
1495 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1496 SAVEFREESV(save_sv);
1497 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1500 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1501 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1503 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1504 PL_sig_ignoring[i] = 0;
1506 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1507 PL_sig_defaulting[i] = 0;
1509 SvREFCNT_dec(PL_psig_name[i]);
1510 to_dec = PL_psig_ptr[i];
1511 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1512 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1513 PL_psig_name[i] = newSVpvn(s, len);
1514 SvREADONLY_on(PL_psig_name[i]);
1516 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1518 (void)rsignal(i, PL_csighandlerp);
1519 #ifdef HAS_SIGPROCMASK
1524 *svp = SvREFCNT_inc_simple_NN(sv);
1526 SvREFCNT_dec(to_dec);
1529 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1530 if (strEQ(s,"IGNORE")) {
1532 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1533 PL_sig_ignoring[i] = 1;
1534 (void)rsignal(i, PL_csighandlerp);
1536 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1540 else if (strEQ(s,"DEFAULT") || !*s) {
1542 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1544 PL_sig_defaulting[i] = 1;
1545 (void)rsignal(i, PL_csighandlerp);
1548 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1553 * We should warn if HINT_STRICT_REFS, but without
1554 * access to a known hint bit in a known OP, we can't
1555 * tell whether HINT_STRICT_REFS is in force or not.
1557 if (!strchr(s,':') && !strchr(s,'\''))
1558 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1560 (void)rsignal(i, PL_csighandlerp);
1562 *svp = SvREFCNT_inc_simple_NN(sv);
1564 #ifdef HAS_SIGPROCMASK
1569 SvREFCNT_dec(to_dec);
1572 #endif /* !PERL_MICRO */
1575 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1580 PERL_ARGS_ASSERT_MAGIC_SETISA;
1581 PERL_UNUSED_ARG(sv);
1583 /* Bail out if destruction is going on */
1584 if(PL_dirty) return 0;
1586 /* Skip _isaelem because _isa will handle it shortly */
1587 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1590 /* XXX Once it's possible, we need to
1591 detect that our @ISA is aliased in
1592 other stashes, and act on the stashes
1593 of all of the aliases */
1595 /* The first case occurs via setisa,
1596 the second via setisa_elem, which
1597 calls this same magic */
1599 SvTYPE(mg->mg_obj) == SVt_PVGV
1601 : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1604 mro_isa_changed_in(stash);
1610 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1615 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1617 /* Bail out if destruction is going on */
1618 if(PL_dirty) return 0;
1622 /* XXX see comments in magic_setisa */
1624 SvTYPE(mg->mg_obj) == SVt_PVGV
1626 : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1629 mro_isa_changed_in(stash);
1635 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1638 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1639 PERL_UNUSED_ARG(sv);
1640 PERL_UNUSED_ARG(mg);
1641 PL_amagic_generation++;
1647 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1649 HV * const hv = (HV*)LvTARG(sv);
1652 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1653 PERL_UNUSED_ARG(mg);
1656 (void) hv_iterinit(hv);
1657 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1660 while (hv_iternext(hv))
1665 sv_setiv(sv, (IV)i);
1670 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1672 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1673 PERL_UNUSED_ARG(mg);
1675 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1680 /* caller is responsible for stack switching/cleanup */
1682 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1687 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1691 PUSHs(SvTIED_obj(sv, mg));
1694 if (mg->mg_len >= 0)
1695 mPUSHp(mg->mg_ptr, mg->mg_len);
1696 else if (mg->mg_len == HEf_SVKEY)
1697 PUSHs((SV*)mg->mg_ptr);
1699 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1708 return call_method(meth, flags);
1712 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1716 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1720 PUSHSTACKi(PERLSI_MAGIC);
1722 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1723 sv_setsv(sv, *PL_stack_sp--);
1733 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1735 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1738 mg->mg_flags |= MGf_GSKIP;
1739 magic_methpack(sv,mg,"FETCH");
1744 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1748 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1751 PUSHSTACKi(PERLSI_MAGIC);
1752 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1759 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1761 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1763 return magic_methpack(sv,mg,"DELETE");
1768 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1773 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1777 PUSHSTACKi(PERLSI_MAGIC);
1778 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1779 sv = *PL_stack_sp--;
1780 retval = SvIV(sv)-1;
1782 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1787 return (U32) retval;
1791 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1795 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1798 PUSHSTACKi(PERLSI_MAGIC);
1800 XPUSHs(SvTIED_obj(sv, mg));
1802 call_method("CLEAR", G_SCALAR|G_DISCARD);
1810 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1813 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1815 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1819 PUSHSTACKi(PERLSI_MAGIC);
1822 PUSHs(SvTIED_obj(sv, mg));
1827 if (call_method(meth, G_SCALAR))
1828 sv_setsv(key, *PL_stack_sp--);
1837 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1839 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1841 return magic_methpack(sv,mg,"EXISTS");
1845 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1849 SV * const tied = SvTIED_obj((SV*)hv, mg);
1850 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1852 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1854 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1856 if (HvEITER_get(hv))
1857 /* we are in an iteration so the hash cannot be empty */
1859 /* no xhv_eiter so now use FIRSTKEY */
1860 key = sv_newmortal();
1861 magic_nextpack((SV*)hv, mg, key);
1862 HvEITER_set(hv, NULL); /* need to reset iterator */
1863 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1866 /* there is a SCALAR method that we can call */
1868 PUSHSTACKi(PERLSI_MAGIC);
1874 if (call_method("SCALAR", G_SCALAR))
1875 retval = *PL_stack_sp--;
1877 retval = &PL_sv_undef;
1884 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1887 GV * const gv = PL_DBline;
1888 const I32 i = SvTRUE(sv);
1889 SV ** const svp = av_fetch(GvAV(gv),
1890 atoi(MgPV_nolen_const(mg)), FALSE);
1892 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1894 if (svp && SvIOKp(*svp)) {
1895 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1897 /* set or clear breakpoint in the relevant control op */
1899 o->op_flags |= OPf_SPECIAL;
1901 o->op_flags &= ~OPf_SPECIAL;
1908 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1911 const AV * const obj = (AV*)mg->mg_obj;
1913 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1916 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1924 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1927 AV * const obj = (AV*)mg->mg_obj;
1929 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1932 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1934 if (ckWARN(WARN_MISC))
1935 Perl_warner(aTHX_ packWARN(WARN_MISC),
1936 "Attempt to set length of freed array");
1942 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1946 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1947 PERL_UNUSED_ARG(sv);
1949 /* during global destruction, mg_obj may already have been freed */
1950 if (PL_in_clean_all)
1953 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1956 /* arylen scalar holds a pointer back to the array, but doesn't own a
1957 reference. Hence the we (the array) are about to go away with it
1958 still pointing at us. Clear its pointer, else it would be pointing
1959 at free memory. See the comment in sv_magic about reference loops,
1960 and why it can't own a reference to us. */
1967 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1970 SV* const lsv = LvTARG(sv);
1972 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1973 PERL_UNUSED_ARG(mg);
1975 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1976 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1977 if (found && found->mg_len >= 0) {
1978 I32 i = found->mg_len;
1980 sv_pos_b2u(lsv, &i);
1981 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1990 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1993 SV* const lsv = LvTARG(sv);
1999 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2000 PERL_UNUSED_ARG(mg);
2002 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2003 found = mg_find(lsv, PERL_MAGIC_regex_global);
2009 #ifdef PERL_OLD_COPY_ON_WRITE
2011 sv_force_normal_flags(lsv, 0);
2013 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2016 else if (!SvOK(sv)) {
2020 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2022 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2025 ulen = sv_len_utf8(lsv);
2035 else if (pos > (SSize_t)len)
2040 sv_pos_u2b(lsv, &p, 0);
2044 found->mg_len = pos;
2045 found->mg_flags &= ~MGf_MINMATCH;
2051 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2054 SV * const lsv = LvTARG(sv);
2055 const char * const tmps = SvPV_const(lsv,len);
2056 I32 offs = LvTARGOFF(sv);
2057 I32 rem = LvTARGLEN(sv);
2059 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2060 PERL_UNUSED_ARG(mg);
2063 sv_pos_u2b(lsv, &offs, &rem);
2064 if (offs > (I32)len)
2066 if (rem + offs > (I32)len)
2068 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
2075 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2079 const char * const tmps = SvPV_const(sv, len);
2080 SV * const lsv = LvTARG(sv);
2081 I32 lvoff = LvTARGOFF(sv);
2082 I32 lvlen = LvTARGLEN(sv);
2084 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2085 PERL_UNUSED_ARG(mg);
2088 sv_utf8_upgrade(lsv);
2089 sv_pos_u2b(lsv, &lvoff, &lvlen);
2090 sv_insert(lsv, lvoff, lvlen, tmps, len);
2091 LvTARGLEN(sv) = sv_len_utf8(sv);
2094 else if (lsv && SvUTF8(lsv)) {
2096 sv_pos_u2b(lsv, &lvoff, &lvlen);
2097 LvTARGLEN(sv) = len;
2098 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2099 sv_insert(lsv, lvoff, lvlen, utf8, len);
2103 sv_insert(lsv, lvoff, lvlen, tmps, len);
2104 LvTARGLEN(sv) = len;
2112 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2116 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2117 PERL_UNUSED_ARG(sv);
2119 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2124 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2128 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2129 PERL_UNUSED_ARG(sv);
2131 /* update taint status */
2140 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2142 SV * const lsv = LvTARG(sv);
2144 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2145 PERL_UNUSED_ARG(mg);
2148 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2156 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2158 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2159 PERL_UNUSED_ARG(mg);
2160 do_vecset(sv); /* XXX slurp this routine */
2165 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2170 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2172 if (LvTARGLEN(sv)) {
2174 SV * const ahv = LvTARG(sv);
2175 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2180 AV* const av = (AV*)LvTARG(sv);
2181 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2182 targ = AvARRAY(av)[LvTARGOFF(sv)];
2184 if (targ && (targ != &PL_sv_undef)) {
2185 /* somebody else defined it for us */
2186 SvREFCNT_dec(LvTARG(sv));
2187 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2189 SvREFCNT_dec(mg->mg_obj);
2191 mg->mg_flags &= ~MGf_REFCOUNTED;
2196 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2201 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2203 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2204 PERL_UNUSED_ARG(mg);
2208 sv_setsv(LvTARG(sv), sv);
2209 SvSETMAGIC(LvTARG(sv));
2215 Perl_vivify_defelem(pTHX_ SV *sv)
2221 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2223 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2226 SV * const ahv = LvTARG(sv);
2227 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2230 if (!value || value == &PL_sv_undef)
2231 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2234 AV* const av = (AV*)LvTARG(sv);
2235 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2236 LvTARG(sv) = NULL; /* array can't be extended */
2238 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2239 if (!svp || (value = *svp) == &PL_sv_undef)
2240 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2243 SvREFCNT_inc_simple_void(value);
2244 SvREFCNT_dec(LvTARG(sv));
2247 SvREFCNT_dec(mg->mg_obj);
2249 mg->mg_flags &= ~MGf_REFCOUNTED;
2253 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2255 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2256 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2260 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2262 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2263 PERL_UNUSED_CONTEXT;
2270 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2272 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2274 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2276 if (uf && uf->uf_set)
2277 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2282 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2284 const char type = mg->mg_type;
2286 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2288 if (type == PERL_MAGIC_qr) {
2289 } else if (type == PERL_MAGIC_bm) {
2293 assert(type == PERL_MAGIC_fm);
2296 return sv_unmagic(sv, type);
2299 #ifdef USE_LOCALE_COLLATE
2301 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2303 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2306 * RenE<eacute> Descartes said "I think not."
2307 * and vanished with a faint plop.
2309 PERL_UNUSED_CONTEXT;
2310 PERL_UNUSED_ARG(sv);
2312 Safefree(mg->mg_ptr);
2318 #endif /* USE_LOCALE_COLLATE */
2320 /* Just clear the UTF-8 cache data. */
2322 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2324 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2325 PERL_UNUSED_CONTEXT;
2326 PERL_UNUSED_ARG(sv);
2327 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2329 mg->mg_len = -1; /* The mg_len holds the len cache. */
2334 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2337 register const char *s;
2339 register const REGEXP * rx;
2340 const char * const remaining = mg->mg_ptr + 1;
2344 PERL_ARGS_ASSERT_MAGIC_SET;
2346 switch (*mg->mg_ptr) {
2347 case '\015': /* $^MATCH */
2348 if (strEQ(remaining, "ATCH"))
2350 case '`': /* ${^PREMATCH} caught below */
2352 paren = RX_BUFF_IDX_PREMATCH;
2354 case '\'': /* ${^POSTMATCH} caught below */
2356 paren = RX_BUFF_IDX_POSTMATCH;
2360 paren = RX_BUFF_IDX_FULLMATCH;
2362 case '1': case '2': case '3': case '4':
2363 case '5': case '6': case '7': case '8': case '9':
2364 paren = atoi(mg->mg_ptr);
2366 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2367 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2370 /* Croak with a READONLY error when a numbered match var is
2371 * set without a previous pattern match. Unless it's C<local $1>
2373 if (!PL_localizing) {
2374 Perl_croak(aTHX_ PL_no_modify);
2377 case '\001': /* ^A */
2378 sv_setsv(PL_bodytarget, sv);
2380 case '\003': /* ^C */
2381 PL_minus_c = (bool)SvIV(sv);
2384 case '\004': /* ^D */
2386 s = SvPV_nolen_const(sv);
2387 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2388 DEBUG_x(dump_all());
2390 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2393 case '\005': /* ^E */
2394 if (*(mg->mg_ptr+1) == '\0') {
2395 #ifdef MACOS_TRADITIONAL
2396 gMacPerl_OSErr = SvIV(sv);
2399 set_vaxc_errno(SvIV(sv));
2402 SetLastError( SvIV(sv) );
2405 os2_setsyserrno(SvIV(sv));
2407 /* will anyone ever use this? */
2408 SETERRNO(SvIV(sv), 4);
2414 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2416 SvREFCNT_dec(PL_encoding);
2417 if (SvOK(sv) || SvGMAGICAL(sv)) {
2418 PL_encoding = newSVsv(sv);
2425 case '\006': /* ^F */
2426 PL_maxsysfd = SvIV(sv);
2428 case '\010': /* ^H */
2429 PL_hints = SvIV(sv);
2431 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2432 Safefree(PL_inplace);
2433 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2435 case '\017': /* ^O */
2436 if (*(mg->mg_ptr+1) == '\0') {
2437 Safefree(PL_osname);
2440 TAINT_PROPER("assigning to $^O");
2441 PL_osname = savesvpv(sv);
2444 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2446 const char *const start = SvPV(sv, len);
2447 const char *out = (const char*)memchr(start, '\0', len);
2449 struct refcounted_he *tmp_he;
2452 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2454 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2456 /* Opening for input is more common than opening for output, so
2457 ensure that hints for input are sooner on linked list. */
2458 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2459 SVs_TEMP | SvUTF8(sv))
2460 : newSVpvn_flags("", 0, SVs_TEMP | SvUTF8(sv));
2463 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2464 newSVpvs_flags("open>", SVs_TEMP),
2467 /* The UTF-8 setting is carried over */
2468 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2470 PL_compiling.cop_hints_hash
2471 = Perl_refcounted_he_new(aTHX_ tmp_he,
2472 newSVpvs_flags("open<", SVs_TEMP),
2476 case '\020': /* ^P */
2477 if (*remaining == '\0') { /* ^P */
2478 PL_perldb = SvIV(sv);
2479 if (PL_perldb && !PL_DBsingle)
2482 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2484 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2487 case '\024': /* ^T */
2489 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2491 PL_basetime = (Time_t)SvIV(sv);
2494 case '\025': /* ^UTF8CACHE */
2495 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2496 PL_utf8cache = (signed char) sv_2iv(sv);
2499 case '\027': /* ^W & $^WARNING_BITS */
2500 if (*(mg->mg_ptr+1) == '\0') {
2501 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2503 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2504 | (i ? G_WARN_ON : G_WARN_OFF) ;
2507 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2508 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2509 if (!SvPOK(sv) && PL_localizing) {
2510 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2511 PL_compiling.cop_warnings = pWARN_NONE;
2516 int accumulate = 0 ;
2517 int any_fatals = 0 ;
2518 const char * const ptr = SvPV_const(sv, len) ;
2519 for (i = 0 ; i < len ; ++i) {
2520 accumulate |= ptr[i] ;
2521 any_fatals |= (ptr[i] & 0xAA) ;
2524 if (!specialWARN(PL_compiling.cop_warnings))
2525 PerlMemShared_free(PL_compiling.cop_warnings);
2526 PL_compiling.cop_warnings = pWARN_NONE;
2528 /* Yuck. I can't see how to abstract this: */
2529 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2530 WARN_ALL) && !any_fatals) {
2531 if (!specialWARN(PL_compiling.cop_warnings))
2532 PerlMemShared_free(PL_compiling.cop_warnings);
2533 PL_compiling.cop_warnings = pWARN_ALL;
2534 PL_dowarn |= G_WARN_ONCE ;
2538 const char *const p = SvPV_const(sv, len);
2540 PL_compiling.cop_warnings
2541 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2544 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2545 PL_dowarn |= G_WARN_ONCE ;
2553 if (PL_localizing) {
2554 if (PL_localizing == 1)
2555 SAVESPTR(PL_last_in_gv);
2557 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2558 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2561 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2562 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2563 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2566 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2567 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2568 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2571 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2574 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2575 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2576 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2579 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2583 IO * const io = GvIOp(PL_defoutgv);
2586 if ((SvIV(sv)) == 0)
2587 IoFLAGS(io) &= ~IOf_FLUSH;
2589 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2590 PerlIO *ofp = IoOFP(io);
2592 (void)PerlIO_flush(ofp);
2593 IoFLAGS(io) |= IOf_FLUSH;
2599 SvREFCNT_dec(PL_rs);
2600 PL_rs = newSVsv(sv);
2604 SvREFCNT_dec(PL_ors_sv);
2605 if (SvOK(sv) || SvGMAGICAL(sv)) {
2606 PL_ors_sv = newSVsv(sv);
2614 SvREFCNT_dec(PL_ofs_sv);
2615 if (SvOK(sv) || SvGMAGICAL(sv)) {
2616 PL_ofs_sv = newSVsv(sv);
2623 CopARYBASE_set(&PL_compiling, SvIV(sv));
2626 #ifdef COMPLEX_STATUS
2627 if (PL_localizing == 2) {
2628 PL_statusvalue = LvTARGOFF(sv);
2629 PL_statusvalue_vms = LvTARGLEN(sv);
2633 #ifdef VMSISH_STATUS
2635 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2638 STATUS_UNIX_EXIT_SET(SvIV(sv));
2643 # define PERL_VMS_BANG vaxc$errno
2645 # define PERL_VMS_BANG 0
2647 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2648 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2653 if (PL_delaymagic) {
2654 PL_delaymagic |= DM_RUID;
2655 break; /* don't do magic till later */
2658 (void)setruid((Uid_t)PL_uid);
2661 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2663 #ifdef HAS_SETRESUID
2664 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2666 if (PL_uid == PL_euid) { /* special case $< = $> */
2668 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2669 if (PL_uid != 0 && PerlProc_getuid() == 0)
2670 (void)PerlProc_setuid(0);
2672 (void)PerlProc_setuid(PL_uid);
2674 PL_uid = PerlProc_getuid();
2675 Perl_croak(aTHX_ "setruid() not implemented");
2680 PL_uid = PerlProc_getuid();
2681 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2685 if (PL_delaymagic) {
2686 PL_delaymagic |= DM_EUID;
2687 break; /* don't do magic till later */
2690 (void)seteuid((Uid_t)PL_euid);
2693 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2695 #ifdef HAS_SETRESUID
2696 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2698 if (PL_euid == PL_uid) /* special case $> = $< */
2699 PerlProc_setuid(PL_euid);
2701 PL_euid = PerlProc_geteuid();
2702 Perl_croak(aTHX_ "seteuid() not implemented");
2707 PL_euid = PerlProc_geteuid();
2708 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2712 if (PL_delaymagic) {
2713 PL_delaymagic |= DM_RGID;
2714 break; /* don't do magic till later */
2717 (void)setrgid((Gid_t)PL_gid);
2720 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2722 #ifdef HAS_SETRESGID
2723 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2725 if (PL_gid == PL_egid) /* special case $( = $) */
2726 (void)PerlProc_setgid(PL_gid);
2728 PL_gid = PerlProc_getgid();
2729 Perl_croak(aTHX_ "setrgid() not implemented");
2734 PL_gid = PerlProc_getgid();
2735 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2738 #ifdef HAS_SETGROUPS
2740 const char *p = SvPV_const(sv, len);
2741 Groups_t *gary = NULL;
2746 for (i = 0; i < NGROUPS; ++i) {
2747 while (*p && !isSPACE(*p))
2754 Newx(gary, i + 1, Groups_t);
2756 Renew(gary, i + 1, Groups_t);
2760 (void)setgroups(i, gary);
2763 #else /* HAS_SETGROUPS */
2765 #endif /* HAS_SETGROUPS */
2766 if (PL_delaymagic) {
2767 PL_delaymagic |= DM_EGID;
2768 break; /* don't do magic till later */
2771 (void)setegid((Gid_t)PL_egid);
2774 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2776 #ifdef HAS_SETRESGID
2777 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2779 if (PL_egid == PL_gid) /* special case $) = $( */
2780 (void)PerlProc_setgid(PL_egid);
2782 PL_egid = PerlProc_getegid();
2783 Perl_croak(aTHX_ "setegid() not implemented");
2788 PL_egid = PerlProc_getegid();
2789 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2792 PL_chopset = SvPV_force(sv,len);
2794 #ifndef MACOS_TRADITIONAL
2796 LOCK_DOLLARZERO_MUTEX;
2797 #ifdef HAS_SETPROCTITLE
2798 /* The BSDs don't show the argv[] in ps(1) output, they
2799 * show a string from the process struct and provide
2800 * the setproctitle() routine to manipulate that. */
2801 if (PL_origalen != 1) {
2802 s = SvPV_const(sv, len);
2803 # if __FreeBSD_version > 410001
2804 /* The leading "-" removes the "perl: " prefix,
2805 * but not the "(perl) suffix from the ps(1)
2806 * output, because that's what ps(1) shows if the
2807 * argv[] is modified. */
2808 setproctitle("-%s", s);
2809 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2810 /* This doesn't really work if you assume that
2811 * $0 = 'foobar'; will wipe out 'perl' from the $0
2812 * because in ps(1) output the result will be like
2813 * sprintf("perl: %s (perl)", s)
2814 * I guess this is a security feature:
2815 * one (a user process) cannot get rid of the original name.
2817 setproctitle("%s", s);
2820 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2821 if (PL_origalen != 1) {
2823 s = SvPV_const(sv, len);
2824 un.pst_command = (char *)s;
2825 pstat(PSTAT_SETCMD, un, len, 0, 0);
2828 if (PL_origalen > 1) {
2829 /* PL_origalen is set in perl_parse(). */
2830 s = SvPV_force(sv,len);
2831 if (len >= (STRLEN)PL_origalen-1) {
2832 /* Longer than original, will be truncated. We assume that
2833 * PL_origalen bytes are available. */
2834 Copy(s, PL_origargv[0], PL_origalen-1, char);
2837 /* Shorter than original, will be padded. */
2839 /* Special case for Mac OS X: see [perl #38868] */
2842 /* Is the space counterintuitive? Yes.
2843 * (You were expecting \0?)
2844 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2846 const int pad = ' ';
2848 Copy(s, PL_origargv[0], len, char);
2849 PL_origargv[0][len] = 0;
2850 memset(PL_origargv[0] + len + 1,
2851 pad, PL_origalen - len - 1);
2853 PL_origargv[0][PL_origalen-1] = 0;
2854 for (i = 1; i < PL_origargc; i++)
2858 UNLOCK_DOLLARZERO_MUTEX;
2866 Perl_whichsig(pTHX_ const char *sig)
2868 register char* const* sigv;
2870 PERL_ARGS_ASSERT_WHICHSIG;
2871 PERL_UNUSED_CONTEXT;
2873 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2874 if (strEQ(sig,*sigv))
2875 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2877 if (strEQ(sig,"CHLD"))
2881 if (strEQ(sig,"CLD"))
2888 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2889 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2891 Perl_sighandler(int sig)
2894 #ifdef PERL_GET_SIG_CONTEXT
2895 dTHXa(PERL_GET_SIG_CONTEXT);
2902 SV * const tSv = PL_Sv;
2906 XPV * const tXpv = PL_Xpv;
2908 if (PL_savestack_ix + 15 <= PL_savestack_max)
2910 if (PL_markstack_ptr < PL_markstack_max - 2)
2912 if (PL_scopestack_ix < PL_scopestack_max - 3)
2915 if (!PL_psig_ptr[sig]) {
2916 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2921 /* Max number of items pushed there is 3*n or 4. We cannot fix
2922 infinity, so we fix 4 (in fact 5): */
2924 PL_savestack_ix += 5; /* Protect save in progress. */
2925 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2928 PL_markstack_ptr++; /* Protect mark. */
2930 PL_scopestack_ix += 1;
2931 /* sv_2cv is too complicated, try a simpler variant first: */
2932 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2933 || SvTYPE(cv) != SVt_PVCV) {
2935 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2938 if (!cv || !CvROOT(cv)) {
2939 if (ckWARN(WARN_SIGNAL))
2940 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2941 PL_sig_name[sig], (gv ? GvENAME(gv)
2948 if(PL_psig_name[sig]) {
2949 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2951 #if !defined(PERL_IMPLICIT_CONTEXT)
2955 sv = sv_newmortal();
2956 sv_setpv(sv,PL_sig_name[sig]);
2959 PUSHSTACKi(PERLSI_SIGNAL);
2962 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2964 struct sigaction oact;
2966 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2969 SV *rv = newRV_noinc((SV*)sih);
2970 /* The siginfo fields signo, code, errno, pid, uid,
2971 * addr, status, and band are defined by POSIX/SUSv3. */
2972 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2973 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2974 #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. */
2975 hv_stores(sih, "errno", newSViv(sip->si_errno));
2976 hv_stores(sih, "status", newSViv(sip->si_status));
2977 hv_stores(sih, "uid", newSViv(sip->si_uid));
2978 hv_stores(sih, "pid", newSViv(sip->si_pid));
2979 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2980 hv_stores(sih, "band", newSViv(sip->si_band));
2984 mPUSHp((char *)sip, sizeof(*sip));
2992 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2995 if (SvTRUE(ERRSV)) {
2997 #ifdef HAS_SIGPROCMASK
2998 /* Handler "died", for example to get out of a restart-able read().
2999 * Before we re-do that on its behalf re-enable the signal which was
3000 * blocked by the system when we entered.
3004 sigaddset(&set,sig);
3005 sigprocmask(SIG_UNBLOCK, &set, NULL);
3007 /* Not clear if this will work */
3008 (void)rsignal(sig, SIG_IGN);
3009 (void)rsignal(sig, PL_csighandlerp);
3011 #endif /* !PERL_MICRO */
3012 Perl_die(aTHX_ NULL);
3016 PL_savestack_ix -= 8; /* Unprotect save in progress. */
3020 PL_scopestack_ix -= 1;
3023 PL_op = myop; /* Apparently not needed... */
3025 PL_Sv = tSv; /* Restore global temporaries. */
3032 S_restore_magic(pTHX_ const void *p)
3035 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3036 SV* const sv = mgs->mgs_sv;
3041 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3043 #ifdef PERL_OLD_COPY_ON_WRITE
3044 /* While magic was saved (and off) sv_setsv may well have seen
3045 this SV as a prime candidate for COW. */
3047 sv_force_normal_flags(sv, 0);
3051 SvFLAGS(sv) |= mgs->mgs_flags;
3054 if (SvGMAGICAL(sv)) {
3055 /* downgrade public flags to private,
3056 and discard any other private flags */
3058 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3060 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3061 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3066 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3068 /* If we're still on top of the stack, pop us off. (That condition
3069 * will be satisfied if restore_magic was called explicitly, but *not*
3070 * if it's being called via leave_scope.)
3071 * The reason for doing this is that otherwise, things like sv_2cv()
3072 * may leave alloc gunk on the savestack, and some code
3073 * (e.g. sighandler) doesn't expect that...
3075 if (PL_savestack_ix == mgs->mgs_ss_ix)
3077 I32 popval = SSPOPINT;
3078 assert(popval == SAVEt_DESTRUCTOR_X);
3079 PL_savestack_ix -= 2;
3081 assert(popval == SAVEt_ALLOC);
3083 PL_savestack_ix -= popval;
3089 S_unwind_handler_stack(pTHX_ const void *p)
3092 const U32 flags = *(const U32*)p;
3094 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3097 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3098 #if !defined(PERL_IMPLICIT_CONTEXT)
3100 SvREFCNT_dec(PL_sig_sv);
3105 =for apidoc magic_sethint
3107 Triggered by a store to %^H, records the key/value pair to
3108 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3109 anything that would need a deep copy. Maybe we should warn if we find a
3115 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3118 SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
3119 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3121 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3123 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3124 an alternative leaf in there, with PL_compiling.cop_hints being used if
3125 it's NULL. If needed for threads, the alternative could lock a mutex,
3126 or take other more complex action. */
3128 /* Something changed in %^H, so it will need to be restored on scope exit.
3129 Doing this here saves a lot of doing it manually in perl code (and
3130 forgetting to do it, and consequent subtle errors. */
3131 PL_hints |= HINT_LOCALIZE_HH;
3132 PL_compiling.cop_hints_hash
3133 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3138 =for apidoc magic_sethint
3140 Triggered by a delete from %^H, records the key to
3141 C<PL_compiling.cop_hints_hash>.
3146 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3150 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3151 PERL_UNUSED_ARG(sv);
3153 assert(mg->mg_len == HEf_SVKEY);
3155 PERL_UNUSED_ARG(sv);
3157 PL_hints |= HINT_LOCALIZE_HH;
3158 PL_compiling.cop_hints_hash
3159 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3160 (SV *)mg->mg_ptr, &PL_sv_placeholder);
3166 * c-indentation-style: bsd
3168 * indent-tabs-mode: t
3171 * ex: set ts=8 sts=4 sw=4 noet: