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);
1533 PERL_UNUSED_ARG(mg);
1534 PL_sub_generation++;
1539 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1542 PERL_UNUSED_ARG(sv);
1543 PERL_UNUSED_ARG(mg);
1544 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1545 PL_amagic_generation++;
1551 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1553 HV * const hv = (HV*)LvTARG(sv);
1555 PERL_UNUSED_ARG(mg);
1558 (void) hv_iterinit(hv);
1559 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1562 while (hv_iternext(hv))
1567 sv_setiv(sv, (IV)i);
1572 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1574 PERL_UNUSED_ARG(mg);
1576 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1581 /* caller is responsible for stack switching/cleanup */
1583 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1590 PUSHs(SvTIED_obj(sv, mg));
1593 if (mg->mg_len >= 0)
1594 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1595 else if (mg->mg_len == HEf_SVKEY)
1596 PUSHs((SV*)mg->mg_ptr);
1598 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1599 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1607 return call_method(meth, flags);
1611 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1617 PUSHSTACKi(PERLSI_MAGIC);
1619 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1620 sv_setsv(sv, *PL_stack_sp--);
1630 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1633 mg->mg_flags |= MGf_GSKIP;
1634 magic_methpack(sv,mg,"FETCH");
1639 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1643 PUSHSTACKi(PERLSI_MAGIC);
1644 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1651 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1653 return magic_methpack(sv,mg,"DELETE");
1658 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1665 PUSHSTACKi(PERLSI_MAGIC);
1666 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1667 sv = *PL_stack_sp--;
1668 retval = (U32) SvIV(sv)-1;
1677 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1682 PUSHSTACKi(PERLSI_MAGIC);
1684 XPUSHs(SvTIED_obj(sv, mg));
1686 call_method("CLEAR", G_SCALAR|G_DISCARD);
1694 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1697 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1701 PUSHSTACKi(PERLSI_MAGIC);
1704 PUSHs(SvTIED_obj(sv, mg));
1709 if (call_method(meth, G_SCALAR))
1710 sv_setsv(key, *PL_stack_sp--);
1719 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1721 return magic_methpack(sv,mg,"EXISTS");
1725 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1729 SV * const tied = SvTIED_obj((SV*)hv, mg);
1730 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1732 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1734 if (HvEITER_get(hv))
1735 /* we are in an iteration so the hash cannot be empty */
1737 /* no xhv_eiter so now use FIRSTKEY */
1738 key = sv_newmortal();
1739 magic_nextpack((SV*)hv, mg, key);
1740 HvEITER_set(hv, NULL); /* need to reset iterator */
1741 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1744 /* there is a SCALAR method that we can call */
1746 PUSHSTACKi(PERLSI_MAGIC);
1752 if (call_method("SCALAR", G_SCALAR))
1753 retval = *PL_stack_sp--;
1755 retval = &PL_sv_undef;
1762 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1765 GV * const gv = PL_DBline;
1766 const I32 i = SvTRUE(sv);
1767 SV ** const svp = av_fetch(GvAV(gv),
1768 atoi(MgPV_nolen_const(mg)), FALSE);
1769 if (svp && SvIOKp(*svp)) {
1770 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1772 /* set or clear breakpoint in the relevant control op */
1774 o->op_flags |= OPf_SPECIAL;
1776 o->op_flags &= ~OPf_SPECIAL;
1783 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1786 const AV * const obj = (AV*)mg->mg_obj;
1788 sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1796 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1799 AV * const obj = (AV*)mg->mg_obj;
1801 av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1803 if (ckWARN(WARN_MISC))
1804 Perl_warner(aTHX_ packWARN(WARN_MISC),
1805 "Attempt to set length of freed array");
1811 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1814 PERL_UNUSED_ARG(sv);
1815 /* during global destruction, mg_obj may already have been freed */
1816 if (PL_in_clean_all)
1819 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1822 /* arylen scalar holds a pointer back to the array, but doesn't own a
1823 reference. Hence the we (the array) are about to go away with it
1824 still pointing at us. Clear its pointer, else it would be pointing
1825 at free memory. See the comment in sv_magic about reference loops,
1826 and why it can't own a reference to us. */
1833 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1836 SV* const lsv = LvTARG(sv);
1837 PERL_UNUSED_ARG(mg);
1839 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1840 MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1841 if (found && found->mg_len >= 0) {
1842 I32 i = found->mg_len;
1844 sv_pos_b2u(lsv, &i);
1845 sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1854 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1857 SV* const lsv = LvTARG(sv);
1863 PERL_UNUSED_ARG(mg);
1865 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1866 found = mg_find(lsv, PERL_MAGIC_regex_global);
1872 #ifdef PERL_OLD_COPY_ON_WRITE
1874 sv_force_normal_flags(lsv, 0);
1876 found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1879 else if (!SvOK(sv)) {
1883 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1885 pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1888 ulen = sv_len_utf8(lsv);
1898 else if (pos > (SSize_t)len)
1903 sv_pos_u2b(lsv, &p, 0);
1907 found->mg_len = pos;
1908 found->mg_flags &= ~MGf_MINMATCH;
1914 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1917 PERL_UNUSED_ARG(mg);
1921 if (isGV_with_GP(sv)) {
1922 /* We're actually already a typeglob, so don't need the stuff below.
1926 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1931 GvGP(sv) = gp_ref(GvGP(gv));
1936 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1939 SV * const lsv = LvTARG(sv);
1940 const char * const tmps = SvPV_const(lsv,len);
1941 I32 offs = LvTARGOFF(sv);
1942 I32 rem = LvTARGLEN(sv);
1943 PERL_UNUSED_ARG(mg);
1946 sv_pos_u2b(lsv, &offs, &rem);
1947 if (offs > (I32)len)
1949 if (rem + offs > (I32)len)
1951 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1958 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1962 const char * const tmps = SvPV_const(sv, len);
1963 SV * const lsv = LvTARG(sv);
1964 I32 lvoff = LvTARGOFF(sv);
1965 I32 lvlen = LvTARGLEN(sv);
1966 PERL_UNUSED_ARG(mg);
1969 sv_utf8_upgrade(lsv);
1970 sv_pos_u2b(lsv, &lvoff, &lvlen);
1971 sv_insert(lsv, lvoff, lvlen, tmps, len);
1972 LvTARGLEN(sv) = sv_len_utf8(sv);
1975 else if (lsv && SvUTF8(lsv)) {
1977 sv_pos_u2b(lsv, &lvoff, &lvlen);
1978 LvTARGLEN(sv) = len;
1979 utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1980 sv_insert(lsv, lvoff, lvlen, utf8, len);
1984 sv_insert(lsv, lvoff, lvlen, tmps, len);
1985 LvTARGLEN(sv) = len;
1993 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1996 PERL_UNUSED_ARG(sv);
1997 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2002 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2005 PERL_UNUSED_ARG(sv);
2006 /* update taint status */
2015 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2017 SV * const lsv = LvTARG(sv);
2018 PERL_UNUSED_ARG(mg);
2021 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2029 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2031 PERL_UNUSED_ARG(mg);
2032 do_vecset(sv); /* XXX slurp this routine */
2037 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2041 if (LvTARGLEN(sv)) {
2043 SV * const ahv = LvTARG(sv);
2044 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2049 AV* const av = (AV*)LvTARG(sv);
2050 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2051 targ = AvARRAY(av)[LvTARGOFF(sv)];
2053 if (targ && (targ != &PL_sv_undef)) {
2054 /* somebody else defined it for us */
2055 SvREFCNT_dec(LvTARG(sv));
2056 LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2058 SvREFCNT_dec(mg->mg_obj);
2060 mg->mg_flags &= ~MGf_REFCOUNTED;
2065 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2070 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2072 PERL_UNUSED_ARG(mg);
2076 sv_setsv(LvTARG(sv), sv);
2077 SvSETMAGIC(LvTARG(sv));
2083 Perl_vivify_defelem(pTHX_ SV *sv)
2089 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2092 SV * const ahv = LvTARG(sv);
2093 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2096 if (!value || value == &PL_sv_undef)
2097 Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2100 AV* const av = (AV*)LvTARG(sv);
2101 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2102 LvTARG(sv) = NULL; /* array can't be extended */
2104 SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2105 if (!svp || (value = *svp) == &PL_sv_undef)
2106 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2109 SvREFCNT_inc_simple_void(value);
2110 SvREFCNT_dec(LvTARG(sv));
2113 SvREFCNT_dec(mg->mg_obj);
2115 mg->mg_flags &= ~MGf_REFCOUNTED;
2119 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2121 return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2125 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2127 PERL_UNUSED_CONTEXT;
2134 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2136 PERL_UNUSED_ARG(mg);
2137 sv_unmagic(sv, PERL_MAGIC_bm);
2144 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2146 PERL_UNUSED_ARG(mg);
2147 sv_unmagic(sv, PERL_MAGIC_fm);
2153 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2155 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2157 if (uf && uf->uf_set)
2158 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2163 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2165 PERL_UNUSED_ARG(mg);
2166 sv_unmagic(sv, PERL_MAGIC_qr);
2171 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2174 regexp * const re = (regexp *)mg->mg_obj;
2175 PERL_UNUSED_ARG(sv);
2181 #ifdef USE_LOCALE_COLLATE
2183 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2186 * RenE<eacute> Descartes said "I think not."
2187 * and vanished with a faint plop.
2189 PERL_UNUSED_CONTEXT;
2190 PERL_UNUSED_ARG(sv);
2192 Safefree(mg->mg_ptr);
2198 #endif /* USE_LOCALE_COLLATE */
2200 /* Just clear the UTF-8 cache data. */
2202 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2204 PERL_UNUSED_CONTEXT;
2205 PERL_UNUSED_ARG(sv);
2206 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2208 mg->mg_len = -1; /* The mg_len holds the len cache. */
2213 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2216 register const char *s;
2219 switch (*mg->mg_ptr) {
2220 case '\001': /* ^A */
2221 sv_setsv(PL_bodytarget, sv);
2223 case '\003': /* ^C */
2224 PL_minus_c = (bool)SvIV(sv);
2227 case '\004': /* ^D */
2229 s = SvPV_nolen_const(sv);
2230 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2231 DEBUG_x(dump_all());
2233 PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2236 case '\005': /* ^E */
2237 if (*(mg->mg_ptr+1) == '\0') {
2238 #ifdef MACOS_TRADITIONAL
2239 gMacPerl_OSErr = SvIV(sv);
2242 set_vaxc_errno(SvIV(sv));
2245 SetLastError( SvIV(sv) );
2248 os2_setsyserrno(SvIV(sv));
2250 /* will anyone ever use this? */
2251 SETERRNO(SvIV(sv), 4);
2257 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2259 SvREFCNT_dec(PL_encoding);
2260 if (SvOK(sv) || SvGMAGICAL(sv)) {
2261 PL_encoding = newSVsv(sv);
2268 case '\006': /* ^F */
2269 PL_maxsysfd = SvIV(sv);
2271 case '\010': /* ^H */
2272 PL_hints = SvIV(sv);
2274 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2275 Safefree(PL_inplace);
2276 PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2278 case '\017': /* ^O */
2279 if (*(mg->mg_ptr+1) == '\0') {
2280 Safefree(PL_osname);
2283 TAINT_PROPER("assigning to $^O");
2284 PL_osname = savesvpv(sv);
2287 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2289 const char *const start = SvPV(sv, len);
2290 const char *out = (const char*)memchr(start, '\0', len);
2292 struct refcounted_he *tmp_he;
2295 PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2297 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2299 /* Opening for input is more common than opening for output, so
2300 ensure that hints for input are sooner on linked list. */
2301 tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2303 SvFLAGS(tmp) |= SvUTF8(sv);
2306 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2307 sv_2mortal(newSVpvs("open>")), tmp);
2309 /* The UTF-8 setting is carried over */
2310 sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2312 PL_compiling.cop_hints_hash
2313 = Perl_refcounted_he_new(aTHX_ tmp_he,
2314 sv_2mortal(newSVpvs("open<")), tmp);
2317 case '\020': /* ^P */
2318 PL_perldb = SvIV(sv);
2319 if (PL_perldb && !PL_DBsingle)
2322 case '\024': /* ^T */
2324 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2326 PL_basetime = (Time_t)SvIV(sv);
2329 case '\025': /* ^UTF8CACHE */
2330 if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2331 PL_utf8cache = (signed char) sv_2iv(sv);
2334 case '\027': /* ^W & $^WARNING_BITS */
2335 if (*(mg->mg_ptr+1) == '\0') {
2336 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2338 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2339 | (i ? G_WARN_ON : G_WARN_OFF) ;
2342 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2343 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2344 if (!SvPOK(sv) && PL_localizing) {
2345 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2346 PL_compiling.cop_warnings = pWARN_NONE;
2351 int accumulate = 0 ;
2352 int any_fatals = 0 ;
2353 const char * const ptr = SvPV_const(sv, len) ;
2354 for (i = 0 ; i < len ; ++i) {
2355 accumulate |= ptr[i] ;
2356 any_fatals |= (ptr[i] & 0xAA) ;
2359 if (!specialWARN(PL_compiling.cop_warnings))
2360 PerlMemShared_free(PL_compiling.cop_warnings);
2361 PL_compiling.cop_warnings = pWARN_NONE;
2363 /* Yuck. I can't see how to abstract this: */
2364 else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2365 WARN_ALL) && !any_fatals) {
2366 if (!specialWARN(PL_compiling.cop_warnings))
2367 PerlMemShared_free(PL_compiling.cop_warnings);
2368 PL_compiling.cop_warnings = pWARN_ALL;
2369 PL_dowarn |= G_WARN_ONCE ;
2373 const char *const p = SvPV_const(sv, len);
2375 PL_compiling.cop_warnings
2376 = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2379 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2380 PL_dowarn |= G_WARN_ONCE ;
2388 if (PL_localizing) {
2389 if (PL_localizing == 1)
2390 SAVESPTR(PL_last_in_gv);
2392 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2393 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2396 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2397 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2398 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2401 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2402 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2403 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2406 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2409 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2410 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2411 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2414 IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2418 IO * const io = GvIOp(PL_defoutgv);
2421 if ((SvIV(sv)) == 0)
2422 IoFLAGS(io) &= ~IOf_FLUSH;
2424 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2425 PerlIO *ofp = IoOFP(io);
2427 (void)PerlIO_flush(ofp);
2428 IoFLAGS(io) |= IOf_FLUSH;
2434 SvREFCNT_dec(PL_rs);
2435 PL_rs = newSVsv(sv);
2439 SvREFCNT_dec(PL_ors_sv);
2440 if (SvOK(sv) || SvGMAGICAL(sv)) {
2441 PL_ors_sv = newSVsv(sv);
2449 SvREFCNT_dec(PL_ofs_sv);
2450 if (SvOK(sv) || SvGMAGICAL(sv)) {
2451 PL_ofs_sv = newSVsv(sv);
2458 CopARYBASE_set(&PL_compiling, SvIV(sv));
2461 #ifdef COMPLEX_STATUS
2462 if (PL_localizing == 2) {
2463 PL_statusvalue = LvTARGOFF(sv);
2464 PL_statusvalue_vms = LvTARGLEN(sv);
2468 #ifdef VMSISH_STATUS
2470 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2473 STATUS_UNIX_EXIT_SET(SvIV(sv));
2478 # define PERL_VMS_BANG vaxc$errno
2480 # define PERL_VMS_BANG 0
2482 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2483 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2488 if (PL_delaymagic) {
2489 PL_delaymagic |= DM_RUID;
2490 break; /* don't do magic till later */
2493 (void)setruid((Uid_t)PL_uid);
2496 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2498 #ifdef HAS_SETRESUID
2499 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2501 if (PL_uid == PL_euid) { /* special case $< = $> */
2503 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2504 if (PL_uid != 0 && PerlProc_getuid() == 0)
2505 (void)PerlProc_setuid(0);
2507 (void)PerlProc_setuid(PL_uid);
2509 PL_uid = PerlProc_getuid();
2510 Perl_croak(aTHX_ "setruid() not implemented");
2515 PL_uid = PerlProc_getuid();
2516 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2520 if (PL_delaymagic) {
2521 PL_delaymagic |= DM_EUID;
2522 break; /* don't do magic till later */
2525 (void)seteuid((Uid_t)PL_euid);
2528 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2530 #ifdef HAS_SETRESUID
2531 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2533 if (PL_euid == PL_uid) /* special case $> = $< */
2534 PerlProc_setuid(PL_euid);
2536 PL_euid = PerlProc_geteuid();
2537 Perl_croak(aTHX_ "seteuid() not implemented");
2542 PL_euid = PerlProc_geteuid();
2543 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2547 if (PL_delaymagic) {
2548 PL_delaymagic |= DM_RGID;
2549 break; /* don't do magic till later */
2552 (void)setrgid((Gid_t)PL_gid);
2555 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2557 #ifdef HAS_SETRESGID
2558 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2560 if (PL_gid == PL_egid) /* special case $( = $) */
2561 (void)PerlProc_setgid(PL_gid);
2563 PL_gid = PerlProc_getgid();
2564 Perl_croak(aTHX_ "setrgid() not implemented");
2569 PL_gid = PerlProc_getgid();
2570 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2573 #ifdef HAS_SETGROUPS
2575 const char *p = SvPV_const(sv, len);
2576 Groups_t *gary = NULL;
2581 for (i = 0; i < NGROUPS; ++i) {
2582 while (*p && !isSPACE(*p))
2589 Newx(gary, i + 1, Groups_t);
2591 Renew(gary, i + 1, Groups_t);
2595 (void)setgroups(i, gary);
2598 #else /* HAS_SETGROUPS */
2600 #endif /* HAS_SETGROUPS */
2601 if (PL_delaymagic) {
2602 PL_delaymagic |= DM_EGID;
2603 break; /* don't do magic till later */
2606 (void)setegid((Gid_t)PL_egid);
2609 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2611 #ifdef HAS_SETRESGID
2612 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2614 if (PL_egid == PL_gid) /* special case $) = $( */
2615 (void)PerlProc_setgid(PL_egid);
2617 PL_egid = PerlProc_getegid();
2618 Perl_croak(aTHX_ "setegid() not implemented");
2623 PL_egid = PerlProc_getegid();
2624 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2627 PL_chopset = SvPV_force(sv,len);
2629 #ifndef MACOS_TRADITIONAL
2631 LOCK_DOLLARZERO_MUTEX;
2632 #ifdef HAS_SETPROCTITLE
2633 /* The BSDs don't show the argv[] in ps(1) output, they
2634 * show a string from the process struct and provide
2635 * the setproctitle() routine to manipulate that. */
2636 if (PL_origalen != 1) {
2637 s = SvPV_const(sv, len);
2638 # if __FreeBSD_version > 410001
2639 /* The leading "-" removes the "perl: " prefix,
2640 * but not the "(perl) suffix from the ps(1)
2641 * output, because that's what ps(1) shows if the
2642 * argv[] is modified. */
2643 setproctitle("-%s", s);
2644 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2645 /* This doesn't really work if you assume that
2646 * $0 = 'foobar'; will wipe out 'perl' from the $0
2647 * because in ps(1) output the result will be like
2648 * sprintf("perl: %s (perl)", s)
2649 * I guess this is a security feature:
2650 * one (a user process) cannot get rid of the original name.
2652 setproctitle("%s", s);
2655 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2656 if (PL_origalen != 1) {
2658 s = SvPV_const(sv, len);
2659 un.pst_command = (char *)s;
2660 pstat(PSTAT_SETCMD, un, len, 0, 0);
2663 if (PL_origalen > 1) {
2664 /* PL_origalen is set in perl_parse(). */
2665 s = SvPV_force(sv,len);
2666 if (len >= (STRLEN)PL_origalen-1) {
2667 /* Longer than original, will be truncated. We assume that
2668 * PL_origalen bytes are available. */
2669 Copy(s, PL_origargv[0], PL_origalen-1, char);
2672 /* Shorter than original, will be padded. */
2674 /* Special case for Mac OS X: see [perl #38868] */
2677 /* Is the space counterintuitive? Yes.
2678 * (You were expecting \0?)
2679 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2681 const int pad = ' ';
2683 Copy(s, PL_origargv[0], len, char);
2684 PL_origargv[0][len] = 0;
2685 memset(PL_origargv[0] + len + 1,
2686 pad, PL_origalen - len - 1);
2688 PL_origargv[0][PL_origalen-1] = 0;
2689 for (i = 1; i < PL_origargc; i++)
2693 UNLOCK_DOLLARZERO_MUTEX;
2701 Perl_whichsig(pTHX_ const char *sig)
2703 register char* const* sigv;
2704 PERL_UNUSED_CONTEXT;
2706 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2707 if (strEQ(sig,*sigv))
2708 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2710 if (strEQ(sig,"CHLD"))
2714 if (strEQ(sig,"CLD"))
2721 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2722 Perl_sighandler(int sig, ...)
2724 Perl_sighandler(int sig)
2727 #ifdef PERL_GET_SIG_CONTEXT
2728 dTHXa(PERL_GET_SIG_CONTEXT);
2735 SV * const tSv = PL_Sv;
2739 XPV * const tXpv = PL_Xpv;
2741 if (PL_savestack_ix + 15 <= PL_savestack_max)
2743 if (PL_markstack_ptr < PL_markstack_max - 2)
2745 if (PL_scopestack_ix < PL_scopestack_max - 3)
2748 if (!PL_psig_ptr[sig]) {
2749 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2754 /* Max number of items pushed there is 3*n or 4. We cannot fix
2755 infinity, so we fix 4 (in fact 5): */
2757 PL_savestack_ix += 5; /* Protect save in progress. */
2758 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2761 PL_markstack_ptr++; /* Protect mark. */
2763 PL_scopestack_ix += 1;
2764 /* sv_2cv is too complicated, try a simpler variant first: */
2765 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2766 || SvTYPE(cv) != SVt_PVCV) {
2768 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2771 if (!cv || !CvROOT(cv)) {
2772 if (ckWARN(WARN_SIGNAL))
2773 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2774 PL_sig_name[sig], (gv ? GvENAME(gv)
2781 if(PL_psig_name[sig]) {
2782 sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2784 #if !defined(PERL_IMPLICIT_CONTEXT)
2788 sv = sv_newmortal();
2789 sv_setpv(sv,PL_sig_name[sig]);
2792 PUSHSTACKi(PERLSI_SIGNAL);
2795 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2797 struct sigaction oact;
2799 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2803 va_start(args, sig);
2804 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2807 SV *rv = newRV_noinc((SV*)sih);
2808 /* The siginfo fields signo, code, errno, pid, uid,
2809 * addr, status, and band are defined by POSIX/SUSv3. */
2810 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2811 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2812 #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. */
2813 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2814 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2815 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2816 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2817 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2818 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2822 PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2831 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2834 if (SvTRUE(ERRSV)) {
2836 #ifdef HAS_SIGPROCMASK
2837 /* Handler "died", for example to get out of a restart-able read().
2838 * Before we re-do that on its behalf re-enable the signal which was
2839 * blocked by the system when we entered.
2843 sigaddset(&set,sig);
2844 sigprocmask(SIG_UNBLOCK, &set, NULL);
2846 /* Not clear if this will work */
2847 (void)rsignal(sig, SIG_IGN);
2848 (void)rsignal(sig, PL_csighandlerp);
2850 #endif /* !PERL_MICRO */
2851 Perl_die(aTHX_ NULL);
2855 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2859 PL_scopestack_ix -= 1;
2862 PL_op = myop; /* Apparently not needed... */
2864 PL_Sv = tSv; /* Restore global temporaries. */
2871 S_restore_magic(pTHX_ const void *p)
2874 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2875 SV* const sv = mgs->mgs_sv;
2880 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2882 #ifdef PERL_OLD_COPY_ON_WRITE
2883 /* While magic was saved (and off) sv_setsv may well have seen
2884 this SV as a prime candidate for COW. */
2886 sv_force_normal_flags(sv, 0);
2890 SvFLAGS(sv) |= mgs->mgs_flags;
2893 if (SvGMAGICAL(sv)) {
2894 /* downgrade public flags to private,
2895 and discard any other private flags */
2897 const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2899 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2900 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2905 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2907 /* If we're still on top of the stack, pop us off. (That condition
2908 * will be satisfied if restore_magic was called explicitly, but *not*
2909 * if it's being called via leave_scope.)
2910 * The reason for doing this is that otherwise, things like sv_2cv()
2911 * may leave alloc gunk on the savestack, and some code
2912 * (e.g. sighandler) doesn't expect that...
2914 if (PL_savestack_ix == mgs->mgs_ss_ix)
2916 I32 popval = SSPOPINT;
2917 assert(popval == SAVEt_DESTRUCTOR_X);
2918 PL_savestack_ix -= 2;
2920 assert(popval == SAVEt_ALLOC);
2922 PL_savestack_ix -= popval;
2928 S_unwind_handler_stack(pTHX_ const void *p)
2931 const U32 flags = *(const U32*)p;
2934 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2935 #if !defined(PERL_IMPLICIT_CONTEXT)
2937 SvREFCNT_dec(PL_sig_sv);
2942 =for apidoc magic_sethint
2944 Triggered by a store to %^H, records the key/value pair to
2945 C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
2946 anything that would need a deep copy. Maybe we should warn if we find a
2952 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2955 assert(mg->mg_len == HEf_SVKEY);
2957 /* mg->mg_obj isn't being used. If needed, it would be possible to store
2958 an alternative leaf in there, with PL_compiling.cop_hints being used if
2959 it's NULL. If needed for threads, the alternative could lock a mutex,
2960 or take other more complex action. */
2962 /* Something changed in %^H, so it will need to be restored on scope exit.
2963 Doing this here saves a lot of doing it manually in perl code (and
2964 forgetting to do it, and consequent subtle errors. */
2965 PL_hints |= HINT_LOCALIZE_HH;
2966 PL_compiling.cop_hints_hash
2967 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2968 (SV *)mg->mg_ptr, sv);
2973 =for apidoc magic_sethint
2975 Triggered by a delete from %^H, records the key to
2976 C<PL_compiling.cop_hints_hash>.
2981 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2984 PERL_UNUSED_ARG(sv);
2986 assert(mg->mg_len == HEf_SVKEY);
2988 PERL_UNUSED_ARG(sv);
2990 PL_hints |= HINT_LOCALIZE_HH;
2991 PL_compiling.cop_hints_hash
2992 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2993 (SV *)mg->mg_ptr, &PL_sv_placeholder);
2999 * c-indentation-style: bsd
3001 * indent-tabs-mode: t
3004 * ex: set ts=8 sts=4 sw=4 noet: