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. */
88 sv_force_normal_flags(sv, 0);
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);
373 const char type = mg->mg_type;
376 (type == PERL_MAGIC_tied)
378 : (type == PERL_MAGIC_regdata && mg->mg_obj)
381 toLOWER(type), key, klen);
390 =for apidoc mg_localize
392 Copy some of the magic from an existing SV to new localized version of
393 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
394 doesn't (eg taint, pos).
400 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
403 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
404 const MGVTBL* const vtbl = mg->mg_virtual;
405 switch (mg->mg_type) {
406 /* value magic types: don't copy */
409 case PERL_MAGIC_regex_global:
410 case PERL_MAGIC_nkeys:
411 #ifdef USE_LOCALE_COLLATE
412 case PERL_MAGIC_collxfrm:
415 case PERL_MAGIC_taint:
417 case PERL_MAGIC_vstring:
418 case PERL_MAGIC_utf8:
419 case PERL_MAGIC_substr:
420 case PERL_MAGIC_defelem:
421 case PERL_MAGIC_arylen:
423 case PERL_MAGIC_backref:
424 case PERL_MAGIC_arylen_p:
425 case PERL_MAGIC_rhash:
426 case PERL_MAGIC_symtab:
430 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
431 /* XXX calling the copy method is probably not correct. DAPM */
432 (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
433 mg->mg_ptr, mg->mg_len);
436 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
437 mg->mg_ptr, mg->mg_len);
439 /* container types should remain read-only across localization */
440 SvFLAGS(nsv) |= SvREADONLY(sv);
443 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
444 SvFLAGS(nsv) |= SvMAGICAL(sv);
454 Free any magic storage used by the SV. See C<sv_magic>.
460 Perl_mg_free(pTHX_ SV *sv)
464 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
465 const MGVTBL* const vtbl = mg->mg_virtual;
466 moremagic = mg->mg_moremagic;
467 if (vtbl && vtbl->svt_free)
468 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
469 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
470 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
471 Safefree(mg->mg_ptr);
472 else if (mg->mg_len == HEf_SVKEY)
473 SvREFCNT_dec((SV*)mg->mg_ptr);
475 if (mg->mg_flags & MGf_REFCOUNTED)
476 SvREFCNT_dec(mg->mg_obj);
479 SvMAGIC_set(sv, NULL);
486 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
488 register const REGEXP *rx;
491 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
492 if (mg->mg_obj) /* @+ */
495 return rx->lastparen;
502 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
506 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
507 register const I32 paren = mg->mg_len;
512 if (paren <= (I32)rx->nparens &&
513 (s = rx->startp[paren]) != -1 &&
514 (t = rx->endp[paren]) != -1)
517 if (mg->mg_obj) /* @+ */
522 if (i > 0 && RX_MATCH_UTF8(rx)) {
523 const char * const b = rx->subbeg;
525 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
535 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
537 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
538 Perl_croak(aTHX_ PL_no_modify);
539 NORETURN_FUNCTION_END;
543 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
547 register const REGEXP *rx;
550 switch (*mg->mg_ptr) {
551 case '1': case '2': case '3': case '4':
552 case '5': case '6': case '7': case '8': case '9': case '&':
553 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
555 paren = atoi(mg->mg_ptr); /* $& is in [0] */
557 if (paren <= (I32)rx->nparens &&
558 (s1 = rx->startp[paren]) != -1 &&
559 (t1 = rx->endp[paren]) != -1)
563 if (i > 0 && RX_MATCH_UTF8(rx)) {
564 const char * const s = rx->subbeg + s1;
569 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
573 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
577 if (ckWARN(WARN_UNINITIALIZED))
582 if (ckWARN(WARN_UNINITIALIZED))
587 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
588 paren = rx->lastparen;
593 case '\016': /* ^N */
594 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
595 paren = rx->lastcloseparen;
601 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
602 if (rx->startp[0] != -1) {
613 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
614 if (rx->endp[0] != -1) {
615 i = rx->sublen - rx->endp[0];
626 if (!SvPOK(sv) && SvNIOK(sv)) {
634 #define SvRTRIM(sv) STMT_START { \
635 STRLEN len = SvCUR(sv); \
636 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
638 SvCUR_set(sv, len); \
642 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
646 register char *s = NULL;
649 const char * const remaining = mg->mg_ptr + 1;
650 const char nextchar = *remaining;
652 switch (*mg->mg_ptr) {
653 case '\001': /* ^A */
654 sv_setsv(sv, PL_bodytarget);
656 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
657 if (nextchar == '\0') {
658 sv_setiv(sv, (IV)PL_minus_c);
660 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
661 sv_setiv(sv, (IV)STATUS_NATIVE);
665 case '\004': /* ^D */
666 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
668 case '\005': /* ^E */
669 if (nextchar == '\0') {
670 #ifdef MACOS_TRADITIONAL
674 sv_setnv(sv,(double)gMacPerl_OSErr);
675 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
680 # include <descrip.h>
681 # include <starlet.h>
683 $DESCRIPTOR(msgdsc,msg);
684 sv_setnv(sv,(NV) vaxc$errno);
685 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
686 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
692 if (!(_emx_env & 0x200)) { /* Under DOS */
693 sv_setnv(sv, (NV)errno);
694 sv_setpv(sv, errno ? Strerror(errno) : "");
696 if (errno != errno_isOS2) {
697 const int tmp = _syserrno();
698 if (tmp) /* 2nd call to _syserrno() makes it 0 */
701 sv_setnv(sv, (NV)Perl_rc);
702 sv_setpv(sv, os2error(Perl_rc));
707 DWORD dwErr = GetLastError();
708 sv_setnv(sv, (NV)dwErr);
710 PerlProc_GetOSError(sv, dwErr);
713 sv_setpvn(sv, "", 0);
718 const int saveerrno = errno;
719 sv_setnv(sv, (NV)errno);
720 sv_setpv(sv, errno ? Strerror(errno) : "");
728 SvNOK_on(sv); /* what a wonderful hack! */
730 else if (strEQ(remaining, "NCODING"))
731 sv_setsv(sv, PL_encoding);
733 case '\006': /* ^F */
734 sv_setiv(sv, (IV)PL_maxsysfd);
736 case '\010': /* ^H */
737 sv_setiv(sv, (IV)PL_hints);
739 case '\011': /* ^I */ /* NOT \t in EBCDIC */
741 sv_setpv(sv, PL_inplace);
743 sv_setsv(sv, &PL_sv_undef);
745 case '\017': /* ^O & ^OPEN */
746 if (nextchar == '\0') {
747 sv_setpv(sv, PL_osname);
750 else if (strEQ(remaining, "PEN")) {
751 if (!PL_compiling.cop_io)
752 sv_setsv(sv, &PL_sv_undef);
754 sv_setsv(sv, PL_compiling.cop_io);
758 case '\020': /* ^P */
759 sv_setiv(sv, (IV)PL_perldb);
761 case '\023': /* ^S */
762 if (nextchar == '\0') {
763 if (PL_lex_state != LEX_NOTPARSING)
766 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
771 case '\024': /* ^T */
772 if (nextchar == '\0') {
774 sv_setnv(sv, PL_basetime);
776 sv_setiv(sv, (IV)PL_basetime);
779 else if (strEQ(remaining, "AINT"))
780 sv_setiv(sv, PL_tainting
781 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
784 case '\025': /* $^UNICODE, $^UTF8LOCALE */
785 if (strEQ(remaining, "NICODE"))
786 sv_setuv(sv, (UV) PL_unicode);
787 else if (strEQ(remaining, "TF8LOCALE"))
788 sv_setuv(sv, (UV) PL_utf8locale);
790 case '\027': /* ^W & $^WARNING_BITS */
791 if (nextchar == '\0')
792 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
793 else if (strEQ(remaining, "ARNING_BITS")) {
794 if (PL_compiling.cop_warnings == pWARN_NONE) {
795 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
797 else if (PL_compiling.cop_warnings == pWARN_STD) {
800 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
804 else if (PL_compiling.cop_warnings == pWARN_ALL) {
805 /* Get the bit mask for $warnings::Bits{all}, because
806 * it could have been extended by warnings::register */
808 HV * const bits=get_hv("warnings::Bits", FALSE);
809 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
810 sv_setsv(sv, *bits_all);
813 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
817 sv_setsv(sv, PL_compiling.cop_warnings);
822 case '1': case '2': case '3': case '4':
823 case '5': case '6': case '7': case '8': case '9': case '&':
824 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
828 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
829 * XXX Does the new way break anything?
831 paren = atoi(mg->mg_ptr); /* $& is in [0] */
833 if (paren <= (I32)rx->nparens &&
834 (s1 = rx->startp[paren]) != -1 &&
835 (t1 = rx->endp[paren]) != -1)
844 int oldtainted = PL_tainted;
847 PL_tainted = oldtainted;
848 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
853 if (RX_MATCH_TAINTED(rx)) {
854 MAGIC* const mg = SvMAGIC(sv);
857 SvMAGIC_set(sv, mg->mg_moremagic);
859 if ((mgt = SvMAGIC(sv))) {
860 mg->mg_moremagic = mgt;
870 sv_setsv(sv,&PL_sv_undef);
873 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
874 paren = rx->lastparen;
878 sv_setsv(sv,&PL_sv_undef);
880 case '\016': /* ^N */
881 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
882 paren = rx->lastcloseparen;
886 sv_setsv(sv,&PL_sv_undef);
889 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
890 if ((s = rx->subbeg) && rx->startp[0] != -1) {
895 sv_setsv(sv,&PL_sv_undef);
898 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
899 if (rx->subbeg && rx->endp[0] != -1) {
900 s = rx->subbeg + rx->endp[0];
901 i = rx->sublen - rx->endp[0];
905 sv_setsv(sv,&PL_sv_undef);
908 if (GvIO(PL_last_in_gv)) {
909 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
914 sv_setiv(sv, (IV)STATUS_CURRENT);
915 #ifdef COMPLEX_STATUS
916 LvTARGOFF(sv) = PL_statusvalue;
917 LvTARGLEN(sv) = PL_statusvalue_vms;
922 if (GvIOp(PL_defoutgv))
923 s = IoTOP_NAME(GvIOp(PL_defoutgv));
927 sv_setpv(sv,GvENAME(PL_defoutgv));
932 if (GvIOp(PL_defoutgv))
933 s = IoFMT_NAME(GvIOp(PL_defoutgv));
935 s = GvENAME(PL_defoutgv);
939 if (GvIOp(PL_defoutgv))
940 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
943 if (GvIOp(PL_defoutgv))
944 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
947 if (GvIOp(PL_defoutgv))
948 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
955 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
958 if (GvIOp(PL_defoutgv))
959 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
965 sv_copypv(sv, PL_ors_sv);
969 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
970 sv_setpv(sv, errno ? Strerror(errno) : "");
973 const int saveerrno = errno;
974 sv_setnv(sv, (NV)errno);
976 if (errno == errno_isOS2 || errno == errno_isOS2_set)
977 sv_setpv(sv, os2error(Perl_rc));
980 sv_setpv(sv, errno ? Strerror(errno) : "");
985 SvNOK_on(sv); /* what a wonderful hack! */
988 sv_setiv(sv, (IV)PL_uid);
991 sv_setiv(sv, (IV)PL_euid);
994 sv_setiv(sv, (IV)PL_gid);
996 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
1000 sv_setiv(sv, (IV)PL_egid);
1001 #ifdef HAS_GETGROUPS
1002 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
1005 #ifdef HAS_GETGROUPS
1007 Groups_t gary[NGROUPS];
1008 I32 j = getgroups(NGROUPS,gary);
1010 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
1013 (void)SvIOK_on(sv); /* what a wonderful hack! */
1015 #ifndef MACOS_TRADITIONAL
1024 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1026 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1028 if (uf && uf->uf_val)
1029 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1034 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1041 s = SvPV_const(sv,len);
1042 ptr = MgPV_const(mg,klen);
1045 #ifdef DYNAMIC_ENV_FETCH
1046 /* We just undefd an environment var. Is a replacement */
1047 /* waiting in the wings? */
1050 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1051 s = SvPV_const(*valp, len);
1055 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1056 /* And you'll never guess what the dog had */
1057 /* in its mouth... */
1059 MgTAINTEDDIR_off(mg);
1061 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1062 char pathbuf[256], eltbuf[256], *cp, *elt;
1066 strncpy(eltbuf, s, 255);
1069 do { /* DCL$PATH may be a search list */
1070 while (1) { /* as may dev portion of any element */
1071 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1072 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1073 cando_by_name(S_IWUSR,0,elt) ) {
1074 MgTAINTEDDIR_on(mg);
1078 if ((cp = strchr(elt, ':')) != Nullch)
1080 if (my_trnlnm(elt, eltbuf, j++))
1086 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1089 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1090 const char * const strend = s + len;
1092 while (s < strend) {
1096 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1097 s, strend, ':', &i);
1099 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1101 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1102 MgTAINTEDDIR_on(mg);
1108 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1114 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1116 PERL_UNUSED_ARG(sv);
1117 my_setenv(MgPV_nolen_const(mg),Nullch);
1122 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1124 #if defined(VMS) || defined(EPOC)
1125 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1127 if (PL_localizing) {
1129 magic_clear_all_env(sv,mg);
1130 hv_iterinit((HV*)sv);
1131 while ((entry = hv_iternext((HV*)sv))) {
1133 my_setenv(hv_iterkey(entry, &keylen),
1134 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1142 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1146 #if defined(VMS) || defined(EPOC)
1147 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1149 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1152 # ifdef USE_ENVIRON_ARRAY
1153 # if defined(USE_ITHREADS)
1154 /* only the parent thread can clobber the process environment */
1155 if (PL_curinterp == aTHX)
1158 # ifndef PERL_USE_SAFE_PUTENV
1159 if (!PL_use_safe_putenv) {
1162 if (environ == PL_origenviron)
1163 environ = (char**)safesysmalloc(sizeof(char*));
1165 for (i = 0; environ[i]; i++)
1166 safesysfree(environ[i]);
1168 # endif /* PERL_USE_SAFE_PUTENV */
1170 environ[0] = Nullch;
1172 # endif /* USE_ENVIRON_ARRAY */
1173 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1174 #endif /* VMS || EPOC */
1175 #endif /* !PERL_MICRO */
1176 PERL_UNUSED_ARG(sv);
1177 PERL_UNUSED_ARG(mg);
1182 #ifdef HAS_SIGPROCMASK
1184 restore_sigmask(pTHX_ SV *save_sv)
1186 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1187 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1191 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1193 /* Are we fetching a signal entry? */
1194 const I32 i = whichsig(MgPV_nolen_const(mg));
1197 sv_setsv(sv,PL_psig_ptr[i]);
1199 Sighandler_t sigstate;
1200 sigstate = rsignal_state(i);
1201 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1202 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1204 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1205 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1207 /* cache state so we don't fetch it again */
1208 if(sigstate == (Sighandler_t) SIG_IGN)
1209 sv_setpv(sv,"IGNORE");
1211 sv_setsv(sv,&PL_sv_undef);
1212 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1219 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1221 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1222 * refactoring might be in order.
1225 register const char * const s = MgPV_nolen_const(mg);
1226 PERL_UNUSED_ARG(sv);
1229 if (strEQ(s,"__DIE__"))
1231 else if (strEQ(s,"__WARN__"))
1234 Perl_croak(aTHX_ "No such hook: %s", s);
1236 SV * const to_dec = *svp;
1238 SvREFCNT_dec(to_dec);
1242 /* Are we clearing a signal entry? */
1243 const I32 i = whichsig(s);
1245 #ifdef HAS_SIGPROCMASK
1248 /* Avoid having the signal arrive at a bad time, if possible. */
1251 sigprocmask(SIG_BLOCK, &set, &save);
1253 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1254 SAVEFREESV(save_sv);
1255 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1258 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1259 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1261 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1262 PL_sig_defaulting[i] = 1;
1263 (void)rsignal(i, PL_csighandlerp);
1265 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1267 if(PL_psig_name[i]) {
1268 SvREFCNT_dec(PL_psig_name[i]);
1271 if(PL_psig_ptr[i]) {
1272 SV *to_dec=PL_psig_ptr[i];
1275 SvREFCNT_dec(to_dec);
1285 S_raise_signal(pTHX_ int sig)
1287 /* Set a flag to say this signal is pending */
1288 PL_psig_pend[sig]++;
1289 /* And one to say _a_ signal is pending */
1294 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1295 Perl_csighandler(int sig, ...)
1297 Perl_csighandler(int sig)
1300 #ifdef PERL_GET_SIG_CONTEXT
1301 dTHXa(PERL_GET_SIG_CONTEXT);
1305 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1306 (void) rsignal(sig, PL_csighandlerp);
1307 if (PL_sig_ignoring[sig]) return;
1309 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1310 if (PL_sig_defaulting[sig])
1311 #ifdef KILL_BY_SIGPRC
1312 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1317 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1318 /* Call the perl level handler now--
1319 * with risk we may be in malloc() etc. */
1320 (*PL_sighandlerp)(sig);
1322 S_raise_signal(aTHX_ sig);
1325 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1327 Perl_csighandler_init(void)
1330 if (PL_sig_handlers_initted) return;
1332 for (sig = 1; sig < SIG_SIZE; sig++) {
1333 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1335 PL_sig_defaulting[sig] = 1;
1336 (void) rsignal(sig, PL_csighandlerp);
1338 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1339 PL_sig_ignoring[sig] = 0;
1342 PL_sig_handlers_initted = 1;
1347 Perl_despatch_signals(pTHX)
1351 for (sig = 1; sig < SIG_SIZE; sig++) {
1352 if (PL_psig_pend[sig]) {
1353 PERL_BLOCKSIG_ADD(set, sig);
1354 PL_psig_pend[sig] = 0;
1355 PERL_BLOCKSIG_BLOCK(set);
1356 (*PL_sighandlerp)(sig);
1357 PERL_BLOCKSIG_UNBLOCK(set);
1363 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1368 /* Need to be careful with SvREFCNT_dec(), because that can have side
1369 * effects (due to closures). We must make sure that the new disposition
1370 * is in place before it is called.
1374 #ifdef HAS_SIGPROCMASK
1379 register const char *s = MgPV_const(mg,len);
1381 if (strEQ(s,"__DIE__"))
1383 else if (strEQ(s,"__WARN__"))
1386 Perl_croak(aTHX_ "No such hook: %s", s);
1394 i = whichsig(s); /* ...no, a brick */
1396 if (ckWARN(WARN_SIGNAL))
1397 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1400 #ifdef HAS_SIGPROCMASK
1401 /* Avoid having the signal arrive at a bad time, if possible. */
1404 sigprocmask(SIG_BLOCK, &set, &save);
1406 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1407 SAVEFREESV(save_sv);
1408 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1411 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1412 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1414 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1415 PL_sig_ignoring[i] = 0;
1417 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1418 PL_sig_defaulting[i] = 0;
1420 SvREFCNT_dec(PL_psig_name[i]);
1421 to_dec = PL_psig_ptr[i];
1422 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1423 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1424 PL_psig_name[i] = newSVpvn(s, len);
1425 SvREADONLY_on(PL_psig_name[i]);
1427 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1429 (void)rsignal(i, PL_csighandlerp);
1430 #ifdef HAS_SIGPROCMASK
1435 *svp = SvREFCNT_inc(sv);
1437 SvREFCNT_dec(to_dec);
1440 s = SvPV_force(sv,len);
1441 if (strEQ(s,"IGNORE")) {
1443 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1444 PL_sig_ignoring[i] = 1;
1445 (void)rsignal(i, PL_csighandlerp);
1447 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1451 else if (strEQ(s,"DEFAULT") || !*s) {
1453 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1455 PL_sig_defaulting[i] = 1;
1456 (void)rsignal(i, PL_csighandlerp);
1459 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1464 * We should warn if HINT_STRICT_REFS, but without
1465 * access to a known hint bit in a known OP, we can't
1466 * tell whether HINT_STRICT_REFS is in force or not.
1468 if (!strchr(s,':') && !strchr(s,'\''))
1469 sv_insert(sv, 0, 0, "main::", 6);
1471 (void)rsignal(i, PL_csighandlerp);
1473 *svp = SvREFCNT_inc(sv);
1475 #ifdef HAS_SIGPROCMASK
1480 SvREFCNT_dec(to_dec);
1483 #endif /* !PERL_MICRO */
1486 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1488 PERL_UNUSED_ARG(sv);
1489 PERL_UNUSED_ARG(mg);
1490 PL_sub_generation++;
1495 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1497 PERL_UNUSED_ARG(sv);
1498 PERL_UNUSED_ARG(mg);
1499 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1500 PL_amagic_generation++;
1506 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1508 HV * const hv = (HV*)LvTARG(sv);
1510 PERL_UNUSED_ARG(mg);
1513 (void) hv_iterinit(hv);
1514 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1517 while (hv_iternext(hv))
1522 sv_setiv(sv, (IV)i);
1527 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1529 PERL_UNUSED_ARG(mg);
1531 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1536 /* caller is responsible for stack switching/cleanup */
1538 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1544 PUSHs(SvTIED_obj(sv, mg));
1547 if (mg->mg_len >= 0)
1548 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1549 else if (mg->mg_len == HEf_SVKEY)
1550 PUSHs((SV*)mg->mg_ptr);
1552 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1553 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1561 return call_method(meth, flags);
1565 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1571 PUSHSTACKi(PERLSI_MAGIC);
1573 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1574 sv_setsv(sv, *PL_stack_sp--);
1584 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1587 mg->mg_flags |= MGf_GSKIP;
1588 magic_methpack(sv,mg,"FETCH");
1593 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1597 PUSHSTACKi(PERLSI_MAGIC);
1598 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1605 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1607 return magic_methpack(sv,mg,"DELETE");
1612 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1619 PUSHSTACKi(PERLSI_MAGIC);
1620 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1621 sv = *PL_stack_sp--;
1622 retval = (U32) SvIV(sv)-1;
1631 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1636 PUSHSTACKi(PERLSI_MAGIC);
1638 XPUSHs(SvTIED_obj(sv, mg));
1640 call_method("CLEAR", G_SCALAR|G_DISCARD);
1648 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1651 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1655 PUSHSTACKi(PERLSI_MAGIC);
1658 PUSHs(SvTIED_obj(sv, mg));
1663 if (call_method(meth, G_SCALAR))
1664 sv_setsv(key, *PL_stack_sp--);
1673 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1675 return magic_methpack(sv,mg,"EXISTS");
1679 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1682 SV *retval = &PL_sv_undef;
1683 SV * const tied = SvTIED_obj((SV*)hv, mg);
1684 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1686 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1688 if (HvEITER_get(hv))
1689 /* we are in an iteration so the hash cannot be empty */
1691 /* no xhv_eiter so now use FIRSTKEY */
1692 key = sv_newmortal();
1693 magic_nextpack((SV*)hv, mg, key);
1694 HvEITER_set(hv, NULL); /* need to reset iterator */
1695 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1698 /* there is a SCALAR method that we can call */
1700 PUSHSTACKi(PERLSI_MAGIC);
1706 if (call_method("SCALAR", G_SCALAR))
1707 retval = *PL_stack_sp--;
1714 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1716 GV * const gv = PL_DBline;
1717 const I32 i = SvTRUE(sv);
1718 SV ** const svp = av_fetch(GvAV(gv),
1719 atoi(MgPV_nolen_const(mg)), FALSE);
1720 if (svp && SvIOKp(*svp)) {
1721 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1723 /* set or clear breakpoint in the relevant control op */
1725 o->op_flags |= OPf_SPECIAL;
1727 o->op_flags &= ~OPf_SPECIAL;
1734 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1736 const AV * const obj = (AV*)mg->mg_obj;
1738 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1746 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1748 AV * const obj = (AV*)mg->mg_obj;
1750 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1752 if (ckWARN(WARN_MISC))
1753 Perl_warner(aTHX_ packWARN(WARN_MISC),
1754 "Attempt to set length of freed array");
1760 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1762 PERL_UNUSED_ARG(sv);
1763 /* during global destruction, mg_obj may already have been freed */
1764 if (PL_in_clean_all)
1767 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1770 /* arylen scalar holds a pointer back to the array, but doesn't own a
1771 reference. Hence the we (the array) are about to go away with it
1772 still pointing at us. Clear its pointer, else it would be pointing
1773 at free memory. See the comment in sv_magic about reference loops,
1774 and why it can't own a reference to us. */
1781 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1783 SV* const lsv = LvTARG(sv);
1785 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1786 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1787 if (mg && mg->mg_len >= 0) {
1790 sv_pos_b2u(lsv, &i);
1791 sv_setiv(sv, i + PL_curcop->cop_arybase);
1800 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1802 SV* const lsv = LvTARG(sv);
1809 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1810 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1814 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1815 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1817 else if (!SvOK(sv)) {
1821 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1823 pos = SvIV(sv) - PL_curcop->cop_arybase;
1826 ulen = sv_len_utf8(lsv);
1836 else if (pos > (SSize_t)len)
1841 sv_pos_u2b(lsv, &p, 0);
1846 mg->mg_flags &= ~MGf_MINMATCH;
1852 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1854 PERL_UNUSED_ARG(mg);
1855 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1857 gv_efullname3(sv,((GV*)sv), "*");
1861 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1866 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1869 PERL_UNUSED_ARG(mg);
1873 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1878 GvGP(sv) = gp_ref(GvGP(gv));
1883 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1886 SV * const lsv = LvTARG(sv);
1887 const char * const tmps = SvPV_const(lsv,len);
1888 I32 offs = LvTARGOFF(sv);
1889 I32 rem = LvTARGLEN(sv);
1890 PERL_UNUSED_ARG(mg);
1893 sv_pos_u2b(lsv, &offs, &rem);
1894 if (offs > (I32)len)
1896 if (rem + offs > (I32)len)
1898 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1905 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1908 const char *tmps = SvPV_const(sv, len);
1909 SV * const lsv = LvTARG(sv);
1910 I32 lvoff = LvTARGOFF(sv);
1911 I32 lvlen = LvTARGLEN(sv);
1912 PERL_UNUSED_ARG(mg);
1915 sv_utf8_upgrade(lsv);
1916 sv_pos_u2b(lsv, &lvoff, &lvlen);
1917 sv_insert(lsv, lvoff, lvlen, tmps, len);
1918 LvTARGLEN(sv) = sv_len_utf8(sv);
1921 else if (lsv && SvUTF8(lsv)) {
1922 sv_pos_u2b(lsv, &lvoff, &lvlen);
1923 LvTARGLEN(sv) = len;
1924 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1925 sv_insert(lsv, lvoff, lvlen, tmps, len);
1929 sv_insert(lsv, lvoff, lvlen, tmps, len);
1930 LvTARGLEN(sv) = len;
1938 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1940 PERL_UNUSED_ARG(sv);
1941 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1946 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1948 PERL_UNUSED_ARG(sv);
1949 /* update taint status unless we're restoring at scope exit */
1950 if (PL_localizing != 2) {
1960 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1962 SV * const lsv = LvTARG(sv);
1963 PERL_UNUSED_ARG(mg);
1970 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1975 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1977 PERL_UNUSED_ARG(mg);
1978 do_vecset(sv); /* XXX slurp this routine */
1983 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1986 if (LvTARGLEN(sv)) {
1988 SV * const ahv = LvTARG(sv);
1989 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1994 AV* const av = (AV*)LvTARG(sv);
1995 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1996 targ = AvARRAY(av)[LvTARGOFF(sv)];
1998 if (targ && targ != &PL_sv_undef) {
1999 /* somebody else defined it for us */
2000 SvREFCNT_dec(LvTARG(sv));
2001 LvTARG(sv) = SvREFCNT_inc(targ);
2003 SvREFCNT_dec(mg->mg_obj);
2004 mg->mg_obj = Nullsv;
2005 mg->mg_flags &= ~MGf_REFCOUNTED;
2010 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2015 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2017 PERL_UNUSED_ARG(mg);
2021 sv_setsv(LvTARG(sv), sv);
2022 SvSETMAGIC(LvTARG(sv));
2028 Perl_vivify_defelem(pTHX_ SV *sv)
2033 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2036 SV * const ahv = LvTARG(sv);
2037 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2040 if (!value || value == &PL_sv_undef)
2041 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2044 AV* const av = (AV*)LvTARG(sv);
2045 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2046 LvTARG(sv) = Nullsv; /* array can't be extended */
2048 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2049 if (!svp || (value = *svp) == &PL_sv_undef)
2050 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2053 (void)SvREFCNT_inc(value);
2054 SvREFCNT_dec(LvTARG(sv));
2057 SvREFCNT_dec(mg->mg_obj);
2058 mg->mg_obj = Nullsv;
2059 mg->mg_flags &= ~MGf_REFCOUNTED;
2063 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2065 AV *const av = (AV*)mg->mg_obj;
2066 SV **svp = AvARRAY(av);
2067 PERL_UNUSED_ARG(sv);
2070 SV *const *const last = svp + AvFILLp(av);
2072 while (svp <= last) {
2074 SV *const referrer = *svp;
2075 if (SvWEAKREF(referrer)) {
2076 /* XXX Should we check that it hasn't changed? */
2077 SvRV_set(referrer, 0);
2079 SvWEAKREF_off(referrer);
2080 } else if (SvTYPE(referrer) == SVt_PVGV ||
2081 SvTYPE(referrer) == SVt_PVLV) {
2082 /* You lookin' at me? */
2083 assert(GvSTASH(referrer));
2084 assert(GvSTASH(referrer) == (HV*)sv);
2085 GvSTASH(referrer) = 0;
2088 "panic: magic_killbackrefs (flags=%"UVxf")",
2089 (UV)SvFLAGS(referrer));
2097 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2102 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2110 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2112 PERL_UNUSED_ARG(mg);
2113 sv_unmagic(sv, PERL_MAGIC_bm);
2119 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2121 PERL_UNUSED_ARG(mg);
2122 sv_unmagic(sv, PERL_MAGIC_fm);
2128 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2130 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2132 if (uf && uf->uf_set)
2133 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2138 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2140 PERL_UNUSED_ARG(mg);
2141 sv_unmagic(sv, PERL_MAGIC_qr);
2146 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2148 regexp * const re = (regexp *)mg->mg_obj;
2149 PERL_UNUSED_ARG(sv);
2155 #ifdef USE_LOCALE_COLLATE
2157 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2160 * RenE<eacute> Descartes said "I think not."
2161 * and vanished with a faint plop.
2163 PERL_UNUSED_ARG(sv);
2165 Safefree(mg->mg_ptr);
2171 #endif /* USE_LOCALE_COLLATE */
2173 /* Just clear the UTF-8 cache data. */
2175 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2177 PERL_UNUSED_ARG(sv);
2178 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2180 mg->mg_len = -1; /* The mg_len holds the len cache. */
2185 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2187 register const char *s;
2190 switch (*mg->mg_ptr) {
2191 case '\001': /* ^A */
2192 sv_setsv(PL_bodytarget, sv);
2194 case '\003': /* ^C */
2195 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2198 case '\004': /* ^D */
2200 s = SvPV_nolen_const(sv);
2201 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2202 DEBUG_x(dump_all());
2204 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2207 case '\005': /* ^E */
2208 if (*(mg->mg_ptr+1) == '\0') {
2209 #ifdef MACOS_TRADITIONAL
2210 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2213 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2216 SetLastError( SvIV(sv) );
2219 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2221 /* will anyone ever use this? */
2222 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2228 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2230 SvREFCNT_dec(PL_encoding);
2231 if (SvOK(sv) || SvGMAGICAL(sv)) {
2232 PL_encoding = newSVsv(sv);
2235 PL_encoding = Nullsv;
2239 case '\006': /* ^F */
2240 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2242 case '\010': /* ^H */
2243 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2245 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2246 Safefree(PL_inplace);
2247 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2249 case '\017': /* ^O */
2250 if (*(mg->mg_ptr+1) == '\0') {
2251 Safefree(PL_osname);
2254 TAINT_PROPER("assigning to $^O");
2255 PL_osname = savesvpv(sv);
2258 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2259 if (!PL_compiling.cop_io)
2260 PL_compiling.cop_io = newSVsv(sv);
2262 sv_setsv(PL_compiling.cop_io,sv);
2265 case '\020': /* ^P */
2266 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2267 if (PL_perldb && !PL_DBsingle)
2270 case '\024': /* ^T */
2272 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2274 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2277 case '\027': /* ^W & $^WARNING_BITS */
2278 if (*(mg->mg_ptr+1) == '\0') {
2279 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2280 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2281 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2282 | (i ? G_WARN_ON : G_WARN_OFF) ;
2285 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2286 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2287 if (!SvPOK(sv) && PL_localizing) {
2288 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2289 PL_compiling.cop_warnings = pWARN_NONE;
2294 int accumulate = 0 ;
2295 int any_fatals = 0 ;
2296 const char * const ptr = SvPV_const(sv, len) ;
2297 for (i = 0 ; i < len ; ++i) {
2298 accumulate |= ptr[i] ;
2299 any_fatals |= (ptr[i] & 0xAA) ;
2302 PL_compiling.cop_warnings = pWARN_NONE;
2303 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2304 PL_compiling.cop_warnings = pWARN_ALL;
2305 PL_dowarn |= G_WARN_ONCE ;
2308 if (specialWARN(PL_compiling.cop_warnings))
2309 PL_compiling.cop_warnings = newSVsv(sv) ;
2311 sv_setsv(PL_compiling.cop_warnings, sv);
2312 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2313 PL_dowarn |= G_WARN_ONCE ;
2321 if (PL_localizing) {
2322 if (PL_localizing == 1)
2323 SAVESPTR(PL_last_in_gv);
2325 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2326 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2329 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2330 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2331 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2334 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2335 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2336 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2339 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2342 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2343 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2344 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2347 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2351 IO * const io = GvIOp(PL_defoutgv);
2354 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2355 IoFLAGS(io) &= ~IOf_FLUSH;
2357 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2358 PerlIO *ofp = IoOFP(io);
2360 (void)PerlIO_flush(ofp);
2361 IoFLAGS(io) |= IOf_FLUSH;
2367 SvREFCNT_dec(PL_rs);
2368 PL_rs = newSVsv(sv);
2372 SvREFCNT_dec(PL_ors_sv);
2373 if (SvOK(sv) || SvGMAGICAL(sv)) {
2374 PL_ors_sv = newSVsv(sv);
2382 SvREFCNT_dec(PL_ofs_sv);
2383 if (SvOK(sv) || SvGMAGICAL(sv)) {
2384 PL_ofs_sv = newSVsv(sv);
2391 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2394 #ifdef COMPLEX_STATUS
2395 if (PL_localizing == 2) {
2396 PL_statusvalue = LvTARGOFF(sv);
2397 PL_statusvalue_vms = LvTARGLEN(sv);
2401 #ifdef VMSISH_STATUS
2403 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2406 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2411 # define PERL_VMS_BANG vaxc$errno
2413 # define PERL_VMS_BANG 0
2415 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2416 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2420 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2421 if (PL_delaymagic) {
2422 PL_delaymagic |= DM_RUID;
2423 break; /* don't do magic till later */
2426 (void)setruid((Uid_t)PL_uid);
2429 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2431 #ifdef HAS_SETRESUID
2432 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2434 if (PL_uid == PL_euid) { /* special case $< = $> */
2436 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2437 if (PL_uid != 0 && PerlProc_getuid() == 0)
2438 (void)PerlProc_setuid(0);
2440 (void)PerlProc_setuid(PL_uid);
2442 PL_uid = PerlProc_getuid();
2443 Perl_croak(aTHX_ "setruid() not implemented");
2448 PL_uid = PerlProc_getuid();
2449 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2452 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2453 if (PL_delaymagic) {
2454 PL_delaymagic |= DM_EUID;
2455 break; /* don't do magic till later */
2458 (void)seteuid((Uid_t)PL_euid);
2461 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2463 #ifdef HAS_SETRESUID
2464 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2466 if (PL_euid == PL_uid) /* special case $> = $< */
2467 PerlProc_setuid(PL_euid);
2469 PL_euid = PerlProc_geteuid();
2470 Perl_croak(aTHX_ "seteuid() not implemented");
2475 PL_euid = PerlProc_geteuid();
2476 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2479 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2480 if (PL_delaymagic) {
2481 PL_delaymagic |= DM_RGID;
2482 break; /* don't do magic till later */
2485 (void)setrgid((Gid_t)PL_gid);
2488 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2490 #ifdef HAS_SETRESGID
2491 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2493 if (PL_gid == PL_egid) /* special case $( = $) */
2494 (void)PerlProc_setgid(PL_gid);
2496 PL_gid = PerlProc_getgid();
2497 Perl_croak(aTHX_ "setrgid() not implemented");
2502 PL_gid = PerlProc_getgid();
2503 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2506 #ifdef HAS_SETGROUPS
2508 const char *p = SvPV_const(sv, len);
2509 Groups_t gary[NGROUPS];
2514 for (i = 0; i < NGROUPS; ++i) {
2515 while (*p && !isSPACE(*p))
2524 (void)setgroups(i, gary);
2526 #else /* HAS_SETGROUPS */
2527 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2528 #endif /* HAS_SETGROUPS */
2529 if (PL_delaymagic) {
2530 PL_delaymagic |= DM_EGID;
2531 break; /* don't do magic till later */
2534 (void)setegid((Gid_t)PL_egid);
2537 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2539 #ifdef HAS_SETRESGID
2540 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2542 if (PL_egid == PL_gid) /* special case $) = $( */
2543 (void)PerlProc_setgid(PL_egid);
2545 PL_egid = PerlProc_getegid();
2546 Perl_croak(aTHX_ "setegid() not implemented");
2551 PL_egid = PerlProc_getegid();
2552 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2555 PL_chopset = SvPV_force(sv,len);
2557 #ifndef MACOS_TRADITIONAL
2559 LOCK_DOLLARZERO_MUTEX;
2560 #ifdef HAS_SETPROCTITLE
2561 /* The BSDs don't show the argv[] in ps(1) output, they
2562 * show a string from the process struct and provide
2563 * the setproctitle() routine to manipulate that. */
2565 s = SvPV_const(sv, len);
2566 # if __FreeBSD_version > 410001
2567 /* The leading "-" removes the "perl: " prefix,
2568 * but not the "(perl) suffix from the ps(1)
2569 * output, because that's what ps(1) shows if the
2570 * argv[] is modified. */
2571 setproctitle("-%s", s);
2572 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2573 /* This doesn't really work if you assume that
2574 * $0 = 'foobar'; will wipe out 'perl' from the $0
2575 * because in ps(1) output the result will be like
2576 * sprintf("perl: %s (perl)", s)
2577 * I guess this is a security feature:
2578 * one (a user process) cannot get rid of the original name.
2580 setproctitle("%s", s);
2584 #if defined(__hpux) && defined(PSTAT_SETCMD)
2587 s = SvPV_const(sv, len);
2588 un.pst_command = (char *)s;
2589 pstat(PSTAT_SETCMD, un, len, 0, 0);
2592 /* PL_origalen is set in perl_parse(). */
2593 s = SvPV_force(sv,len);
2594 if (len >= (STRLEN)PL_origalen-1) {
2595 /* Longer than original, will be truncated. We assume that
2596 * PL_origalen bytes are available. */
2597 Copy(s, PL_origargv[0], PL_origalen-1, char);
2600 /* Shorter than original, will be padded. */
2601 Copy(s, PL_origargv[0], len, char);
2602 PL_origargv[0][len] = 0;
2603 memset(PL_origargv[0] + len + 1,
2604 /* Is the space counterintuitive? Yes.
2605 * (You were expecting \0?)
2606 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2609 PL_origalen - len - 1);
2611 PL_origargv[0][PL_origalen-1] = 0;
2612 for (i = 1; i < PL_origargc; i++)
2614 UNLOCK_DOLLARZERO_MUTEX;
2622 Perl_whichsig(pTHX_ const char *sig)
2624 register char* const* sigv;
2626 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2627 if (strEQ(sig,*sigv))
2628 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2630 if (strEQ(sig,"CHLD"))
2634 if (strEQ(sig,"CLD"))
2641 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2642 Perl_sighandler(int sig, ...)
2644 Perl_sighandler(int sig)
2647 #ifdef PERL_GET_SIG_CONTEXT
2648 dTHXa(PERL_GET_SIG_CONTEXT);
2655 SV * const tSv = PL_Sv;
2659 XPV * const tXpv = PL_Xpv;
2661 if (PL_savestack_ix + 15 <= PL_savestack_max)
2663 if (PL_markstack_ptr < PL_markstack_max - 2)
2665 if (PL_scopestack_ix < PL_scopestack_max - 3)
2668 if (!PL_psig_ptr[sig]) {
2669 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2674 /* Max number of items pushed there is 3*n or 4. We cannot fix
2675 infinity, so we fix 4 (in fact 5): */
2677 PL_savestack_ix += 5; /* Protect save in progress. */
2678 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2681 PL_markstack_ptr++; /* Protect mark. */
2683 PL_scopestack_ix += 1;
2684 /* sv_2cv is too complicated, try a simpler variant first: */
2685 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2686 || SvTYPE(cv) != SVt_PVCV) {
2688 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2691 if (!cv || !CvROOT(cv)) {
2692 if (ckWARN(WARN_SIGNAL))
2693 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2694 PL_sig_name[sig], (gv ? GvENAME(gv)
2701 if(PL_psig_name[sig]) {
2702 sv = SvREFCNT_inc(PL_psig_name[sig]);
2704 #if !defined(PERL_IMPLICIT_CONTEXT)
2708 sv = sv_newmortal();
2709 sv_setpv(sv,PL_sig_name[sig]);
2712 PUSHSTACKi(PERLSI_SIGNAL);
2715 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2717 struct sigaction oact;
2719 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2723 va_start(args, sig);
2724 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2727 SV *rv = newRV_noinc((SV*)sih);
2728 /* The siginfo fields signo, code, errno, pid, uid,
2729 * addr, status, and band are defined by POSIX/SUSv3. */
2730 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2731 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2732 #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. */
2733 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2734 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2735 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2736 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2737 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2738 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2742 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2751 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2754 if (SvTRUE(ERRSV)) {
2756 #ifdef HAS_SIGPROCMASK
2757 /* Handler "died", for example to get out of a restart-able read().
2758 * Before we re-do that on its behalf re-enable the signal which was
2759 * blocked by the system when we entered.
2763 sigaddset(&set,sig);
2764 sigprocmask(SIG_UNBLOCK, &set, NULL);
2766 /* Not clear if this will work */
2767 (void)rsignal(sig, SIG_IGN);
2768 (void)rsignal(sig, PL_csighandlerp);
2770 #endif /* !PERL_MICRO */
2771 Perl_die(aTHX_ Nullch);
2775 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2779 PL_scopestack_ix -= 1;
2782 PL_op = myop; /* Apparently not needed... */
2784 PL_Sv = tSv; /* Restore global temporaries. */
2791 S_restore_magic(pTHX_ const void *p)
2793 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2794 SV* const sv = mgs->mgs_sv;
2799 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2801 #ifdef PERL_OLD_COPY_ON_WRITE
2802 /* While magic was saved (and off) sv_setsv may well have seen
2803 this SV as a prime candidate for COW. */
2805 sv_force_normal_flags(sv, 0);
2809 SvFLAGS(sv) |= mgs->mgs_flags;
2812 if (SvGMAGICAL(sv)) {
2813 /* downgrade public flags to private,
2814 and discard any other private flags */
2816 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2818 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2819 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2824 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2826 /* If we're still on top of the stack, pop us off. (That condition
2827 * will be satisfied if restore_magic was called explicitly, but *not*
2828 * if it's being called via leave_scope.)
2829 * The reason for doing this is that otherwise, things like sv_2cv()
2830 * may leave alloc gunk on the savestack, and some code
2831 * (e.g. sighandler) doesn't expect that...
2833 if (PL_savestack_ix == mgs->mgs_ss_ix)
2835 I32 popval = SSPOPINT;
2836 assert(popval == SAVEt_DESTRUCTOR_X);
2837 PL_savestack_ix -= 2;
2839 assert(popval == SAVEt_ALLOC);
2841 PL_savestack_ix -= popval;
2847 S_unwind_handler_stack(pTHX_ const void *p)
2850 const U32 flags = *(const U32*)p;
2853 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2854 /* cxstack_ix-- Not needed, die already unwound it. */
2855 #if !defined(PERL_IMPLICIT_CONTEXT)
2857 SvREFCNT_dec(PL_sig_sv);
2863 * c-indentation-style: bsd
2865 * indent-tabs-mode: t
2868 * ex: set ts=8 sts=4 sw=4 noet: