3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent.
15 * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
19 =head1 Magical Functions
21 "Magic" is special data attached to SV structures in order to give them
22 "magical" properties. When any Perl code tries to read from, or assign to,
23 an SV marked as magical, it calls the 'get' or 'set' function associated
24 with that SV's magic. A get is called prior to reading an SV, in order to
25 give it a chance to update its internal value (get on $. writes the line
26 number of the last read filehandle into to the SV's IV slot), while
27 set is called after an SV has been written to, in order to allow it to make
28 use of its changed value (set on $/ copies the SV's new value to the
29 PL_rs global variable).
31 Magic is implemented as a linked list of MAGIC structures attached to the
32 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
33 of functions that implement the get(), set(), length() etc functions,
34 plus space for some flags and pointers. For example, a tied variable has
35 a MAGIC structure that contains a pointer to the object associated with the
44 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
50 #if defined(HAS_SETGROUPS)
57 # include <sys/pstat.h>
60 #ifdef HAS_PRCTL_SET_NAME
61 # include <sys/prctl.h>
64 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
65 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
67 Signal_t Perl_csighandler(int sig);
71 /* Missing protos on LynxOS */
72 void setruid(uid_t id);
73 void seteuid(uid_t id);
74 void setrgid(uid_t id);
75 void setegid(uid_t id);
79 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
88 /* MGS is typedef'ed to struct magic_state in perl.h */
91 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
96 PERL_ARGS_ASSERT_SAVE_MAGIC;
98 assert(SvMAGICAL(sv));
99 /* Turning READONLY off for a copy-on-write scalar (including shared
100 hash keys) is a bad idea. */
102 sv_force_normal_flags(sv, 0);
104 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
106 mgs = SSPTR(mgs_ix, MGS*);
108 mgs->mgs_magical = SvMAGICAL(sv);
109 mgs->mgs_readonly = SvREADONLY(sv) != 0;
110 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
114 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
115 /* No public flags are set, so promote any private flags to public. */
116 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
121 =for apidoc mg_magical
123 Turns on the magical status of an SV. See C<sv_magic>.
129 Perl_mg_magical(pTHX_ SV *sv)
132 PERL_ARGS_ASSERT_MG_MAGICAL;
136 if ((mg = SvMAGIC(sv))) {
138 const MGVTBL* const vtbl = mg->mg_virtual;
140 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
147 } while ((mg = mg->mg_moremagic));
148 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
154 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
157 S_is_container_magic(const MAGIC *mg)
160 switch (mg->mg_type) {
163 case PERL_MAGIC_regex_global:
164 case PERL_MAGIC_nkeys:
165 #ifdef USE_LOCALE_COLLATE
166 case PERL_MAGIC_collxfrm:
169 case PERL_MAGIC_taint:
171 case PERL_MAGIC_vstring:
172 case PERL_MAGIC_utf8:
173 case PERL_MAGIC_substr:
174 case PERL_MAGIC_defelem:
175 case PERL_MAGIC_arylen:
177 case PERL_MAGIC_backref:
178 case PERL_MAGIC_arylen_p:
179 case PERL_MAGIC_rhash:
180 case PERL_MAGIC_symtab:
190 Do magic after a value is retrieved from the SV. See C<sv_magic>.
196 Perl_mg_get(pTHX_ SV *sv)
199 const I32 mgs_ix = SSNEW(sizeof(MGS));
200 const bool was_temp = cBOOL(SvTEMP(sv));
202 MAGIC *newmg, *head, *cur, *mg;
203 /* guard against sv having being freed midway by holding a private
206 PERL_ARGS_ASSERT_MG_GET;
208 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
209 cause the SV's buffer to get stolen (and maybe other stuff).
212 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
217 save_magic(mgs_ix, sv);
219 /* We must call svt_get(sv, mg) for each valid entry in the linked
220 list of magic. svt_get() may delete the current entry, add new
221 magic to the head of the list, or upgrade the SV. AMS 20010810 */
223 newmg = cur = head = mg = SvMAGIC(sv);
225 const MGVTBL * const vtbl = mg->mg_virtual;
226 MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
228 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
229 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
231 /* guard against magic having been deleted - eg FETCH calling
234 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
238 /* recalculate flags if this entry was deleted. */
239 if (mg->mg_flags & MGf_GSKIP)
240 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
246 /* Have we finished with the new entries we saw? Start again
247 where we left off (unless there are more new entries). */
255 /* Were any new entries added? */
256 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
260 (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
264 restore_magic(INT2PTR(void *, (IV)mgs_ix));
266 if (SvREFCNT(sv) == 1) {
267 /* We hold the last reference to this SV, which implies that the
268 SV was deleted as a side effect of the routines we called. */
277 Do magic after a value is assigned to the SV. See C<sv_magic>.
283 Perl_mg_set(pTHX_ SV *sv)
286 const I32 mgs_ix = SSNEW(sizeof(MGS));
290 PERL_ARGS_ASSERT_MG_SET;
292 save_magic(mgs_ix, sv);
294 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
295 const MGVTBL* vtbl = mg->mg_virtual;
296 nextmg = mg->mg_moremagic; /* it may delete itself */
297 if (mg->mg_flags & MGf_GSKIP) {
298 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
299 (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
301 if (PL_localizing == 2 && !S_is_container_magic(mg))
303 if (vtbl && vtbl->svt_set)
304 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
307 restore_magic(INT2PTR(void*, (IV)mgs_ix));
312 =for apidoc mg_length
314 Report on the SV's length. See C<sv_magic>.
320 Perl_mg_length(pTHX_ SV *sv)
326 PERL_ARGS_ASSERT_MG_LENGTH;
328 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
329 const MGVTBL * const vtbl = mg->mg_virtual;
330 if (vtbl && vtbl->svt_len) {
331 const I32 mgs_ix = SSNEW(sizeof(MGS));
332 save_magic(mgs_ix, sv);
333 /* omit MGf_GSKIP -- not changed here */
334 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
335 restore_magic(INT2PTR(void*, (IV)mgs_ix));
341 /* You can't know whether it's UTF-8 until you get the string again...
343 const U8 *s = (U8*)SvPV_const(sv, len);
346 len = utf8_length(s, s + len);
353 Perl_mg_size(pTHX_ SV *sv)
357 PERL_ARGS_ASSERT_MG_SIZE;
359 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
360 const MGVTBL* const vtbl = mg->mg_virtual;
361 if (vtbl && vtbl->svt_len) {
362 const I32 mgs_ix = SSNEW(sizeof(MGS));
364 save_magic(mgs_ix, sv);
365 /* omit MGf_GSKIP -- not changed here */
366 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
367 restore_magic(INT2PTR(void*, (IV)mgs_ix));
374 return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
378 Perl_croak(aTHX_ "Size magic not implemented");
387 Clear something magical that the SV represents. See C<sv_magic>.
393 Perl_mg_clear(pTHX_ SV *sv)
395 const I32 mgs_ix = SSNEW(sizeof(MGS));
399 PERL_ARGS_ASSERT_MG_CLEAR;
401 save_magic(mgs_ix, sv);
403 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
404 const MGVTBL* const vtbl = mg->mg_virtual;
405 /* omit GSKIP -- never set here */
407 nextmg = mg->mg_moremagic; /* it may delete itself */
409 if (vtbl && vtbl->svt_clear)
410 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
413 restore_magic(INT2PTR(void*, (IV)mgs_ix));
420 Finds the magic pointer for type matching the SV. See C<sv_magic>.
426 Perl_mg_find(pTHX_ const SV *sv, int type)
431 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
432 if (mg->mg_type == type)
442 Copies the magic from one SV to another. See C<sv_magic>.
448 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
453 PERL_ARGS_ASSERT_MG_COPY;
455 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
456 const MGVTBL* const vtbl = mg->mg_virtual;
457 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
458 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
461 const char type = mg->mg_type;
462 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
464 (type == PERL_MAGIC_tied)
466 : (type == PERL_MAGIC_regdata && mg->mg_obj)
469 toLOWER(type), key, klen);
478 =for apidoc mg_localize
480 Copy some of the magic from an existing SV to new localized version of that
481 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
484 If setmagic is false then no set magic will be called on the new (empty) SV.
485 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
486 and that will handle the magic.
492 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
497 PERL_ARGS_ASSERT_MG_LOCALIZE;
499 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
500 const MGVTBL* const vtbl = mg->mg_virtual;
501 if (!S_is_container_magic(mg))
504 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
505 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
507 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
508 mg->mg_ptr, mg->mg_len);
510 /* container types should remain read-only across localization */
511 SvFLAGS(nsv) |= SvREADONLY(sv);
514 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
515 SvFLAGS(nsv) |= SvMAGICAL(sv);
527 Free any magic storage used by the SV. See C<sv_magic>.
533 Perl_mg_free(pTHX_ SV *sv)
538 PERL_ARGS_ASSERT_MG_FREE;
540 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
541 const MGVTBL* const vtbl = mg->mg_virtual;
542 moremagic = mg->mg_moremagic;
543 if (vtbl && vtbl->svt_free)
544 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
545 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
546 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
547 Safefree(mg->mg_ptr);
548 else if (mg->mg_len == HEf_SVKEY)
549 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
551 if (mg->mg_flags & MGf_REFCOUNTED)
552 SvREFCNT_dec(mg->mg_obj);
554 SvMAGIC_set(sv, moremagic);
556 SvMAGIC_set(sv, NULL);
564 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
569 PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
572 register const REGEXP * const rx = PM_GETRE(PL_curpm);
574 if (mg->mg_obj) { /* @+ */
575 /* return the number possible */
576 return RX_NPARENS(rx);
578 I32 paren = RX_LASTPAREN(rx);
580 /* return the last filled */
582 && (RX_OFFS(rx)[paren].start == -1
583 || RX_OFFS(rx)[paren].end == -1) )
594 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
598 PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
601 register const REGEXP * const rx = PM_GETRE(PL_curpm);
603 register const I32 paren = mg->mg_len;
608 if (paren <= (I32)RX_NPARENS(rx) &&
609 (s = RX_OFFS(rx)[paren].start) != -1 &&
610 (t = RX_OFFS(rx)[paren].end) != -1)
613 if (mg->mg_obj) /* @+ */
618 if (i > 0 && RX_MATCH_UTF8(rx)) {
619 const char * const b = RX_SUBBEG(rx);
621 i = utf8_length((U8*)b, (U8*)(b+i));
632 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
634 PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
637 Perl_croak(aTHX_ "%s", PL_no_modify);
638 NORETURN_FUNCTION_END;
642 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
647 register const REGEXP * rx;
648 const char * const remaining = mg->mg_ptr + 1;
650 PERL_ARGS_ASSERT_MAGIC_LEN;
652 switch (*mg->mg_ptr) {
654 if (*remaining == '\0') { /* ^P */
656 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
658 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
662 case '\015': /* $^MATCH */
663 if (strEQ(remaining, "ATCH")) {
670 paren = RX_BUFF_IDX_PREMATCH;
674 paren = RX_BUFF_IDX_POSTMATCH;
678 paren = RX_BUFF_IDX_FULLMATCH;
680 case '1': case '2': case '3': case '4':
681 case '5': case '6': case '7': case '8': case '9':
682 paren = atoi(mg->mg_ptr);
684 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
686 i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
689 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
692 if (ckWARN(WARN_UNINITIALIZED))
697 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
698 paren = RX_LASTPAREN(rx);
703 case '\016': /* ^N */
704 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
705 paren = RX_LASTCLOSEPAREN(rx);
712 if (!SvPOK(sv) && SvNIOK(sv)) {
720 #define SvRTRIM(sv) STMT_START { \
722 STRLEN len = SvCUR(sv); \
723 char * const p = SvPVX(sv); \
724 while (len > 0 && isSPACE(p[len-1])) \
726 SvCUR_set(sv, len); \
732 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
734 PERL_ARGS_ASSERT_EMULATE_COP_IO;
736 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
737 sv_setsv(sv, &PL_sv_undef);
741 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
742 SV *const value = Perl_refcounted_he_fetch(aTHX_
744 0, "open<", 5, 0, 0);
749 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
750 SV *const value = Perl_refcounted_he_fetch(aTHX_
752 0, "open>", 5, 0, 0);
760 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
764 register char *s = NULL;
766 const char * const remaining = mg->mg_ptr + 1;
767 const char nextchar = *remaining;
769 PERL_ARGS_ASSERT_MAGIC_GET;
771 switch (*mg->mg_ptr) {
772 case '\001': /* ^A */
773 sv_setsv(sv, PL_bodytarget);
775 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
776 if (nextchar == '\0') {
777 sv_setiv(sv, (IV)PL_minus_c);
779 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
780 sv_setiv(sv, (IV)STATUS_NATIVE);
784 case '\004': /* ^D */
785 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
787 case '\005': /* ^E */
788 if (nextchar == '\0') {
791 # include <descrip.h>
792 # include <starlet.h>
794 $DESCRIPTOR(msgdsc,msg);
795 sv_setnv(sv,(NV) vaxc$errno);
796 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
797 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
802 if (!(_emx_env & 0x200)) { /* Under DOS */
803 sv_setnv(sv, (NV)errno);
804 sv_setpv(sv, errno ? Strerror(errno) : "");
806 if (errno != errno_isOS2) {
807 const int tmp = _syserrno();
808 if (tmp) /* 2nd call to _syserrno() makes it 0 */
811 sv_setnv(sv, (NV)Perl_rc);
812 sv_setpv(sv, os2error(Perl_rc));
816 const DWORD dwErr = GetLastError();
817 sv_setnv(sv, (NV)dwErr);
819 PerlProc_GetOSError(sv, dwErr);
828 sv_setnv(sv, (NV)errno);
829 sv_setpv(sv, errno ? Strerror(errno) : "");
834 SvNOK_on(sv); /* what a wonderful hack! */
836 else if (strEQ(remaining, "NCODING"))
837 sv_setsv(sv, PL_encoding);
839 case '\006': /* ^F */
840 sv_setiv(sv, (IV)PL_maxsysfd);
842 case '\010': /* ^H */
843 sv_setiv(sv, (IV)PL_hints);
845 case '\011': /* ^I */ /* NOT \t in EBCDIC */
846 sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
848 case '\017': /* ^O & ^OPEN */
849 if (nextchar == '\0') {
850 sv_setpv(sv, PL_osname);
853 else if (strEQ(remaining, "PEN")) {
854 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
858 if (nextchar == '\0') { /* ^P */
859 sv_setiv(sv, (IV)PL_perldb);
860 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
861 goto do_prematch_fetch;
862 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
863 goto do_postmatch_fetch;
866 case '\023': /* ^S */
867 if (nextchar == '\0') {
868 if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
871 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
876 case '\024': /* ^T */
877 if (nextchar == '\0') {
879 sv_setnv(sv, PL_basetime);
881 sv_setiv(sv, (IV)PL_basetime);
884 else if (strEQ(remaining, "AINT"))
885 sv_setiv(sv, PL_tainting
886 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
889 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
890 if (strEQ(remaining, "NICODE"))
891 sv_setuv(sv, (UV) PL_unicode);
892 else if (strEQ(remaining, "TF8LOCALE"))
893 sv_setuv(sv, (UV) PL_utf8locale);
894 else if (strEQ(remaining, "TF8CACHE"))
895 sv_setiv(sv, (IV) PL_utf8cache);
897 case '\027': /* ^W & $^WARNING_BITS */
898 if (nextchar == '\0')
899 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
900 else if (strEQ(remaining, "ARNING_BITS")) {
901 if (PL_compiling.cop_warnings == pWARN_NONE) {
902 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
904 else if (PL_compiling.cop_warnings == pWARN_STD) {
907 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
911 else if (PL_compiling.cop_warnings == pWARN_ALL) {
912 /* Get the bit mask for $warnings::Bits{all}, because
913 * it could have been extended by warnings::register */
914 HV * const bits=get_hv("warnings::Bits", 0);
916 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
918 sv_setsv(sv, *bits_all);
921 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
925 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
926 *PL_compiling.cop_warnings);
931 case '\015': /* $^MATCH */
932 if (strEQ(remaining, "ATCH")) {
933 case '1': case '2': case '3': case '4':
934 case '5': case '6': case '7': case '8': case '9': case '&':
935 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
937 * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
938 * XXX Does the new way break anything?
940 paren = atoi(mg->mg_ptr); /* $& is in [0] */
941 CALLREG_NUMBUF_FETCH(rx,paren,sv);
944 sv_setsv(sv,&PL_sv_undef);
948 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
949 if (RX_LASTPAREN(rx)) {
950 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
954 sv_setsv(sv,&PL_sv_undef);
956 case '\016': /* ^N */
957 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
958 if (RX_LASTCLOSEPAREN(rx)) {
959 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
964 sv_setsv(sv,&PL_sv_undef);
968 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
969 CALLREG_NUMBUF_FETCH(rx,-2,sv);
972 sv_setsv(sv,&PL_sv_undef);
976 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
977 CALLREG_NUMBUF_FETCH(rx,-1,sv);
980 sv_setsv(sv,&PL_sv_undef);
983 if (GvIO(PL_last_in_gv)) {
984 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
989 sv_setiv(sv, (IV)STATUS_CURRENT);
990 #ifdef COMPLEX_STATUS
991 SvUPGRADE(sv, SVt_PVLV);
992 LvTARGOFF(sv) = PL_statusvalue;
993 LvTARGLEN(sv) = PL_statusvalue_vms;
998 if (!isGV_with_GP(PL_defoutgv))
1000 else if (GvIOp(PL_defoutgv))
1001 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1005 sv_setpv(sv,GvENAME(PL_defoutgv));
1006 sv_catpvs(sv,"_TOP");
1010 if (!isGV_with_GP(PL_defoutgv))
1012 else if (GvIOp(PL_defoutgv))
1013 s = IoFMT_NAME(GvIOp(PL_defoutgv));
1015 s = GvENAME(PL_defoutgv);
1019 if (GvIO(PL_defoutgv))
1020 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1023 if (GvIO(PL_defoutgv))
1024 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1027 if (GvIO(PL_defoutgv))
1028 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1035 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1038 if (GvIO(PL_defoutgv))
1039 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1043 sv_copypv(sv, PL_ors_sv);
1049 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1051 sv_setnv(sv, (NV)errno);
1054 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1055 sv_setpv(sv, os2error(Perl_rc));
1058 sv_setpv(sv, errno ? Strerror(errno) : "");
1060 SvPOK_on(sv); /* may have got removed during taint processing */
1065 SvNOK_on(sv); /* what a wonderful hack! */
1068 sv_setiv(sv, (IV)PL_uid);
1071 sv_setiv(sv, (IV)PL_euid);
1074 sv_setiv(sv, (IV)PL_gid);
1077 sv_setiv(sv, (IV)PL_egid);
1079 #ifdef HAS_GETGROUPS
1081 Groups_t *gary = NULL;
1082 I32 i, num_groups = getgroups(0, gary);
1083 Newx(gary, num_groups, Groups_t);
1084 num_groups = getgroups(num_groups, gary);
1085 for (i = 0; i < num_groups; i++)
1086 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1089 (void)SvIOK_on(sv); /* what a wonderful hack! */
1099 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1101 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1103 PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1105 if (uf && uf->uf_val)
1106 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1111 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1114 STRLEN len = 0, klen;
1115 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1116 const char * const ptr = MgPV_const(mg,klen);
1119 PERL_ARGS_ASSERT_MAGIC_SETENV;
1121 #ifdef DYNAMIC_ENV_FETCH
1122 /* We just undefd an environment var. Is a replacement */
1123 /* waiting in the wings? */
1125 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1127 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1131 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1132 /* And you'll never guess what the dog had */
1133 /* in its mouth... */
1135 MgTAINTEDDIR_off(mg);
1137 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1138 char pathbuf[256], eltbuf[256], *cp, *elt;
1142 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1144 do { /* DCL$PATH may be a search list */
1145 while (1) { /* as may dev portion of any element */
1146 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1147 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1148 cando_by_name(S_IWUSR,0,elt) ) {
1149 MgTAINTEDDIR_on(mg);
1153 if ((cp = strchr(elt, ':')) != NULL)
1155 if (my_trnlnm(elt, eltbuf, j++))
1161 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1164 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1165 const char * const strend = s + len;
1167 while (s < strend) {
1171 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1172 const char path_sep = '|';
1174 const char path_sep = ':';
1176 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1177 s, strend, path_sep, &i);
1179 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1181 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1183 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1185 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1186 MgTAINTEDDIR_on(mg);
1192 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1198 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1200 PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1201 PERL_UNUSED_ARG(sv);
1202 my_setenv(MgPV_nolen_const(mg),NULL);
1207 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1210 PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1211 PERL_UNUSED_ARG(mg);
1213 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1215 if (PL_localizing) {
1218 hv_iterinit(MUTABLE_HV(sv));
1219 while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1221 my_setenv(hv_iterkey(entry, &keylen),
1222 SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1230 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1233 PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1234 PERL_UNUSED_ARG(sv);
1235 PERL_UNUSED_ARG(mg);
1237 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1245 #ifdef HAS_SIGPROCMASK
1247 restore_sigmask(pTHX_ SV *save_sv)
1249 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1250 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1254 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1257 /* Are we fetching a signal entry? */
1258 int i = (I16)mg->mg_private;
1260 PERL_ARGS_ASSERT_MAGIC_GETSIG;
1263 mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
1268 sv_setsv(sv,PL_psig_ptr[i]);
1270 Sighandler_t sigstate = rsignal_state(i);
1271 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1272 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1275 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1276 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1279 /* cache state so we don't fetch it again */
1280 if(sigstate == (Sighandler_t) SIG_IGN)
1281 sv_setpvs(sv,"IGNORE");
1283 sv_setsv(sv,&PL_sv_undef);
1284 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1291 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1293 PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1294 PERL_UNUSED_ARG(sv);
1296 magic_setsig(NULL, mg);
1297 return sv_unmagic(sv, mg->mg_type);
1301 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1302 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1304 Perl_csighandler(int sig)
1307 #ifdef PERL_GET_SIG_CONTEXT
1308 dTHXa(PERL_GET_SIG_CONTEXT);
1312 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1313 (void) rsignal(sig, PL_csighandlerp);
1314 if (PL_sig_ignoring[sig]) return;
1316 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1317 if (PL_sig_defaulting[sig])
1318 #ifdef KILL_BY_SIGPRC
1319 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1334 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1335 /* Call the perl level handler now--
1336 * with risk we may be in malloc() or being destructed etc. */
1337 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1338 (*PL_sighandlerp)(sig, NULL, NULL);
1340 (*PL_sighandlerp)(sig);
1343 if (!PL_psig_pend) return;
1344 /* Set a flag to say this signal is pending, that is awaiting delivery after
1345 * the current Perl opcode completes */
1346 PL_psig_pend[sig]++;
1348 #ifndef SIG_PENDING_DIE_COUNT
1349 # define SIG_PENDING_DIE_COUNT 120
1351 /* Add one to say _a_ signal is pending */
1352 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1353 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1354 (unsigned long)SIG_PENDING_DIE_COUNT);
1358 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1360 Perl_csighandler_init(void)
1363 if (PL_sig_handlers_initted) return;
1365 for (sig = 1; sig < SIG_SIZE; sig++) {
1366 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1368 PL_sig_defaulting[sig] = 1;
1369 (void) rsignal(sig, PL_csighandlerp);
1371 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1372 PL_sig_ignoring[sig] = 0;
1375 PL_sig_handlers_initted = 1;
1380 Perl_despatch_signals(pTHX)
1385 for (sig = 1; sig < SIG_SIZE; sig++) {
1386 if (PL_psig_pend[sig]) {
1387 PERL_BLOCKSIG_ADD(set, sig);
1388 PL_psig_pend[sig] = 0;
1389 PERL_BLOCKSIG_BLOCK(set);
1390 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1391 (*PL_sighandlerp)(sig, NULL, NULL);
1393 (*PL_sighandlerp)(sig);
1395 PERL_BLOCKSIG_UNBLOCK(set);
1400 /* sv of NULL signifies that we're acting as magic_clearsig. */
1402 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1407 /* Need to be careful with SvREFCNT_dec(), because that can have side
1408 * effects (due to closures). We must make sure that the new disposition
1409 * is in place before it is called.
1413 #ifdef HAS_SIGPROCMASK
1417 register const char *s = MgPV_const(mg,len);
1419 PERL_ARGS_ASSERT_MAGIC_SETSIG;
1422 if (strEQ(s,"__DIE__"))
1424 else if (strEQ(s,"__WARN__")
1425 && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1426 /* Merge the existing behaviours, which are as follows:
1427 magic_setsig, we always set svp to &PL_warnhook
1428 (hence we always change the warnings handler)
1429 For magic_clearsig, we don't change the warnings handler if it's
1430 set to the &PL_warnhook. */
1433 Perl_croak(aTHX_ "No such hook: %s", s);
1436 if (*svp != PERL_WARNHOOK_FATAL)
1442 i = (I16)mg->mg_private;
1444 i = whichsig(s); /* ...no, a brick */
1445 mg->mg_private = (U16)i;
1449 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1452 #ifdef HAS_SIGPROCMASK
1453 /* Avoid having the signal arrive at a bad time, if possible. */
1456 sigprocmask(SIG_BLOCK, &set, &save);
1458 save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1459 SAVEFREESV(save_sv);
1460 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1463 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1464 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1466 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1467 PL_sig_ignoring[i] = 0;
1469 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1470 PL_sig_defaulting[i] = 0;
1472 to_dec = PL_psig_ptr[i];
1474 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1475 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1477 /* Signals don't change name during the program's execution, so once
1478 they're cached in the appropriate slot of PL_psig_name, they can
1481 Ideally we'd find some way of making SVs at (C) compile time, or
1482 at least, doing most of the work. */
1483 if (!PL_psig_name[i]) {
1484 PL_psig_name[i] = newSVpvn(s, len);
1485 SvREADONLY_on(PL_psig_name[i]);
1488 SvREFCNT_dec(PL_psig_name[i]);
1489 PL_psig_name[i] = NULL;
1490 PL_psig_ptr[i] = NULL;
1493 if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1495 (void)rsignal(i, PL_csighandlerp);
1498 *svp = SvREFCNT_inc_simple_NN(sv);
1500 if (sv && SvOK(sv)) {
1501 s = SvPV_force(sv, len);
1505 if (sv && strEQ(s,"IGNORE")) {
1507 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1508 PL_sig_ignoring[i] = 1;
1509 (void)rsignal(i, PL_csighandlerp);
1511 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1515 else if (!sv || strEQ(s,"DEFAULT") || !len) {
1517 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1518 PL_sig_defaulting[i] = 1;
1519 (void)rsignal(i, PL_csighandlerp);
1521 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1527 * We should warn if HINT_STRICT_REFS, but without
1528 * access to a known hint bit in a known OP, we can't
1529 * tell whether HINT_STRICT_REFS is in force or not.
1531 if (!strchr(s,':') && !strchr(s,'\''))
1532 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1535 (void)rsignal(i, PL_csighandlerp);
1537 *svp = SvREFCNT_inc_simple_NN(sv);
1541 #ifdef HAS_SIGPROCMASK
1545 SvREFCNT_dec(to_dec);
1548 #endif /* !PERL_MICRO */
1551 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1554 PERL_ARGS_ASSERT_MAGIC_SETISA;
1555 PERL_UNUSED_ARG(sv);
1557 /* Skip _isaelem because _isa will handle it shortly */
1558 if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1561 return magic_clearisa(NULL, mg);
1564 /* sv of NULL signifies that we're acting as magic_setisa. */
1566 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1571 PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1573 /* Bail out if destruction is going on */
1574 if(PL_dirty) return 0;
1577 av_clear(MUTABLE_AV(sv));
1579 /* XXX Once it's possible, we need to
1580 detect that our @ISA is aliased in
1581 other stashes, and act on the stashes
1582 of all of the aliases */
1584 /* The first case occurs via setisa,
1585 the second via setisa_elem, which
1586 calls this same magic */
1588 SvTYPE(mg->mg_obj) == SVt_PVGV
1589 ? (const GV *)mg->mg_obj
1590 : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1594 mro_isa_changed_in(stash);
1600 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1603 PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1604 PERL_UNUSED_ARG(sv);
1605 PERL_UNUSED_ARG(mg);
1606 PL_amagic_generation++;
1612 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1614 HV * const hv = MUTABLE_HV(LvTARG(sv));
1617 PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1618 PERL_UNUSED_ARG(mg);
1621 (void) hv_iterinit(hv);
1622 if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1625 while (hv_iternext(hv))
1630 sv_setiv(sv, (IV)i);
1635 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1637 PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1638 PERL_UNUSED_ARG(mg);
1640 hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1645 /* caller is responsible for stack switching/cleanup */
1647 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1652 PERL_ARGS_ASSERT_MAGIC_METHCALL;
1656 PUSHs(SvTIED_obj(sv, mg));
1659 if (mg->mg_len >= 0)
1660 mPUSHp(mg->mg_ptr, mg->mg_len);
1661 else if (mg->mg_len == HEf_SVKEY)
1662 PUSHs(MUTABLE_SV(mg->mg_ptr));
1664 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1673 return call_method(meth, flags);
1677 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1681 PERL_ARGS_ASSERT_MAGIC_METHPACK;
1685 PUSHSTACKi(PERLSI_MAGIC);
1687 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1688 sv_setsv(sv, *PL_stack_sp--);
1698 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1700 PERL_ARGS_ASSERT_MAGIC_GETPACK;
1702 if (mg->mg_type == PERL_MAGIC_tiedelem)
1703 mg->mg_flags |= MGf_GSKIP;
1704 magic_methpack(sv,mg,"FETCH");
1709 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1715 PERL_ARGS_ASSERT_MAGIC_SETPACK;
1717 /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
1718 * STORE() is not $val, but rather a PVLV (the sv in this call), whose
1719 * public flags indicate its value based on copying from $val. Doing
1720 * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
1721 * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
1722 * wrong if $val happened to be tainted, as sv hasn't got magic
1723 * enabled, even though taint magic is in the chain. In which case,
1724 * fake up a temporary tainted value (this is easier than temporarily
1725 * re-enabling magic on sv). */
1727 if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
1728 && (tmg->mg_len & 1))
1730 val = sv_mortalcopy(sv);
1737 PUSHSTACKi(PERLSI_MAGIC);
1738 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, val);
1745 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1747 PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1749 return magic_methpack(sv,mg,"DELETE");
1754 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1759 PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1763 PUSHSTACKi(PERLSI_MAGIC);
1764 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1765 sv = *PL_stack_sp--;
1766 retval = SvIV(sv)-1;
1768 Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1773 return (U32) retval;
1777 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1781 PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1784 PUSHSTACKi(PERLSI_MAGIC);
1786 XPUSHs(SvTIED_obj(sv, mg));
1788 call_method("CLEAR", G_SCALAR|G_DISCARD);
1796 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1799 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1801 PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1805 PUSHSTACKi(PERLSI_MAGIC);
1808 PUSHs(SvTIED_obj(sv, mg));
1813 if (call_method(meth, G_SCALAR))
1814 sv_setsv(key, *PL_stack_sp--);
1823 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1825 PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1827 return magic_methpack(sv,mg,"EXISTS");
1831 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1835 SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
1836 HV * const pkg = SvSTASH((const SV *)SvRV(tied));
1838 PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1840 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1842 if (HvEITER_get(hv))
1843 /* we are in an iteration so the hash cannot be empty */
1845 /* no xhv_eiter so now use FIRSTKEY */
1846 key = sv_newmortal();
1847 magic_nextpack(MUTABLE_SV(hv), mg, key);
1848 HvEITER_set(hv, NULL); /* need to reset iterator */
1849 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1852 /* there is a SCALAR method that we can call */
1854 PUSHSTACKi(PERLSI_MAGIC);
1860 if (call_method("SCALAR", G_SCALAR))
1861 retval = *PL_stack_sp--;
1863 retval = &PL_sv_undef;
1870 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1873 GV * const gv = PL_DBline;
1874 const I32 i = SvTRUE(sv);
1875 SV ** const svp = av_fetch(GvAV(gv),
1876 atoi(MgPV_nolen_const(mg)), FALSE);
1878 PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1880 if (svp && SvIOKp(*svp)) {
1881 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1883 /* set or clear breakpoint in the relevant control op */
1885 o->op_flags |= OPf_SPECIAL;
1887 o->op_flags &= ~OPf_SPECIAL;
1894 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1897 AV * const obj = MUTABLE_AV(mg->mg_obj);
1899 PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1902 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1910 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1913 AV * const obj = MUTABLE_AV(mg->mg_obj);
1915 PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1918 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1920 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1921 "Attempt to set length of freed array");
1927 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1931 PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1932 PERL_UNUSED_ARG(sv);
1934 /* during global destruction, mg_obj may already have been freed */
1935 if (PL_in_clean_all)
1938 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1941 /* arylen scalar holds a pointer back to the array, but doesn't own a
1942 reference. Hence the we (the array) are about to go away with it
1943 still pointing at us. Clear its pointer, else it would be pointing
1944 at free memory. See the comment in sv_magic about reference loops,
1945 and why it can't own a reference to us. */
1952 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1955 SV* const lsv = LvTARG(sv);
1957 PERL_ARGS_ASSERT_MAGIC_GETPOS;
1958 PERL_UNUSED_ARG(mg);
1960 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1961 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1962 if (found && found->mg_len >= 0) {
1963 I32 i = found->mg_len;
1965 sv_pos_b2u(lsv, &i);
1966 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1975 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1978 SV* const lsv = LvTARG(sv);
1984 PERL_ARGS_ASSERT_MAGIC_SETPOS;
1985 PERL_UNUSED_ARG(mg);
1987 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1988 found = mg_find(lsv, PERL_MAGIC_regex_global);
1994 #ifdef PERL_OLD_COPY_ON_WRITE
1996 sv_force_normal_flags(lsv, 0);
1998 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2001 else if (!SvOK(sv)) {
2005 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2007 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2010 ulen = sv_len_utf8(lsv);
2020 else if (pos > (SSize_t)len)
2025 sv_pos_u2b(lsv, &p, 0);
2029 found->mg_len = pos;
2030 found->mg_flags &= ~MGf_MINMATCH;
2036 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2039 SV * const lsv = LvTARG(sv);
2040 const char * const tmps = SvPV_const(lsv,len);
2041 STRLEN offs = LvTARGOFF(sv);
2042 STRLEN rem = LvTARGLEN(sv);
2044 PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2045 PERL_UNUSED_ARG(mg);
2048 offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
2051 if (rem > len - offs)
2053 sv_setpvn(sv, tmps + offs, rem);
2060 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2064 const char * const tmps = SvPV_const(sv, len);
2065 SV * const lsv = LvTARG(sv);
2066 STRLEN lvoff = LvTARGOFF(sv);
2067 STRLEN lvlen = LvTARGLEN(sv);
2069 PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2070 PERL_UNUSED_ARG(mg);
2073 sv_utf8_upgrade(lsv);
2074 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2075 sv_insert(lsv, lvoff, lvlen, tmps, len);
2076 LvTARGLEN(sv) = sv_len_utf8(sv);
2079 else if (lsv && SvUTF8(lsv)) {
2081 lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2082 LvTARGLEN(sv) = len;
2083 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2084 sv_insert(lsv, lvoff, lvlen, utf8, len);
2088 sv_insert(lsv, lvoff, lvlen, tmps, len);
2089 LvTARGLEN(sv) = len;
2096 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2100 PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2101 PERL_UNUSED_ARG(sv);
2103 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2108 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2112 PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2113 PERL_UNUSED_ARG(sv);
2115 /* update taint status */
2124 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2126 SV * const lsv = LvTARG(sv);
2128 PERL_ARGS_ASSERT_MAGIC_GETVEC;
2129 PERL_UNUSED_ARG(mg);
2132 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2140 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2142 PERL_ARGS_ASSERT_MAGIC_SETVEC;
2143 PERL_UNUSED_ARG(mg);
2144 do_vecset(sv); /* XXX slurp this routine */
2149 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2154 PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2156 if (LvTARGLEN(sv)) {
2158 SV * const ahv = LvTARG(sv);
2159 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2164 AV *const av = MUTABLE_AV(LvTARG(sv));
2165 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2166 targ = AvARRAY(av)[LvTARGOFF(sv)];
2168 if (targ && (targ != &PL_sv_undef)) {
2169 /* somebody else defined it for us */
2170 SvREFCNT_dec(LvTARG(sv));
2171 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2173 SvREFCNT_dec(mg->mg_obj);
2175 mg->mg_flags &= ~MGf_REFCOUNTED;
2180 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2185 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2187 PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2188 PERL_UNUSED_ARG(mg);
2192 sv_setsv(LvTARG(sv), sv);
2193 SvSETMAGIC(LvTARG(sv));
2199 Perl_vivify_defelem(pTHX_ SV *sv)
2205 PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2207 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2210 SV * const ahv = LvTARG(sv);
2211 HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2214 if (!value || value == &PL_sv_undef)
2215 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2218 AV *const av = MUTABLE_AV(LvTARG(sv));
2219 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2220 LvTARG(sv) = NULL; /* array can't be extended */
2222 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2223 if (!svp || (value = *svp) == &PL_sv_undef)
2224 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2227 SvREFCNT_inc_simple_void(value);
2228 SvREFCNT_dec(LvTARG(sv));
2231 SvREFCNT_dec(mg->mg_obj);
2233 mg->mg_flags &= ~MGf_REFCOUNTED;
2237 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2239 PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2240 return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2244 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2246 PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2247 PERL_UNUSED_CONTEXT;
2249 if (!isGV_with_GP(sv))
2255 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2257 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2259 PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2261 if (uf && uf->uf_set)
2262 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2267 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2269 const char type = mg->mg_type;
2271 PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2273 if (type == PERL_MAGIC_qr) {
2274 } else if (type == PERL_MAGIC_bm) {
2278 assert(type == PERL_MAGIC_fm);
2281 return sv_unmagic(sv, type);
2284 #ifdef USE_LOCALE_COLLATE
2286 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2288 PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2291 * RenE<eacute> Descartes said "I think not."
2292 * and vanished with a faint plop.
2294 PERL_UNUSED_CONTEXT;
2295 PERL_UNUSED_ARG(sv);
2297 Safefree(mg->mg_ptr);
2303 #endif /* USE_LOCALE_COLLATE */
2305 /* Just clear the UTF-8 cache data. */
2307 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2309 PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2310 PERL_UNUSED_CONTEXT;
2311 PERL_UNUSED_ARG(sv);
2312 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2314 mg->mg_len = -1; /* The mg_len holds the len cache. */
2319 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2322 register const char *s;
2324 register const REGEXP * rx;
2325 const char * const remaining = mg->mg_ptr + 1;
2329 PERL_ARGS_ASSERT_MAGIC_SET;
2331 switch (*mg->mg_ptr) {
2332 case '\015': /* $^MATCH */
2333 if (strEQ(remaining, "ATCH"))
2335 case '`': /* ${^PREMATCH} caught below */
2337 paren = RX_BUFF_IDX_PREMATCH;
2339 case '\'': /* ${^POSTMATCH} caught below */
2341 paren = RX_BUFF_IDX_POSTMATCH;
2345 paren = RX_BUFF_IDX_FULLMATCH;
2347 case '1': case '2': case '3': case '4':
2348 case '5': case '6': case '7': case '8': case '9':
2349 paren = atoi(mg->mg_ptr);
2351 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2352 CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2355 /* Croak with a READONLY error when a numbered match var is
2356 * set without a previous pattern match. Unless it's C<local $1>
2358 if (!PL_localizing) {
2359 Perl_croak(aTHX_ "%s", PL_no_modify);
2362 case '\001': /* ^A */
2363 sv_setsv(PL_bodytarget, sv);
2365 case '\003': /* ^C */
2366 PL_minus_c = cBOOL(SvIV(sv));
2369 case '\004': /* ^D */
2371 s = SvPV_nolen_const(sv);
2372 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2373 if (DEBUG_x_TEST || DEBUG_B_TEST)
2374 dump_all_perl(!DEBUG_B_TEST);
2376 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2379 case '\005': /* ^E */
2380 if (*(mg->mg_ptr+1) == '\0') {
2382 set_vaxc_errno(SvIV(sv));
2385 SetLastError( SvIV(sv) );
2388 os2_setsyserrno(SvIV(sv));
2390 /* will anyone ever use this? */
2391 SETERRNO(SvIV(sv), 4);
2396 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2397 SvREFCNT_dec(PL_encoding);
2398 if (SvOK(sv) || SvGMAGICAL(sv)) {
2399 PL_encoding = newSVsv(sv);
2406 case '\006': /* ^F */
2407 PL_maxsysfd = SvIV(sv);
2409 case '\010': /* ^H */
2410 PL_hints = SvIV(sv);
2412 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2413 Safefree(PL_inplace);
2414 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2416 case '\017': /* ^O */
2417 if (*(mg->mg_ptr+1) == '\0') {
2418 Safefree(PL_osname);
2421 TAINT_PROPER("assigning to $^O");
2422 PL_osname = savesvpv(sv);
2425 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2427 const char *const start = SvPV(sv, len);
2428 const char *out = (const char*)memchr(start, '\0', len);
2432 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2433 PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2435 /* Opening for input is more common than opening for output, so
2436 ensure that hints for input are sooner on linked list. */
2437 tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2439 : newSVpvs_flags("", SvUTF8(sv));
2440 (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2443 tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2445 (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2449 case '\020': /* ^P */
2450 if (*remaining == '\0') { /* ^P */
2451 PL_perldb = SvIV(sv);
2452 if (PL_perldb && !PL_DBsingle)
2455 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2457 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2460 case '\024': /* ^T */
2462 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2464 PL_basetime = (Time_t)SvIV(sv);
2467 case '\025': /* ^UTF8CACHE */
2468 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2469 PL_utf8cache = (signed char) sv_2iv(sv);
2472 case '\027': /* ^W & $^WARNING_BITS */
2473 if (*(mg->mg_ptr+1) == '\0') {
2474 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2476 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2477 | (i ? G_WARN_ON : G_WARN_OFF) ;
2480 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2481 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2482 if (!SvPOK(sv) && PL_localizing) {
2483 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2484 PL_compiling.cop_warnings = pWARN_NONE;
2489 int accumulate = 0 ;
2490 int any_fatals = 0 ;
2491 const char * const ptr = SvPV_const(sv, len) ;
2492 for (i = 0 ; i < len ; ++i) {
2493 accumulate |= ptr[i] ;
2494 any_fatals |= (ptr[i] & 0xAA) ;
2497 if (!specialWARN(PL_compiling.cop_warnings))
2498 PerlMemShared_free(PL_compiling.cop_warnings);
2499 PL_compiling.cop_warnings = pWARN_NONE;
2501 /* Yuck. I can't see how to abstract this: */
2502 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2503 WARN_ALL) && !any_fatals) {
2504 if (!specialWARN(PL_compiling.cop_warnings))
2505 PerlMemShared_free(PL_compiling.cop_warnings);
2506 PL_compiling.cop_warnings = pWARN_ALL;
2507 PL_dowarn |= G_WARN_ONCE ;
2511 const char *const p = SvPV_const(sv, len);
2513 PL_compiling.cop_warnings
2514 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2517 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2518 PL_dowarn |= G_WARN_ONCE ;
2526 if (PL_localizing) {
2527 if (PL_localizing == 1)
2528 SAVESPTR(PL_last_in_gv);
2530 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2531 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2534 if (isGV_with_GP(PL_defoutgv)) {
2535 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2536 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2537 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2541 if (isGV_with_GP(PL_defoutgv)) {
2542 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2543 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2544 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2548 if (isGV_with_GP(PL_defoutgv))
2549 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2552 if (isGV_with_GP(PL_defoutgv)) {
2553 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2554 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2555 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2559 if (isGV_with_GP(PL_defoutgv))
2560 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2564 IO * const io = GvIO(PL_defoutgv);
2567 if ((SvIV(sv)) == 0)
2568 IoFLAGS(io) &= ~IOf_FLUSH;
2570 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2571 PerlIO *ofp = IoOFP(io);
2573 (void)PerlIO_flush(ofp);
2574 IoFLAGS(io) |= IOf_FLUSH;
2580 SvREFCNT_dec(PL_rs);
2581 PL_rs = newSVsv(sv);
2584 SvREFCNT_dec(PL_ors_sv);
2585 if (SvOK(sv) || SvGMAGICAL(sv)) {
2586 PL_ors_sv = newSVsv(sv);
2593 CopARYBASE_set(&PL_compiling, SvIV(sv));
2596 #ifdef COMPLEX_STATUS
2597 if (PL_localizing == 2) {
2598 SvUPGRADE(sv, SVt_PVLV);
2599 PL_statusvalue = LvTARGOFF(sv);
2600 PL_statusvalue_vms = LvTARGLEN(sv);
2604 #ifdef VMSISH_STATUS
2606 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2609 STATUS_UNIX_EXIT_SET(SvIV(sv));
2614 # define PERL_VMS_BANG vaxc$errno
2616 # define PERL_VMS_BANG 0
2618 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2619 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2624 if (PL_delaymagic) {
2625 PL_delaymagic |= DM_RUID;
2626 break; /* don't do magic till later */
2629 (void)setruid((Uid_t)PL_uid);
2632 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2634 #ifdef HAS_SETRESUID
2635 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2637 if (PL_uid == PL_euid) { /* special case $< = $> */
2639 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2640 if (PL_uid != 0 && PerlProc_getuid() == 0)
2641 (void)PerlProc_setuid(0);
2643 (void)PerlProc_setuid(PL_uid);
2645 PL_uid = PerlProc_getuid();
2646 Perl_croak(aTHX_ "setruid() not implemented");
2651 PL_uid = PerlProc_getuid();
2655 if (PL_delaymagic) {
2656 PL_delaymagic |= DM_EUID;
2657 break; /* don't do magic till later */
2660 (void)seteuid((Uid_t)PL_euid);
2663 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2665 #ifdef HAS_SETRESUID
2666 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2668 if (PL_euid == PL_uid) /* special case $> = $< */
2669 PerlProc_setuid(PL_euid);
2671 PL_euid = PerlProc_geteuid();
2672 Perl_croak(aTHX_ "seteuid() not implemented");
2677 PL_euid = PerlProc_geteuid();
2681 if (PL_delaymagic) {
2682 PL_delaymagic |= DM_RGID;
2683 break; /* don't do magic till later */
2686 (void)setrgid((Gid_t)PL_gid);
2689 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2691 #ifdef HAS_SETRESGID
2692 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2694 if (PL_gid == PL_egid) /* special case $( = $) */
2695 (void)PerlProc_setgid(PL_gid);
2697 PL_gid = PerlProc_getgid();
2698 Perl_croak(aTHX_ "setrgid() not implemented");
2703 PL_gid = PerlProc_getgid();
2706 #ifdef HAS_SETGROUPS
2708 const char *p = SvPV_const(sv, len);
2709 Groups_t *gary = NULL;
2710 #ifdef _SC_NGROUPS_MAX
2711 int maxgrp = sysconf(_SC_NGROUPS_MAX);
2716 int maxgrp = NGROUPS;
2722 for (i = 0; i < maxgrp; ++i) {
2723 while (*p && !isSPACE(*p))
2730 Newx(gary, i + 1, Groups_t);
2732 Renew(gary, i + 1, Groups_t);
2736 (void)setgroups(i, gary);
2739 #else /* HAS_SETGROUPS */
2741 #endif /* HAS_SETGROUPS */
2742 if (PL_delaymagic) {
2743 PL_delaymagic |= DM_EGID;
2744 break; /* don't do magic till later */
2747 (void)setegid((Gid_t)PL_egid);
2750 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2752 #ifdef HAS_SETRESGID
2753 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2755 if (PL_egid == PL_gid) /* special case $) = $( */
2756 (void)PerlProc_setgid(PL_egid);
2758 PL_egid = PerlProc_getegid();
2759 Perl_croak(aTHX_ "setegid() not implemented");
2764 PL_egid = PerlProc_getegid();
2767 PL_chopset = SvPV_force(sv,len);
2770 LOCK_DOLLARZERO_MUTEX;
2771 #ifdef HAS_SETPROCTITLE
2772 /* The BSDs don't show the argv[] in ps(1) output, they
2773 * show a string from the process struct and provide
2774 * the setproctitle() routine to manipulate that. */
2775 if (PL_origalen != 1) {
2776 s = SvPV_const(sv, len);
2777 # if __FreeBSD_version > 410001
2778 /* The leading "-" removes the "perl: " prefix,
2779 * but not the "(perl) suffix from the ps(1)
2780 * output, because that's what ps(1) shows if the
2781 * argv[] is modified. */
2782 setproctitle("-%s", s);
2783 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2784 /* This doesn't really work if you assume that
2785 * $0 = 'foobar'; will wipe out 'perl' from the $0
2786 * because in ps(1) output the result will be like
2787 * sprintf("perl: %s (perl)", s)
2788 * I guess this is a security feature:
2789 * one (a user process) cannot get rid of the original name.
2791 setproctitle("%s", s);
2794 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2795 if (PL_origalen != 1) {
2797 s = SvPV_const(sv, len);
2798 un.pst_command = (char *)s;
2799 pstat(PSTAT_SETCMD, un, len, 0, 0);
2802 if (PL_origalen > 1) {
2803 /* PL_origalen is set in perl_parse(). */
2804 s = SvPV_force(sv,len);
2805 if (len >= (STRLEN)PL_origalen-1) {
2806 /* Longer than original, will be truncated. We assume that
2807 * PL_origalen bytes are available. */
2808 Copy(s, PL_origargv[0], PL_origalen-1, char);
2811 /* Shorter than original, will be padded. */
2813 /* Special case for Mac OS X: see [perl #38868] */
2816 /* Is the space counterintuitive? Yes.
2817 * (You were expecting \0?)
2818 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2820 const int pad = ' ';
2822 Copy(s, PL_origargv[0], len, char);
2823 PL_origargv[0][len] = 0;
2824 memset(PL_origargv[0] + len + 1,
2825 pad, PL_origalen - len - 1);
2827 PL_origargv[0][PL_origalen-1] = 0;
2828 for (i = 1; i < PL_origargc; i++)
2830 #ifdef HAS_PRCTL_SET_NAME
2831 /* Set the legacy process name in addition to the POSIX name on Linux */
2832 if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2833 /* diag_listed_as: SKIPME */
2834 Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2839 UNLOCK_DOLLARZERO_MUTEX;
2846 Perl_whichsig(pTHX_ const char *sig)
2848 register char* const* sigv;
2850 PERL_ARGS_ASSERT_WHICHSIG;
2851 PERL_UNUSED_CONTEXT;
2853 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2854 if (strEQ(sig,*sigv))
2855 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2857 if (strEQ(sig,"CHLD"))
2861 if (strEQ(sig,"CLD"))
2868 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2869 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2871 Perl_sighandler(int sig)
2874 #ifdef PERL_GET_SIG_CONTEXT
2875 dTHXa(PERL_GET_SIG_CONTEXT);
2882 SV * const tSv = PL_Sv;
2886 XPV * const tXpv = PL_Xpv;
2888 if (PL_savestack_ix + 15 <= PL_savestack_max)
2890 if (PL_markstack_ptr < PL_markstack_max - 2)
2892 if (PL_scopestack_ix < PL_scopestack_max - 3)
2895 if (!PL_psig_ptr[sig]) {
2896 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2901 /* Max number of items pushed there is 3*n or 4. We cannot fix
2902 infinity, so we fix 4 (in fact 5): */
2904 PL_savestack_ix += 5; /* Protect save in progress. */
2905 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2908 PL_markstack_ptr++; /* Protect mark. */
2910 PL_scopestack_ix += 1;
2911 /* sv_2cv is too complicated, try a simpler variant first: */
2912 if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2913 || SvTYPE(cv) != SVt_PVCV) {
2915 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2918 if (!cv || !CvROOT(cv)) {
2919 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2920 PL_sig_name[sig], (gv ? GvENAME(gv)
2927 if(PL_psig_name[sig]) {
2928 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2930 #if !defined(PERL_IMPLICIT_CONTEXT)
2934 sv = sv_newmortal();
2935 sv_setpv(sv,PL_sig_name[sig]);
2938 PUSHSTACKi(PERLSI_SIGNAL);
2941 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2943 struct sigaction oact;
2945 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2948 SV *rv = newRV_noinc(MUTABLE_SV(sih));
2949 /* The siginfo fields signo, code, errno, pid, uid,
2950 * addr, status, and band are defined by POSIX/SUSv3. */
2951 (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2952 (void)hv_stores(sih, "code", newSViv(sip->si_code));
2953 #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. */
2954 hv_stores(sih, "errno", newSViv(sip->si_errno));
2955 hv_stores(sih, "status", newSViv(sip->si_status));
2956 hv_stores(sih, "uid", newSViv(sip->si_uid));
2957 hv_stores(sih, "pid", newSViv(sip->si_pid));
2958 hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
2959 hv_stores(sih, "band", newSViv(sip->si_band));
2963 mPUSHp((char *)sip, sizeof(*sip));
2971 call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2974 if (SvTRUE(ERRSV)) {
2976 #ifdef HAS_SIGPROCMASK
2977 /* Handler "died", for example to get out of a restart-able read().
2978 * Before we re-do that on its behalf re-enable the signal which was
2979 * blocked by the system when we entered.
2983 sigaddset(&set,sig);
2984 sigprocmask(SIG_UNBLOCK, &set, NULL);
2986 /* Not clear if this will work */
2987 (void)rsignal(sig, SIG_IGN);
2988 (void)rsignal(sig, PL_csighandlerp);
2990 #endif /* !PERL_MICRO */
2991 Perl_die(aTHX_ NULL);
2995 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2999 PL_scopestack_ix -= 1;
3002 PL_op = myop; /* Apparently not needed... */
3004 PL_Sv = tSv; /* Restore global temporaries. */
3011 S_restore_magic(pTHX_ const void *p)
3014 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3015 SV* const sv = mgs->mgs_sv;
3020 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3022 #ifdef PERL_OLD_COPY_ON_WRITE
3023 /* While magic was saved (and off) sv_setsv may well have seen
3024 this SV as a prime candidate for COW. */
3026 sv_force_normal_flags(sv, 0);
3029 if (mgs->mgs_readonly)
3031 if (mgs->mgs_magical)
3032 SvFLAGS(sv) |= mgs->mgs_magical;
3035 if (SvGMAGICAL(sv)) {
3036 /* downgrade public flags to private,
3037 and discard any other private flags */
3039 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3041 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3042 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3047 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
3049 /* If we're still on top of the stack, pop us off. (That condition
3050 * will be satisfied if restore_magic was called explicitly, but *not*
3051 * if it's being called via leave_scope.)
3052 * The reason for doing this is that otherwise, things like sv_2cv()
3053 * may leave alloc gunk on the savestack, and some code
3054 * (e.g. sighandler) doesn't expect that...
3056 if (PL_savestack_ix == mgs->mgs_ss_ix)
3058 I32 popval = SSPOPINT;
3059 assert(popval == SAVEt_DESTRUCTOR_X);
3060 PL_savestack_ix -= 2;
3062 assert(popval == SAVEt_ALLOC);
3064 PL_savestack_ix -= popval;
3070 S_unwind_handler_stack(pTHX_ const void *p)
3073 const U32 flags = *(const U32*)p;
3075 PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3078 PL_savestack_ix -= 5; /* Unprotect save in progress. */
3079 #if !defined(PERL_IMPLICIT_CONTEXT)
3081 SvREFCNT_dec(PL_sig_sv);
3086 =for apidoc magic_sethint
3088 Triggered by a store to %^H, records the key/value pair to
3089 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
3090 anything that would need a deep copy. Maybe we should warn if we find a
3096 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3099 SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3100 : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3102 PERL_ARGS_ASSERT_MAGIC_SETHINT;
3104 /* mg->mg_obj isn't being used. If needed, it would be possible to store
3105 an alternative leaf in there, with PL_compiling.cop_hints being used if
3106 it's NULL. If needed for threads, the alternative could lock a mutex,
3107 or take other more complex action. */
3109 /* Something changed in %^H, so it will need to be restored on scope exit.
3110 Doing this here saves a lot of doing it manually in perl code (and
3111 forgetting to do it, and consequent subtle errors. */
3112 PL_hints |= HINT_LOCALIZE_HH;
3113 PL_compiling.cop_hints_hash
3114 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3119 =for apidoc magic_clearhint
3121 Triggered by a delete from %^H, records the key to
3122 C<PL_compiling.cop_hints_hash>.
3127 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3131 PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3132 PERL_UNUSED_ARG(sv);
3134 assert(mg->mg_len == HEf_SVKEY);
3136 PERL_UNUSED_ARG(sv);
3138 PL_hints |= HINT_LOCALIZE_HH;
3139 PL_compiling.cop_hints_hash
3140 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3141 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3146 =for apidoc magic_clearhints
3148 Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
3153 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3155 PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3156 PERL_UNUSED_ARG(sv);
3157 PERL_UNUSED_ARG(mg);
3158 if (PL_compiling.cop_hints_hash) {
3159 Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3160 PL_compiling.cop_hints_hash = NULL;
3167 * c-indentation-style: bsd
3169 * indent-tabs-mode: t
3172 * ex: set ts=8 sts=4 sw=4 noet: