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);
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)
845 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
850 if (RX_MATCH_TAINTED(rx)) {
851 MAGIC* const mg = SvMAGIC(sv);
854 SvMAGIC_set(sv, mg->mg_moremagic);
856 if ((mgt = SvMAGIC(sv))) {
857 mg->mg_moremagic = mgt;
867 sv_setsv(sv,&PL_sv_undef);
870 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
871 paren = rx->lastparen;
875 sv_setsv(sv,&PL_sv_undef);
877 case '\016': /* ^N */
878 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
879 paren = rx->lastcloseparen;
883 sv_setsv(sv,&PL_sv_undef);
886 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
887 if ((s = rx->subbeg) && rx->startp[0] != -1) {
892 sv_setsv(sv,&PL_sv_undef);
895 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
896 if (rx->subbeg && rx->endp[0] != -1) {
897 s = rx->subbeg + rx->endp[0];
898 i = rx->sublen - rx->endp[0];
902 sv_setsv(sv,&PL_sv_undef);
905 if (GvIO(PL_last_in_gv)) {
906 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
911 sv_setiv(sv, (IV)STATUS_CURRENT);
912 #ifdef COMPLEX_STATUS
913 LvTARGOFF(sv) = PL_statusvalue;
914 LvTARGLEN(sv) = PL_statusvalue_vms;
919 if (GvIOp(PL_defoutgv))
920 s = IoTOP_NAME(GvIOp(PL_defoutgv));
924 sv_setpv(sv,GvENAME(PL_defoutgv));
929 if (GvIOp(PL_defoutgv))
930 s = IoFMT_NAME(GvIOp(PL_defoutgv));
932 s = GvENAME(PL_defoutgv);
936 if (GvIOp(PL_defoutgv))
937 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
940 if (GvIOp(PL_defoutgv))
941 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
944 if (GvIOp(PL_defoutgv))
945 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
952 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
955 if (GvIOp(PL_defoutgv))
956 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
962 sv_copypv(sv, PL_ors_sv);
966 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
967 sv_setpv(sv, errno ? Strerror(errno) : "");
970 const int saveerrno = errno;
971 sv_setnv(sv, (NV)errno);
973 if (errno == errno_isOS2 || errno == errno_isOS2_set)
974 sv_setpv(sv, os2error(Perl_rc));
977 sv_setpv(sv, errno ? Strerror(errno) : "");
982 SvNOK_on(sv); /* what a wonderful hack! */
985 sv_setiv(sv, (IV)PL_uid);
988 sv_setiv(sv, (IV)PL_euid);
991 sv_setiv(sv, (IV)PL_gid);
993 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
997 sv_setiv(sv, (IV)PL_egid);
999 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
1002 #ifdef HAS_GETGROUPS
1004 Groups_t gary[NGROUPS];
1005 I32 j = getgroups(NGROUPS,gary);
1007 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
1010 (void)SvIOK_on(sv); /* what a wonderful hack! */
1012 #ifndef MACOS_TRADITIONAL
1021 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1023 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1025 if (uf && uf->uf_val)
1026 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1031 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1038 s = SvPV_const(sv,len);
1039 ptr = MgPV_const(mg,klen);
1042 #ifdef DYNAMIC_ENV_FETCH
1043 /* We just undefd an environment var. Is a replacement */
1044 /* waiting in the wings? */
1047 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1048 s = SvPV_const(*valp, len);
1052 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1053 /* And you'll never guess what the dog had */
1054 /* in its mouth... */
1056 MgTAINTEDDIR_off(mg);
1058 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1059 char pathbuf[256], eltbuf[256], *cp, *elt;
1063 strncpy(eltbuf, s, 255);
1066 do { /* DCL$PATH may be a search list */
1067 while (1) { /* as may dev portion of any element */
1068 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1069 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1070 cando_by_name(S_IWUSR,0,elt) ) {
1071 MgTAINTEDDIR_on(mg);
1075 if ((cp = strchr(elt, ':')) != Nullch)
1077 if (my_trnlnm(elt, eltbuf, j++))
1083 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1086 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1087 const char * const strend = s + len;
1089 while (s < strend) {
1093 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1094 s, strend, ':', &i);
1096 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1098 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1099 MgTAINTEDDIR_on(mg);
1105 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1111 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1113 PERL_UNUSED_ARG(sv);
1114 my_setenv(MgPV_nolen_const(mg),Nullch);
1119 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1121 #if defined(VMS) || defined(EPOC)
1122 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1124 if (PL_localizing) {
1126 magic_clear_all_env(sv,mg);
1127 hv_iterinit((HV*)sv);
1128 while ((entry = hv_iternext((HV*)sv))) {
1130 my_setenv(hv_iterkey(entry, &keylen),
1131 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1139 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1143 #if defined(VMS) || defined(EPOC)
1144 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1146 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1149 # ifdef USE_ENVIRON_ARRAY
1150 # if defined(USE_ITHREADS)
1151 /* only the parent thread can clobber the process environment */
1152 if (PL_curinterp == aTHX)
1155 # ifndef PERL_USE_SAFE_PUTENV
1156 if (!PL_use_safe_putenv) {
1159 if (environ == PL_origenviron)
1160 environ = (char**)safesysmalloc(sizeof(char*));
1162 for (i = 0; environ[i]; i++)
1163 safesysfree(environ[i]);
1165 # endif /* PERL_USE_SAFE_PUTENV */
1167 environ[0] = Nullch;
1169 # endif /* USE_ENVIRON_ARRAY */
1170 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1171 #endif /* VMS || EPOC */
1172 #endif /* !PERL_MICRO */
1173 PERL_UNUSED_ARG(sv);
1174 PERL_UNUSED_ARG(mg);
1179 #ifdef HAS_SIGPROCMASK
1181 restore_sigmask(pTHX_ SV *save_sv)
1183 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1184 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1188 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1190 /* Are we fetching a signal entry? */
1191 const I32 i = whichsig(MgPV_nolen_const(mg));
1194 sv_setsv(sv,PL_psig_ptr[i]);
1196 Sighandler_t sigstate;
1197 sigstate = rsignal_state(i);
1198 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1199 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1201 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1202 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1204 /* cache state so we don't fetch it again */
1205 if(sigstate == (Sighandler_t) SIG_IGN)
1206 sv_setpv(sv,"IGNORE");
1208 sv_setsv(sv,&PL_sv_undef);
1209 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1216 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1218 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1219 * refactoring might be in order.
1222 register const char * const s = MgPV_nolen_const(mg);
1223 PERL_UNUSED_ARG(sv);
1226 if (strEQ(s,"__DIE__"))
1228 else if (strEQ(s,"__WARN__"))
1231 Perl_croak(aTHX_ "No such hook: %s", s);
1233 SV * const to_dec = *svp;
1235 SvREFCNT_dec(to_dec);
1239 /* Are we clearing a signal entry? */
1240 const I32 i = whichsig(s);
1242 #ifdef HAS_SIGPROCMASK
1245 /* Avoid having the signal arrive at a bad time, if possible. */
1248 sigprocmask(SIG_BLOCK, &set, &save);
1250 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1251 SAVEFREESV(save_sv);
1252 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1255 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1256 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1258 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1259 PL_sig_defaulting[i] = 1;
1260 (void)rsignal(i, PL_csighandlerp);
1262 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1264 if(PL_psig_name[i]) {
1265 SvREFCNT_dec(PL_psig_name[i]);
1268 if(PL_psig_ptr[i]) {
1269 SV *to_dec=PL_psig_ptr[i];
1272 SvREFCNT_dec(to_dec);
1282 S_raise_signal(pTHX_ int sig)
1284 /* Set a flag to say this signal is pending */
1285 PL_psig_pend[sig]++;
1286 /* And one to say _a_ signal is pending */
1291 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1292 Perl_csighandler(int sig, ...)
1294 Perl_csighandler(int sig)
1297 #ifdef PERL_GET_SIG_CONTEXT
1298 dTHXa(PERL_GET_SIG_CONTEXT);
1302 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1303 (void) rsignal(sig, PL_csighandlerp);
1304 if (PL_sig_ignoring[sig]) return;
1306 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1307 if (PL_sig_defaulting[sig])
1308 #ifdef KILL_BY_SIGPRC
1309 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1314 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1315 /* Call the perl level handler now--
1316 * with risk we may be in malloc() etc. */
1317 (*PL_sighandlerp)(sig);
1319 S_raise_signal(aTHX_ sig);
1322 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1324 Perl_csighandler_init(void)
1327 if (PL_sig_handlers_initted) return;
1329 for (sig = 1; sig < SIG_SIZE; sig++) {
1330 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1332 PL_sig_defaulting[sig] = 1;
1333 (void) rsignal(sig, PL_csighandlerp);
1335 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1336 PL_sig_ignoring[sig] = 0;
1339 PL_sig_handlers_initted = 1;
1344 Perl_despatch_signals(pTHX)
1348 for (sig = 1; sig < SIG_SIZE; sig++) {
1349 if (PL_psig_pend[sig]) {
1350 PERL_BLOCKSIG_ADD(set, sig);
1351 PL_psig_pend[sig] = 0;
1352 PERL_BLOCKSIG_BLOCK(set);
1353 (*PL_sighandlerp)(sig);
1354 PERL_BLOCKSIG_UNBLOCK(set);
1360 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1365 /* Need to be careful with SvREFCNT_dec(), because that can have side
1366 * effects (due to closures). We must make sure that the new disposition
1367 * is in place before it is called.
1371 #ifdef HAS_SIGPROCMASK
1376 register const char *s = MgPV_const(mg,len);
1378 if (strEQ(s,"__DIE__"))
1380 else if (strEQ(s,"__WARN__"))
1383 Perl_croak(aTHX_ "No such hook: %s", s);
1391 i = whichsig(s); /* ...no, a brick */
1393 if (ckWARN(WARN_SIGNAL))
1394 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1397 #ifdef HAS_SIGPROCMASK
1398 /* Avoid having the signal arrive at a bad time, if possible. */
1401 sigprocmask(SIG_BLOCK, &set, &save);
1403 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1404 SAVEFREESV(save_sv);
1405 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1408 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1409 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1411 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1412 PL_sig_ignoring[i] = 0;
1414 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1415 PL_sig_defaulting[i] = 0;
1417 SvREFCNT_dec(PL_psig_name[i]);
1418 to_dec = PL_psig_ptr[i];
1419 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1420 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1421 PL_psig_name[i] = newSVpvn(s, len);
1422 SvREADONLY_on(PL_psig_name[i]);
1424 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1426 (void)rsignal(i, PL_csighandlerp);
1427 #ifdef HAS_SIGPROCMASK
1432 *svp = SvREFCNT_inc(sv);
1434 SvREFCNT_dec(to_dec);
1437 s = SvPV_force(sv,len);
1438 if (strEQ(s,"IGNORE")) {
1440 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1441 PL_sig_ignoring[i] = 1;
1442 (void)rsignal(i, PL_csighandlerp);
1444 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1448 else if (strEQ(s,"DEFAULT") || !*s) {
1450 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1452 PL_sig_defaulting[i] = 1;
1453 (void)rsignal(i, PL_csighandlerp);
1456 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1461 * We should warn if HINT_STRICT_REFS, but without
1462 * access to a known hint bit in a known OP, we can't
1463 * tell whether HINT_STRICT_REFS is in force or not.
1465 if (!strchr(s,':') && !strchr(s,'\''))
1466 sv_insert(sv, 0, 0, "main::", 6);
1468 (void)rsignal(i, PL_csighandlerp);
1470 *svp = SvREFCNT_inc(sv);
1472 #ifdef HAS_SIGPROCMASK
1477 SvREFCNT_dec(to_dec);
1480 #endif /* !PERL_MICRO */
1483 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1485 PERL_UNUSED_ARG(sv);
1486 PERL_UNUSED_ARG(mg);
1487 PL_sub_generation++;
1492 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1494 PERL_UNUSED_ARG(sv);
1495 PERL_UNUSED_ARG(mg);
1496 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1497 PL_amagic_generation++;
1503 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1505 HV * const hv = (HV*)LvTARG(sv);
1507 PERL_UNUSED_ARG(mg);
1510 (void) hv_iterinit(hv);
1511 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1514 while (hv_iternext(hv))
1519 sv_setiv(sv, (IV)i);
1524 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1526 PERL_UNUSED_ARG(mg);
1528 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1533 /* caller is responsible for stack switching/cleanup */
1535 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1541 PUSHs(SvTIED_obj(sv, mg));
1544 if (mg->mg_len >= 0)
1545 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1546 else if (mg->mg_len == HEf_SVKEY)
1547 PUSHs((SV*)mg->mg_ptr);
1549 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1550 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1558 return call_method(meth, flags);
1562 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1568 PUSHSTACKi(PERLSI_MAGIC);
1570 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1571 sv_setsv(sv, *PL_stack_sp--);
1581 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1584 mg->mg_flags |= MGf_GSKIP;
1585 magic_methpack(sv,mg,"FETCH");
1590 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1594 PUSHSTACKi(PERLSI_MAGIC);
1595 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1602 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1604 return magic_methpack(sv,mg,"DELETE");
1609 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1616 PUSHSTACKi(PERLSI_MAGIC);
1617 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1618 sv = *PL_stack_sp--;
1619 retval = (U32) SvIV(sv)-1;
1628 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1633 PUSHSTACKi(PERLSI_MAGIC);
1635 XPUSHs(SvTIED_obj(sv, mg));
1637 call_method("CLEAR", G_SCALAR|G_DISCARD);
1645 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1648 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1652 PUSHSTACKi(PERLSI_MAGIC);
1655 PUSHs(SvTIED_obj(sv, mg));
1660 if (call_method(meth, G_SCALAR))
1661 sv_setsv(key, *PL_stack_sp--);
1670 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1672 return magic_methpack(sv,mg,"EXISTS");
1676 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1679 SV *retval = &PL_sv_undef;
1680 SV * const tied = SvTIED_obj((SV*)hv, mg);
1681 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1683 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1685 if (HvEITER_get(hv))
1686 /* we are in an iteration so the hash cannot be empty */
1688 /* no xhv_eiter so now use FIRSTKEY */
1689 key = sv_newmortal();
1690 magic_nextpack((SV*)hv, mg, key);
1691 HvEITER_set(hv, NULL); /* need to reset iterator */
1692 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1695 /* there is a SCALAR method that we can call */
1697 PUSHSTACKi(PERLSI_MAGIC);
1703 if (call_method("SCALAR", G_SCALAR))
1704 retval = *PL_stack_sp--;
1711 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1713 GV * const gv = PL_DBline;
1714 const I32 i = SvTRUE(sv);
1715 SV ** const svp = av_fetch(GvAV(gv),
1716 atoi(MgPV_nolen_const(mg)), FALSE);
1717 if (svp && SvIOKp(*svp)) {
1718 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1720 /* set or clear breakpoint in the relevant control op */
1722 o->op_flags |= OPf_SPECIAL;
1724 o->op_flags &= ~OPf_SPECIAL;
1731 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1733 const AV * const obj = (AV*)mg->mg_obj;
1735 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1743 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1745 AV * const obj = (AV*)mg->mg_obj;
1747 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1749 if (ckWARN(WARN_MISC))
1750 Perl_warner(aTHX_ packWARN(WARN_MISC),
1751 "Attempt to set length of freed array");
1757 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1759 PERL_UNUSED_ARG(sv);
1760 /* during global destruction, mg_obj may already have been freed */
1761 if (PL_in_clean_all)
1764 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1767 /* arylen scalar holds a pointer back to the array, but doesn't own a
1768 reference. Hence the we (the array) are about to go away with it
1769 still pointing at us. Clear its pointer, else it would be pointing
1770 at free memory. See the comment in sv_magic about reference loops,
1771 and why it can't own a reference to us. */
1778 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1780 SV* const lsv = LvTARG(sv);
1782 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1783 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1784 if (mg && mg->mg_len >= 0) {
1787 sv_pos_b2u(lsv, &i);
1788 sv_setiv(sv, i + PL_curcop->cop_arybase);
1797 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1799 SV* const lsv = LvTARG(sv);
1806 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1807 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1811 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1812 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1814 else if (!SvOK(sv)) {
1818 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1820 pos = SvIV(sv) - PL_curcop->cop_arybase;
1823 ulen = sv_len_utf8(lsv);
1833 else if (pos > (SSize_t)len)
1838 sv_pos_u2b(lsv, &p, 0);
1843 mg->mg_flags &= ~MGf_MINMATCH;
1849 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1851 PERL_UNUSED_ARG(mg);
1852 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1854 gv_efullname3(sv,((GV*)sv), "*");
1858 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1863 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1866 PERL_UNUSED_ARG(mg);
1870 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1875 GvGP(sv) = gp_ref(GvGP(gv));
1880 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1883 SV * const lsv = LvTARG(sv);
1884 const char * const tmps = SvPV_const(lsv,len);
1885 I32 offs = LvTARGOFF(sv);
1886 I32 rem = LvTARGLEN(sv);
1887 PERL_UNUSED_ARG(mg);
1890 sv_pos_u2b(lsv, &offs, &rem);
1891 if (offs > (I32)len)
1893 if (rem + offs > (I32)len)
1895 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1902 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1905 const char *tmps = SvPV_const(sv, len);
1906 SV * const lsv = LvTARG(sv);
1907 I32 lvoff = LvTARGOFF(sv);
1908 I32 lvlen = LvTARGLEN(sv);
1909 PERL_UNUSED_ARG(mg);
1912 sv_utf8_upgrade(lsv);
1913 sv_pos_u2b(lsv, &lvoff, &lvlen);
1914 sv_insert(lsv, lvoff, lvlen, tmps, len);
1915 LvTARGLEN(sv) = sv_len_utf8(sv);
1918 else if (lsv && SvUTF8(lsv)) {
1919 sv_pos_u2b(lsv, &lvoff, &lvlen);
1920 LvTARGLEN(sv) = len;
1921 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1922 sv_insert(lsv, lvoff, lvlen, tmps, len);
1926 sv_insert(lsv, lvoff, lvlen, tmps, len);
1927 LvTARGLEN(sv) = len;
1935 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1937 PERL_UNUSED_ARG(sv);
1938 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1943 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1945 PERL_UNUSED_ARG(sv);
1946 /* update taint status unless we're restoring at scope exit */
1947 if (PL_localizing != 2) {
1957 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1959 SV * const lsv = LvTARG(sv);
1960 PERL_UNUSED_ARG(mg);
1967 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1972 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1974 PERL_UNUSED_ARG(mg);
1975 do_vecset(sv); /* XXX slurp this routine */
1980 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1983 if (LvTARGLEN(sv)) {
1985 SV * const ahv = LvTARG(sv);
1986 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1991 AV* const av = (AV*)LvTARG(sv);
1992 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1993 targ = AvARRAY(av)[LvTARGOFF(sv)];
1995 if (targ && targ != &PL_sv_undef) {
1996 /* somebody else defined it for us */
1997 SvREFCNT_dec(LvTARG(sv));
1998 LvTARG(sv) = SvREFCNT_inc(targ);
2000 SvREFCNT_dec(mg->mg_obj);
2001 mg->mg_obj = Nullsv;
2002 mg->mg_flags &= ~MGf_REFCOUNTED;
2007 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2012 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2014 PERL_UNUSED_ARG(mg);
2018 sv_setsv(LvTARG(sv), sv);
2019 SvSETMAGIC(LvTARG(sv));
2025 Perl_vivify_defelem(pTHX_ SV *sv)
2030 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2033 SV * const ahv = LvTARG(sv);
2034 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2037 if (!value || value == &PL_sv_undef)
2038 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2041 AV* const av = (AV*)LvTARG(sv);
2042 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2043 LvTARG(sv) = Nullsv; /* array can't be extended */
2045 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2046 if (!svp || (value = *svp) == &PL_sv_undef)
2047 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2050 (void)SvREFCNT_inc(value);
2051 SvREFCNT_dec(LvTARG(sv));
2054 SvREFCNT_dec(mg->mg_obj);
2055 mg->mg_obj = Nullsv;
2056 mg->mg_flags &= ~MGf_REFCOUNTED;
2060 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2062 AV *const av = (AV*)mg->mg_obj;
2063 SV **svp = AvARRAY(av);
2064 PERL_UNUSED_ARG(sv);
2067 SV *const *const last = svp + AvFILLp(av);
2069 while (svp <= last) {
2071 SV *const referrer = *svp;
2072 if (SvWEAKREF(referrer)) {
2073 /* XXX Should we check that it hasn't changed? */
2074 SvRV_set(referrer, 0);
2076 SvWEAKREF_off(referrer);
2077 } else if (SvTYPE(referrer) == SVt_PVGV ||
2078 SvTYPE(referrer) == SVt_PVLV) {
2079 /* You lookin' at me? */
2080 assert(GvSTASH(referrer));
2081 assert(GvSTASH(referrer) == (HV*)sv);
2082 GvSTASH(referrer) = 0;
2085 "panic: magic_killbackrefs (flags=%"UVxf")",
2086 (UV)SvFLAGS(referrer));
2094 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2099 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2107 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2109 PERL_UNUSED_ARG(mg);
2110 sv_unmagic(sv, PERL_MAGIC_bm);
2116 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2118 PERL_UNUSED_ARG(mg);
2119 sv_unmagic(sv, PERL_MAGIC_fm);
2125 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2127 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2129 if (uf && uf->uf_set)
2130 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2135 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2137 PERL_UNUSED_ARG(mg);
2138 sv_unmagic(sv, PERL_MAGIC_qr);
2143 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2145 regexp * const re = (regexp *)mg->mg_obj;
2146 PERL_UNUSED_ARG(sv);
2152 #ifdef USE_LOCALE_COLLATE
2154 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2157 * RenE<eacute> Descartes said "I think not."
2158 * and vanished with a faint plop.
2160 PERL_UNUSED_ARG(sv);
2162 Safefree(mg->mg_ptr);
2168 #endif /* USE_LOCALE_COLLATE */
2170 /* Just clear the UTF-8 cache data. */
2172 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2174 PERL_UNUSED_ARG(sv);
2175 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2177 mg->mg_len = -1; /* The mg_len holds the len cache. */
2182 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2184 register const char *s;
2187 switch (*mg->mg_ptr) {
2188 case '\001': /* ^A */
2189 sv_setsv(PL_bodytarget, sv);
2191 case '\003': /* ^C */
2192 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2195 case '\004': /* ^D */
2197 s = SvPV_nolen_const(sv);
2198 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2199 DEBUG_x(dump_all());
2201 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2204 case '\005': /* ^E */
2205 if (*(mg->mg_ptr+1) == '\0') {
2206 #ifdef MACOS_TRADITIONAL
2207 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2210 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2213 SetLastError( SvIV(sv) );
2216 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2218 /* will anyone ever use this? */
2219 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2225 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2227 SvREFCNT_dec(PL_encoding);
2228 if (SvOK(sv) || SvGMAGICAL(sv)) {
2229 PL_encoding = newSVsv(sv);
2232 PL_encoding = Nullsv;
2236 case '\006': /* ^F */
2237 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2239 case '\010': /* ^H */
2240 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2242 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2243 Safefree(PL_inplace);
2244 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2246 case '\017': /* ^O */
2247 if (*(mg->mg_ptr+1) == '\0') {
2248 Safefree(PL_osname);
2251 TAINT_PROPER("assigning to $^O");
2252 PL_osname = savesvpv(sv);
2255 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2256 if (!PL_compiling.cop_io)
2257 PL_compiling.cop_io = newSVsv(sv);
2259 sv_setsv(PL_compiling.cop_io,sv);
2262 case '\020': /* ^P */
2263 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2264 if (PL_perldb && !PL_DBsingle)
2267 case '\024': /* ^T */
2269 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2271 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2274 case '\027': /* ^W & $^WARNING_BITS */
2275 if (*(mg->mg_ptr+1) == '\0') {
2276 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2277 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2278 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2279 | (i ? G_WARN_ON : G_WARN_OFF) ;
2282 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2283 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2284 if (!SvPOK(sv) && PL_localizing) {
2285 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2286 PL_compiling.cop_warnings = pWARN_NONE;
2291 int accumulate = 0 ;
2292 int any_fatals = 0 ;
2293 const char * const ptr = SvPV_const(sv, len) ;
2294 for (i = 0 ; i < len ; ++i) {
2295 accumulate |= ptr[i] ;
2296 any_fatals |= (ptr[i] & 0xAA) ;
2299 PL_compiling.cop_warnings = pWARN_NONE;
2300 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2301 PL_compiling.cop_warnings = pWARN_ALL;
2302 PL_dowarn |= G_WARN_ONCE ;
2305 if (specialWARN(PL_compiling.cop_warnings))
2306 PL_compiling.cop_warnings = newSVsv(sv) ;
2308 sv_setsv(PL_compiling.cop_warnings, sv);
2309 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2310 PL_dowarn |= G_WARN_ONCE ;
2318 if (PL_localizing) {
2319 if (PL_localizing == 1)
2320 SAVESPTR(PL_last_in_gv);
2322 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2323 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2326 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2327 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2328 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2331 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2332 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2333 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2336 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2339 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2340 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2341 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2344 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2348 IO * const io = GvIOp(PL_defoutgv);
2351 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2352 IoFLAGS(io) &= ~IOf_FLUSH;
2354 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2355 PerlIO *ofp = IoOFP(io);
2357 (void)PerlIO_flush(ofp);
2358 IoFLAGS(io) |= IOf_FLUSH;
2364 SvREFCNT_dec(PL_rs);
2365 PL_rs = newSVsv(sv);
2369 SvREFCNT_dec(PL_ors_sv);
2370 if (SvOK(sv) || SvGMAGICAL(sv)) {
2371 PL_ors_sv = newSVsv(sv);
2379 SvREFCNT_dec(PL_ofs_sv);
2380 if (SvOK(sv) || SvGMAGICAL(sv)) {
2381 PL_ofs_sv = newSVsv(sv);
2388 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2391 #ifdef COMPLEX_STATUS
2392 if (PL_localizing == 2) {
2393 PL_statusvalue = LvTARGOFF(sv);
2394 PL_statusvalue_vms = LvTARGLEN(sv);
2398 #ifdef VMSISH_STATUS
2400 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2403 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2408 # define PERL_VMS_BANG vaxc$errno
2410 # define PERL_VMS_BANG 0
2412 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2413 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2417 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2418 if (PL_delaymagic) {
2419 PL_delaymagic |= DM_RUID;
2420 break; /* don't do magic till later */
2423 (void)setruid((Uid_t)PL_uid);
2426 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2428 #ifdef HAS_SETRESUID
2429 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2431 if (PL_uid == PL_euid) { /* special case $< = $> */
2433 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2434 if (PL_uid != 0 && PerlProc_getuid() == 0)
2435 (void)PerlProc_setuid(0);
2437 (void)PerlProc_setuid(PL_uid);
2439 PL_uid = PerlProc_getuid();
2440 Perl_croak(aTHX_ "setruid() not implemented");
2445 PL_uid = PerlProc_getuid();
2446 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2449 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2450 if (PL_delaymagic) {
2451 PL_delaymagic |= DM_EUID;
2452 break; /* don't do magic till later */
2455 (void)seteuid((Uid_t)PL_euid);
2458 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2460 #ifdef HAS_SETRESUID
2461 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2463 if (PL_euid == PL_uid) /* special case $> = $< */
2464 PerlProc_setuid(PL_euid);
2466 PL_euid = PerlProc_geteuid();
2467 Perl_croak(aTHX_ "seteuid() not implemented");
2472 PL_euid = PerlProc_geteuid();
2473 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2476 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2477 if (PL_delaymagic) {
2478 PL_delaymagic |= DM_RGID;
2479 break; /* don't do magic till later */
2482 (void)setrgid((Gid_t)PL_gid);
2485 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2487 #ifdef HAS_SETRESGID
2488 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2490 if (PL_gid == PL_egid) /* special case $( = $) */
2491 (void)PerlProc_setgid(PL_gid);
2493 PL_gid = PerlProc_getgid();
2494 Perl_croak(aTHX_ "setrgid() not implemented");
2499 PL_gid = PerlProc_getgid();
2500 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2503 #ifdef HAS_SETGROUPS
2505 const char *p = SvPV_const(sv, len);
2506 Groups_t gary[NGROUPS];
2511 for (i = 0; i < NGROUPS; ++i) {
2512 while (*p && !isSPACE(*p))
2521 (void)setgroups(i, gary);
2523 #else /* HAS_SETGROUPS */
2524 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2525 #endif /* HAS_SETGROUPS */
2526 if (PL_delaymagic) {
2527 PL_delaymagic |= DM_EGID;
2528 break; /* don't do magic till later */
2531 (void)setegid((Gid_t)PL_egid);
2534 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2536 #ifdef HAS_SETRESGID
2537 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2539 if (PL_egid == PL_gid) /* special case $) = $( */
2540 (void)PerlProc_setgid(PL_egid);
2542 PL_egid = PerlProc_getegid();
2543 Perl_croak(aTHX_ "setegid() not implemented");
2548 PL_egid = PerlProc_getegid();
2549 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2552 PL_chopset = SvPV_force(sv,len);
2554 #ifndef MACOS_TRADITIONAL
2556 LOCK_DOLLARZERO_MUTEX;
2557 #ifdef HAS_SETPROCTITLE
2558 /* The BSDs don't show the argv[] in ps(1) output, they
2559 * show a string from the process struct and provide
2560 * the setproctitle() routine to manipulate that. */
2562 s = SvPV_const(sv, len);
2563 # if __FreeBSD_version > 410001
2564 /* The leading "-" removes the "perl: " prefix,
2565 * but not the "(perl) suffix from the ps(1)
2566 * output, because that's what ps(1) shows if the
2567 * argv[] is modified. */
2568 setproctitle("-%s", s);
2569 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2570 /* This doesn't really work if you assume that
2571 * $0 = 'foobar'; will wipe out 'perl' from the $0
2572 * because in ps(1) output the result will be like
2573 * sprintf("perl: %s (perl)", s)
2574 * I guess this is a security feature:
2575 * one (a user process) cannot get rid of the original name.
2577 setproctitle("%s", s);
2581 #if defined(__hpux) && defined(PSTAT_SETCMD)
2584 s = SvPV_const(sv, len);
2585 un.pst_command = (char *)s;
2586 pstat(PSTAT_SETCMD, un, len, 0, 0);
2589 /* PL_origalen is set in perl_parse(). */
2590 s = SvPV_force(sv,len);
2591 if (len >= (STRLEN)PL_origalen-1) {
2592 /* Longer than original, will be truncated. We assume that
2593 * PL_origalen bytes are available. */
2594 Copy(s, PL_origargv[0], PL_origalen-1, char);
2597 /* Shorter than original, will be padded. */
2598 Copy(s, PL_origargv[0], len, char);
2599 PL_origargv[0][len] = 0;
2600 memset(PL_origargv[0] + len + 1,
2601 /* Is the space counterintuitive? Yes.
2602 * (You were expecting \0?)
2603 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2606 PL_origalen - len - 1);
2608 PL_origargv[0][PL_origalen-1] = 0;
2609 for (i = 1; i < PL_origargc; i++)
2611 UNLOCK_DOLLARZERO_MUTEX;
2619 Perl_whichsig(pTHX_ const char *sig)
2621 register char* const* sigv;
2623 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2624 if (strEQ(sig,*sigv))
2625 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2627 if (strEQ(sig,"CHLD"))
2631 if (strEQ(sig,"CLD"))
2638 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2639 Perl_sighandler(int sig, ...)
2641 Perl_sighandler(int sig)
2644 #ifdef PERL_GET_SIG_CONTEXT
2645 dTHXa(PERL_GET_SIG_CONTEXT);
2652 SV * const tSv = PL_Sv;
2656 XPV * const tXpv = PL_Xpv;
2658 if (PL_savestack_ix + 15 <= PL_savestack_max)
2660 if (PL_markstack_ptr < PL_markstack_max - 2)
2662 if (PL_scopestack_ix < PL_scopestack_max - 3)
2665 if (!PL_psig_ptr[sig]) {
2666 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2671 /* Max number of items pushed there is 3*n or 4. We cannot fix
2672 infinity, so we fix 4 (in fact 5): */
2674 PL_savestack_ix += 5; /* Protect save in progress. */
2675 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2678 PL_markstack_ptr++; /* Protect mark. */
2680 PL_scopestack_ix += 1;
2681 /* sv_2cv is too complicated, try a simpler variant first: */
2682 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2683 || SvTYPE(cv) != SVt_PVCV) {
2685 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2688 if (!cv || !CvROOT(cv)) {
2689 if (ckWARN(WARN_SIGNAL))
2690 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2691 PL_sig_name[sig], (gv ? GvENAME(gv)
2698 if(PL_psig_name[sig]) {
2699 sv = SvREFCNT_inc(PL_psig_name[sig]);
2701 #if !defined(PERL_IMPLICIT_CONTEXT)
2705 sv = sv_newmortal();
2706 sv_setpv(sv,PL_sig_name[sig]);
2709 PUSHSTACKi(PERLSI_SIGNAL);
2712 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2714 struct sigaction oact;
2716 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2720 va_start(args, sig);
2721 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2724 SV *rv = newRV_noinc((SV*)sih);
2725 /* The siginfo fields signo, code, errno, pid, uid,
2726 * addr, status, and band are defined by POSIX/SUSv3. */
2727 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2728 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2729 #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. */
2730 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2731 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2732 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2733 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2734 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2735 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2739 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2746 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2749 if (SvTRUE(ERRSV)) {
2751 #ifdef HAS_SIGPROCMASK
2752 /* Handler "died", for example to get out of a restart-able read().
2753 * Before we re-do that on its behalf re-enable the signal which was
2754 * blocked by the system when we entered.
2758 sigaddset(&set,sig);
2759 sigprocmask(SIG_UNBLOCK, &set, NULL);
2761 /* Not clear if this will work */
2762 (void)rsignal(sig, SIG_IGN);
2763 (void)rsignal(sig, PL_csighandlerp);
2765 #endif /* !PERL_MICRO */
2766 Perl_die(aTHX_ Nullch);
2770 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2774 PL_scopestack_ix -= 1;
2777 PL_op = myop; /* Apparently not needed... */
2779 PL_Sv = tSv; /* Restore global temporaries. */
2786 S_restore_magic(pTHX_ const void *p)
2788 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2789 SV* const sv = mgs->mgs_sv;
2794 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2796 #ifdef PERL_OLD_COPY_ON_WRITE
2797 /* While magic was saved (and off) sv_setsv may well have seen
2798 this SV as a prime candidate for COW. */
2800 sv_force_normal(sv);
2804 SvFLAGS(sv) |= mgs->mgs_flags;
2807 if (SvGMAGICAL(sv)) {
2808 /* downgrade public flags to private,
2809 and discard any other private flags */
2811 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2813 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2814 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2819 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2821 /* If we're still on top of the stack, pop us off. (That condition
2822 * will be satisfied if restore_magic was called explicitly, but *not*
2823 * if it's being called via leave_scope.)
2824 * The reason for doing this is that otherwise, things like sv_2cv()
2825 * may leave alloc gunk on the savestack, and some code
2826 * (e.g. sighandler) doesn't expect that...
2828 if (PL_savestack_ix == mgs->mgs_ss_ix)
2830 I32 popval = SSPOPINT;
2831 assert(popval == SAVEt_DESTRUCTOR_X);
2832 PL_savestack_ix -= 2;
2834 assert(popval == SAVEt_ALLOC);
2836 PL_savestack_ix -= popval;
2842 S_unwind_handler_stack(pTHX_ const void *p)
2845 const U32 flags = *(const U32*)p;
2848 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2849 /* cxstack_ix-- Not needed, die already unwound it. */
2850 #if !defined(PERL_IMPLICIT_CONTEXT)
2852 SvREFCNT_dec(PL_sig_sv);
2858 * c-indentation-style: bsd
2860 * indent-tabs-mode: t
2863 * ex: set ts=8 sts=4 sw=4 noet: