3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005 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)
52 # include <sys/pstat.h>
55 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
56 Signal_t Perl_csighandler(int sig, ...);
58 Signal_t Perl_csighandler(int sig);
62 /* Missing protos on LynxOS */
63 void setruid(uid_t id);
64 void seteuid(uid_t id);
65 void setrgid(uid_t id);
66 void setegid(uid_t id);
70 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
78 /* MGS is typedef'ed to struct magic_state in perl.h */
81 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
84 assert(SvMAGICAL(sv));
85 #ifdef PERL_OLD_COPY_ON_WRITE
86 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
91 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
93 mgs = SSPTR(mgs_ix, MGS*);
95 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
96 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
100 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
104 =for apidoc mg_magical
106 Turns on the magical status of an SV. See C<sv_magic>.
112 Perl_mg_magical(pTHX_ SV *sv)
115 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
116 const MGVTBL* const vtbl = mg->mg_virtual;
118 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
122 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
131 Do magic after a value is retrieved from the SV. See C<sv_magic>.
137 Perl_mg_get(pTHX_ SV *sv)
139 const I32 mgs_ix = SSNEW(sizeof(MGS));
140 const bool was_temp = (bool)SvTEMP(sv);
142 MAGIC *newmg, *head, *cur, *mg;
143 /* guard against sv having being freed midway by holding a private
146 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
147 cause the SV's buffer to get stolen (and maybe other stuff).
150 sv_2mortal(SvREFCNT_inc(sv));
155 save_magic(mgs_ix, sv);
157 /* We must call svt_get(sv, mg) for each valid entry in the linked
158 list of magic. svt_get() may delete the current entry, add new
159 magic to the head of the list, or upgrade the SV. AMS 20010810 */
161 newmg = cur = head = mg = SvMAGIC(sv);
163 const MGVTBL * const vtbl = mg->mg_virtual;
165 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
166 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
168 /* guard against magic having been deleted - eg FETCH calling
173 /* Don't restore the flags for this entry if it was deleted. */
174 if (mg->mg_flags & MGf_GSKIP)
175 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
178 mg = mg->mg_moremagic;
181 /* Have we finished with the new entries we saw? Start again
182 where we left off (unless there are more new entries). */
190 /* Were any new entries added? */
191 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
198 restore_magic(INT2PTR(void *, (IV)mgs_ix));
200 if (SvREFCNT(sv) == 1) {
201 /* We hold the last reference to this SV, which implies that the
202 SV was deleted as a side effect of the routines we called. */
211 Do magic after a value is assigned to the SV. See C<sv_magic>.
217 Perl_mg_set(pTHX_ SV *sv)
219 const I32 mgs_ix = SSNEW(sizeof(MGS));
223 save_magic(mgs_ix, sv);
225 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
226 const MGVTBL* vtbl = mg->mg_virtual;
227 nextmg = mg->mg_moremagic; /* it may delete itself */
228 if (mg->mg_flags & MGf_GSKIP) {
229 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
230 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
232 if (vtbl && vtbl->svt_set)
233 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
236 restore_magic(INT2PTR(void*, (IV)mgs_ix));
241 =for apidoc mg_length
243 Report on the SV's length. See C<sv_magic>.
249 Perl_mg_length(pTHX_ SV *sv)
254 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
255 const MGVTBL * const vtbl = mg->mg_virtual;
256 if (vtbl && vtbl->svt_len) {
257 const I32 mgs_ix = SSNEW(sizeof(MGS));
258 save_magic(mgs_ix, sv);
259 /* omit MGf_GSKIP -- not changed here */
260 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
261 restore_magic(INT2PTR(void*, (IV)mgs_ix));
267 const U8 *s = (U8*)SvPV_const(sv, len);
268 len = Perl_utf8_length(aTHX_ s, s + len);
271 (void)SvPV_const(sv, len);
276 Perl_mg_size(pTHX_ SV *sv)
280 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
281 const MGVTBL* const vtbl = mg->mg_virtual;
282 if (vtbl && vtbl->svt_len) {
283 const I32 mgs_ix = SSNEW(sizeof(MGS));
285 save_magic(mgs_ix, sv);
286 /* omit MGf_GSKIP -- not changed here */
287 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
288 restore_magic(INT2PTR(void*, (IV)mgs_ix));
295 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
299 Perl_croak(aTHX_ "Size magic not implemented");
308 Clear something magical that the SV represents. See C<sv_magic>.
314 Perl_mg_clear(pTHX_ SV *sv)
316 const I32 mgs_ix = SSNEW(sizeof(MGS));
319 save_magic(mgs_ix, sv);
321 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
322 const MGVTBL* const vtbl = mg->mg_virtual;
323 /* omit GSKIP -- never set here */
325 if (vtbl && vtbl->svt_clear)
326 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
329 restore_magic(INT2PTR(void*, (IV)mgs_ix));
336 Finds the magic pointer for type matching the SV. See C<sv_magic>.
342 Perl_mg_find(pTHX_ const SV *sv, int type)
346 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
347 if (mg->mg_type == type)
357 Copies the magic from one SV to another. See C<sv_magic>.
363 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
367 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
368 const MGVTBL* const vtbl = mg->mg_virtual;
369 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
370 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
372 else if (isUPPER(mg->mg_type)) {
374 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
375 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
377 toLOWER(mg->mg_type), key, klen);
385 =for apidoc mg_localize
387 Copy some of the magic from an existing SV to new localized version of
388 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
389 doesn't (eg taint, pos).
395 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
398 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
399 const MGVTBL* const vtbl = mg->mg_virtual;
400 switch (mg->mg_type) {
401 /* value magic types: don't copy */
404 case PERL_MAGIC_regex_global:
405 case PERL_MAGIC_nkeys:
406 #ifdef USE_LOCALE_COLLATE
407 case PERL_MAGIC_collxfrm:
410 case PERL_MAGIC_taint:
412 case PERL_MAGIC_vstring:
413 case PERL_MAGIC_utf8:
414 case PERL_MAGIC_substr:
415 case PERL_MAGIC_defelem:
416 case PERL_MAGIC_arylen:
418 case PERL_MAGIC_backref:
419 case PERL_MAGIC_arylen_p:
420 case PERL_MAGIC_rhash:
421 case PERL_MAGIC_symtab:
425 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
426 /* XXX calling the copy method is probably not correct. DAPM */
427 (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
428 mg->mg_ptr, mg->mg_len);
431 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
432 mg->mg_ptr, mg->mg_len);
434 /* container types should remain read-only across localization */
435 SvFLAGS(nsv) |= SvREADONLY(sv);
438 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
439 SvFLAGS(nsv) |= SvMAGICAL(sv);
449 Free any magic storage used by the SV. See C<sv_magic>.
455 Perl_mg_free(pTHX_ SV *sv)
459 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
460 const MGVTBL* const vtbl = mg->mg_virtual;
461 moremagic = mg->mg_moremagic;
462 if (vtbl && vtbl->svt_free)
463 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
464 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
465 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
466 Safefree(mg->mg_ptr);
467 else if (mg->mg_len == HEf_SVKEY)
468 SvREFCNT_dec((SV*)mg->mg_ptr);
470 if (mg->mg_flags & MGf_REFCOUNTED)
471 SvREFCNT_dec(mg->mg_obj);
474 SvMAGIC_set(sv, NULL);
481 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
483 register const REGEXP *rx;
486 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
487 if (mg->mg_obj) /* @+ */
490 return rx->lastparen;
497 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
501 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
502 register const I32 paren = mg->mg_len;
507 if (paren <= (I32)rx->nparens &&
508 (s = rx->startp[paren]) != -1 &&
509 (t = rx->endp[paren]) != -1)
512 if (mg->mg_obj) /* @+ */
517 if (i > 0 && RX_MATCH_UTF8(rx)) {
518 const char * const b = rx->subbeg;
520 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
530 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
532 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
533 Perl_croak(aTHX_ PL_no_modify);
534 NORETURN_FUNCTION_END;
538 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
542 register const REGEXP *rx;
545 switch (*mg->mg_ptr) {
546 case '1': case '2': case '3': case '4':
547 case '5': case '6': case '7': case '8': case '9': case '&':
548 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
550 paren = atoi(mg->mg_ptr); /* $& is in [0] */
552 if (paren <= (I32)rx->nparens &&
553 (s1 = rx->startp[paren]) != -1 &&
554 (t1 = rx->endp[paren]) != -1)
558 if (i > 0 && RX_MATCH_UTF8(rx)) {
559 const char * const s = rx->subbeg + s1;
564 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
568 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
572 if (ckWARN(WARN_UNINITIALIZED))
577 if (ckWARN(WARN_UNINITIALIZED))
582 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
583 paren = rx->lastparen;
588 case '\016': /* ^N */
589 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
590 paren = rx->lastcloseparen;
596 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
597 if (rx->startp[0] != -1) {
608 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
609 if (rx->endp[0] != -1) {
610 i = rx->sublen - rx->endp[0];
621 if (!SvPOK(sv) && SvNIOK(sv)) {
629 #define SvRTRIM(sv) STMT_START { \
630 STRLEN len = SvCUR(sv); \
631 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
633 SvCUR_set(sv, len); \
637 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
641 register char *s = NULL;
645 switch (*mg->mg_ptr) {
646 case '\001': /* ^A */
647 sv_setsv(sv, PL_bodytarget);
649 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
650 if (*(mg->mg_ptr+1) == '\0') {
651 sv_setiv(sv, (IV)PL_minus_c);
653 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
654 sv_setiv(sv, (IV)STATUS_NATIVE);
658 case '\004': /* ^D */
659 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
661 case '\005': /* ^E */
662 if (*(mg->mg_ptr+1) == '\0') {
663 #ifdef MACOS_TRADITIONAL
667 sv_setnv(sv,(double)gMacPerl_OSErr);
668 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
673 # include <descrip.h>
674 # include <starlet.h>
676 $DESCRIPTOR(msgdsc,msg);
677 sv_setnv(sv,(NV) vaxc$errno);
678 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
679 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
685 if (!(_emx_env & 0x200)) { /* Under DOS */
686 sv_setnv(sv, (NV)errno);
687 sv_setpv(sv, errno ? Strerror(errno) : "");
689 if (errno != errno_isOS2) {
690 int tmp = _syserrno();
691 if (tmp) /* 2nd call to _syserrno() makes it 0 */
694 sv_setnv(sv, (NV)Perl_rc);
695 sv_setpv(sv, os2error(Perl_rc));
700 DWORD dwErr = GetLastError();
701 sv_setnv(sv, (NV)dwErr);
704 PerlProc_GetOSError(sv, dwErr);
707 sv_setpvn(sv, "", 0);
712 const int saveerrno = errno;
713 sv_setnv(sv, (NV)errno);
714 sv_setpv(sv, errno ? Strerror(errno) : "");
722 SvNOK_on(sv); /* what a wonderful hack! */
724 else if (strEQ(mg->mg_ptr+1, "NCODING"))
725 sv_setsv(sv, PL_encoding);
727 case '\006': /* ^F */
728 sv_setiv(sv, (IV)PL_maxsysfd);
730 case '\010': /* ^H */
731 sv_setiv(sv, (IV)PL_hints);
733 case '\011': /* ^I */ /* NOT \t in EBCDIC */
735 sv_setpv(sv, PL_inplace);
737 sv_setsv(sv, &PL_sv_undef);
739 case '\017': /* ^O & ^OPEN */
740 if (*(mg->mg_ptr+1) == '\0') {
741 sv_setpv(sv, PL_osname);
744 else if (strEQ(mg->mg_ptr, "\017PEN")) {
745 if (!PL_compiling.cop_io)
746 sv_setsv(sv, &PL_sv_undef);
748 sv_setsv(sv, PL_compiling.cop_io);
752 case '\020': /* ^P */
753 sv_setiv(sv, (IV)PL_perldb);
755 case '\023': /* ^S */
756 if (*(mg->mg_ptr+1) == '\0') {
757 if (PL_lex_state != LEX_NOTPARSING)
760 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
765 case '\024': /* ^T */
766 if (*(mg->mg_ptr+1) == '\0') {
768 sv_setnv(sv, PL_basetime);
770 sv_setiv(sv, (IV)PL_basetime);
773 else if (strEQ(mg->mg_ptr, "\024AINT"))
774 sv_setiv(sv, PL_tainting
775 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
778 case '\025': /* $^UNICODE, $^UTF8LOCALE */
779 if (strEQ(mg->mg_ptr, "\025NICODE"))
780 sv_setuv(sv, (UV) PL_unicode);
781 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
782 sv_setuv(sv, (UV) PL_utf8locale);
784 case '\027': /* ^W & $^WARNING_BITS */
785 if (*(mg->mg_ptr+1) == '\0')
786 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
787 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
788 if (PL_compiling.cop_warnings == pWARN_NONE ||
789 PL_compiling.cop_warnings == pWARN_STD)
791 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
793 else if (PL_compiling.cop_warnings == pWARN_ALL) {
794 /* Get the bit mask for $warnings::Bits{all}, because
795 * it could have been extended by warnings::register */
797 HV *bits=get_hv("warnings::Bits", FALSE);
798 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
799 sv_setsv(sv, *bits_all);
802 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
806 sv_setsv(sv, PL_compiling.cop_warnings);
811 case '1': case '2': case '3': case '4':
812 case '5': case '6': case '7': case '8': case '9': case '&':
813 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
817 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
818 * XXX Does the new way break anything?
820 paren = atoi(mg->mg_ptr); /* $& is in [0] */
822 if (paren <= (I32)rx->nparens &&
823 (s1 = rx->startp[paren]) != -1 &&
824 (t1 = rx->endp[paren]) != -1)
834 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
839 if (RX_MATCH_TAINTED(rx)) {
840 MAGIC* mg = SvMAGIC(sv);
843 SvMAGIC_set(sv, mg->mg_moremagic);
845 if ((mgt = SvMAGIC(sv))) {
846 mg->mg_moremagic = mgt;
856 sv_setsv(sv,&PL_sv_undef);
859 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
860 paren = rx->lastparen;
864 sv_setsv(sv,&PL_sv_undef);
866 case '\016': /* ^N */
867 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
868 paren = rx->lastcloseparen;
872 sv_setsv(sv,&PL_sv_undef);
875 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
876 if ((s = rx->subbeg) && rx->startp[0] != -1) {
881 sv_setsv(sv,&PL_sv_undef);
884 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
885 if (rx->subbeg && rx->endp[0] != -1) {
886 s = rx->subbeg + rx->endp[0];
887 i = rx->sublen - rx->endp[0];
891 sv_setsv(sv,&PL_sv_undef);
894 if (GvIO(PL_last_in_gv)) {
895 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
900 sv_setiv(sv, (IV)STATUS_CURRENT);
901 #ifdef COMPLEX_STATUS
902 LvTARGOFF(sv) = PL_statusvalue;
903 LvTARGLEN(sv) = PL_statusvalue_vms;
908 if (GvIOp(PL_defoutgv))
909 s = IoTOP_NAME(GvIOp(PL_defoutgv));
913 sv_setpv(sv,GvENAME(PL_defoutgv));
918 if (GvIOp(PL_defoutgv))
919 s = IoFMT_NAME(GvIOp(PL_defoutgv));
921 s = GvENAME(PL_defoutgv);
925 if (GvIOp(PL_defoutgv))
926 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
929 if (GvIOp(PL_defoutgv))
930 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
933 if (GvIOp(PL_defoutgv))
934 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
941 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
944 if (GvIOp(PL_defoutgv))
945 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
951 sv_copypv(sv, PL_ors_sv);
955 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
956 sv_setpv(sv, errno ? Strerror(errno) : "");
959 const int saveerrno = errno;
960 sv_setnv(sv, (NV)errno);
962 if (errno == errno_isOS2 || errno == errno_isOS2_set)
963 sv_setpv(sv, os2error(Perl_rc));
966 sv_setpv(sv, errno ? Strerror(errno) : "");
971 SvNOK_on(sv); /* what a wonderful hack! */
974 sv_setiv(sv, (IV)PL_uid);
977 sv_setiv(sv, (IV)PL_euid);
980 sv_setiv(sv, (IV)PL_gid);
982 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
986 sv_setiv(sv, (IV)PL_egid);
988 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
993 Groups_t gary[NGROUPS];
994 I32 j = getgroups(NGROUPS,gary);
996 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
999 (void)SvIOK_on(sv); /* what a wonderful hack! */
1001 #ifndef MACOS_TRADITIONAL
1010 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1012 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1014 if (uf && uf->uf_val)
1015 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1020 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1027 s = SvPV_const(sv,len);
1028 ptr = MgPV_const(mg,klen);
1031 #ifdef DYNAMIC_ENV_FETCH
1032 /* We just undefd an environment var. Is a replacement */
1033 /* waiting in the wings? */
1036 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1037 s = SvPV_const(*valp, len);
1041 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1042 /* And you'll never guess what the dog had */
1043 /* in its mouth... */
1045 MgTAINTEDDIR_off(mg);
1047 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1048 char pathbuf[256], eltbuf[256], *cp, *elt = (char *) s;
1052 do { /* DCL$PATH may be a search list */
1053 while (1) { /* as may dev portion of any element */
1054 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1055 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1056 cando_by_name(S_IWUSR,0,elt) ) {
1057 MgTAINTEDDIR_on(mg);
1061 if ((cp = strchr(elt, ':')) != Nullch)
1063 if (my_trnlnm(elt, eltbuf, j++))
1069 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1072 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1073 const char * const strend = s + len;
1075 while (s < strend) {
1079 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1080 s, strend, ':', &i);
1082 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1084 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1085 MgTAINTEDDIR_on(mg);
1091 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1097 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1099 PERL_UNUSED_ARG(sv);
1100 my_setenv(MgPV_nolen_const(mg),Nullch);
1105 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1107 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1108 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1110 if (PL_localizing) {
1112 magic_clear_all_env(sv,mg);
1113 hv_iterinit((HV*)sv);
1114 while ((entry = hv_iternext((HV*)sv))) {
1116 my_setenv(hv_iterkey(entry, &keylen),
1117 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1125 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1129 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1130 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1132 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1135 # ifdef USE_ENVIRON_ARRAY
1136 # if defined(USE_ITHREADS)
1137 /* only the parent thread can clobber the process environment */
1138 if (PL_curinterp == aTHX)
1141 # ifndef PERL_USE_SAFE_PUTENV
1142 if (!PL_use_safe_putenv) {
1145 if (environ == PL_origenviron)
1146 environ = (char**)safesysmalloc(sizeof(char*));
1148 for (i = 0; environ[i]; i++)
1149 safesysfree(environ[i]);
1151 # endif /* PERL_USE_SAFE_PUTENV */
1153 environ[0] = Nullch;
1155 # endif /* USE_ENVIRON_ARRAY */
1156 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1157 #endif /* VMS || EPOC */
1158 #endif /* !PERL_MICRO */
1159 PERL_UNUSED_ARG(sv);
1160 PERL_UNUSED_ARG(mg);
1165 #ifdef HAS_SIGPROCMASK
1167 restore_sigmask(pTHX_ SV *save_sv)
1169 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1170 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1174 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1176 /* Are we fetching a signal entry? */
1177 const I32 i = whichsig(MgPV_nolen_const(mg));
1180 sv_setsv(sv,PL_psig_ptr[i]);
1182 Sighandler_t sigstate;
1183 sigstate = rsignal_state(i);
1184 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1185 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1187 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1188 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1190 /* cache state so we don't fetch it again */
1191 if(sigstate == (Sighandler_t) SIG_IGN)
1192 sv_setpv(sv,"IGNORE");
1194 sv_setsv(sv,&PL_sv_undef);
1195 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1202 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1204 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1205 * refactoring might be in order.
1208 register const char * const s = MgPV_nolen_const(mg);
1209 PERL_UNUSED_ARG(sv);
1212 if (strEQ(s,"__DIE__"))
1214 else if (strEQ(s,"__WARN__"))
1217 Perl_croak(aTHX_ "No such hook: %s", s);
1219 SV * const to_dec = *svp;
1221 SvREFCNT_dec(to_dec);
1225 /* Are we clearing a signal entry? */
1226 const I32 i = whichsig(s);
1228 #ifdef HAS_SIGPROCMASK
1231 /* Avoid having the signal arrive at a bad time, if possible. */
1234 sigprocmask(SIG_BLOCK, &set, &save);
1236 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1237 SAVEFREESV(save_sv);
1238 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1241 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1242 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1244 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1245 PL_sig_defaulting[i] = 1;
1246 (void)rsignal(i, PL_csighandlerp);
1248 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1250 if(PL_psig_name[i]) {
1251 SvREFCNT_dec(PL_psig_name[i]);
1254 if(PL_psig_ptr[i]) {
1255 SV *to_dec=PL_psig_ptr[i];
1258 SvREFCNT_dec(to_dec);
1268 S_raise_signal(pTHX_ int sig)
1270 /* Set a flag to say this signal is pending */
1271 PL_psig_pend[sig]++;
1272 /* And one to say _a_ signal is pending */
1277 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1278 Perl_csighandler(int sig, ...)
1280 Perl_csighandler(int sig)
1283 #ifdef PERL_GET_SIG_CONTEXT
1284 dTHXa(PERL_GET_SIG_CONTEXT);
1288 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1289 (void) rsignal(sig, PL_csighandlerp);
1290 if (PL_sig_ignoring[sig]) return;
1292 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1293 if (PL_sig_defaulting[sig])
1294 #ifdef KILL_BY_SIGPRC
1295 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1300 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1301 /* Call the perl level handler now--
1302 * with risk we may be in malloc() etc. */
1303 (*PL_sighandlerp)(sig);
1305 S_raise_signal(aTHX_ sig);
1308 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1310 Perl_csighandler_init(void)
1313 if (PL_sig_handlers_initted) return;
1315 for (sig = 1; sig < SIG_SIZE; sig++) {
1316 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1318 PL_sig_defaulting[sig] = 1;
1319 (void) rsignal(sig, PL_csighandlerp);
1321 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1322 PL_sig_ignoring[sig] = 0;
1325 PL_sig_handlers_initted = 1;
1330 Perl_despatch_signals(pTHX)
1334 for (sig = 1; sig < SIG_SIZE; sig++) {
1335 if (PL_psig_pend[sig]) {
1336 PERL_BLOCKSIG_ADD(set, sig);
1337 PL_psig_pend[sig] = 0;
1338 PERL_BLOCKSIG_BLOCK(set);
1339 (*PL_sighandlerp)(sig);
1340 PERL_BLOCKSIG_UNBLOCK(set);
1346 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1351 /* Need to be careful with SvREFCNT_dec(), because that can have side
1352 * effects (due to closures). We must make sure that the new disposition
1353 * is in place before it is called.
1357 #ifdef HAS_SIGPROCMASK
1362 register const char *s = MgPV_const(mg,len);
1364 if (strEQ(s,"__DIE__"))
1366 else if (strEQ(s,"__WARN__"))
1369 Perl_croak(aTHX_ "No such hook: %s", s);
1377 i = whichsig(s); /* ...no, a brick */
1379 if (ckWARN(WARN_SIGNAL))
1380 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1383 #ifdef HAS_SIGPROCMASK
1384 /* Avoid having the signal arrive at a bad time, if possible. */
1387 sigprocmask(SIG_BLOCK, &set, &save);
1389 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1390 SAVEFREESV(save_sv);
1391 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1394 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1395 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1397 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1398 PL_sig_ignoring[i] = 0;
1400 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1401 PL_sig_defaulting[i] = 0;
1403 SvREFCNT_dec(PL_psig_name[i]);
1404 to_dec = PL_psig_ptr[i];
1405 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1406 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1407 PL_psig_name[i] = newSVpvn(s, len);
1408 SvREADONLY_on(PL_psig_name[i]);
1410 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1412 (void)rsignal(i, PL_csighandlerp);
1413 #ifdef HAS_SIGPROCMASK
1418 *svp = SvREFCNT_inc(sv);
1420 SvREFCNT_dec(to_dec);
1423 s = SvPV_force(sv,len);
1424 if (strEQ(s,"IGNORE")) {
1426 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1427 PL_sig_ignoring[i] = 1;
1428 (void)rsignal(i, PL_csighandlerp);
1430 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1434 else if (strEQ(s,"DEFAULT") || !*s) {
1436 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1438 PL_sig_defaulting[i] = 1;
1439 (void)rsignal(i, PL_csighandlerp);
1442 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1447 * We should warn if HINT_STRICT_REFS, but without
1448 * access to a known hint bit in a known OP, we can't
1449 * tell whether HINT_STRICT_REFS is in force or not.
1451 if (!strchr(s,':') && !strchr(s,'\''))
1452 sv_insert(sv, 0, 0, "main::", 6);
1454 (void)rsignal(i, PL_csighandlerp);
1456 *svp = SvREFCNT_inc(sv);
1458 #ifdef HAS_SIGPROCMASK
1463 SvREFCNT_dec(to_dec);
1466 #endif /* !PERL_MICRO */
1469 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1471 PERL_UNUSED_ARG(sv);
1472 PERL_UNUSED_ARG(mg);
1473 PL_sub_generation++;
1478 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1480 PERL_UNUSED_ARG(sv);
1481 PERL_UNUSED_ARG(mg);
1482 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1483 PL_amagic_generation++;
1489 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1491 HV * const hv = (HV*)LvTARG(sv);
1493 PERL_UNUSED_ARG(mg);
1496 (void) hv_iterinit(hv);
1497 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1500 while (hv_iternext(hv))
1505 sv_setiv(sv, (IV)i);
1510 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1512 PERL_UNUSED_ARG(mg);
1514 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1519 /* caller is responsible for stack switching/cleanup */
1521 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1527 PUSHs(SvTIED_obj(sv, mg));
1530 if (mg->mg_len >= 0)
1531 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1532 else if (mg->mg_len == HEf_SVKEY)
1533 PUSHs((SV*)mg->mg_ptr);
1535 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1536 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1544 return call_method(meth, flags);
1548 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1554 PUSHSTACKi(PERLSI_MAGIC);
1556 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1557 sv_setsv(sv, *PL_stack_sp--);
1567 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1570 mg->mg_flags |= MGf_GSKIP;
1571 magic_methpack(sv,mg,"FETCH");
1576 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1580 PUSHSTACKi(PERLSI_MAGIC);
1581 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1588 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1590 return magic_methpack(sv,mg,"DELETE");
1595 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1602 PUSHSTACKi(PERLSI_MAGIC);
1603 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1604 sv = *PL_stack_sp--;
1605 retval = (U32) SvIV(sv)-1;
1614 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1619 PUSHSTACKi(PERLSI_MAGIC);
1621 XPUSHs(SvTIED_obj(sv, mg));
1623 call_method("CLEAR", G_SCALAR|G_DISCARD);
1631 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1634 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1638 PUSHSTACKi(PERLSI_MAGIC);
1641 PUSHs(SvTIED_obj(sv, mg));
1646 if (call_method(meth, G_SCALAR))
1647 sv_setsv(key, *PL_stack_sp--);
1656 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1658 return magic_methpack(sv,mg,"EXISTS");
1662 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1665 SV *retval = &PL_sv_undef;
1666 SV * const tied = SvTIED_obj((SV*)hv, mg);
1667 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1669 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1671 if (HvEITER_get(hv))
1672 /* we are in an iteration so the hash cannot be empty */
1674 /* no xhv_eiter so now use FIRSTKEY */
1675 key = sv_newmortal();
1676 magic_nextpack((SV*)hv, mg, key);
1677 HvEITER_set(hv, NULL); /* need to reset iterator */
1678 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1681 /* there is a SCALAR method that we can call */
1683 PUSHSTACKi(PERLSI_MAGIC);
1689 if (call_method("SCALAR", G_SCALAR))
1690 retval = *PL_stack_sp--;
1697 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1699 GV * const gv = PL_DBline;
1700 const I32 i = SvTRUE(sv);
1701 SV ** const svp = av_fetch(GvAV(gv),
1702 atoi(MgPV_nolen_const(mg)), FALSE);
1703 if (svp && SvIOKp(*svp)) {
1704 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1706 /* set or clear breakpoint in the relevant control op */
1708 o->op_flags |= OPf_SPECIAL;
1710 o->op_flags &= ~OPf_SPECIAL;
1717 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1719 const AV * const obj = (AV*)mg->mg_obj;
1721 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1729 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1731 AV * const obj = (AV*)mg->mg_obj;
1733 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1735 if (ckWARN(WARN_MISC))
1736 Perl_warner(aTHX_ packWARN(WARN_MISC),
1737 "Attempt to set length of freed array");
1743 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1745 PERL_UNUSED_ARG(sv);
1746 /* during global destruction, mg_obj may already have been freed */
1747 if (PL_in_clean_all)
1750 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1753 /* arylen scalar holds a pointer back to the array, but doesn't own a
1754 reference. Hence the we (the array) are about to go away with it
1755 still pointing at us. Clear its pointer, else it would be pointing
1756 at free memory. See the comment in sv_magic about reference loops,
1757 and why it can't own a reference to us. */
1764 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1766 SV* const lsv = LvTARG(sv);
1768 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1769 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1770 if (mg && mg->mg_len >= 0) {
1773 sv_pos_b2u(lsv, &i);
1774 sv_setiv(sv, i + PL_curcop->cop_arybase);
1783 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1785 SV* const lsv = LvTARG(sv);
1792 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1793 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1797 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1798 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1800 else if (!SvOK(sv)) {
1804 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1806 pos = SvIV(sv) - PL_curcop->cop_arybase;
1809 ulen = sv_len_utf8(lsv);
1819 else if (pos > (SSize_t)len)
1824 sv_pos_u2b(lsv, &p, 0);
1829 mg->mg_flags &= ~MGf_MINMATCH;
1835 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1837 PERL_UNUSED_ARG(mg);
1838 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1840 gv_efullname3(sv,((GV*)sv), "*");
1844 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1849 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1852 PERL_UNUSED_ARG(mg);
1856 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1861 GvGP(sv) = gp_ref(GvGP(gv));
1866 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1869 SV * const lsv = LvTARG(sv);
1870 const char * const tmps = SvPV_const(lsv,len);
1871 I32 offs = LvTARGOFF(sv);
1872 I32 rem = LvTARGLEN(sv);
1873 PERL_UNUSED_ARG(mg);
1876 sv_pos_u2b(lsv, &offs, &rem);
1877 if (offs > (I32)len)
1879 if (rem + offs > (I32)len)
1881 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1888 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1891 const char *tmps = SvPV_const(sv, len);
1892 SV * const lsv = LvTARG(sv);
1893 I32 lvoff = LvTARGOFF(sv);
1894 I32 lvlen = LvTARGLEN(sv);
1895 PERL_UNUSED_ARG(mg);
1898 sv_utf8_upgrade(lsv);
1899 sv_pos_u2b(lsv, &lvoff, &lvlen);
1900 sv_insert(lsv, lvoff, lvlen, tmps, len);
1901 LvTARGLEN(sv) = sv_len_utf8(sv);
1904 else if (lsv && SvUTF8(lsv)) {
1905 sv_pos_u2b(lsv, &lvoff, &lvlen);
1906 LvTARGLEN(sv) = len;
1907 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1908 sv_insert(lsv, lvoff, lvlen, tmps, len);
1912 sv_insert(lsv, lvoff, lvlen, tmps, len);
1913 LvTARGLEN(sv) = len;
1921 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1923 PERL_UNUSED_ARG(sv);
1924 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1929 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1931 PERL_UNUSED_ARG(sv);
1932 /* update taint status unless we're restoring at scope exit */
1933 if (PL_localizing != 2) {
1943 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1945 SV * const lsv = LvTARG(sv);
1946 PERL_UNUSED_ARG(mg);
1953 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1958 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1960 PERL_UNUSED_ARG(mg);
1961 do_vecset(sv); /* XXX slurp this routine */
1966 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1969 if (LvTARGLEN(sv)) {
1971 SV * const ahv = LvTARG(sv);
1972 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1977 AV* const av = (AV*)LvTARG(sv);
1978 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1979 targ = AvARRAY(av)[LvTARGOFF(sv)];
1981 if (targ && targ != &PL_sv_undef) {
1982 /* somebody else defined it for us */
1983 SvREFCNT_dec(LvTARG(sv));
1984 LvTARG(sv) = SvREFCNT_inc(targ);
1986 SvREFCNT_dec(mg->mg_obj);
1987 mg->mg_obj = Nullsv;
1988 mg->mg_flags &= ~MGf_REFCOUNTED;
1993 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1998 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2000 PERL_UNUSED_ARG(mg);
2004 sv_setsv(LvTARG(sv), sv);
2005 SvSETMAGIC(LvTARG(sv));
2011 Perl_vivify_defelem(pTHX_ SV *sv)
2016 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2019 SV * const ahv = LvTARG(sv);
2020 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2023 if (!value || value == &PL_sv_undef)
2024 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2027 AV* const av = (AV*)LvTARG(sv);
2028 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2029 LvTARG(sv) = Nullsv; /* array can't be extended */
2031 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2032 if (!svp || (value = *svp) == &PL_sv_undef)
2033 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2036 (void)SvREFCNT_inc(value);
2037 SvREFCNT_dec(LvTARG(sv));
2040 SvREFCNT_dec(mg->mg_obj);
2041 mg->mg_obj = Nullsv;
2042 mg->mg_flags &= ~MGf_REFCOUNTED;
2046 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2048 AV *const av = (AV*)mg->mg_obj;
2049 SV **svp = AvARRAY(av);
2050 PERL_UNUSED_ARG(sv);
2053 SV *const *const last = svp + AvFILLp(av);
2055 while (svp <= last) {
2057 SV *const referrer = *svp;
2058 if (SvWEAKREF(referrer)) {
2059 /* XXX Should we check that it hasn't changed? */
2060 SvRV_set(referrer, 0);
2062 SvWEAKREF_off(referrer);
2063 } else if (SvTYPE(referrer) == SVt_PVGV ||
2064 SvTYPE(referrer) == SVt_PVLV) {
2065 /* You lookin' at me? */
2066 assert(GvSTASH(referrer));
2067 assert(GvSTASH(referrer) == (HV*)sv);
2068 GvSTASH(referrer) = 0;
2071 "panic: magic_killbackrefs (flags=%"UVxf")",
2080 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2085 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2093 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2095 PERL_UNUSED_ARG(mg);
2096 sv_unmagic(sv, PERL_MAGIC_bm);
2102 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2104 PERL_UNUSED_ARG(mg);
2105 sv_unmagic(sv, PERL_MAGIC_fm);
2111 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2113 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2115 if (uf && uf->uf_set)
2116 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2121 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2123 PERL_UNUSED_ARG(mg);
2124 sv_unmagic(sv, PERL_MAGIC_qr);
2129 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2131 regexp * const re = (regexp *)mg->mg_obj;
2132 PERL_UNUSED_ARG(sv);
2138 #ifdef USE_LOCALE_COLLATE
2140 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2143 * RenE<eacute> Descartes said "I think not."
2144 * and vanished with a faint plop.
2146 PERL_UNUSED_ARG(sv);
2148 Safefree(mg->mg_ptr);
2154 #endif /* USE_LOCALE_COLLATE */
2156 /* Just clear the UTF-8 cache data. */
2158 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2160 PERL_UNUSED_ARG(sv);
2161 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2163 mg->mg_len = -1; /* The mg_len holds the len cache. */
2168 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2170 register const char *s;
2173 switch (*mg->mg_ptr) {
2174 case '\001': /* ^A */
2175 sv_setsv(PL_bodytarget, sv);
2177 case '\003': /* ^C */
2178 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2181 case '\004': /* ^D */
2183 s = SvPV_nolen_const(sv);
2184 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2185 DEBUG_x(dump_all());
2187 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2190 case '\005': /* ^E */
2191 if (*(mg->mg_ptr+1) == '\0') {
2192 #ifdef MACOS_TRADITIONAL
2193 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2196 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2199 SetLastError( SvIV(sv) );
2202 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2204 /* will anyone ever use this? */
2205 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2211 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2213 SvREFCNT_dec(PL_encoding);
2214 if (SvOK(sv) || SvGMAGICAL(sv)) {
2215 PL_encoding = newSVsv(sv);
2218 PL_encoding = Nullsv;
2222 case '\006': /* ^F */
2223 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2225 case '\010': /* ^H */
2226 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2228 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2229 Safefree(PL_inplace);
2230 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2232 case '\017': /* ^O */
2233 if (*(mg->mg_ptr+1) == '\0') {
2234 Safefree(PL_osname);
2237 TAINT_PROPER("assigning to $^O");
2238 PL_osname = savesvpv(sv);
2241 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2242 if (!PL_compiling.cop_io)
2243 PL_compiling.cop_io = newSVsv(sv);
2245 sv_setsv(PL_compiling.cop_io,sv);
2248 case '\020': /* ^P */
2249 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2250 if (PL_perldb && !PL_DBsingle)
2253 case '\024': /* ^T */
2255 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2257 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2260 case '\027': /* ^W & $^WARNING_BITS */
2261 if (*(mg->mg_ptr+1) == '\0') {
2262 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2263 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2264 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2265 | (i ? G_WARN_ON : G_WARN_OFF) ;
2268 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2269 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2270 if (!SvPOK(sv) && PL_localizing) {
2271 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2272 PL_compiling.cop_warnings = pWARN_NONE;
2277 int accumulate = 0 ;
2278 int any_fatals = 0 ;
2279 const char * const ptr = SvPV_const(sv, len) ;
2280 for (i = 0 ; i < len ; ++i) {
2281 accumulate |= ptr[i] ;
2282 any_fatals |= (ptr[i] & 0xAA) ;
2285 PL_compiling.cop_warnings = pWARN_NONE;
2286 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2287 PL_compiling.cop_warnings = pWARN_ALL;
2288 PL_dowarn |= G_WARN_ONCE ;
2291 if (specialWARN(PL_compiling.cop_warnings))
2292 PL_compiling.cop_warnings = newSVsv(sv) ;
2294 sv_setsv(PL_compiling.cop_warnings, sv);
2295 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2296 PL_dowarn |= G_WARN_ONCE ;
2304 if (PL_localizing) {
2305 if (PL_localizing == 1)
2306 SAVESPTR(PL_last_in_gv);
2308 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2309 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2312 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2313 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2314 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2317 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2318 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2319 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2322 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2325 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2326 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2327 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2330 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2334 IO * const io = GvIOp(PL_defoutgv);
2337 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2338 IoFLAGS(io) &= ~IOf_FLUSH;
2340 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2341 PerlIO *ofp = IoOFP(io);
2343 (void)PerlIO_flush(ofp);
2344 IoFLAGS(io) |= IOf_FLUSH;
2350 SvREFCNT_dec(PL_rs);
2351 PL_rs = newSVsv(sv);
2355 SvREFCNT_dec(PL_ors_sv);
2356 if (SvOK(sv) || SvGMAGICAL(sv)) {
2357 PL_ors_sv = newSVsv(sv);
2365 SvREFCNT_dec(PL_ofs_sv);
2366 if (SvOK(sv) || SvGMAGICAL(sv)) {
2367 PL_ofs_sv = newSVsv(sv);
2374 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2377 #ifdef COMPLEX_STATUS
2378 if (PL_localizing == 2) {
2379 PL_statusvalue = LvTARGOFF(sv);
2380 PL_statusvalue_vms = LvTARGLEN(sv);
2384 #ifdef VMSISH_STATUS
2386 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2389 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2394 # define PERL_VMS_BANG vaxc$errno
2396 # define PERL_VMS_BANG 0
2398 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2399 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2403 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2404 if (PL_delaymagic) {
2405 PL_delaymagic |= DM_RUID;
2406 break; /* don't do magic till later */
2409 (void)setruid((Uid_t)PL_uid);
2412 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2414 #ifdef HAS_SETRESUID
2415 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2417 if (PL_uid == PL_euid) { /* special case $< = $> */
2419 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2420 if (PL_uid != 0 && PerlProc_getuid() == 0)
2421 (void)PerlProc_setuid(0);
2423 (void)PerlProc_setuid(PL_uid);
2425 PL_uid = PerlProc_getuid();
2426 Perl_croak(aTHX_ "setruid() not implemented");
2431 PL_uid = PerlProc_getuid();
2432 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2435 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2436 if (PL_delaymagic) {
2437 PL_delaymagic |= DM_EUID;
2438 break; /* don't do magic till later */
2441 (void)seteuid((Uid_t)PL_euid);
2444 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2446 #ifdef HAS_SETRESUID
2447 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2449 if (PL_euid == PL_uid) /* special case $> = $< */
2450 PerlProc_setuid(PL_euid);
2452 PL_euid = PerlProc_geteuid();
2453 Perl_croak(aTHX_ "seteuid() not implemented");
2458 PL_euid = PerlProc_geteuid();
2459 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2462 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2463 if (PL_delaymagic) {
2464 PL_delaymagic |= DM_RGID;
2465 break; /* don't do magic till later */
2468 (void)setrgid((Gid_t)PL_gid);
2471 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2473 #ifdef HAS_SETRESGID
2474 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2476 if (PL_gid == PL_egid) /* special case $( = $) */
2477 (void)PerlProc_setgid(PL_gid);
2479 PL_gid = PerlProc_getgid();
2480 Perl_croak(aTHX_ "setrgid() not implemented");
2485 PL_gid = PerlProc_getgid();
2486 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2489 #ifdef HAS_SETGROUPS
2491 const char *p = SvPV_const(sv, len);
2492 Groups_t gary[NGROUPS];
2497 for (i = 0; i < NGROUPS; ++i) {
2498 while (*p && !isSPACE(*p))
2507 (void)setgroups(i, gary);
2509 #else /* HAS_SETGROUPS */
2510 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2511 #endif /* HAS_SETGROUPS */
2512 if (PL_delaymagic) {
2513 PL_delaymagic |= DM_EGID;
2514 break; /* don't do magic till later */
2517 (void)setegid((Gid_t)PL_egid);
2520 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2522 #ifdef HAS_SETRESGID
2523 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2525 if (PL_egid == PL_gid) /* special case $) = $( */
2526 (void)PerlProc_setgid(PL_egid);
2528 PL_egid = PerlProc_getegid();
2529 Perl_croak(aTHX_ "setegid() not implemented");
2534 PL_egid = PerlProc_getegid();
2535 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2538 PL_chopset = SvPV_force(sv,len);
2540 #ifndef MACOS_TRADITIONAL
2542 LOCK_DOLLARZERO_MUTEX;
2543 #ifdef HAS_SETPROCTITLE
2544 /* The BSDs don't show the argv[] in ps(1) output, they
2545 * show a string from the process struct and provide
2546 * the setproctitle() routine to manipulate that. */
2548 s = SvPV_const(sv, len);
2549 # if __FreeBSD_version > 410001
2550 /* The leading "-" removes the "perl: " prefix,
2551 * but not the "(perl) suffix from the ps(1)
2552 * output, because that's what ps(1) shows if the
2553 * argv[] is modified. */
2554 setproctitle("-%s", s);
2555 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2556 /* This doesn't really work if you assume that
2557 * $0 = 'foobar'; will wipe out 'perl' from the $0
2558 * because in ps(1) output the result will be like
2559 * sprintf("perl: %s (perl)", s)
2560 * I guess this is a security feature:
2561 * one (a user process) cannot get rid of the original name.
2563 setproctitle("%s", s);
2567 #if defined(__hpux) && defined(PSTAT_SETCMD)
2570 s = SvPV_const(sv, len);
2571 un.pst_command = (char *)s;
2572 pstat(PSTAT_SETCMD, un, len, 0, 0);
2575 /* PL_origalen is set in perl_parse(). */
2576 s = SvPV_force(sv,len);
2577 if (len >= (STRLEN)PL_origalen-1) {
2578 /* Longer than original, will be truncated. We assume that
2579 * PL_origalen bytes are available. */
2580 Copy(s, PL_origargv[0], PL_origalen-1, char);
2583 /* Shorter than original, will be padded. */
2584 Copy(s, PL_origargv[0], len, char);
2585 PL_origargv[0][len] = 0;
2586 memset(PL_origargv[0] + len + 1,
2587 /* Is the space counterintuitive? Yes.
2588 * (You were expecting \0?)
2589 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2592 PL_origalen - len - 1);
2594 PL_origargv[0][PL_origalen-1] = 0;
2595 for (i = 1; i < PL_origargc; i++)
2597 UNLOCK_DOLLARZERO_MUTEX;
2605 Perl_whichsig(pTHX_ const char *sig)
2607 register char* const* sigv;
2609 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2610 if (strEQ(sig,*sigv))
2611 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2613 if (strEQ(sig,"CHLD"))
2617 if (strEQ(sig,"CLD"))
2624 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2625 Perl_sighandler(int sig, ...)
2627 Perl_sighandler(int sig)
2630 #ifdef PERL_GET_SIG_CONTEXT
2631 dTHXa(PERL_GET_SIG_CONTEXT);
2638 SV * const tSv = PL_Sv;
2642 XPV * const tXpv = PL_Xpv;
2644 if (PL_savestack_ix + 15 <= PL_savestack_max)
2646 if (PL_markstack_ptr < PL_markstack_max - 2)
2648 if (PL_scopestack_ix < PL_scopestack_max - 3)
2651 if (!PL_psig_ptr[sig]) {
2652 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2657 /* Max number of items pushed there is 3*n or 4. We cannot fix
2658 infinity, so we fix 4 (in fact 5): */
2660 PL_savestack_ix += 5; /* Protect save in progress. */
2661 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2664 PL_markstack_ptr++; /* Protect mark. */
2666 PL_scopestack_ix += 1;
2667 /* sv_2cv is too complicated, try a simpler variant first: */
2668 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2669 || SvTYPE(cv) != SVt_PVCV) {
2671 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2674 if (!cv || !CvROOT(cv)) {
2675 if (ckWARN(WARN_SIGNAL))
2676 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2677 PL_sig_name[sig], (gv ? GvENAME(gv)
2684 if(PL_psig_name[sig]) {
2685 sv = SvREFCNT_inc(PL_psig_name[sig]);
2687 #if !defined(PERL_IMPLICIT_CONTEXT)
2691 sv = sv_newmortal();
2692 sv_setpv(sv,PL_sig_name[sig]);
2695 PUSHSTACKi(PERLSI_SIGNAL);
2698 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2700 struct sigaction oact;
2702 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2706 va_start(args, sig);
2707 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2710 SV *rv = newRV_noinc((SV*)sih);
2711 /* The siginfo fields signo, code, errno, pid, uid,
2712 * addr, status, and band are defined by POSIX/SUSv3. */
2713 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2714 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2715 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2716 #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. */
2717 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2718 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2719 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2720 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2721 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2725 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2732 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2735 if (SvTRUE(ERRSV)) {
2737 #ifdef HAS_SIGPROCMASK
2738 /* Handler "died", for example to get out of a restart-able read().
2739 * Before we re-do that on its behalf re-enable the signal which was
2740 * blocked by the system when we entered.
2744 sigaddset(&set,sig);
2745 sigprocmask(SIG_UNBLOCK, &set, NULL);
2747 /* Not clear if this will work */
2748 (void)rsignal(sig, SIG_IGN);
2749 (void)rsignal(sig, PL_csighandlerp);
2751 #endif /* !PERL_MICRO */
2756 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2760 PL_scopestack_ix -= 1;
2763 PL_op = myop; /* Apparently not needed... */
2765 PL_Sv = tSv; /* Restore global temporaries. */
2772 S_restore_magic(pTHX_ const void *p)
2774 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2775 SV* const sv = mgs->mgs_sv;
2780 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2782 #ifdef PERL_OLD_COPY_ON_WRITE
2783 /* While magic was saved (and off) sv_setsv may well have seen
2784 this SV as a prime candidate for COW. */
2786 sv_force_normal(sv);
2790 SvFLAGS(sv) |= mgs->mgs_flags;
2794 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2797 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2799 /* If we're still on top of the stack, pop us off. (That condition
2800 * will be satisfied if restore_magic was called explicitly, but *not*
2801 * if it's being called via leave_scope.)
2802 * The reason for doing this is that otherwise, things like sv_2cv()
2803 * may leave alloc gunk on the savestack, and some code
2804 * (e.g. sighandler) doesn't expect that...
2806 if (PL_savestack_ix == mgs->mgs_ss_ix)
2808 I32 popval = SSPOPINT;
2809 assert(popval == SAVEt_DESTRUCTOR_X);
2810 PL_savestack_ix -= 2;
2812 assert(popval == SAVEt_ALLOC);
2814 PL_savestack_ix -= popval;
2820 S_unwind_handler_stack(pTHX_ const void *p)
2823 const U32 flags = *(const U32*)p;
2826 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2827 /* cxstack_ix-- Not needed, die already unwound it. */
2828 #if !defined(PERL_IMPLICIT_CONTEXT)
2830 SvREFCNT_dec(PL_sig_sv);
2836 * c-indentation-style: bsd
2838 * indent-tabs-mode: t
2841 * ex: set ts=8 sts=4 sw=4 noet: