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 if ((mg = SvMAGIC(sv))) {
129 const MGVTBL* const vtbl = mg->mg_virtual;
131 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
138 } while ((mg = mg->mg_moremagic));
139 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
145 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
148 S_is_container_magic(const MAGIC *mg)
151 switch (mg->mg_type) {
154 case PERL_MAGIC_regex_global:
155 case PERL_MAGIC_nkeys:
156 #ifdef USE_LOCALE_COLLATE
157 case PERL_MAGIC_collxfrm:
160 case PERL_MAGIC_taint:
162 case PERL_MAGIC_vstring:
163 case PERL_MAGIC_utf8:
164 case PERL_MAGIC_substr:
165 case PERL_MAGIC_defelem:
166 case PERL_MAGIC_arylen:
168 case PERL_MAGIC_backref:
169 case PERL_MAGIC_arylen_p:
170 case PERL_MAGIC_rhash:
171 case PERL_MAGIC_symtab:
181 Do magic after a value is retrieved from the SV. See C<sv_magic>.
187 Perl_mg_get(pTHX_ SV *sv)
190 const I32 mgs_ix = SSNEW(sizeof(MGS));
191 const bool was_temp = (bool)SvTEMP(sv);
193 MAGIC *newmg, *head, *cur, *mg;
194 /* guard against sv having being freed midway by holding a private
197 PERL_ARGS_ASSERT_MG_GET;
199 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
200 cause the SV's buffer to get stolen (and maybe other stuff).
203 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
208 save_magic(mgs_ix, sv);
210 /* We must call svt_get(sv, mg) for each valid entry in the linked
211 list of magic. svt_get() may delete the current entry, add new
212 magic to the head of the list, or upgrade the SV. AMS 20010810 */
214 newmg = cur = head = mg = SvMAGIC(sv);
216 const MGVTBL * const vtbl = mg->mg_virtual;
218 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
219 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
221 /* guard against magic having been deleted - eg FETCH calling
226 /* Don't restore the flags for this entry if it was deleted. */
227 if (mg->mg_flags & MGf_GSKIP)
228 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
231 mg = mg->mg_moremagic;
234 /* Have we finished with the new entries we saw? Start again
235 where we left off (unless there are more new entries). */
243 /* Were any new entries added? */
244 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
251 restore_magic(INT2PTR(void *, (IV)mgs_ix));
253 if (SvREFCNT(sv) == 1) {
254 /* We hold the last reference to this SV, which implies that the
255 SV was deleted as a side effect of the routines we called. */
264 Do magic after a value is assigned to the SV. See C<sv_magic>.
270 Perl_mg_set(pTHX_ SV *sv)
273 const I32 mgs_ix = SSNEW(sizeof(MGS));
277 PERL_ARGS_ASSERT_MG_SET;
279 save_magic(mgs_ix, sv);
281 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
282 const MGVTBL* vtbl = mg->mg_virtual;
283 nextmg = mg->mg_moremagic; /* it may delete itself */
284 if (mg->mg_flags & MGf_GSKIP) {
285 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
286 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
288 if (PL_localizing == 2 && !S_is_container_magic(mg))
290 if (vtbl && vtbl->svt_set)
291 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
294 restore_magic(INT2PTR(void*, (IV)mgs_ix));
299 =for apidoc mg_length
301 Report on the SV's length. See C<sv_magic>.
307 Perl_mg_length(pTHX_ SV *sv)
313 PERL_ARGS_ASSERT_MG_LENGTH;
315 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
316 const MGVTBL * const vtbl = mg->mg_virtual;
317 if (vtbl && vtbl->svt_len) {
318 const I32 mgs_ix = SSNEW(sizeof(MGS));
319 save_magic(mgs_ix, sv);
320 /* omit MGf_GSKIP -- not changed here */
321 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
322 restore_magic(INT2PTR(void*, (IV)mgs_ix));
328 /* You can't know whether it's UTF-8 until you get the string again...
330 const U8 *s = (U8*)SvPV_const(sv, len);
333 len = utf8_length(s, s + len);
340 Perl_mg_size(pTHX_ SV *sv)
344 PERL_ARGS_ASSERT_MG_SIZE;
346 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
347 const MGVTBL* const vtbl = mg->mg_virtual;
348 if (vtbl && vtbl->svt_len) {
349 const I32 mgs_ix = SSNEW(sizeof(MGS));
351 save_magic(mgs_ix, sv);
352 /* omit MGf_GSKIP -- not changed here */
353 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
354 restore_magic(INT2PTR(void*, (IV)mgs_ix));
361 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
365 Perl_croak(aTHX_ "Size magic not implemented");
374 Clear something magical that the SV represents. See C<sv_magic>.
380 Perl_mg_clear(pTHX_ SV *sv)
382 const I32 mgs_ix = SSNEW(sizeof(MGS));
385 PERL_ARGS_ASSERT_MG_CLEAR;
387 save_magic(mgs_ix, sv);
389 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
390 const MGVTBL* const vtbl = mg->mg_virtual;
391 /* omit GSKIP -- never set here */
393 if (vtbl && vtbl->svt_clear)
394 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
397 restore_magic(INT2PTR(void*, (IV)mgs_ix));
404 Finds the magic pointer for type matching the SV. See C<sv_magic>.
410 Perl_mg_find(pTHX_ const SV *sv, int type)
415 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
416 if (mg->mg_type == type)
426 Copies the magic from one SV to another. See C<sv_magic>.
432 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
437 PERL_ARGS_ASSERT_MG_COPY;
439 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
440 const MGVTBL* const vtbl = mg->mg_virtual;
441 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
442 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
445 const char type = mg->mg_type;
446 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
448 (type == PERL_MAGIC_tied)
450 : (type == PERL_MAGIC_regdata && mg->mg_obj)
453 toLOWER(type), key, klen);
462 =for apidoc mg_localize
464 Copy some of the magic from an existing SV to new localized version of
465 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
466 doesn't (eg taint, pos).
472 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
477 PERL_ARGS_ASSERT_MG_LOCALIZE;
479 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
480 const MGVTBL* const vtbl = mg->mg_virtual;
481 if (!S_is_container_magic(mg))
484 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
485 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
487 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
488 mg->mg_ptr, mg->mg_len);
490 /* container types should remain read-only across localization */
491 SvFLAGS(nsv) |= SvREADONLY(sv);
494 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
495 SvFLAGS(nsv) |= SvMAGICAL(sv);
505 Free any magic storage used by the SV. See C<sv_magic>.
511 Perl_mg_free(pTHX_ SV *sv)
516 PERL_ARGS_ASSERT_MG_FREE;
518 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
519 const MGVTBL* const vtbl = mg->mg_virtual;
520 moremagic = mg->mg_moremagic;
521 if (vtbl && vtbl->svt_free)
522 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
523 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
524 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
525 Safefree(mg->mg_ptr);
526 else if (mg->mg_len == HEf_SVKEY)
527 SvREFCNT_dec((SV*)mg->mg_ptr);
529 if (mg->mg_flags & MGf_REFCOUNTED)
530 SvREFCNT_dec(mg->mg_obj);
532 SvMAGIC_set(sv, moremagic);
534 SvMAGIC_set(sv, NULL);
541 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
546 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
549 register const REGEXP * const rx = PM_GETRE(PL_curpm);
551 if (mg->mg_obj) { /* @+ */
552 /* return the number possible */
553 return RX_NPARENS(rx);
555 I32 paren = RX_LASTPAREN(rx);
557 /* return the last filled */
559 && (RX_OFFS(rx)[paren].start == -1
560 || RX_OFFS(rx)[paren].end == -1) )
571 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
575 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
578 register const REGEXP * const rx = PM_GETRE(PL_curpm);
580 register const I32 paren = mg->mg_len;
585 if (paren <= (I32)RX_NPARENS(rx) &&
586 (s = RX_OFFS(rx)[paren].start) != -1 &&
587 (t = RX_OFFS(rx)[paren].end) != -1)
590 if (mg->mg_obj) /* @+ */
595 if (i > 0 && RX_MATCH_UTF8(rx)) {
596 const char * const b = RX_SUBBEG(rx);
598 i = utf8_length((U8*)b, (U8*)(b+i));
609 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
611 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
614 Perl_croak(aTHX_ PL_no_modify);
615 NORETURN_FUNCTION_END;
619 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
624 register const REGEXP * rx;
625 const char * const remaining = mg->mg_ptr + 1;
627 PERL_ARGS_ASSERT_MAGIC_LEN;
629 switch (*mg->mg_ptr) {
631 if (*remaining == '\0') { /* ^P */
633 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
635 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
639 case '\015': /* $^MATCH */
640 if (strEQ(remaining, "ATCH")) {
647 paren = RX_BUFF_IDX_PREMATCH;
651 paren = RX_BUFF_IDX_POSTMATCH;
655 paren = RX_BUFF_IDX_FULLMATCH;
657 case '1': case '2': case '3': case '4':
658 case '5': case '6': case '7': case '8': case '9':
659 paren = atoi(mg->mg_ptr);
661 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
663 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
666 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
669 if (ckWARN(WARN_UNINITIALIZED))
674 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
675 paren = RX_LASTPAREN(rx);
680 case '\016': /* ^N */
681 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
682 paren = RX_LASTCLOSEPAREN(rx);
689 if (!SvPOK(sv) && SvNIOK(sv)) {
697 #define SvRTRIM(sv) STMT_START { \
699 STRLEN len = SvCUR(sv); \
700 char * const p = SvPVX(sv); \
701 while (len > 0 && isSPACE(p[len-1])) \
703 SvCUR_set(sv, len); \
709 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
711 PERL_ARGS_ASSERT_EMULATE_COP_IO;
713 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
714 sv_setsv(sv, &PL_sv_undef);
718 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
719 SV *const value = Perl_refcounted_he_fetch(aTHX_
721 0, "open<", 5, 0, 0);
726 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
727 SV *const value = Perl_refcounted_he_fetch(aTHX_
729 0, "open>", 5, 0, 0);
737 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
741 register char *s = NULL;
743 const char * const remaining = mg->mg_ptr + 1;
744 const char nextchar = *remaining;
746 PERL_ARGS_ASSERT_MAGIC_GET;
748 switch (*mg->mg_ptr) {
749 case '\001': /* ^A */
750 sv_setsv(sv, PL_bodytarget);
752 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
753 if (nextchar == '\0') {
754 sv_setiv(sv, (IV)PL_minus_c);
756 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
757 sv_setiv(sv, (IV)STATUS_NATIVE);
761 case '\004': /* ^D */
762 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
764 case '\005': /* ^E */
765 if (nextchar == '\0') {
766 #if defined(MACOS_TRADITIONAL)
770 sv_setnv(sv,(double)gMacPerl_OSErr);
771 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
775 # include <descrip.h>
776 # include <starlet.h>
778 $DESCRIPTOR(msgdsc,msg);
779 sv_setnv(sv,(NV) vaxc$errno);
780 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
781 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
786 if (!(_emx_env & 0x200)) { /* Under DOS */
787 sv_setnv(sv, (NV)errno);
788 sv_setpv(sv, errno ? Strerror(errno) : "");
790 if (errno != errno_isOS2) {
791 const int tmp = _syserrno();
792 if (tmp) /* 2nd call to _syserrno() makes it 0 */
795 sv_setnv(sv, (NV)Perl_rc);
796 sv_setpv(sv, os2error(Perl_rc));
800 const DWORD dwErr = GetLastError();
801 sv_setnv(sv, (NV)dwErr);
803 PerlProc_GetOSError(sv, dwErr);
806 sv_setpvn(sv, "", 0);
811 const int saveerrno = errno;
812 sv_setnv(sv, (NV)errno);
813 sv_setpv(sv, errno ? Strerror(errno) : "");
818 SvNOK_on(sv); /* what a wonderful hack! */
820 else if (strEQ(remaining, "NCODING"))
821 sv_setsv(sv, PL_encoding);
823 case '\006': /* ^F */
824 sv_setiv(sv, (IV)PL_maxsysfd);
826 case '\010': /* ^H */
827 sv_setiv(sv, (IV)PL_hints);
829 case '\011': /* ^I */ /* NOT \t in EBCDIC */
830 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
832 case '\017': /* ^O & ^OPEN */
833 if (nextchar == '\0') {
834 sv_setpv(sv, PL_osname);
837 else if (strEQ(remaining, "PEN")) {
838 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
842 if (nextchar == '\0') { /* ^P */
843 sv_setiv(sv, (IV)PL_perldb);
844 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
845 goto do_prematch_fetch;
846 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
847 goto do_postmatch_fetch;
850 case '\023': /* ^S */
851 if (nextchar == '\0') {
852 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
855 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
860 case '\024': /* ^T */
861 if (nextchar == '\0') {
863 sv_setnv(sv, PL_basetime);
865 sv_setiv(sv, (IV)PL_basetime);
868 else if (strEQ(remaining, "AINT"))
869 sv_setiv(sv, PL_tainting
870 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
873 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
874 if (strEQ(remaining, "NICODE"))
875 sv_setuv(sv, (UV) PL_unicode);
876 else if (strEQ(remaining, "TF8LOCALE"))
877 sv_setuv(sv, (UV) PL_utf8locale);
878 else if (strEQ(remaining, "TF8CACHE"))
879 sv_setiv(sv, (IV) PL_utf8cache);
881 case '\027': /* ^W & $^WARNING_BITS */
882 if (nextchar == '\0')
883 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
884 else if (strEQ(remaining, "ARNING_BITS")) {
885 if (PL_compiling.cop_warnings == pWARN_NONE) {
886 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
888 else if (PL_compiling.cop_warnings == pWARN_STD) {
891 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
895 else if (PL_compiling.cop_warnings == pWARN_ALL) {
896 /* Get the bit mask for $warnings::Bits{all}, because
897 * it could have been extended by warnings::register */
898 HV * const bits=get_hv("warnings::Bits", FALSE);
900 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
902 sv_setsv(sv, *bits_all);
905 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
909 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
910 *PL_compiling.cop_warnings);
915 case '\015': /* $^MATCH */
916 if (strEQ(remaining, "ATCH")) {
917 case '1': case '2': case '3': case '4':
918 case '5': case '6': case '7': case '8': case '9': case '&':
919 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
921 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
922 * XXX Does the new way break anything?
924 paren = atoi(mg->mg_ptr); /* $& is in [0] */
925 CALLREG_NUMBUF_FETCH(rx,paren,sv);
928 sv_setsv(sv,&PL_sv_undef);
932 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
933 if (RX_LASTPAREN(rx)) {
934 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
938 sv_setsv(sv,&PL_sv_undef);
940 case '\016': /* ^N */
941 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
942 if (RX_LASTCLOSEPAREN(rx)) {
943 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
948 sv_setsv(sv,&PL_sv_undef);
952 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
953 CALLREG_NUMBUF_FETCH(rx,-2,sv);
956 sv_setsv(sv,&PL_sv_undef);
960 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
961 CALLREG_NUMBUF_FETCH(rx,-1,sv);
964 sv_setsv(sv,&PL_sv_undef);
967 if (GvIO(PL_last_in_gv)) {
968 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
973 sv_setiv(sv, (IV)STATUS_CURRENT);
974 #ifdef COMPLEX_STATUS
975 LvTARGOFF(sv) = PL_statusvalue;
976 LvTARGLEN(sv) = PL_statusvalue_vms;
981 if (GvIOp(PL_defoutgv))
982 s = IoTOP_NAME(GvIOp(PL_defoutgv));
986 sv_setpv(sv,GvENAME(PL_defoutgv));
987 sv_catpvs(sv,"_TOP");
991 if (GvIOp(PL_defoutgv))
992 s = IoFMT_NAME(GvIOp(PL_defoutgv));
994 s = GvENAME(PL_defoutgv);
998 if (GvIOp(PL_defoutgv))
999 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1002 if (GvIOp(PL_defoutgv))
1003 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1006 if (GvIOp(PL_defoutgv))
1007 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1014 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1017 if (GvIOp(PL_defoutgv))
1018 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1024 sv_copypv(sv, PL_ors_sv);
1028 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1029 sv_setpv(sv, errno ? Strerror(errno) : "");
1032 const int saveerrno = errno;
1033 sv_setnv(sv, (NV)errno);
1035 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1036 sv_setpv(sv, os2error(Perl_rc));
1039 sv_setpv(sv, errno ? Strerror(errno) : "");
1044 SvNOK_on(sv); /* what a wonderful hack! */
1047 sv_setiv(sv, (IV)PL_uid);
1050 sv_setiv(sv, (IV)PL_euid);
1053 sv_setiv(sv, (IV)PL_gid);
1056 sv_setiv(sv, (IV)PL_egid);
1058 #ifdef HAS_GETGROUPS
1060 Groups_t *gary = NULL;
1061 I32 i, num_groups = getgroups(0, gary);
1062 Newx(gary, num_groups, Groups_t);
1063 num_groups = getgroups(num_groups, gary);
1064 for (i = 0; i < num_groups; i++)
1065 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1068 (void)SvIOK_on(sv); /* what a wonderful hack! */
1071 #ifndef MACOS_TRADITIONAL
1080 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1082 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1084 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1086 if (uf && uf->uf_val)
1087 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1092 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1095 STRLEN len = 0, klen;
1096 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1097 const char * const ptr = MgPV_const(mg,klen);
1100 PERL_ARGS_ASSERT_MAGIC_SETENV;
1102 #ifdef DYNAMIC_ENV_FETCH
1103 /* We just undefd an environment var. Is a replacement */
1104 /* waiting in the wings? */
1106 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1108 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1112 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1113 /* And you'll never guess what the dog had */
1114 /* in its mouth... */
1116 MgTAINTEDDIR_off(mg);
1118 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1119 char pathbuf[256], eltbuf[256], *cp, *elt;
1123 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1125 do { /* DCL$PATH may be a search list */
1126 while (1) { /* as may dev portion of any element */
1127 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1128 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1129 cando_by_name(S_IWUSR,0,elt) ) {
1130 MgTAINTEDDIR_on(mg);
1134 if ((cp = strchr(elt, ':')) != NULL)
1136 if (my_trnlnm(elt, eltbuf, j++))
1142 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1145 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1146 const char * const strend = s + len;
1148 while (s < strend) {
1152 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1153 const char path_sep = '|';
1155 const char path_sep = ':';
1157 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1158 s, strend, path_sep, &i);
1160 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1162 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1164 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1166 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1167 MgTAINTEDDIR_on(mg);
1173 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1179 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1181 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1182 PERL_UNUSED_ARG(sv);
1183 my_setenv(MgPV_nolen_const(mg),NULL);
1188 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1191 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1192 PERL_UNUSED_ARG(mg);
1194 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1196 if (PL_localizing) {
1199 hv_iterinit((HV*)sv);
1200 while ((entry = hv_iternext((HV*)sv))) {
1202 my_setenv(hv_iterkey(entry, &keylen),
1203 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1211 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1214 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1215 PERL_UNUSED_ARG(sv);
1216 PERL_UNUSED_ARG(mg);
1218 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1226 #ifdef HAS_SIGPROCMASK
1228 restore_sigmask(pTHX_ SV *save_sv)
1230 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1231 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1235 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1238 /* Are we fetching a signal entry? */
1239 const I32 i = whichsig(MgPV_nolen_const(mg));
1241 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1245 sv_setsv(sv,PL_psig_ptr[i]);
1247 Sighandler_t sigstate = rsignal_state(i);
1248 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1249 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1252 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1253 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1256 /* cache state so we don't fetch it again */
1257 if(sigstate == (Sighandler_t) SIG_IGN)
1258 sv_setpvs(sv,"IGNORE");
1260 sv_setsv(sv,&PL_sv_undef);
1261 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1268 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1270 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1271 * refactoring might be in order.
1274 register const char * const s = MgPV_nolen_const(mg);
1275 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1276 PERL_UNUSED_ARG(sv);
1279 if (strEQ(s,"__DIE__"))
1281 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1284 SV *const to_dec = *svp;
1286 SvREFCNT_dec(to_dec);
1290 /* Are we clearing a signal entry? */
1291 const I32 i = whichsig(s);
1293 #ifdef HAS_SIGPROCMASK
1296 /* Avoid having the signal arrive at a bad time, if possible. */
1299 sigprocmask(SIG_BLOCK, &set, &save);
1301 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1302 SAVEFREESV(save_sv);
1303 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1306 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1307 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1309 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1310 PL_sig_defaulting[i] = 1;
1311 (void)rsignal(i, PL_csighandlerp);
1313 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1315 if(PL_psig_name[i]) {
1316 SvREFCNT_dec(PL_psig_name[i]);
1319 if(PL_psig_ptr[i]) {
1320 SV * const to_dec=PL_psig_ptr[i];
1323 SvREFCNT_dec(to_dec);
1333 * The signal handling nomenclature has gotten a bit confusing since the advent of
1334 * safe signals. S_raise_signal only raises signals by analogy with what the
1335 * underlying system's signal mechanism does. It might be more proper to say that
1336 * it defers signals that have already been raised and caught.
1338 * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
1339 * in the sense of being on the system's signal queue in between raising and delivery.
1340 * They are only pending on Perl's deferral list, i.e., they track deferred signals
1341 * awaiting delivery after the current Perl opcode completes and say nothing about
1342 * signals raised but not yet caught in the underlying signal implementation.
1345 #ifndef SIG_PENDING_DIE_COUNT
1346 # define SIG_PENDING_DIE_COUNT 120
1350 S_raise_signal(pTHX_ int sig)
1353 /* Set a flag to say this signal is pending */
1354 PL_psig_pend[sig]++;
1355 /* And one to say _a_ signal is pending */
1356 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1357 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1358 (unsigned long)SIG_PENDING_DIE_COUNT);
1362 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1363 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1365 Perl_csighandler(int sig)
1368 #ifdef PERL_GET_SIG_CONTEXT
1369 dTHXa(PERL_GET_SIG_CONTEXT);
1373 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1375 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1376 (void) rsignal(sig, PL_csighandlerp);
1377 if (PL_sig_ignoring[sig]) return;
1379 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1380 if (PL_sig_defaulting[sig])
1381 #ifdef KILL_BY_SIGPRC
1382 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1387 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1399 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1400 /* Call the perl level handler now--
1401 * with risk we may be in malloc() etc. */
1402 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1403 (*PL_sighandlerp)(sig, NULL, NULL);
1405 (*PL_sighandlerp)(sig);
1408 S_raise_signal(aTHX_ sig);
1411 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1413 Perl_csighandler_init(void)
1416 if (PL_sig_handlers_initted) return;
1418 for (sig = 1; sig < SIG_SIZE; sig++) {
1419 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1421 PL_sig_defaulting[sig] = 1;
1422 (void) rsignal(sig, PL_csighandlerp);
1424 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1425 PL_sig_ignoring[sig] = 0;
1428 PL_sig_handlers_initted = 1;
1433 Perl_despatch_signals(pTHX)
1438 for (sig = 1; sig < SIG_SIZE; sig++) {
1439 if (PL_psig_pend[sig]) {
1440 PERL_BLOCKSIG_ADD(set, sig);
1441 PL_psig_pend[sig] = 0;
1442 PERL_BLOCKSIG_BLOCK(set);
1443 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1444 (*PL_sighandlerp)(sig, NULL, NULL);
1446 (*PL_sighandlerp)(sig);
1448 PERL_BLOCKSIG_UNBLOCK(set);
1454 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1459 /* Need to be careful with SvREFCNT_dec(), because that can have side
1460 * effects (due to closures). We must make sure that the new disposition
1461 * is in place before it is called.
1465 #ifdef HAS_SIGPROCMASK
1469 register const char *s = MgPV_const(mg,len);
1471 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1474 if (strEQ(s,"__DIE__"))
1476 else if (strEQ(s,"__WARN__"))
1479 Perl_croak(aTHX_ "No such hook: %s", s);
1482 if (*svp != PERL_WARNHOOK_FATAL)
1488 i = whichsig(s); /* ...no, a brick */
1490 if (ckWARN(WARN_SIGNAL))
1491 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1494 #ifdef HAS_SIGPROCMASK
1495 /* Avoid having the signal arrive at a bad time, if possible. */
1498 sigprocmask(SIG_BLOCK, &set, &save);
1500 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1501 SAVEFREESV(save_sv);
1502 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1505 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1506 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1508 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1509 PL_sig_ignoring[i] = 0;
1511 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1512 PL_sig_defaulting[i] = 0;
1514 SvREFCNT_dec(PL_psig_name[i]);
1515 to_dec = PL_psig_ptr[i];
1516 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1517 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1518 PL_psig_name[i] = newSVpvn(s, len);
1519 SvREADONLY_on(PL_psig_name[i]);
1521 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1523 (void)rsignal(i, PL_csighandlerp);
1524 #ifdef HAS_SIGPROCMASK
1529 *svp = SvREFCNT_inc_simple_NN(sv);
1531 SvREFCNT_dec(to_dec);
1534 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1535 if (strEQ(s,"IGNORE")) {
1537 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1538 PL_sig_ignoring[i] = 1;
1539 (void)rsignal(i, PL_csighandlerp);
1541 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1545 else if (strEQ(s,"DEFAULT") || !*s) {
1547 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1549 PL_sig_defaulting[i] = 1;
1550 (void)rsignal(i, PL_csighandlerp);
1553 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1558 * We should warn if HINT_STRICT_REFS, but without
1559 * access to a known hint bit in a known OP, we can't
1560 * tell whether HINT_STRICT_REFS is in force or not.
1562 if (!strchr(s,':') && !strchr(s,'\''))
1563 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1566 (void)rsignal(i, PL_csighandlerp);
1568 *svp = SvREFCNT_inc_simple_NN(sv);
1570 #ifdef HAS_SIGPROCMASK
1575 SvREFCNT_dec(to_dec);
1578 #endif /* !PERL_MICRO */
1581 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1586 PERL_ARGS_ASSERT_MAGIC_SETISA;
1587 PERL_UNUSED_ARG(sv);
1589 /* Bail out if destruction is going on */
1590 if(PL_dirty) return 0;
1592 /* Skip _isaelem because _isa will handle it shortly */
1593 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1596 /* XXX Once it's possible, we need to
1597 detect that our @ISA is aliased in
1598 other stashes, and act on the stashes
1599 of all of the aliases */
1601 /* The first case occurs via setisa,
1602 the second via setisa_elem, which
1603 calls this same magic */
1605 SvTYPE(mg->mg_obj) == SVt_PVGV
1607 : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1610 mro_isa_changed_in(stash);
1616 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1621 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1623 /* Bail out if destruction is going on */
1624 if(PL_dirty) return 0;
1628 /* XXX see comments in magic_setisa */
1630 SvTYPE(mg->mg_obj) == SVt_PVGV
1632 : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1635 mro_isa_changed_in(stash);
1641 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1644 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1645 PERL_UNUSED_ARG(sv);
1646 PERL_UNUSED_ARG(mg);
1647 PL_amagic_generation++;
1653 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1655 HV * const hv = (HV*)LvTARG(sv);
1658 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1659 PERL_UNUSED_ARG(mg);
1662 (void) hv_iterinit(hv);
1663 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1666 while (hv_iternext(hv))
1671 sv_setiv(sv, (IV)i);
1676 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1678 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1679 PERL_UNUSED_ARG(mg);
1681 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1686 /* caller is responsible for stack switching/cleanup */
1688 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1693 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1697 PUSHs(SvTIED_obj(sv, mg));
1700 if (mg->mg_len >= 0)
1701 mPUSHp(mg->mg_ptr, mg->mg_len);
1702 else if (mg->mg_len == HEf_SVKEY)
1703 PUSHs((SV*)mg->mg_ptr);
1705 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1714 return call_method(meth, flags);
1718 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1722 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1726 PUSHSTACKi(PERLSI_MAGIC);
1728 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1729 sv_setsv(sv, *PL_stack_sp--);
1739 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1741 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1744 mg->mg_flags |= MGf_GSKIP;
1745 magic_methpack(sv,mg,"FETCH");
1750 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1754 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1757 PUSHSTACKi(PERLSI_MAGIC);
1758 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1765 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1767 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1769 return magic_methpack(sv,mg,"DELETE");
1774 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1779 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1783 PUSHSTACKi(PERLSI_MAGIC);
1784 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1785 sv = *PL_stack_sp--;
1786 retval = SvIV(sv)-1;
1788 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1793 return (U32) retval;
1797 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1801 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1804 PUSHSTACKi(PERLSI_MAGIC);
1806 XPUSHs(SvTIED_obj(sv, mg));
1808 call_method("CLEAR", G_SCALAR|G_DISCARD);
1816 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1819 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1821 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1825 PUSHSTACKi(PERLSI_MAGIC);
1828 PUSHs(SvTIED_obj(sv, mg));
1833 if (call_method(meth, G_SCALAR))
1834 sv_setsv(key, *PL_stack_sp--);
1843 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1845 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1847 return magic_methpack(sv,mg,"EXISTS");
1851 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1855 SV * const tied = SvTIED_obj((SV*)hv, mg);
1856 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1858 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1860 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1862 if (HvEITER_get(hv))
1863 /* we are in an iteration so the hash cannot be empty */
1865 /* no xhv_eiter so now use FIRSTKEY */
1866 key = sv_newmortal();
1867 magic_nextpack((SV*)hv, mg, key);
1868 HvEITER_set(hv, NULL); /* need to reset iterator */
1869 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1872 /* there is a SCALAR method that we can call */
1874 PUSHSTACKi(PERLSI_MAGIC);
1880 if (call_method("SCALAR", G_SCALAR))
1881 retval = *PL_stack_sp--;
1883 retval = &PL_sv_undef;
1890 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1893 GV * const gv = PL_DBline;
1894 const I32 i = SvTRUE(sv);
1895 SV ** const svp = av_fetch(GvAV(gv),
1896 atoi(MgPV_nolen_const(mg)), FALSE);
1898 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1900 if (svp && SvIOKp(*svp)) {
1901 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1903 /* set or clear breakpoint in the relevant control op */
1905 o->op_flags |= OPf_SPECIAL;
1907 o->op_flags &= ~OPf_SPECIAL;
1914 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1917 const AV * const obj = (AV*)mg->mg_obj;
1919 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1922 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1930 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1933 AV * const obj = (AV*)mg->mg_obj;
1935 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1938 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1940 if (ckWARN(WARN_MISC))
1941 Perl_warner(aTHX_ packWARN(WARN_MISC),
1942 "Attempt to set length of freed array");
1948 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1952 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1953 PERL_UNUSED_ARG(sv);
1955 /* during global destruction, mg_obj may already have been freed */
1956 if (PL_in_clean_all)
1959 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1962 /* arylen scalar holds a pointer back to the array, but doesn't own a
1963 reference. Hence the we (the array) are about to go away with it
1964 still pointing at us. Clear its pointer, else it would be pointing
1965 at free memory. See the comment in sv_magic about reference loops,
1966 and why it can't own a reference to us. */
1973 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1976 SV* const lsv = LvTARG(sv);
1978 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1979 PERL_UNUSED_ARG(mg);
1981 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1982 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1983 if (found && found->mg_len >= 0) {
1984 I32 i = found->mg_len;
1986 sv_pos_b2u(lsv, &i);
1987 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1996 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1999 SV* const lsv = LvTARG(sv);
2005 PERL_ARGS_ASSERT_MAGIC_SETPOS;
2006 PERL_UNUSED_ARG(mg);
2008 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
2009 found = mg_find(lsv, PERL_MAGIC_regex_global);
2015 #ifdef PERL_OLD_COPY_ON_WRITE
2017 sv_force_normal_flags(lsv, 0);
2019 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2022 else if (!SvOK(sv)) {
2026 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2028 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2031 ulen = sv_len_utf8(lsv);
2041 else if (pos > (SSize_t)len)
2046 sv_pos_u2b(lsv, &p, 0);
2050 found->mg_len = pos;
2051 found->mg_flags &= ~MGf_MINMATCH;
2057 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2060 SV * const lsv = LvTARG(sv);
2061 const char * const tmps = SvPV_const(lsv,len);
2062 I32 offs = LvTARGOFF(sv);
2063 I32 rem = LvTARGLEN(sv);
2065 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2066 PERL_UNUSED_ARG(mg);
2069 sv_pos_u2b(lsv, &offs, &rem);
2070 if (offs > (I32)len)
2072 if (rem + offs > (I32)len)
2074 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
2081 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2085 const char * const tmps = SvPV_const(sv, len);
2086 SV * const lsv = LvTARG(sv);
2087 I32 lvoff = LvTARGOFF(sv);
2088 I32 lvlen = LvTARGLEN(sv);
2090 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2091 PERL_UNUSED_ARG(mg);
2094 sv_utf8_upgrade(lsv);
2095 sv_pos_u2b(lsv, &lvoff, &lvlen);
2096 sv_insert(lsv, lvoff, lvlen, tmps, len);
2097 LvTARGLEN(sv) = sv_len_utf8(sv);
2100 else if (lsv && SvUTF8(lsv)) {
2102 sv_pos_u2b(lsv, &lvoff, &lvlen);
2103 LvTARGLEN(sv) = len;
2104 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2105 sv_insert(lsv, lvoff, lvlen, utf8, len);
2109 sv_insert(lsv, lvoff, lvlen, tmps, len);
2110 LvTARGLEN(sv) = len;
2118 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2122 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2123 PERL_UNUSED_ARG(sv);
2125 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2130 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2134 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2135 PERL_UNUSED_ARG(sv);
2137 /* update taint status */
2146 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2148 SV * const lsv = LvTARG(sv);
2150 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2151 PERL_UNUSED_ARG(mg);
2154 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2162 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2164 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2165 PERL_UNUSED_ARG(mg);
2166 do_vecset(sv); /* XXX slurp this routine */
2171 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2176 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2178 if (LvTARGLEN(sv)) {
2180 SV * const ahv = LvTARG(sv);
2181 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2186 AV* const av = (AV*)LvTARG(sv);
2187 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2188 targ = AvARRAY(av)[LvTARGOFF(sv)];
2190 if (targ && (targ != &PL_sv_undef)) {
2191 /* somebody else defined it for us */
2192 SvREFCNT_dec(LvTARG(sv));
2193 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2195 SvREFCNT_dec(mg->mg_obj);
2197 mg->mg_flags &= ~MGf_REFCOUNTED;
2202 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2207 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2209 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2210 PERL_UNUSED_ARG(mg);
2214 sv_setsv(LvTARG(sv), sv);
2215 SvSETMAGIC(LvTARG(sv));
2221 Perl_vivify_defelem(pTHX_ SV *sv)
2227 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2229 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2232 SV * const ahv = LvTARG(sv);
2233 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2236 if (!value || value == &PL_sv_undef)
2237 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2240 AV* const av = (AV*)LvTARG(sv);
2241 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2242 LvTARG(sv) = NULL; /* array can't be extended */
2244 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2245 if (!svp || (value = *svp) == &PL_sv_undef)
2246 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2249 SvREFCNT_inc_simple_void(value);
2250 SvREFCNT_dec(LvTARG(sv));
2253 SvREFCNT_dec(mg->mg_obj);
2255 mg->mg_flags &= ~MGf_REFCOUNTED;
2259 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2261 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2262 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2266 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2268 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2269 PERL_UNUSED_CONTEXT;
2276 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2278 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2280 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2282 if (uf && uf->uf_set)
2283 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2288 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2290 const char type = mg->mg_type;
2292 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2294 if (type == PERL_MAGIC_qr) {
2295 } else if (type == PERL_MAGIC_bm) {
2299 assert(type == PERL_MAGIC_fm);
2302 return sv_unmagic(sv, type);
2305 #ifdef USE_LOCALE_COLLATE
2307 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2309 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2312 * RenE<eacute> Descartes said "I think not."
2313 * and vanished with a faint plop.
2315 PERL_UNUSED_CONTEXT;
2316 PERL_UNUSED_ARG(sv);
2318 Safefree(mg->mg_ptr);
2324 #endif /* USE_LOCALE_COLLATE */
2326 /* Just clear the UTF-8 cache data. */
2328 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2330 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2331 PERL_UNUSED_CONTEXT;
2332 PERL_UNUSED_ARG(sv);
2333 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2335 mg->mg_len = -1; /* The mg_len holds the len cache. */
2340 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2343 register const char *s;
2345 register const REGEXP * rx;
2346 const char * const remaining = mg->mg_ptr + 1;
2350 PERL_ARGS_ASSERT_MAGIC_SET;
2352 switch (*mg->mg_ptr) {
2353 case '\015': /* $^MATCH */
2354 if (strEQ(remaining, "ATCH"))
2356 case '`': /* ${^PREMATCH} caught below */
2358 paren = RX_BUFF_IDX_PREMATCH;
2360 case '\'': /* ${^POSTMATCH} caught below */
2362 paren = RX_BUFF_IDX_POSTMATCH;
2366 paren = RX_BUFF_IDX_FULLMATCH;
2368 case '1': case '2': case '3': case '4':
2369 case '5': case '6': case '7': case '8': case '9':
2370 paren = atoi(mg->mg_ptr);
2372 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2373 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2376 /* Croak with a READONLY error when a numbered match var is
2377 * set without a previous pattern match. Unless it's C<local $1>
2379 if (!PL_localizing) {
2380 Perl_croak(aTHX_ PL_no_modify);
2383 case '\001': /* ^A */
2384 sv_setsv(PL_bodytarget, sv);
2386 case '\003': /* ^C */
2387 PL_minus_c = (bool)SvIV(sv);
2390 case '\004': /* ^D */
2392 s = SvPV_nolen_const(sv);
2393 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2394 DEBUG_x(dump_all());
2396 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2399 case '\005': /* ^E */
2400 if (*(mg->mg_ptr+1) == '\0') {
2401 #ifdef MACOS_TRADITIONAL
2402 gMacPerl_OSErr = SvIV(sv);
2405 set_vaxc_errno(SvIV(sv));
2408 SetLastError( SvIV(sv) );
2411 os2_setsyserrno(SvIV(sv));
2413 /* will anyone ever use this? */
2414 SETERRNO(SvIV(sv), 4);
2420 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2422 SvREFCNT_dec(PL_encoding);
2423 if (SvOK(sv) || SvGMAGICAL(sv)) {
2424 PL_encoding = newSVsv(sv);
2431 case '\006': /* ^F */
2432 PL_maxsysfd = SvIV(sv);
2434 case '\010': /* ^H */
2435 PL_hints = SvIV(sv);
2437 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2438 Safefree(PL_inplace);
2439 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2441 case '\017': /* ^O */
2442 if (*(mg->mg_ptr+1) == '\0') {
2443 Safefree(PL_osname);
2446 TAINT_PROPER("assigning to $^O");
2447 PL_osname = savesvpv(sv);
2450 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2452 const char *const start = SvPV(sv, len);
2453 const char *out = (const char*)memchr(start, '\0', len);
2455 struct refcounted_he *tmp_he;
2458 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2460 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2462 /* Opening for input is more common than opening for output, so
2463 ensure that hints for input are sooner on linked list. */
2464 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2465 SVs_TEMP | SvUTF8(sv))
2466 : newSVpvn_flags("", 0, SVs_TEMP | SvUTF8(sv));
2469 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2470 newSVpvs_flags("open>", SVs_TEMP),
2473 /* The UTF-8 setting is carried over */
2474 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2476 PL_compiling.cop_hints_hash
2477 = Perl_refcounted_he_new(aTHX_ tmp_he,
2478 newSVpvs_flags("open<", SVs_TEMP),
2482 case '\020': /* ^P */
2483 if (*remaining == '\0') { /* ^P */
2484 PL_perldb = SvIV(sv);
2485 if (PL_perldb && !PL_DBsingle)
2488 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2490 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2493 case '\024': /* ^T */
2495 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2497 PL_basetime = (Time_t)SvIV(sv);
2500 case '\025': /* ^UTF8CACHE */
2501 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2502 PL_utf8cache = (signed char) sv_2iv(sv);
2505 case '\027': /* ^W & $^WARNING_BITS */
2506 if (*(mg->mg_ptr+1) == '\0') {
2507 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2509 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2510 | (i ? G_WARN_ON : G_WARN_OFF) ;
2513 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2514 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2515 if (!SvPOK(sv) && PL_localizing) {
2516 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2517 PL_compiling.cop_warnings = pWARN_NONE;
2522 int accumulate = 0 ;
2523 int any_fatals = 0 ;
2524 const char * const ptr = SvPV_const(sv, len) ;
2525 for (i = 0 ; i < len ; ++i) {
2526 accumulate |= ptr[i] ;
2527 any_fatals |= (ptr[i] & 0xAA) ;
2530 if (!specialWARN(PL_compiling.cop_warnings))
2531 PerlMemShared_free(PL_compiling.cop_warnings);
2532 PL_compiling.cop_warnings = pWARN_NONE;
2534 /* Yuck. I can't see how to abstract this: */
2535 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2536 WARN_ALL) && !any_fatals) {
2537 if (!specialWARN(PL_compiling.cop_warnings))
2538 PerlMemShared_free(PL_compiling.cop_warnings);
2539 PL_compiling.cop_warnings = pWARN_ALL;
2540 PL_dowarn |= G_WARN_ONCE ;
2544 const char *const p = SvPV_const(sv, len);
2546 PL_compiling.cop_warnings
2547 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2550 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2551 PL_dowarn |= G_WARN_ONCE ;
2559 if (PL_localizing) {
2560 if (PL_localizing == 1)
2561 SAVESPTR(PL_last_in_gv);
2563 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2564 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2567 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2568 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2569 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2572 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2573 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2574 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2577 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2580 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2581 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2582 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2585 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2589 IO * const io = GvIOp(PL_defoutgv);
2592 if ((SvIV(sv)) == 0)
2593 IoFLAGS(io) &= ~IOf_FLUSH;
2595 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2596 PerlIO *ofp = IoOFP(io);
2598 (void)PerlIO_flush(ofp);
2599 IoFLAGS(io) |= IOf_FLUSH;
2605 SvREFCNT_dec(PL_rs);
2606 PL_rs = newSVsv(sv);
2610 SvREFCNT_dec(PL_ors_sv);
2611 if (SvOK(sv) || SvGMAGICAL(sv)) {
2612 PL_ors_sv = newSVsv(sv);
2620 SvREFCNT_dec(PL_ofs_sv);
2621 if (SvOK(sv) || SvGMAGICAL(sv)) {
2622 PL_ofs_sv = newSVsv(sv);
2629 CopARYBASE_set(&PL_compiling, SvIV(sv));
2632 #ifdef COMPLEX_STATUS
2633 if (PL_localizing == 2) {
2634 PL_statusvalue = LvTARGOFF(sv);
2635 PL_statusvalue_vms = LvTARGLEN(sv);
2639 #ifdef VMSISH_STATUS
2641 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2644 STATUS_UNIX_EXIT_SET(SvIV(sv));
2649 # define PERL_VMS_BANG vaxc$errno
2651 # define PERL_VMS_BANG 0
2653 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2654 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2659 if (PL_delaymagic) {
2660 PL_delaymagic |= DM_RUID;
2661 break; /* don't do magic till later */
2664 (void)setruid((Uid_t)PL_uid);
2667 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2669 #ifdef HAS_SETRESUID
2670 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2672 if (PL_uid == PL_euid) { /* special case $< = $> */
2674 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2675 if (PL_uid != 0 && PerlProc_getuid() == 0)
2676 (void)PerlProc_setuid(0);
2678 (void)PerlProc_setuid(PL_uid);
2680 PL_uid = PerlProc_getuid();
2681 Perl_croak(aTHX_ "setruid() not implemented");
2686 PL_uid = PerlProc_getuid();
2687 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2691 if (PL_delaymagic) {
2692 PL_delaymagic |= DM_EUID;
2693 break; /* don't do magic till later */
2696 (void)seteuid((Uid_t)PL_euid);
2699 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2701 #ifdef HAS_SETRESUID
2702 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2704 if (PL_euid == PL_uid) /* special case $> = $< */
2705 PerlProc_setuid(PL_euid);
2707 PL_euid = PerlProc_geteuid();
2708 Perl_croak(aTHX_ "seteuid() not implemented");
2713 PL_euid = PerlProc_geteuid();
2714 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2718 if (PL_delaymagic) {
2719 PL_delaymagic |= DM_RGID;
2720 break; /* don't do magic till later */
2723 (void)setrgid((Gid_t)PL_gid);
2726 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2728 #ifdef HAS_SETRESGID
2729 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2731 if (PL_gid == PL_egid) /* special case $( = $) */
2732 (void)PerlProc_setgid(PL_gid);
2734 PL_gid = PerlProc_getgid();
2735 Perl_croak(aTHX_ "setrgid() not implemented");
2740 PL_gid = PerlProc_getgid();
2741 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2744 #ifdef HAS_SETGROUPS
2746 const char *p = SvPV_const(sv, len);
2747 Groups_t *gary = NULL;
2752 for (i = 0; i < NGROUPS; ++i) {
2753 while (*p && !isSPACE(*p))
2760 Newx(gary, i + 1, Groups_t);
2762 Renew(gary, i + 1, Groups_t);
2766 (void)setgroups(i, gary);
2769 #else /* HAS_SETGROUPS */
2771 #endif /* HAS_SETGROUPS */
2772 if (PL_delaymagic) {
2773 PL_delaymagic |= DM_EGID;
2774 break; /* don't do magic till later */
2777 (void)setegid((Gid_t)PL_egid);
2780 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2782 #ifdef HAS_SETRESGID
2783 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2785 if (PL_egid == PL_gid) /* special case $) = $( */
2786 (void)PerlProc_setgid(PL_egid);
2788 PL_egid = PerlProc_getegid();
2789 Perl_croak(aTHX_ "setegid() not implemented");
2794 PL_egid = PerlProc_getegid();
2795 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2798 PL_chopset = SvPV_force(sv,len);
2800 #ifndef MACOS_TRADITIONAL
2802 LOCK_DOLLARZERO_MUTEX;
2803 #ifdef HAS_SETPROCTITLE
2804 /* The BSDs don't show the argv[] in ps(1) output, they
2805 * show a string from the process struct and provide
2806 * the setproctitle() routine to manipulate that. */
2807 if (PL_origalen != 1) {
2808 s = SvPV_const(sv, len);
2809 # if __FreeBSD_version > 410001
2810 /* The leading "-" removes the "perl: " prefix,
2811 * but not the "(perl) suffix from the ps(1)
2812 * output, because that's what ps(1) shows if the
2813 * argv[] is modified. */
2814 setproctitle("-%s", s);
2815 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2816 /* This doesn't really work if you assume that
2817 * $0 = 'foobar'; will wipe out 'perl' from the $0
2818 * because in ps(1) output the result will be like
2819 * sprintf("perl: %s (perl)", s)
2820 * I guess this is a security feature:
2821 * one (a user process) cannot get rid of the original name.
2823 setproctitle("%s", s);
2826 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2827 if (PL_origalen != 1) {
2829 s = SvPV_const(sv, len);
2830 un.pst_command = (char *)s;
2831 pstat(PSTAT_SETCMD, un, len, 0, 0);
2834 if (PL_origalen > 1) {
2835 /* PL_origalen is set in perl_parse(). */
2836 s = SvPV_force(sv,len);
2837 if (len >= (STRLEN)PL_origalen-1) {
2838 /* Longer than original, will be truncated. We assume that
2839 * PL_origalen bytes are available. */
2840 Copy(s, PL_origargv[0], PL_origalen-1, char);
2843 /* Shorter than original, will be padded. */
2845 /* Special case for Mac OS X: see [perl #38868] */
2848 /* Is the space counterintuitive? Yes.
2849 * (You were expecting \0?)
2850 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2852 const int pad = ' ';
2854 Copy(s, PL_origargv[0], len, char);
2855 PL_origargv[0][len] = 0;
2856 memset(PL_origargv[0] + len + 1,
2857 pad, PL_origalen - len - 1);
2859 PL_origargv[0][PL_origalen-1] = 0;
2860 for (i = 1; i < PL_origargc; i++)
2864 UNLOCK_DOLLARZERO_MUTEX;
2872 Perl_whichsig(pTHX_ const char *sig)
2874 register char* const* sigv;
2876 PERL_ARGS_ASSERT_WHICHSIG;
2877 PERL_UNUSED_CONTEXT;
2879 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2880 if (strEQ(sig,*sigv))
2881 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2883 if (strEQ(sig,"CHLD"))
2887 if (strEQ(sig,"CLD"))
2894 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2895 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2897 Perl_sighandler(int sig)
2900 #ifdef PERL_GET_SIG_CONTEXT
2901 dTHXa(PERL_GET_SIG_CONTEXT);
2908 SV * const tSv = PL_Sv;
2912 XPV * const tXpv = PL_Xpv;
2914 if (PL_savestack_ix + 15 <= PL_savestack_max)
2916 if (PL_markstack_ptr < PL_markstack_max - 2)
2918 if (PL_scopestack_ix < PL_scopestack_max - 3)
2921 if (!PL_psig_ptr[sig]) {
2922 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2927 /* Max number of items pushed there is 3*n or 4. We cannot fix
2928 infinity, so we fix 4 (in fact 5): */
2930 PL_savestack_ix += 5; /* Protect save in progress. */
2931 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2934 PL_markstack_ptr++; /* Protect mark. */
2936 PL_scopestack_ix += 1;
2937 /* sv_2cv is too complicated, try a simpler variant first: */
2938 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2939 || SvTYPE(cv) != SVt_PVCV) {
2941 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2944 if (!cv || !CvROOT(cv)) {
2945 if (ckWARN(WARN_SIGNAL))
2946 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2947 PL_sig_name[sig], (gv ? GvENAME(gv)
2954 if(PL_psig_name[sig]) {
2955 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2957 #if !defined(PERL_IMPLICIT_CONTEXT)
2961 sv = sv_newmortal();
2962 sv_setpv(sv,PL_sig_name[sig]);
2965 PUSHSTACKi(PERLSI_SIGNAL);
2968 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2970 struct sigaction oact;
2972 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2975 SV *rv = newRV_noinc((SV*)sih);
2976 /* The siginfo fields signo, code, errno, pid, uid,
2977 * addr, status, and band are defined by POSIX/SUSv3. */
2978 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2979 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2980 #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. */
2981 hv_stores(sih, "errno", newSViv(sip->si_errno));
2982 hv_stores(sih, "status", newSViv(sip->si_status));
2983 hv_stores(sih, "uid", newSViv(sip->si_uid));
2984 hv_stores(sih, "pid", newSViv(sip->si_pid));
2985 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2986 hv_stores(sih, "band", newSViv(sip->si_band));
2990 mPUSHp((char *)sip, sizeof(*sip));
2998 call_sv((SV*)cv, G_DISCARD|G_EVAL);
3001 if (SvTRUE(ERRSV)) {
3003 #ifdef HAS_SIGPROCMASK
3004 /* Handler "died", for example to get out of a restart-able read().
3005 * Before we re-do that on its behalf re-enable the signal which was
3006 * blocked by the system when we entered.
3010 sigaddset(&set,sig);
3011 sigprocmask(SIG_UNBLOCK, &set, NULL);
3013 /* Not clear if this will work */
3014 (void)rsignal(sig, SIG_IGN);
3015 (void)rsignal(sig, PL_csighandlerp);
3017 #endif /* !PERL_MICRO */
3018 Perl_die(aTHX_ NULL);
3022 PL_savestack_ix -= 8; /* Unprotect save in progress. */
3026 PL_scopestack_ix -= 1;
3029 PL_op = myop; /* Apparently not needed... */
3031 PL_Sv = tSv; /* Restore global temporaries. */
3038 S_restore_magic(pTHX_ const void *p)
3041 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3042 SV* const sv = mgs->mgs_sv;
3047 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3049 #ifdef PERL_OLD_COPY_ON_WRITE
3050 /* While magic was saved (and off) sv_setsv may well have seen
3051 this SV as a prime candidate for COW. */
3053 sv_force_normal_flags(sv, 0);
3057 SvFLAGS(sv) |= mgs->mgs_flags;
3060 if (SvGMAGICAL(sv)) {
3061 /* downgrade public flags to private,
3062 and discard any other private flags */
3064 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3066 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3067 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3072 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3074 /* If we're still on top of the stack, pop us off. (That condition
3075 * will be satisfied if restore_magic was called explicitly, but *not*
3076 * if it's being called via leave_scope.)
3077 * The reason for doing this is that otherwise, things like sv_2cv()
3078 * may leave alloc gunk on the savestack, and some code
3079 * (e.g. sighandler) doesn't expect that...
3081 if (PL_savestack_ix == mgs->mgs_ss_ix)
3083 I32 popval = SSPOPINT;
3084 assert(popval == SAVEt_DESTRUCTOR_X);
3085 PL_savestack_ix -= 2;
3087 assert(popval == SAVEt_ALLOC);
3089 PL_savestack_ix -= popval;
3095 S_unwind_handler_stack(pTHX_ const void *p)
3098 const U32 flags = *(const U32*)p;
3100 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3103 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3104 #if !defined(PERL_IMPLICIT_CONTEXT)
3106 SvREFCNT_dec(PL_sig_sv);
3111 =for apidoc magic_sethint
3113 Triggered by a store to %^H, records the key/value pair to
3114 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3115 anything that would need a deep copy. Maybe we should warn if we find a
3121 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3124 SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
3125 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3127 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3129 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3130 an alternative leaf in there, with PL_compiling.cop_hints being used if
3131 it's NULL. If needed for threads, the alternative could lock a mutex,
3132 or take other more complex action. */
3134 /* Something changed in %^H, so it will need to be restored on scope exit.
3135 Doing this here saves a lot of doing it manually in perl code (and
3136 forgetting to do it, and consequent subtle errors. */
3137 PL_hints |= HINT_LOCALIZE_HH;
3138 PL_compiling.cop_hints_hash
3139 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3144 =for apidoc magic_clearhint
3146 Triggered by a delete from %^H, records the key to
3147 C<PL_compiling.cop_hints_hash>.
3152 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3156 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3157 PERL_UNUSED_ARG(sv);
3159 assert(mg->mg_len == HEf_SVKEY);
3161 PERL_UNUSED_ARG(sv);
3163 PL_hints |= HINT_LOCALIZE_HH;
3164 PL_compiling.cop_hints_hash
3165 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3166 (SV *)mg->mg_ptr, &PL_sv_placeholder);
3172 * c-indentation-style: bsd
3174 * indent-tabs-mode: t
3177 * ex: set ts=8 sts=4 sw=4 noet: