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, ...);
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)
88 assert(SvMAGICAL(sv));
89 /* Turning READONLY off for a copy-on-write scalar (including shared
90 hash keys) is a bad idea. */
92 sv_force_normal_flags(sv, 0);
94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
96 mgs = SSPTR(mgs_ix, MGS*);
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
103 if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
104 /* No public flags are set, so promote any private flags to public. */
105 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
110 =for apidoc mg_magical
112 Turns on the magical status of an SV. See C<sv_magic>.
118 Perl_mg_magical(pTHX_ SV *sv)
122 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
123 const MGVTBL* const vtbl = mg->mg_virtual;
125 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
129 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
136 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
139 S_is_container_magic(const MAGIC *mg)
141 switch (mg->mg_type) {
144 case PERL_MAGIC_regex_global:
145 case PERL_MAGIC_nkeys:
146 #ifdef USE_LOCALE_COLLATE
147 case PERL_MAGIC_collxfrm:
150 case PERL_MAGIC_taint:
152 case PERL_MAGIC_vstring:
153 case PERL_MAGIC_utf8:
154 case PERL_MAGIC_substr:
155 case PERL_MAGIC_defelem:
156 case PERL_MAGIC_arylen:
158 case PERL_MAGIC_backref:
159 case PERL_MAGIC_arylen_p:
160 case PERL_MAGIC_rhash:
161 case PERL_MAGIC_symtab:
171 Do magic after a value is retrieved from the SV. See C<sv_magic>.
177 Perl_mg_get(pTHX_ SV *sv)
180 const I32 mgs_ix = SSNEW(sizeof(MGS));
181 const bool was_temp = (bool)SvTEMP(sv);
183 MAGIC *newmg, *head, *cur, *mg;
184 /* guard against sv having being freed midway by holding a private
187 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
188 cause the SV's buffer to get stolen (and maybe other stuff).
191 sv_2mortal(SvREFCNT_inc_simple_NN(sv));
196 save_magic(mgs_ix, sv);
198 /* We must call svt_get(sv, mg) for each valid entry in the linked
199 list of magic. svt_get() may delete the current entry, add new
200 magic to the head of the list, or upgrade the SV. AMS 20010810 */
202 newmg = cur = head = mg = SvMAGIC(sv);
204 const MGVTBL * const vtbl = mg->mg_virtual;
206 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
207 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
209 /* guard against magic having been deleted - eg FETCH calling
214 /* Don't restore the flags for this entry if it was deleted. */
215 if (mg->mg_flags & MGf_GSKIP)
216 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
219 mg = mg->mg_moremagic;
222 /* Have we finished with the new entries we saw? Start again
223 where we left off (unless there are more new entries). */
231 /* Were any new entries added? */
232 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
239 restore_magic(INT2PTR(void *, (IV)mgs_ix));
241 if (SvREFCNT(sv) == 1) {
242 /* We hold the last reference to this SV, which implies that the
243 SV was deleted as a side effect of the routines we called. */
252 Do magic after a value is assigned to the SV. See C<sv_magic>.
258 Perl_mg_set(pTHX_ SV *sv)
261 const I32 mgs_ix = SSNEW(sizeof(MGS));
265 save_magic(mgs_ix, sv);
267 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
268 const MGVTBL* vtbl = mg->mg_virtual;
269 nextmg = mg->mg_moremagic; /* it may delete itself */
270 if (mg->mg_flags & MGf_GSKIP) {
271 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
272 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
274 if (PL_localizing == 2 && !S_is_container_magic(mg))
276 if (vtbl && vtbl->svt_set)
277 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
280 restore_magic(INT2PTR(void*, (IV)mgs_ix));
285 =for apidoc mg_length
287 Report on the SV's length. See C<sv_magic>.
293 Perl_mg_length(pTHX_ SV *sv)
299 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
300 const MGVTBL * const vtbl = mg->mg_virtual;
301 if (vtbl && vtbl->svt_len) {
302 const I32 mgs_ix = SSNEW(sizeof(MGS));
303 save_magic(mgs_ix, sv);
304 /* omit MGf_GSKIP -- not changed here */
305 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
306 restore_magic(INT2PTR(void*, (IV)mgs_ix));
312 const U8 *s = (U8*)SvPV_const(sv, len);
313 len = utf8_length(s, s + len);
316 (void)SvPV_const(sv, len);
321 Perl_mg_size(pTHX_ SV *sv)
325 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
326 const MGVTBL* const vtbl = mg->mg_virtual;
327 if (vtbl && vtbl->svt_len) {
328 const I32 mgs_ix = SSNEW(sizeof(MGS));
330 save_magic(mgs_ix, sv);
331 /* omit MGf_GSKIP -- not changed here */
332 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
333 restore_magic(INT2PTR(void*, (IV)mgs_ix));
340 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
344 Perl_croak(aTHX_ "Size magic not implemented");
353 Clear something magical that the SV represents. See C<sv_magic>.
359 Perl_mg_clear(pTHX_ SV *sv)
361 const I32 mgs_ix = SSNEW(sizeof(MGS));
364 save_magic(mgs_ix, sv);
366 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
367 const MGVTBL* const vtbl = mg->mg_virtual;
368 /* omit GSKIP -- never set here */
370 if (vtbl && vtbl->svt_clear)
371 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
374 restore_magic(INT2PTR(void*, (IV)mgs_ix));
381 Finds the magic pointer for type matching the SV. See C<sv_magic>.
387 Perl_mg_find(pTHX_ const SV *sv, int type)
392 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
393 if (mg->mg_type == type)
403 Copies the magic from one SV to another. See C<sv_magic>.
409 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
413 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
414 const MGVTBL* const vtbl = mg->mg_virtual;
415 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
416 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
419 const char type = mg->mg_type;
420 if (isUPPER(type) && type != PERL_MAGIC_uvar) {
422 (type == PERL_MAGIC_tied)
424 : (type == PERL_MAGIC_regdata && mg->mg_obj)
427 toLOWER(type), key, klen);
436 =for apidoc mg_localize
438 Copy some of the magic from an existing SV to new localized version of
439 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
440 doesn't (eg taint, pos).
446 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
450 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
451 const MGVTBL* const vtbl = mg->mg_virtual;
452 if (!S_is_container_magic(mg))
455 if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
456 (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
458 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
459 mg->mg_ptr, mg->mg_len);
461 /* container types should remain read-only across localization */
462 SvFLAGS(nsv) |= SvREADONLY(sv);
465 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
466 SvFLAGS(nsv) |= SvMAGICAL(sv);
476 Free any magic storage used by the SV. See C<sv_magic>.
482 Perl_mg_free(pTHX_ SV *sv)
486 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
487 const MGVTBL* const vtbl = mg->mg_virtual;
488 moremagic = mg->mg_moremagic;
489 if (vtbl && vtbl->svt_free)
490 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
491 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
492 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
493 Safefree(mg->mg_ptr);
494 else if (mg->mg_len == HEf_SVKEY)
495 SvREFCNT_dec((SV*)mg->mg_ptr);
497 if (mg->mg_flags & MGf_REFCOUNTED)
498 SvREFCNT_dec(mg->mg_obj);
501 SvMAGIC_set(sv, NULL);
508 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
514 register const REGEXP * const rx = PM_GETRE(PL_curpm);
516 if (mg->mg_obj) { /* @+ */
517 /* return the number possible */
520 I32 paren = rx->lastparen;
522 /* return the last filled */
524 && (rx->offs[paren].start == -1
525 || rx->offs[paren].end == -1) )
536 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
540 register const REGEXP * const rx = PM_GETRE(PL_curpm);
542 register const I32 paren = mg->mg_len;
547 if (paren <= (I32)rx->nparens &&
548 (s = rx->offs[paren].start) != -1 &&
549 (t = rx->offs[paren].end) != -1)
552 if (mg->mg_obj) /* @+ */
557 if (i > 0 && RX_MATCH_UTF8(rx)) {
558 const char * const b = rx->subbeg;
560 i = utf8_length((U8*)b, (U8*)(b+i));
571 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
575 Perl_croak(aTHX_ PL_no_modify);
576 NORETURN_FUNCTION_END;
580 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
585 register const REGEXP *rx;
588 switch (*mg->mg_ptr) {
589 case '1': case '2': case '3': case '4':
590 case '5': case '6': case '7': case '8': case '9': case '&':
591 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
593 paren = atoi(mg->mg_ptr); /* $& is in [0] */
595 if (paren <= (I32)rx->nparens &&
596 (s1 = rx->offs[paren].start) != -1 &&
597 (t1 = rx->offs[paren].end) != -1)
601 if (i > 0 && RX_MATCH_UTF8(rx)) {
602 const char * const s = rx->subbeg + s1;
607 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
611 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
615 if (ckWARN(WARN_UNINITIALIZED))
620 if (ckWARN(WARN_UNINITIALIZED))
625 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
626 paren = rx->lastparen;
631 case '\016': /* ^N */
632 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
633 paren = rx->lastcloseparen;
639 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
640 if (rx->offs[0].start != -1) {
641 i = rx->offs[0].start;
651 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
652 if (rx->offs[0].end != -1) {
653 i = rx->sublen - rx->offs[0].end;
655 s1 = rx->offs[0].end;
664 if (!SvPOK(sv) && SvNIOK(sv)) {
672 #define SvRTRIM(sv) STMT_START { \
674 STRLEN len = SvCUR(sv); \
675 char * const p = SvPVX(sv); \
676 while (len > 0 && isSPACE(p[len-1])) \
678 SvCUR_set(sv, len); \
684 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
686 if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
687 sv_setsv(sv, &PL_sv_undef);
691 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
692 SV *const value = Perl_refcounted_he_fetch(aTHX_
694 0, "open<", 5, 0, 0);
699 if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
700 SV *const value = Perl_refcounted_he_fetch(aTHX_
702 0, "open>", 5, 0, 0);
710 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
714 register char *s = NULL;
716 const char * const remaining = mg->mg_ptr + 1;
717 const char nextchar = *remaining;
719 switch (*mg->mg_ptr) {
720 case '\001': /* ^A */
721 sv_setsv(sv, PL_bodytarget);
723 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
724 if (nextchar == '\0') {
725 sv_setiv(sv, (IV)PL_minus_c);
727 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
728 sv_setiv(sv, (IV)STATUS_NATIVE);
732 case '\004': /* ^D */
733 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
735 case '\005': /* ^E */
736 if (nextchar == '\0') {
737 #if defined(MACOS_TRADITIONAL)
741 sv_setnv(sv,(double)gMacPerl_OSErr);
742 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
746 # include <descrip.h>
747 # include <starlet.h>
749 $DESCRIPTOR(msgdsc,msg);
750 sv_setnv(sv,(NV) vaxc$errno);
751 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
752 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
757 if (!(_emx_env & 0x200)) { /* Under DOS */
758 sv_setnv(sv, (NV)errno);
759 sv_setpv(sv, errno ? Strerror(errno) : "");
761 if (errno != errno_isOS2) {
762 const int tmp = _syserrno();
763 if (tmp) /* 2nd call to _syserrno() makes it 0 */
766 sv_setnv(sv, (NV)Perl_rc);
767 sv_setpv(sv, os2error(Perl_rc));
771 const DWORD dwErr = GetLastError();
772 sv_setnv(sv, (NV)dwErr);
774 PerlProc_GetOSError(sv, dwErr);
777 sv_setpvn(sv, "", 0);
782 const int saveerrno = errno;
783 sv_setnv(sv, (NV)errno);
784 sv_setpv(sv, errno ? Strerror(errno) : "");
789 SvNOK_on(sv); /* what a wonderful hack! */
791 else if (strEQ(remaining, "NCODING"))
792 sv_setsv(sv, PL_encoding);
794 case '\006': /* ^F */
795 sv_setiv(sv, (IV)PL_maxsysfd);
797 case '\010': /* ^H */
798 sv_setiv(sv, (IV)PL_hints);
800 case '\011': /* ^I */ /* NOT \t in EBCDIC */
802 sv_setpv(sv, PL_inplace);
804 sv_setsv(sv, &PL_sv_undef);
806 case '\017': /* ^O & ^OPEN */
807 if (nextchar == '\0') {
808 sv_setpv(sv, PL_osname);
811 else if (strEQ(remaining, "PEN")) {
812 Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
816 if (nextchar == '\0') { /* ^P */
817 sv_setiv(sv, (IV)PL_perldb);
818 } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
819 goto do_prematch_fetch;
820 } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
821 goto do_postmatch_fetch;
824 case '\023': /* ^S */
825 if (nextchar == '\0') {
826 if (PL_lex_state != LEX_NOTPARSING)
829 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
834 case '\024': /* ^T */
835 if (nextchar == '\0') {
837 sv_setnv(sv, PL_basetime);
839 sv_setiv(sv, (IV)PL_basetime);
842 else if (strEQ(remaining, "AINT"))
843 sv_setiv(sv, PL_tainting
844 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
847 case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
848 if (strEQ(remaining, "NICODE"))
849 sv_setuv(sv, (UV) PL_unicode);
850 else if (strEQ(remaining, "TF8LOCALE"))
851 sv_setuv(sv, (UV) PL_utf8locale);
852 else if (strEQ(remaining, "TF8CACHE"))
853 sv_setiv(sv, (IV) PL_utf8cache);
855 case '\027': /* ^W & $^WARNING_BITS */
856 if (nextchar == '\0')
857 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
858 else if (strEQ(remaining, "ARNING_BITS")) {
859 if (PL_compiling.cop_warnings == pWARN_NONE) {
860 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
862 else if (PL_compiling.cop_warnings == pWARN_STD) {
865 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
869 else if (PL_compiling.cop_warnings == pWARN_ALL) {
870 /* Get the bit mask for $warnings::Bits{all}, because
871 * it could have been extended by warnings::register */
872 HV * const bits=get_hv("warnings::Bits", FALSE);
874 SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
876 sv_setsv(sv, *bits_all);
879 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
883 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
884 *PL_compiling.cop_warnings);
889 case '\015': /* $^MATCH */
890 if (strEQ(remaining, "ATCH")) {
891 case '1': case '2': case '3': case '4':
892 case '5': case '6': case '7': case '8': case '9': case '&':
893 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
895 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
896 * XXX Does the new way break anything?
898 paren = atoi(mg->mg_ptr); /* $& is in [0] */
899 CALLREG_NUMBUF(rx,paren,sv);
902 sv_setsv(sv,&PL_sv_undef);
906 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
908 CALLREG_NUMBUF(rx,rx->lastparen,sv);
912 sv_setsv(sv,&PL_sv_undef);
914 case '\016': /* ^N */
915 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
916 if (rx->lastcloseparen) {
917 CALLREG_NUMBUF(rx,rx->lastcloseparen,sv);
922 sv_setsv(sv,&PL_sv_undef);
926 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
927 CALLREG_NUMBUF(rx,-2,sv);
930 sv_setsv(sv,&PL_sv_undef);
934 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
935 CALLREG_NUMBUF(rx,-1,sv);
938 sv_setsv(sv,&PL_sv_undef);
941 if (GvIO(PL_last_in_gv)) {
942 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
947 sv_setiv(sv, (IV)STATUS_CURRENT);
948 #ifdef COMPLEX_STATUS
949 LvTARGOFF(sv) = PL_statusvalue;
950 LvTARGLEN(sv) = PL_statusvalue_vms;
955 if (GvIOp(PL_defoutgv))
956 s = IoTOP_NAME(GvIOp(PL_defoutgv));
960 sv_setpv(sv,GvENAME(PL_defoutgv));
965 if (GvIOp(PL_defoutgv))
966 s = IoFMT_NAME(GvIOp(PL_defoutgv));
968 s = GvENAME(PL_defoutgv);
972 if (GvIOp(PL_defoutgv))
973 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
976 if (GvIOp(PL_defoutgv))
977 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
980 if (GvIOp(PL_defoutgv))
981 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
988 sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
991 if (GvIOp(PL_defoutgv))
992 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
998 sv_copypv(sv, PL_ors_sv);
1002 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1003 sv_setpv(sv, errno ? Strerror(errno) : "");
1006 const int saveerrno = errno;
1007 sv_setnv(sv, (NV)errno);
1009 if (errno == errno_isOS2 || errno == errno_isOS2_set)
1010 sv_setpv(sv, os2error(Perl_rc));
1013 sv_setpv(sv, errno ? Strerror(errno) : "");
1018 SvNOK_on(sv); /* what a wonderful hack! */
1021 sv_setiv(sv, (IV)PL_uid);
1024 sv_setiv(sv, (IV)PL_euid);
1027 sv_setiv(sv, (IV)PL_gid);
1030 sv_setiv(sv, (IV)PL_egid);
1032 #ifdef HAS_GETGROUPS
1034 Groups_t *gary = NULL;
1035 I32 i, num_groups = getgroups(0, gary);
1036 Newx(gary, num_groups, Groups_t);
1037 num_groups = getgroups(num_groups, gary);
1038 for (i = 0; i < num_groups; i++)
1039 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1042 (void)SvIOK_on(sv); /* what a wonderful hack! */
1045 #ifndef MACOS_TRADITIONAL
1054 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1056 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1058 if (uf && uf->uf_val)
1059 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1064 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1067 STRLEN len = 0, klen;
1068 const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1069 const char * const ptr = MgPV_const(mg,klen);
1072 #ifdef DYNAMIC_ENV_FETCH
1073 /* We just undefd an environment var. Is a replacement */
1074 /* waiting in the wings? */
1076 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1078 s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1082 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1083 /* And you'll never guess what the dog had */
1084 /* in its mouth... */
1086 MgTAINTEDDIR_off(mg);
1088 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1089 char pathbuf[256], eltbuf[256], *cp, *elt;
1093 my_strlcpy(eltbuf, s, sizeof(eltbuf));
1095 do { /* DCL$PATH may be a search list */
1096 while (1) { /* as may dev portion of any element */
1097 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1098 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1099 cando_by_name(S_IWUSR,0,elt) ) {
1100 MgTAINTEDDIR_on(mg);
1104 if ((cp = strchr(elt, ':')) != NULL)
1106 if (my_trnlnm(elt, eltbuf, j++))
1112 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1115 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1116 const char * const strend = s + len;
1118 while (s < strend) {
1122 #ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
1123 const char path_sep = '|';
1125 const char path_sep = ':';
1127 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1128 s, strend, path_sep, &i);
1130 if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
1132 || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1134 || *tmpbuf != '/' /* no starting slash -- assume relative path */
1136 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1137 MgTAINTEDDIR_on(mg);
1143 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1149 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1151 PERL_UNUSED_ARG(sv);
1152 my_setenv(MgPV_nolen_const(mg),NULL);
1157 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1160 PERL_UNUSED_ARG(mg);
1162 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1164 if (PL_localizing) {
1167 hv_iterinit((HV*)sv);
1168 while ((entry = hv_iternext((HV*)sv))) {
1170 my_setenv(hv_iterkey(entry, &keylen),
1171 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1179 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1182 PERL_UNUSED_ARG(sv);
1183 PERL_UNUSED_ARG(mg);
1185 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1193 #ifdef HAS_SIGPROCMASK
1195 restore_sigmask(pTHX_ SV *save_sv)
1197 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1198 (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1202 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1205 /* Are we fetching a signal entry? */
1206 const I32 i = whichsig(MgPV_nolen_const(mg));
1209 sv_setsv(sv,PL_psig_ptr[i]);
1211 Sighandler_t sigstate = rsignal_state(i);
1212 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1213 if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1216 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1217 if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1220 /* cache state so we don't fetch it again */
1221 if(sigstate == (Sighandler_t) SIG_IGN)
1222 sv_setpvs(sv,"IGNORE");
1224 sv_setsv(sv,&PL_sv_undef);
1225 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1232 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1234 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1235 * refactoring might be in order.
1238 register const char * const s = MgPV_nolen_const(mg);
1239 PERL_UNUSED_ARG(sv);
1242 if (strEQ(s,"__DIE__"))
1244 else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1247 SV *const to_dec = *svp;
1249 SvREFCNT_dec(to_dec);
1253 /* Are we clearing a signal entry? */
1254 const I32 i = whichsig(s);
1256 #ifdef HAS_SIGPROCMASK
1259 /* Avoid having the signal arrive at a bad time, if possible. */
1262 sigprocmask(SIG_BLOCK, &set, &save);
1264 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1265 SAVEFREESV(save_sv);
1266 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1269 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1270 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1272 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1273 PL_sig_defaulting[i] = 1;
1274 (void)rsignal(i, PL_csighandlerp);
1276 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1278 if(PL_psig_name[i]) {
1279 SvREFCNT_dec(PL_psig_name[i]);
1282 if(PL_psig_ptr[i]) {
1283 SV * const to_dec=PL_psig_ptr[i];
1286 SvREFCNT_dec(to_dec);
1296 * The signal handling nomenclature has gotten a bit confusing since the advent of
1297 * safe signals. S_raise_signal only raises signals by analogy with what the
1298 * underlying system's signal mechanism does. It might be more proper to say that
1299 * it defers signals that have already been raised and caught.
1301 * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
1302 * in the sense of being on the system's signal queue in between raising and delivery.
1303 * They are only pending on Perl's deferral list, i.e., they track deferred signals
1304 * awaiting delivery after the current Perl opcode completes and say nothing about
1305 * signals raised but not yet caught in the underlying signal implementation.
1308 #ifndef SIG_PENDING_DIE_COUNT
1309 # define SIG_PENDING_DIE_COUNT 120
1313 S_raise_signal(pTHX_ int sig)
1316 /* Set a flag to say this signal is pending */
1317 PL_psig_pend[sig]++;
1318 /* And one to say _a_ signal is pending */
1319 if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1320 Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1321 (unsigned long)SIG_PENDING_DIE_COUNT);
1325 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1326 Perl_csighandler(int sig, ...)
1328 Perl_csighandler(int sig)
1331 #ifdef PERL_GET_SIG_CONTEXT
1332 dTHXa(PERL_GET_SIG_CONTEXT);
1336 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1337 (void) rsignal(sig, PL_csighandlerp);
1338 if (PL_sig_ignoring[sig]) return;
1340 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1341 if (PL_sig_defaulting[sig])
1342 #ifdef KILL_BY_SIGPRC
1343 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1358 (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1359 /* Call the perl level handler now--
1360 * with risk we may be in malloc() etc. */
1361 (*PL_sighandlerp)(sig);
1363 S_raise_signal(aTHX_ sig);
1366 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1368 Perl_csighandler_init(void)
1371 if (PL_sig_handlers_initted) return;
1373 for (sig = 1; sig < SIG_SIZE; sig++) {
1374 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1376 PL_sig_defaulting[sig] = 1;
1377 (void) rsignal(sig, PL_csighandlerp);
1379 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1380 PL_sig_ignoring[sig] = 0;
1383 PL_sig_handlers_initted = 1;
1388 Perl_despatch_signals(pTHX)
1393 for (sig = 1; sig < SIG_SIZE; sig++) {
1394 if (PL_psig_pend[sig]) {
1395 PERL_BLOCKSIG_ADD(set, sig);
1396 PL_psig_pend[sig] = 0;
1397 PERL_BLOCKSIG_BLOCK(set);
1398 (*PL_sighandlerp)(sig);
1399 PERL_BLOCKSIG_UNBLOCK(set);
1405 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1410 /* Need to be careful with SvREFCNT_dec(), because that can have side
1411 * effects (due to closures). We must make sure that the new disposition
1412 * is in place before it is called.
1416 #ifdef HAS_SIGPROCMASK
1421 register const char *s = MgPV_const(mg,len);
1423 if (strEQ(s,"__DIE__"))
1425 else if (strEQ(s,"__WARN__"))
1428 Perl_croak(aTHX_ "No such hook: %s", s);
1431 if (*svp != PERL_WARNHOOK_FATAL)
1437 i = whichsig(s); /* ...no, a brick */
1439 if (ckWARN(WARN_SIGNAL))
1440 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1443 #ifdef HAS_SIGPROCMASK
1444 /* Avoid having the signal arrive at a bad time, if possible. */
1447 sigprocmask(SIG_BLOCK, &set, &save);
1449 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1450 SAVEFREESV(save_sv);
1451 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1454 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1455 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1457 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1458 PL_sig_ignoring[i] = 0;
1460 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1461 PL_sig_defaulting[i] = 0;
1463 SvREFCNT_dec(PL_psig_name[i]);
1464 to_dec = PL_psig_ptr[i];
1465 PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1466 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1467 PL_psig_name[i] = newSVpvn(s, len);
1468 SvREADONLY_on(PL_psig_name[i]);
1470 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1472 (void)rsignal(i, PL_csighandlerp);
1473 #ifdef HAS_SIGPROCMASK
1478 *svp = SvREFCNT_inc_simple_NN(sv);
1480 SvREFCNT_dec(to_dec);
1483 s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1484 if (strEQ(s,"IGNORE")) {
1486 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1487 PL_sig_ignoring[i] = 1;
1488 (void)rsignal(i, PL_csighandlerp);
1490 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1494 else if (strEQ(s,"DEFAULT") || !*s) {
1496 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1498 PL_sig_defaulting[i] = 1;
1499 (void)rsignal(i, PL_csighandlerp);
1502 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1507 * We should warn if HINT_STRICT_REFS, but without
1508 * access to a known hint bit in a known OP, we can't
1509 * tell whether HINT_STRICT_REFS is in force or not.
1511 if (!strchr(s,':') && !strchr(s,'\''))
1512 Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1514 (void)rsignal(i, PL_csighandlerp);
1516 *svp = SvREFCNT_inc_simple_NN(sv);
1518 #ifdef HAS_SIGPROCMASK
1523 SvREFCNT_dec(to_dec);
1526 #endif /* !PERL_MICRO */
1529 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1532 PERL_UNUSED_ARG(sv);
1534 /* The first case occurs via setisa,
1535 the second via setisa_elem, which
1536 calls this same magic */
1539 SvTYPE(mg->mg_obj) == SVt_PVGV
1541 : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1549 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1552 PERL_UNUSED_ARG(sv);
1553 PERL_UNUSED_ARG(mg);
1554 PL_amagic_generation++;
1560 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1562 HV * const hv = (HV*)LvTARG(sv);
1564 PERL_UNUSED_ARG(mg);
1567 (void) hv_iterinit(hv);
1568 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1571 while (hv_iternext(hv))
1576 sv_setiv(sv, (IV)i);
1581 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1583 PERL_UNUSED_ARG(mg);
1585 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1590 /* caller is responsible for stack switching/cleanup */
1592 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1599 PUSHs(SvTIED_obj(sv, mg));
1602 if (mg->mg_len >= 0)
1603 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1604 else if (mg->mg_len == HEf_SVKEY)
1605 PUSHs((SV*)mg->mg_ptr);
1607 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1608 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1616 return call_method(meth, flags);
1620 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1626 PUSHSTACKi(PERLSI_MAGIC);
1628 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1629 sv_setsv(sv, *PL_stack_sp--);
1639 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1642 mg->mg_flags |= MGf_GSKIP;
1643 magic_methpack(sv,mg,"FETCH");
1648 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1652 PUSHSTACKi(PERLSI_MAGIC);
1653 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1660 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1662 return magic_methpack(sv,mg,"DELETE");
1667 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1674 PUSHSTACKi(PERLSI_MAGIC);
1675 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1676 sv = *PL_stack_sp--;
1677 retval = (U32) SvIV(sv)-1;
1686 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1691 PUSHSTACKi(PERLSI_MAGIC);
1693 XPUSHs(SvTIED_obj(sv, mg));
1695 call_method("CLEAR", G_SCALAR|G_DISCARD);
1703 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1706 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1710 PUSHSTACKi(PERLSI_MAGIC);
1713 PUSHs(SvTIED_obj(sv, mg));
1718 if (call_method(meth, G_SCALAR))
1719 sv_setsv(key, *PL_stack_sp--);
1728 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1730 return magic_methpack(sv,mg,"EXISTS");
1734 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1738 SV * const tied = SvTIED_obj((SV*)hv, mg);
1739 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1741 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1743 if (HvEITER_get(hv))
1744 /* we are in an iteration so the hash cannot be empty */
1746 /* no xhv_eiter so now use FIRSTKEY */
1747 key = sv_newmortal();
1748 magic_nextpack((SV*)hv, mg, key);
1749 HvEITER_set(hv, NULL); /* need to reset iterator */
1750 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1753 /* there is a SCALAR method that we can call */
1755 PUSHSTACKi(PERLSI_MAGIC);
1761 if (call_method("SCALAR", G_SCALAR))
1762 retval = *PL_stack_sp--;
1764 retval = &PL_sv_undef;
1771 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1774 GV * const gv = PL_DBline;
1775 const I32 i = SvTRUE(sv);
1776 SV ** const svp = av_fetch(GvAV(gv),
1777 atoi(MgPV_nolen_const(mg)), FALSE);
1778 if (svp && SvIOKp(*svp)) {
1779 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1781 /* set or clear breakpoint in the relevant control op */
1783 o->op_flags |= OPf_SPECIAL;
1785 o->op_flags &= ~OPf_SPECIAL;
1792 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1795 const AV * const obj = (AV*)mg->mg_obj;
1797 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1805 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1808 AV * const obj = (AV*)mg->mg_obj;
1810 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1812 if (ckWARN(WARN_MISC))
1813 Perl_warner(aTHX_ packWARN(WARN_MISC),
1814 "Attempt to set length of freed array");
1820 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1823 PERL_UNUSED_ARG(sv);
1824 /* during global destruction, mg_obj may already have been freed */
1825 if (PL_in_clean_all)
1828 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1831 /* arylen scalar holds a pointer back to the array, but doesn't own a
1832 reference. Hence the we (the array) are about to go away with it
1833 still pointing at us. Clear its pointer, else it would be pointing
1834 at free memory. See the comment in sv_magic about reference loops,
1835 and why it can't own a reference to us. */
1842 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1845 SV* const lsv = LvTARG(sv);
1846 PERL_UNUSED_ARG(mg);
1848 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1849 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1850 if (found && found->mg_len >= 0) {
1851 I32 i = found->mg_len;
1853 sv_pos_b2u(lsv, &i);
1854 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1863 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1866 SV* const lsv = LvTARG(sv);
1872 PERL_UNUSED_ARG(mg);
1874 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1875 found = mg_find(lsv, PERL_MAGIC_regex_global);
1881 #ifdef PERL_OLD_COPY_ON_WRITE
1883 sv_force_normal_flags(lsv, 0);
1885 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1888 else if (!SvOK(sv)) {
1892 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1894 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1897 ulen = sv_len_utf8(lsv);
1907 else if (pos > (SSize_t)len)
1912 sv_pos_u2b(lsv, &p, 0);
1916 found->mg_len = pos;
1917 found->mg_flags &= ~MGf_MINMATCH;
1923 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1926 PERL_UNUSED_ARG(mg);
1928 Perl_croak(aTHX_ "Perl_magic_setglob is dead code?");
1932 if (isGV_with_GP(sv)) {
1933 /* We're actually already a typeglob, so don't need the stuff below.
1937 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1942 GvGP(sv) = gp_ref(GvGP(gv));
1947 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1950 SV * const lsv = LvTARG(sv);
1951 const char * const tmps = SvPV_const(lsv,len);
1952 I32 offs = LvTARGOFF(sv);
1953 I32 rem = LvTARGLEN(sv);
1954 PERL_UNUSED_ARG(mg);
1957 sv_pos_u2b(lsv, &offs, &rem);
1958 if (offs > (I32)len)
1960 if (rem + offs > (I32)len)
1962 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1969 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1973 const char * const tmps = SvPV_const(sv, len);
1974 SV * const lsv = LvTARG(sv);
1975 I32 lvoff = LvTARGOFF(sv);
1976 I32 lvlen = LvTARGLEN(sv);
1977 PERL_UNUSED_ARG(mg);
1980 sv_utf8_upgrade(lsv);
1981 sv_pos_u2b(lsv, &lvoff, &lvlen);
1982 sv_insert(lsv, lvoff, lvlen, tmps, len);
1983 LvTARGLEN(sv) = sv_len_utf8(sv);
1986 else if (lsv && SvUTF8(lsv)) {
1988 sv_pos_u2b(lsv, &lvoff, &lvlen);
1989 LvTARGLEN(sv) = len;
1990 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1991 sv_insert(lsv, lvoff, lvlen, utf8, len);
1995 sv_insert(lsv, lvoff, lvlen, tmps, len);
1996 LvTARGLEN(sv) = len;
2004 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2007 PERL_UNUSED_ARG(sv);
2008 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2013 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2016 PERL_UNUSED_ARG(sv);
2017 /* update taint status */
2026 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2028 SV * const lsv = LvTARG(sv);
2029 PERL_UNUSED_ARG(mg);
2032 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2040 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2042 PERL_UNUSED_ARG(mg);
2043 do_vecset(sv); /* XXX slurp this routine */
2048 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2052 if (LvTARGLEN(sv)) {
2054 SV * const ahv = LvTARG(sv);
2055 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2060 AV* const av = (AV*)LvTARG(sv);
2061 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2062 targ = AvARRAY(av)[LvTARGOFF(sv)];
2064 if (targ && (targ != &PL_sv_undef)) {
2065 /* somebody else defined it for us */
2066 SvREFCNT_dec(LvTARG(sv));
2067 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2069 SvREFCNT_dec(mg->mg_obj);
2071 mg->mg_flags &= ~MGf_REFCOUNTED;
2076 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2081 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2083 PERL_UNUSED_ARG(mg);
2087 sv_setsv(LvTARG(sv), sv);
2088 SvSETMAGIC(LvTARG(sv));
2094 Perl_vivify_defelem(pTHX_ SV *sv)
2100 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2103 SV * const ahv = LvTARG(sv);
2104 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2107 if (!value || value == &PL_sv_undef)
2108 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2111 AV* const av = (AV*)LvTARG(sv);
2112 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2113 LvTARG(sv) = NULL; /* array can't be extended */
2115 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2116 if (!svp || (value = *svp) == &PL_sv_undef)
2117 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2120 SvREFCNT_inc_simple_void(value);
2121 SvREFCNT_dec(LvTARG(sv));
2124 SvREFCNT_dec(mg->mg_obj);
2126 mg->mg_flags &= ~MGf_REFCOUNTED;
2130 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2132 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2136 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2138 PERL_UNUSED_CONTEXT;
2145 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2147 PERL_UNUSED_ARG(mg);
2148 sv_unmagic(sv, PERL_MAGIC_bm);
2155 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2157 PERL_UNUSED_ARG(mg);
2158 sv_unmagic(sv, PERL_MAGIC_fm);
2164 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2166 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2168 if (uf && uf->uf_set)
2169 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2174 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2176 PERL_UNUSED_ARG(mg);
2177 sv_unmagic(sv, PERL_MAGIC_qr);
2182 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2185 regexp * const re = (regexp *)mg->mg_obj;
2186 PERL_UNUSED_ARG(sv);
2192 #ifdef USE_LOCALE_COLLATE
2194 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2197 * RenE<eacute> Descartes said "I think not."
2198 * and vanished with a faint plop.
2200 PERL_UNUSED_CONTEXT;
2201 PERL_UNUSED_ARG(sv);
2203 Safefree(mg->mg_ptr);
2209 #endif /* USE_LOCALE_COLLATE */
2211 /* Just clear the UTF-8 cache data. */
2213 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2215 PERL_UNUSED_CONTEXT;
2216 PERL_UNUSED_ARG(sv);
2217 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2219 mg->mg_len = -1; /* The mg_len holds the len cache. */
2224 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2227 register const char *s;
2230 switch (*mg->mg_ptr) {
2231 case '\001': /* ^A */
2232 sv_setsv(PL_bodytarget, sv);
2234 case '\003': /* ^C */
2235 PL_minus_c = (bool)SvIV(sv);
2238 case '\004': /* ^D */
2240 s = SvPV_nolen_const(sv);
2241 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2242 DEBUG_x(dump_all());
2244 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2247 case '\005': /* ^E */
2248 if (*(mg->mg_ptr+1) == '\0') {
2249 #ifdef MACOS_TRADITIONAL
2250 gMacPerl_OSErr = SvIV(sv);
2253 set_vaxc_errno(SvIV(sv));
2256 SetLastError( SvIV(sv) );
2259 os2_setsyserrno(SvIV(sv));
2261 /* will anyone ever use this? */
2262 SETERRNO(SvIV(sv), 4);
2268 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2270 SvREFCNT_dec(PL_encoding);
2271 if (SvOK(sv) || SvGMAGICAL(sv)) {
2272 PL_encoding = newSVsv(sv);
2279 case '\006': /* ^F */
2280 PL_maxsysfd = SvIV(sv);
2282 case '\010': /* ^H */
2283 PL_hints = SvIV(sv);
2285 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2286 Safefree(PL_inplace);
2287 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2289 case '\017': /* ^O */
2290 if (*(mg->mg_ptr+1) == '\0') {
2291 Safefree(PL_osname);
2294 TAINT_PROPER("assigning to $^O");
2295 PL_osname = savesvpv(sv);
2298 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2300 const char *const start = SvPV(sv, len);
2301 const char *out = (const char*)memchr(start, '\0', len);
2303 struct refcounted_he *tmp_he;
2306 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2308 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2310 /* Opening for input is more common than opening for output, so
2311 ensure that hints for input are sooner on linked list. */
2312 tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2314 SvFLAGS(tmp) |= SvUTF8(sv);
2317 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2318 sv_2mortal(newSVpvs("open>")), tmp);
2320 /* The UTF-8 setting is carried over */
2321 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2323 PL_compiling.cop_hints_hash
2324 = Perl_refcounted_he_new(aTHX_ tmp_he,
2325 sv_2mortal(newSVpvs("open<")), tmp);
2328 case '\020': /* ^P */
2329 PL_perldb = SvIV(sv);
2330 if (PL_perldb && !PL_DBsingle)
2333 case '\024': /* ^T */
2335 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2337 PL_basetime = (Time_t)SvIV(sv);
2340 case '\025': /* ^UTF8CACHE */
2341 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2342 PL_utf8cache = (signed char) sv_2iv(sv);
2345 case '\027': /* ^W & $^WARNING_BITS */
2346 if (*(mg->mg_ptr+1) == '\0') {
2347 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2349 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2350 | (i ? G_WARN_ON : G_WARN_OFF) ;
2353 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2354 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2355 if (!SvPOK(sv) && PL_localizing) {
2356 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2357 PL_compiling.cop_warnings = pWARN_NONE;
2362 int accumulate = 0 ;
2363 int any_fatals = 0 ;
2364 const char * const ptr = SvPV_const(sv, len) ;
2365 for (i = 0 ; i < len ; ++i) {
2366 accumulate |= ptr[i] ;
2367 any_fatals |= (ptr[i] & 0xAA) ;
2370 if (!specialWARN(PL_compiling.cop_warnings))
2371 PerlMemShared_free(PL_compiling.cop_warnings);
2372 PL_compiling.cop_warnings = pWARN_NONE;
2374 /* Yuck. I can't see how to abstract this: */
2375 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2376 WARN_ALL) && !any_fatals) {
2377 if (!specialWARN(PL_compiling.cop_warnings))
2378 PerlMemShared_free(PL_compiling.cop_warnings);
2379 PL_compiling.cop_warnings = pWARN_ALL;
2380 PL_dowarn |= G_WARN_ONCE ;
2384 const char *const p = SvPV_const(sv, len);
2386 PL_compiling.cop_warnings
2387 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2390 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2391 PL_dowarn |= G_WARN_ONCE ;
2399 if (PL_localizing) {
2400 if (PL_localizing == 1)
2401 SAVESPTR(PL_last_in_gv);
2403 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2404 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2407 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2408 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2409 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2412 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2413 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2414 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2417 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2420 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2421 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2422 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2425 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2429 IO * const io = GvIOp(PL_defoutgv);
2432 if ((SvIV(sv)) == 0)
2433 IoFLAGS(io) &= ~IOf_FLUSH;
2435 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2436 PerlIO *ofp = IoOFP(io);
2438 (void)PerlIO_flush(ofp);
2439 IoFLAGS(io) |= IOf_FLUSH;
2445 SvREFCNT_dec(PL_rs);
2446 PL_rs = newSVsv(sv);
2450 SvREFCNT_dec(PL_ors_sv);
2451 if (SvOK(sv) || SvGMAGICAL(sv)) {
2452 PL_ors_sv = newSVsv(sv);
2460 SvREFCNT_dec(PL_ofs_sv);
2461 if (SvOK(sv) || SvGMAGICAL(sv)) {
2462 PL_ofs_sv = newSVsv(sv);
2469 CopARYBASE_set(&PL_compiling, SvIV(sv));
2472 #ifdef COMPLEX_STATUS
2473 if (PL_localizing == 2) {
2474 PL_statusvalue = LvTARGOFF(sv);
2475 PL_statusvalue_vms = LvTARGLEN(sv);
2479 #ifdef VMSISH_STATUS
2481 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2484 STATUS_UNIX_EXIT_SET(SvIV(sv));
2489 # define PERL_VMS_BANG vaxc$errno
2491 # define PERL_VMS_BANG 0
2493 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2494 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2499 if (PL_delaymagic) {
2500 PL_delaymagic |= DM_RUID;
2501 break; /* don't do magic till later */
2504 (void)setruid((Uid_t)PL_uid);
2507 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2509 #ifdef HAS_SETRESUID
2510 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2512 if (PL_uid == PL_euid) { /* special case $< = $> */
2514 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2515 if (PL_uid != 0 && PerlProc_getuid() == 0)
2516 (void)PerlProc_setuid(0);
2518 (void)PerlProc_setuid(PL_uid);
2520 PL_uid = PerlProc_getuid();
2521 Perl_croak(aTHX_ "setruid() not implemented");
2526 PL_uid = PerlProc_getuid();
2527 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2531 if (PL_delaymagic) {
2532 PL_delaymagic |= DM_EUID;
2533 break; /* don't do magic till later */
2536 (void)seteuid((Uid_t)PL_euid);
2539 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2541 #ifdef HAS_SETRESUID
2542 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2544 if (PL_euid == PL_uid) /* special case $> = $< */
2545 PerlProc_setuid(PL_euid);
2547 PL_euid = PerlProc_geteuid();
2548 Perl_croak(aTHX_ "seteuid() not implemented");
2553 PL_euid = PerlProc_geteuid();
2554 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2558 if (PL_delaymagic) {
2559 PL_delaymagic |= DM_RGID;
2560 break; /* don't do magic till later */
2563 (void)setrgid((Gid_t)PL_gid);
2566 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2568 #ifdef HAS_SETRESGID
2569 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2571 if (PL_gid == PL_egid) /* special case $( = $) */
2572 (void)PerlProc_setgid(PL_gid);
2574 PL_gid = PerlProc_getgid();
2575 Perl_croak(aTHX_ "setrgid() not implemented");
2580 PL_gid = PerlProc_getgid();
2581 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2584 #ifdef HAS_SETGROUPS
2586 const char *p = SvPV_const(sv, len);
2587 Groups_t *gary = NULL;
2592 for (i = 0; i < NGROUPS; ++i) {
2593 while (*p && !isSPACE(*p))
2600 Newx(gary, i + 1, Groups_t);
2602 Renew(gary, i + 1, Groups_t);
2606 (void)setgroups(i, gary);
2609 #else /* HAS_SETGROUPS */
2611 #endif /* HAS_SETGROUPS */
2612 if (PL_delaymagic) {
2613 PL_delaymagic |= DM_EGID;
2614 break; /* don't do magic till later */
2617 (void)setegid((Gid_t)PL_egid);
2620 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2622 #ifdef HAS_SETRESGID
2623 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2625 if (PL_egid == PL_gid) /* special case $) = $( */
2626 (void)PerlProc_setgid(PL_egid);
2628 PL_egid = PerlProc_getegid();
2629 Perl_croak(aTHX_ "setegid() not implemented");
2634 PL_egid = PerlProc_getegid();
2635 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2638 PL_chopset = SvPV_force(sv,len);
2640 #ifndef MACOS_TRADITIONAL
2642 LOCK_DOLLARZERO_MUTEX;
2643 #ifdef HAS_SETPROCTITLE
2644 /* The BSDs don't show the argv[] in ps(1) output, they
2645 * show a string from the process struct and provide
2646 * the setproctitle() routine to manipulate that. */
2647 if (PL_origalen != 1) {
2648 s = SvPV_const(sv, len);
2649 # if __FreeBSD_version > 410001
2650 /* The leading "-" removes the "perl: " prefix,
2651 * but not the "(perl) suffix from the ps(1)
2652 * output, because that's what ps(1) shows if the
2653 * argv[] is modified. */
2654 setproctitle("-%s", s);
2655 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2656 /* This doesn't really work if you assume that
2657 * $0 = 'foobar'; will wipe out 'perl' from the $0
2658 * because in ps(1) output the result will be like
2659 * sprintf("perl: %s (perl)", s)
2660 * I guess this is a security feature:
2661 * one (a user process) cannot get rid of the original name.
2663 setproctitle("%s", s);
2666 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2667 if (PL_origalen != 1) {
2669 s = SvPV_const(sv, len);
2670 un.pst_command = (char *)s;
2671 pstat(PSTAT_SETCMD, un, len, 0, 0);
2674 if (PL_origalen > 1) {
2675 /* PL_origalen is set in perl_parse(). */
2676 s = SvPV_force(sv,len);
2677 if (len >= (STRLEN)PL_origalen-1) {
2678 /* Longer than original, will be truncated. We assume that
2679 * PL_origalen bytes are available. */
2680 Copy(s, PL_origargv[0], PL_origalen-1, char);
2683 /* Shorter than original, will be padded. */
2685 /* Special case for Mac OS X: see [perl #38868] */
2688 /* Is the space counterintuitive? Yes.
2689 * (You were expecting \0?)
2690 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2692 const int pad = ' ';
2694 Copy(s, PL_origargv[0], len, char);
2695 PL_origargv[0][len] = 0;
2696 memset(PL_origargv[0] + len + 1,
2697 pad, PL_origalen - len - 1);
2699 PL_origargv[0][PL_origalen-1] = 0;
2700 for (i = 1; i < PL_origargc; i++)
2704 UNLOCK_DOLLARZERO_MUTEX;
2712 Perl_whichsig(pTHX_ const char *sig)
2714 register char* const* sigv;
2715 PERL_UNUSED_CONTEXT;
2717 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2718 if (strEQ(sig,*sigv))
2719 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2721 if (strEQ(sig,"CHLD"))
2725 if (strEQ(sig,"CLD"))
2732 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2733 Perl_sighandler(int sig, ...)
2735 Perl_sighandler(int sig)
2738 #ifdef PERL_GET_SIG_CONTEXT
2739 dTHXa(PERL_GET_SIG_CONTEXT);
2746 SV * const tSv = PL_Sv;
2750 XPV * const tXpv = PL_Xpv;
2752 if (PL_savestack_ix + 15 <= PL_savestack_max)
2754 if (PL_markstack_ptr < PL_markstack_max - 2)
2756 if (PL_scopestack_ix < PL_scopestack_max - 3)
2759 if (!PL_psig_ptr[sig]) {
2760 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2765 /* Max number of items pushed there is 3*n or 4. We cannot fix
2766 infinity, so we fix 4 (in fact 5): */
2768 PL_savestack_ix += 5; /* Protect save in progress. */
2769 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2772 PL_markstack_ptr++; /* Protect mark. */
2774 PL_scopestack_ix += 1;
2775 /* sv_2cv is too complicated, try a simpler variant first: */
2776 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2777 || SvTYPE(cv) != SVt_PVCV) {
2779 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2782 if (!cv || !CvROOT(cv)) {
2783 if (ckWARN(WARN_SIGNAL))
2784 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2785 PL_sig_name[sig], (gv ? GvENAME(gv)
2792 if(PL_psig_name[sig]) {
2793 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2795 #if !defined(PERL_IMPLICIT_CONTEXT)
2799 sv = sv_newmortal();
2800 sv_setpv(sv,PL_sig_name[sig]);
2803 PUSHSTACKi(PERLSI_SIGNAL);
2806 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2808 struct sigaction oact;
2810 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2814 va_start(args, sig);
2815 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2818 SV *rv = newRV_noinc((SV*)sih);
2819 /* The siginfo fields signo, code, errno, pid, uid,
2820 * addr, status, and band are defined by POSIX/SUSv3. */
2821 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2822 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2823 #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. */
2824 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2825 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2826 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2827 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2828 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2829 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2833 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2842 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2845 if (SvTRUE(ERRSV)) {
2847 #ifdef HAS_SIGPROCMASK
2848 /* Handler "died", for example to get out of a restart-able read().
2849 * Before we re-do that on its behalf re-enable the signal which was
2850 * blocked by the system when we entered.
2854 sigaddset(&set,sig);
2855 sigprocmask(SIG_UNBLOCK, &set, NULL);
2857 /* Not clear if this will work */
2858 (void)rsignal(sig, SIG_IGN);
2859 (void)rsignal(sig, PL_csighandlerp);
2861 #endif /* !PERL_MICRO */
2862 Perl_die(aTHX_ NULL);
2866 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2870 PL_scopestack_ix -= 1;
2873 PL_op = myop; /* Apparently not needed... */
2875 PL_Sv = tSv; /* Restore global temporaries. */
2882 S_restore_magic(pTHX_ const void *p)
2885 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2886 SV* const sv = mgs->mgs_sv;
2891 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2893 #ifdef PERL_OLD_COPY_ON_WRITE
2894 /* While magic was saved (and off) sv_setsv may well have seen
2895 this SV as a prime candidate for COW. */
2897 sv_force_normal_flags(sv, 0);
2901 SvFLAGS(sv) |= mgs->mgs_flags;
2904 if (SvGMAGICAL(sv)) {
2905 /* downgrade public flags to private,
2906 and discard any other private flags */
2908 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2910 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2911 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2916 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2918 /* If we're still on top of the stack, pop us off. (That condition
2919 * will be satisfied if restore_magic was called explicitly, but *not*
2920 * if it's being called via leave_scope.)
2921 * The reason for doing this is that otherwise, things like sv_2cv()
2922 * may leave alloc gunk on the savestack, and some code
2923 * (e.g. sighandler) doesn't expect that...
2925 if (PL_savestack_ix == mgs->mgs_ss_ix)
2927 I32 popval = SSPOPINT;
2928 assert(popval == SAVEt_DESTRUCTOR_X);
2929 PL_savestack_ix -= 2;
2931 assert(popval == SAVEt_ALLOC);
2933 PL_savestack_ix -= popval;
2939 S_unwind_handler_stack(pTHX_ const void *p)
2942 const U32 flags = *(const U32*)p;
2945 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2946 #if !defined(PERL_IMPLICIT_CONTEXT)
2948 SvREFCNT_dec(PL_sig_sv);
2953 =for apidoc magic_sethint
2955 Triggered by a store to %^H, records the key/value pair to
2956 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2957 anything that would need a deep copy. Maybe we should warn if we find a
2963 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2966 assert(mg->mg_len == HEf_SVKEY);
2968 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2969 an alternative leaf in there, with PL_compiling.cop_hints being used if
2970 it's NULL. If needed for threads, the alternative could lock a mutex,
2971 or take other more complex action. */
2973 /* Something changed in %^H, so it will need to be restored on scope exit.
2974 Doing this here saves a lot of doing it manually in perl code (and
2975 forgetting to do it, and consequent subtle errors. */
2976 PL_hints |= HINT_LOCALIZE_HH;
2977 PL_compiling.cop_hints_hash
2978 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2979 (SV *)mg->mg_ptr, sv);
2984 =for apidoc magic_sethint
2986 Triggered by a delete from %^H, records the key to
2987 C<PL_compiling.cop_hints_hash>.
2992 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2995 PERL_UNUSED_ARG(sv);
2997 assert(mg->mg_len == HEf_SVKEY);
2999 PERL_UNUSED_ARG(sv);
3001 PL_hints |= HINT_LOCALIZE_HH;
3002 PL_compiling.cop_hints_hash
3003 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3004 (SV *)mg->mg_ptr, &PL_sv_placeholder);
3010 * c-indentation-style: bsd
3012 * indent-tabs-mode: t
3015 * ex: set ts=8 sts=4 sw=4 noet: