3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
52 # include <sys/pstat.h>
55 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
56 Signal_t Perl_csighandler(int sig, ...);
58 Signal_t Perl_csighandler(int sig);
62 /* Missing protos on LynxOS */
63 void setruid(uid_t id);
64 void seteuid(uid_t id);
65 void setrgid(uid_t id);
66 void setegid(uid_t id);
70 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
78 /* MGS is typedef'ed to struct magic_state in perl.h */
81 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
84 assert(SvMAGICAL(sv));
85 #ifdef PERL_OLD_COPY_ON_WRITE
86 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
91 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
93 mgs = SSPTR(mgs_ix, MGS*);
95 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
96 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
100 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
104 =for apidoc mg_magical
106 Turns on the magical status of an SV. See C<sv_magic>.
112 Perl_mg_magical(pTHX_ SV *sv)
115 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
116 const MGVTBL* const vtbl = mg->mg_virtual;
118 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
122 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
131 Do magic after a value is retrieved from the SV. See C<sv_magic>.
137 Perl_mg_get(pTHX_ SV *sv)
139 const I32 mgs_ix = SSNEW(sizeof(MGS));
140 const bool was_temp = (bool)SvTEMP(sv);
142 MAGIC *newmg, *head, *cur, *mg;
143 /* guard against sv having being freed midway by holding a private
146 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
147 cause the SV's buffer to get stolen (and maybe other stuff).
150 sv_2mortal(SvREFCNT_inc(sv));
155 save_magic(mgs_ix, sv);
157 /* We must call svt_get(sv, mg) for each valid entry in the linked
158 list of magic. svt_get() may delete the current entry, add new
159 magic to the head of the list, or upgrade the SV. AMS 20010810 */
161 newmg = cur = head = mg = SvMAGIC(sv);
163 const MGVTBL * const vtbl = mg->mg_virtual;
165 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
166 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
168 /* guard against magic having been deleted - eg FETCH calling
173 /* Don't restore the flags for this entry if it was deleted. */
174 if (mg->mg_flags & MGf_GSKIP)
175 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
178 mg = mg->mg_moremagic;
181 /* Have we finished with the new entries we saw? Start again
182 where we left off (unless there are more new entries). */
190 /* Were any new entries added? */
191 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
198 restore_magic(INT2PTR(void *, (IV)mgs_ix));
200 if (SvREFCNT(sv) == 1) {
201 /* We hold the last reference to this SV, which implies that the
202 SV was deleted as a side effect of the routines we called. */
211 Do magic after a value is assigned to the SV. See C<sv_magic>.
217 Perl_mg_set(pTHX_ SV *sv)
219 const I32 mgs_ix = SSNEW(sizeof(MGS));
223 save_magic(mgs_ix, sv);
225 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
226 const MGVTBL* vtbl = mg->mg_virtual;
227 nextmg = mg->mg_moremagic; /* it may delete itself */
228 if (mg->mg_flags & MGf_GSKIP) {
229 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
230 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
232 if (vtbl && vtbl->svt_set)
233 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
236 restore_magic(INT2PTR(void*, (IV)mgs_ix));
241 =for apidoc mg_length
243 Report on the SV's length. See C<sv_magic>.
249 Perl_mg_length(pTHX_ SV *sv)
254 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
255 const MGVTBL * const vtbl = mg->mg_virtual;
256 if (vtbl && vtbl->svt_len) {
257 const I32 mgs_ix = SSNEW(sizeof(MGS));
258 save_magic(mgs_ix, sv);
259 /* omit MGf_GSKIP -- not changed here */
260 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
261 restore_magic(INT2PTR(void*, (IV)mgs_ix));
267 const U8 *s = (U8*)SvPV_const(sv, len);
268 len = Perl_utf8_length(aTHX_ s, s + len);
271 (void)SvPV_const(sv, len);
276 Perl_mg_size(pTHX_ SV *sv)
280 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
281 const MGVTBL* const vtbl = mg->mg_virtual;
282 if (vtbl && vtbl->svt_len) {
283 const I32 mgs_ix = SSNEW(sizeof(MGS));
285 save_magic(mgs_ix, sv);
286 /* omit MGf_GSKIP -- not changed here */
287 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
288 restore_magic(INT2PTR(void*, (IV)mgs_ix));
295 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
299 Perl_croak(aTHX_ "Size magic not implemented");
308 Clear something magical that the SV represents. See C<sv_magic>.
314 Perl_mg_clear(pTHX_ SV *sv)
316 const I32 mgs_ix = SSNEW(sizeof(MGS));
319 save_magic(mgs_ix, sv);
321 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
322 const MGVTBL* const vtbl = mg->mg_virtual;
323 /* omit GSKIP -- never set here */
325 if (vtbl && vtbl->svt_clear)
326 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
329 restore_magic(INT2PTR(void*, (IV)mgs_ix));
336 Finds the magic pointer for type matching the SV. See C<sv_magic>.
342 Perl_mg_find(pTHX_ const SV *sv, int type)
346 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
347 if (mg->mg_type == type)
357 Copies the magic from one SV to another. See C<sv_magic>.
363 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
367 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
368 const MGVTBL* const vtbl = mg->mg_virtual;
369 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
370 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
372 else if (isUPPER(mg->mg_type)) {
374 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
375 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
377 toLOWER(mg->mg_type), key, klen);
385 =for apidoc mg_localize
387 Copy some of the magic from an existing SV to new localized version of
388 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
389 doesn't (eg taint, pos).
395 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
398 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
399 const MGVTBL* const vtbl = mg->mg_virtual;
400 switch (mg->mg_type) {
401 /* value magic types: don't copy */
404 case PERL_MAGIC_regex_global:
405 case PERL_MAGIC_nkeys:
406 #ifdef USE_LOCALE_COLLATE
407 case PERL_MAGIC_collxfrm:
410 case PERL_MAGIC_taint:
412 case PERL_MAGIC_vstring:
413 case PERL_MAGIC_utf8:
414 case PERL_MAGIC_substr:
415 case PERL_MAGIC_defelem:
416 case PERL_MAGIC_arylen:
418 case PERL_MAGIC_backref:
419 case PERL_MAGIC_arylen_p:
420 case PERL_MAGIC_rhash:
421 case PERL_MAGIC_symtab:
425 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
426 /* XXX calling the copy method is probably not correct. DAPM */
427 (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
428 mg->mg_ptr, mg->mg_len);
431 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
432 mg->mg_ptr, mg->mg_len);
434 /* container types should remain read-only across localization */
435 SvFLAGS(nsv) |= SvREADONLY(sv);
438 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
439 SvFLAGS(nsv) |= SvMAGICAL(sv);
449 Free any magic storage used by the SV. See C<sv_magic>.
455 Perl_mg_free(pTHX_ SV *sv)
459 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
460 const MGVTBL* const vtbl = mg->mg_virtual;
461 moremagic = mg->mg_moremagic;
462 if (vtbl && vtbl->svt_free)
463 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
464 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
465 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
466 Safefree(mg->mg_ptr);
467 else if (mg->mg_len == HEf_SVKEY)
468 SvREFCNT_dec((SV*)mg->mg_ptr);
470 if (mg->mg_flags & MGf_REFCOUNTED)
471 SvREFCNT_dec(mg->mg_obj);
474 SvMAGIC_set(sv, NULL);
481 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
483 register const REGEXP *rx;
486 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
487 if (mg->mg_obj) /* @+ */
490 return rx->lastparen;
497 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
501 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
502 register const I32 paren = mg->mg_len;
507 if (paren <= (I32)rx->nparens &&
508 (s = rx->startp[paren]) != -1 &&
509 (t = rx->endp[paren]) != -1)
512 if (mg->mg_obj) /* @+ */
517 if (i > 0 && RX_MATCH_UTF8(rx)) {
518 const char * const b = rx->subbeg;
520 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
530 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
532 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
533 Perl_croak(aTHX_ PL_no_modify);
534 NORETURN_FUNCTION_END;
538 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
542 register const REGEXP *rx;
545 switch (*mg->mg_ptr) {
546 case '1': case '2': case '3': case '4':
547 case '5': case '6': case '7': case '8': case '9': case '&':
548 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
550 paren = atoi(mg->mg_ptr); /* $& is in [0] */
552 if (paren <= (I32)rx->nparens &&
553 (s1 = rx->startp[paren]) != -1 &&
554 (t1 = rx->endp[paren]) != -1)
558 if (i > 0 && RX_MATCH_UTF8(rx)) {
559 const char * const s = rx->subbeg + s1;
564 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
568 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
572 if (ckWARN(WARN_UNINITIALIZED))
577 if (ckWARN(WARN_UNINITIALIZED))
582 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
583 paren = rx->lastparen;
588 case '\016': /* ^N */
589 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
590 paren = rx->lastcloseparen;
596 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
597 if (rx->startp[0] != -1) {
608 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
609 if (rx->endp[0] != -1) {
610 i = rx->sublen - rx->endp[0];
621 if (!SvPOK(sv) && SvNIOK(sv)) {
629 #define SvRTRIM(sv) STMT_START { \
630 STRLEN len = SvCUR(sv); \
631 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
633 SvCUR_set(sv, len); \
637 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
641 register char *s = NULL;
645 switch (*mg->mg_ptr) {
646 case '\001': /* ^A */
647 sv_setsv(sv, PL_bodytarget);
649 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
650 if (*(mg->mg_ptr+1) == '\0') {
651 sv_setiv(sv, (IV)PL_minus_c);
653 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
654 sv_setiv(sv, (IV)STATUS_NATIVE);
658 case '\004': /* ^D */
659 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
661 case '\005': /* ^E */
662 if (*(mg->mg_ptr+1) == '\0') {
663 #ifdef MACOS_TRADITIONAL
667 sv_setnv(sv,(double)gMacPerl_OSErr);
668 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
673 # include <descrip.h>
674 # include <starlet.h>
676 $DESCRIPTOR(msgdsc,msg);
677 sv_setnv(sv,(NV) vaxc$errno);
678 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
679 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
685 if (!(_emx_env & 0x200)) { /* Under DOS */
686 sv_setnv(sv, (NV)errno);
687 sv_setpv(sv, errno ? Strerror(errno) : "");
689 if (errno != errno_isOS2) {
690 int tmp = _syserrno();
691 if (tmp) /* 2nd call to _syserrno() makes it 0 */
694 sv_setnv(sv, (NV)Perl_rc);
695 sv_setpv(sv, os2error(Perl_rc));
700 DWORD dwErr = GetLastError();
701 sv_setnv(sv, (NV)dwErr);
704 PerlProc_GetOSError(sv, dwErr);
707 sv_setpvn(sv, "", 0);
712 const int saveerrno = errno;
713 sv_setnv(sv, (NV)errno);
714 sv_setpv(sv, errno ? Strerror(errno) : "");
722 SvNOK_on(sv); /* what a wonderful hack! */
724 else if (strEQ(mg->mg_ptr+1, "NCODING"))
725 sv_setsv(sv, PL_encoding);
727 case '\006': /* ^F */
728 sv_setiv(sv, (IV)PL_maxsysfd);
730 case '\010': /* ^H */
731 sv_setiv(sv, (IV)PL_hints);
733 case '\011': /* ^I */ /* NOT \t in EBCDIC */
735 sv_setpv(sv, PL_inplace);
737 sv_setsv(sv, &PL_sv_undef);
739 case '\017': /* ^O & ^OPEN */
740 if (*(mg->mg_ptr+1) == '\0') {
741 sv_setpv(sv, PL_osname);
744 else if (strEQ(mg->mg_ptr, "\017PEN")) {
745 if (!PL_compiling.cop_io)
746 sv_setsv(sv, &PL_sv_undef);
748 sv_setsv(sv, PL_compiling.cop_io);
752 case '\020': /* ^P */
753 sv_setiv(sv, (IV)PL_perldb);
755 case '\023': /* ^S */
756 if (*(mg->mg_ptr+1) == '\0') {
757 if (PL_lex_state != LEX_NOTPARSING)
760 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
765 case '\024': /* ^T */
766 if (*(mg->mg_ptr+1) == '\0') {
768 sv_setnv(sv, PL_basetime);
770 sv_setiv(sv, (IV)PL_basetime);
773 else if (strEQ(mg->mg_ptr, "\024AINT"))
774 sv_setiv(sv, PL_tainting
775 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
778 case '\025': /* $^UNICODE, $^UTF8LOCALE */
779 if (strEQ(mg->mg_ptr, "\025NICODE"))
780 sv_setuv(sv, (UV) PL_unicode);
781 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
782 sv_setuv(sv, (UV) PL_utf8locale);
784 case '\027': /* ^W & $^WARNING_BITS */
785 if (*(mg->mg_ptr+1) == '\0')
786 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
787 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
788 if (PL_compiling.cop_warnings == pWARN_NONE) {
789 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
791 else if (PL_compiling.cop_warnings == pWARN_STD) {
794 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
798 else if (PL_compiling.cop_warnings == pWARN_ALL) {
799 /* Get the bit mask for $warnings::Bits{all}, because
800 * it could have been extended by warnings::register */
802 HV *bits=get_hv("warnings::Bits", FALSE);
803 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
804 sv_setsv(sv, *bits_all);
807 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
811 sv_setsv(sv, PL_compiling.cop_warnings);
816 case '1': case '2': case '3': case '4':
817 case '5': case '6': case '7': case '8': case '9': case '&':
818 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
822 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
823 * XXX Does the new way break anything?
825 paren = atoi(mg->mg_ptr); /* $& is in [0] */
827 if (paren <= (I32)rx->nparens &&
828 (s1 = rx->startp[paren]) != -1 &&
829 (t1 = rx->endp[paren]) != -1)
839 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
844 if (RX_MATCH_TAINTED(rx)) {
845 MAGIC* mg = SvMAGIC(sv);
848 SvMAGIC_set(sv, mg->mg_moremagic);
850 if ((mgt = SvMAGIC(sv))) {
851 mg->mg_moremagic = mgt;
861 sv_setsv(sv,&PL_sv_undef);
864 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
865 paren = rx->lastparen;
869 sv_setsv(sv,&PL_sv_undef);
871 case '\016': /* ^N */
872 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
873 paren = rx->lastcloseparen;
877 sv_setsv(sv,&PL_sv_undef);
880 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
881 if ((s = rx->subbeg) && rx->startp[0] != -1) {
886 sv_setsv(sv,&PL_sv_undef);
889 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
890 if (rx->subbeg && rx->endp[0] != -1) {
891 s = rx->subbeg + rx->endp[0];
892 i = rx->sublen - rx->endp[0];
896 sv_setsv(sv,&PL_sv_undef);
899 if (GvIO(PL_last_in_gv)) {
900 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
905 sv_setiv(sv, (IV)STATUS_CURRENT);
906 #ifdef COMPLEX_STATUS
907 LvTARGOFF(sv) = PL_statusvalue;
908 LvTARGLEN(sv) = PL_statusvalue_vms;
913 if (GvIOp(PL_defoutgv))
914 s = IoTOP_NAME(GvIOp(PL_defoutgv));
918 sv_setpv(sv,GvENAME(PL_defoutgv));
923 if (GvIOp(PL_defoutgv))
924 s = IoFMT_NAME(GvIOp(PL_defoutgv));
926 s = GvENAME(PL_defoutgv);
930 if (GvIOp(PL_defoutgv))
931 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
934 if (GvIOp(PL_defoutgv))
935 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
938 if (GvIOp(PL_defoutgv))
939 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
946 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
949 if (GvIOp(PL_defoutgv))
950 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
956 sv_copypv(sv, PL_ors_sv);
960 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
961 sv_setpv(sv, errno ? Strerror(errno) : "");
964 const int saveerrno = errno;
965 sv_setnv(sv, (NV)errno);
967 if (errno == errno_isOS2 || errno == errno_isOS2_set)
968 sv_setpv(sv, os2error(Perl_rc));
971 sv_setpv(sv, errno ? Strerror(errno) : "");
976 SvNOK_on(sv); /* what a wonderful hack! */
979 sv_setiv(sv, (IV)PL_uid);
982 sv_setiv(sv, (IV)PL_euid);
985 sv_setiv(sv, (IV)PL_gid);
987 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
991 sv_setiv(sv, (IV)PL_egid);
993 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
998 Groups_t gary[NGROUPS];
999 I32 j = getgroups(NGROUPS,gary);
1001 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
1004 (void)SvIOK_on(sv); /* what a wonderful hack! */
1006 #ifndef MACOS_TRADITIONAL
1015 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1017 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1019 if (uf && uf->uf_val)
1020 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1025 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1032 s = SvPV_const(sv,len);
1033 ptr = MgPV_const(mg,klen);
1036 #ifdef DYNAMIC_ENV_FETCH
1037 /* We just undefd an environment var. Is a replacement */
1038 /* waiting in the wings? */
1041 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1042 s = SvPV_const(*valp, len);
1046 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1047 /* And you'll never guess what the dog had */
1048 /* in its mouth... */
1050 MgTAINTEDDIR_off(mg);
1052 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1053 char pathbuf[256], eltbuf[256], *cp, *elt;
1057 strncpy(eltbuf, s, 255);
1060 do { /* DCL$PATH may be a search list */
1061 while (1) { /* as may dev portion of any element */
1062 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1063 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1064 cando_by_name(S_IWUSR,0,elt) ) {
1065 MgTAINTEDDIR_on(mg);
1069 if ((cp = strchr(elt, ':')) != Nullch)
1071 if (my_trnlnm(elt, eltbuf, j++))
1077 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1080 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1081 const char * const strend = s + len;
1083 while (s < strend) {
1087 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1088 s, strend, ':', &i);
1090 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1092 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1093 MgTAINTEDDIR_on(mg);
1099 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1105 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1107 PERL_UNUSED_ARG(sv);
1108 my_setenv(MgPV_nolen_const(mg),Nullch);
1113 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1115 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1116 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1118 if (PL_localizing) {
1120 magic_clear_all_env(sv,mg);
1121 hv_iterinit((HV*)sv);
1122 while ((entry = hv_iternext((HV*)sv))) {
1124 my_setenv(hv_iterkey(entry, &keylen),
1125 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1133 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1137 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1138 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1140 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1143 # ifdef USE_ENVIRON_ARRAY
1144 # if defined(USE_ITHREADS)
1145 /* only the parent thread can clobber the process environment */
1146 if (PL_curinterp == aTHX)
1149 # ifndef PERL_USE_SAFE_PUTENV
1150 if (!PL_use_safe_putenv) {
1153 if (environ == PL_origenviron)
1154 environ = (char**)safesysmalloc(sizeof(char*));
1156 for (i = 0; environ[i]; i++)
1157 safesysfree(environ[i]);
1159 # endif /* PERL_USE_SAFE_PUTENV */
1161 environ[0] = Nullch;
1163 # endif /* USE_ENVIRON_ARRAY */
1164 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1165 #endif /* VMS || EPOC */
1166 #endif /* !PERL_MICRO */
1167 PERL_UNUSED_ARG(sv);
1168 PERL_UNUSED_ARG(mg);
1173 #ifdef HAS_SIGPROCMASK
1175 restore_sigmask(pTHX_ SV *save_sv)
1177 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1178 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1182 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1184 /* Are we fetching a signal entry? */
1185 const I32 i = whichsig(MgPV_nolen_const(mg));
1188 sv_setsv(sv,PL_psig_ptr[i]);
1190 Sighandler_t sigstate;
1191 sigstate = rsignal_state(i);
1192 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1193 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1195 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1196 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1198 /* cache state so we don't fetch it again */
1199 if(sigstate == (Sighandler_t) SIG_IGN)
1200 sv_setpv(sv,"IGNORE");
1202 sv_setsv(sv,&PL_sv_undef);
1203 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1210 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1212 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1213 * refactoring might be in order.
1216 register const char * const s = MgPV_nolen_const(mg);
1217 PERL_UNUSED_ARG(sv);
1220 if (strEQ(s,"__DIE__"))
1222 else if (strEQ(s,"__WARN__"))
1225 Perl_croak(aTHX_ "No such hook: %s", s);
1227 SV * const to_dec = *svp;
1229 SvREFCNT_dec(to_dec);
1233 /* Are we clearing a signal entry? */
1234 const I32 i = whichsig(s);
1236 #ifdef HAS_SIGPROCMASK
1239 /* Avoid having the signal arrive at a bad time, if possible. */
1242 sigprocmask(SIG_BLOCK, &set, &save);
1244 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1245 SAVEFREESV(save_sv);
1246 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1249 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1250 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1252 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1253 PL_sig_defaulting[i] = 1;
1254 (void)rsignal(i, PL_csighandlerp);
1256 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1258 if(PL_psig_name[i]) {
1259 SvREFCNT_dec(PL_psig_name[i]);
1262 if(PL_psig_ptr[i]) {
1263 SV *to_dec=PL_psig_ptr[i];
1266 SvREFCNT_dec(to_dec);
1276 S_raise_signal(pTHX_ int sig)
1278 /* Set a flag to say this signal is pending */
1279 PL_psig_pend[sig]++;
1280 /* And one to say _a_ signal is pending */
1285 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1286 Perl_csighandler(int sig, ...)
1288 Perl_csighandler(int sig)
1291 #ifdef PERL_GET_SIG_CONTEXT
1292 dTHXa(PERL_GET_SIG_CONTEXT);
1296 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1297 (void) rsignal(sig, PL_csighandlerp);
1298 if (PL_sig_ignoring[sig]) return;
1300 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1301 if (PL_sig_defaulting[sig])
1302 #ifdef KILL_BY_SIGPRC
1303 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1308 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1309 /* Call the perl level handler now--
1310 * with risk we may be in malloc() etc. */
1311 (*PL_sighandlerp)(sig);
1313 S_raise_signal(aTHX_ sig);
1316 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1318 Perl_csighandler_init(void)
1321 if (PL_sig_handlers_initted) return;
1323 for (sig = 1; sig < SIG_SIZE; sig++) {
1324 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1326 PL_sig_defaulting[sig] = 1;
1327 (void) rsignal(sig, PL_csighandlerp);
1329 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1330 PL_sig_ignoring[sig] = 0;
1333 PL_sig_handlers_initted = 1;
1338 Perl_despatch_signals(pTHX)
1342 for (sig = 1; sig < SIG_SIZE; sig++) {
1343 if (PL_psig_pend[sig]) {
1344 PERL_BLOCKSIG_ADD(set, sig);
1345 PL_psig_pend[sig] = 0;
1346 PERL_BLOCKSIG_BLOCK(set);
1347 (*PL_sighandlerp)(sig);
1348 PERL_BLOCKSIG_UNBLOCK(set);
1354 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1359 /* Need to be careful with SvREFCNT_dec(), because that can have side
1360 * effects (due to closures). We must make sure that the new disposition
1361 * is in place before it is called.
1365 #ifdef HAS_SIGPROCMASK
1370 register const char *s = MgPV_const(mg,len);
1372 if (strEQ(s,"__DIE__"))
1374 else if (strEQ(s,"__WARN__"))
1377 Perl_croak(aTHX_ "No such hook: %s", s);
1385 i = whichsig(s); /* ...no, a brick */
1387 if (ckWARN(WARN_SIGNAL))
1388 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1391 #ifdef HAS_SIGPROCMASK
1392 /* Avoid having the signal arrive at a bad time, if possible. */
1395 sigprocmask(SIG_BLOCK, &set, &save);
1397 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1398 SAVEFREESV(save_sv);
1399 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1402 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1403 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1405 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1406 PL_sig_ignoring[i] = 0;
1408 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1409 PL_sig_defaulting[i] = 0;
1411 SvREFCNT_dec(PL_psig_name[i]);
1412 to_dec = PL_psig_ptr[i];
1413 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1414 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1415 PL_psig_name[i] = newSVpvn(s, len);
1416 SvREADONLY_on(PL_psig_name[i]);
1418 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1420 (void)rsignal(i, PL_csighandlerp);
1421 #ifdef HAS_SIGPROCMASK
1426 *svp = SvREFCNT_inc(sv);
1428 SvREFCNT_dec(to_dec);
1431 s = SvPV_force(sv,len);
1432 if (strEQ(s,"IGNORE")) {
1434 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1435 PL_sig_ignoring[i] = 1;
1436 (void)rsignal(i, PL_csighandlerp);
1438 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1442 else if (strEQ(s,"DEFAULT") || !*s) {
1444 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1446 PL_sig_defaulting[i] = 1;
1447 (void)rsignal(i, PL_csighandlerp);
1450 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1455 * We should warn if HINT_STRICT_REFS, but without
1456 * access to a known hint bit in a known OP, we can't
1457 * tell whether HINT_STRICT_REFS is in force or not.
1459 if (!strchr(s,':') && !strchr(s,'\''))
1460 sv_insert(sv, 0, 0, "main::", 6);
1462 (void)rsignal(i, PL_csighandlerp);
1464 *svp = SvREFCNT_inc(sv);
1466 #ifdef HAS_SIGPROCMASK
1471 SvREFCNT_dec(to_dec);
1474 #endif /* !PERL_MICRO */
1477 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1479 PERL_UNUSED_ARG(sv);
1480 PERL_UNUSED_ARG(mg);
1481 PL_sub_generation++;
1486 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1488 PERL_UNUSED_ARG(sv);
1489 PERL_UNUSED_ARG(mg);
1490 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1491 PL_amagic_generation++;
1497 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1499 HV * const hv = (HV*)LvTARG(sv);
1501 PERL_UNUSED_ARG(mg);
1504 (void) hv_iterinit(hv);
1505 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1508 while (hv_iternext(hv))
1513 sv_setiv(sv, (IV)i);
1518 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1520 PERL_UNUSED_ARG(mg);
1522 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1527 /* caller is responsible for stack switching/cleanup */
1529 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1535 PUSHs(SvTIED_obj(sv, mg));
1538 if (mg->mg_len >= 0)
1539 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1540 else if (mg->mg_len == HEf_SVKEY)
1541 PUSHs((SV*)mg->mg_ptr);
1543 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1544 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1552 return call_method(meth, flags);
1556 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1562 PUSHSTACKi(PERLSI_MAGIC);
1564 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1565 sv_setsv(sv, *PL_stack_sp--);
1575 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1578 mg->mg_flags |= MGf_GSKIP;
1579 magic_methpack(sv,mg,"FETCH");
1584 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1588 PUSHSTACKi(PERLSI_MAGIC);
1589 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1596 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1598 return magic_methpack(sv,mg,"DELETE");
1603 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1610 PUSHSTACKi(PERLSI_MAGIC);
1611 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1612 sv = *PL_stack_sp--;
1613 retval = (U32) SvIV(sv)-1;
1622 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1627 PUSHSTACKi(PERLSI_MAGIC);
1629 XPUSHs(SvTIED_obj(sv, mg));
1631 call_method("CLEAR", G_SCALAR|G_DISCARD);
1639 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1642 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1646 PUSHSTACKi(PERLSI_MAGIC);
1649 PUSHs(SvTIED_obj(sv, mg));
1654 if (call_method(meth, G_SCALAR))
1655 sv_setsv(key, *PL_stack_sp--);
1664 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1666 return magic_methpack(sv,mg,"EXISTS");
1670 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1673 SV *retval = &PL_sv_undef;
1674 SV * const tied = SvTIED_obj((SV*)hv, mg);
1675 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1677 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1679 if (HvEITER_get(hv))
1680 /* we are in an iteration so the hash cannot be empty */
1682 /* no xhv_eiter so now use FIRSTKEY */
1683 key = sv_newmortal();
1684 magic_nextpack((SV*)hv, mg, key);
1685 HvEITER_set(hv, NULL); /* need to reset iterator */
1686 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1689 /* there is a SCALAR method that we can call */
1691 PUSHSTACKi(PERLSI_MAGIC);
1697 if (call_method("SCALAR", G_SCALAR))
1698 retval = *PL_stack_sp--;
1705 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1707 GV * const gv = PL_DBline;
1708 const I32 i = SvTRUE(sv);
1709 SV ** const svp = av_fetch(GvAV(gv),
1710 atoi(MgPV_nolen_const(mg)), FALSE);
1711 if (svp && SvIOKp(*svp)) {
1712 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1714 /* set or clear breakpoint in the relevant control op */
1716 o->op_flags |= OPf_SPECIAL;
1718 o->op_flags &= ~OPf_SPECIAL;
1725 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1727 const AV * const obj = (AV*)mg->mg_obj;
1729 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1737 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1739 AV * const obj = (AV*)mg->mg_obj;
1741 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1743 if (ckWARN(WARN_MISC))
1744 Perl_warner(aTHX_ packWARN(WARN_MISC),
1745 "Attempt to set length of freed array");
1751 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1753 PERL_UNUSED_ARG(sv);
1754 /* during global destruction, mg_obj may already have been freed */
1755 if (PL_in_clean_all)
1758 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1761 /* arylen scalar holds a pointer back to the array, but doesn't own a
1762 reference. Hence the we (the array) are about to go away with it
1763 still pointing at us. Clear its pointer, else it would be pointing
1764 at free memory. See the comment in sv_magic about reference loops,
1765 and why it can't own a reference to us. */
1772 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1774 SV* const lsv = LvTARG(sv);
1776 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1777 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1778 if (mg && mg->mg_len >= 0) {
1781 sv_pos_b2u(lsv, &i);
1782 sv_setiv(sv, i + PL_curcop->cop_arybase);
1791 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1793 SV* const lsv = LvTARG(sv);
1800 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1801 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1805 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1806 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1808 else if (!SvOK(sv)) {
1812 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1814 pos = SvIV(sv) - PL_curcop->cop_arybase;
1817 ulen = sv_len_utf8(lsv);
1827 else if (pos > (SSize_t)len)
1832 sv_pos_u2b(lsv, &p, 0);
1837 mg->mg_flags &= ~MGf_MINMATCH;
1843 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1845 PERL_UNUSED_ARG(mg);
1846 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1848 gv_efullname3(sv,((GV*)sv), "*");
1852 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1857 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1860 PERL_UNUSED_ARG(mg);
1864 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1869 GvGP(sv) = gp_ref(GvGP(gv));
1874 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1877 SV * const lsv = LvTARG(sv);
1878 const char * const tmps = SvPV_const(lsv,len);
1879 I32 offs = LvTARGOFF(sv);
1880 I32 rem = LvTARGLEN(sv);
1881 PERL_UNUSED_ARG(mg);
1884 sv_pos_u2b(lsv, &offs, &rem);
1885 if (offs > (I32)len)
1887 if (rem + offs > (I32)len)
1889 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1896 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1899 const char *tmps = SvPV_const(sv, len);
1900 SV * const lsv = LvTARG(sv);
1901 I32 lvoff = LvTARGOFF(sv);
1902 I32 lvlen = LvTARGLEN(sv);
1903 PERL_UNUSED_ARG(mg);
1906 sv_utf8_upgrade(lsv);
1907 sv_pos_u2b(lsv, &lvoff, &lvlen);
1908 sv_insert(lsv, lvoff, lvlen, tmps, len);
1909 LvTARGLEN(sv) = sv_len_utf8(sv);
1912 else if (lsv && SvUTF8(lsv)) {
1913 sv_pos_u2b(lsv, &lvoff, &lvlen);
1914 LvTARGLEN(sv) = len;
1915 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1916 sv_insert(lsv, lvoff, lvlen, tmps, len);
1920 sv_insert(lsv, lvoff, lvlen, tmps, len);
1921 LvTARGLEN(sv) = len;
1929 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1931 PERL_UNUSED_ARG(sv);
1932 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1937 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1939 PERL_UNUSED_ARG(sv);
1940 /* update taint status unless we're restoring at scope exit */
1941 if (PL_localizing != 2) {
1951 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1953 SV * const lsv = LvTARG(sv);
1954 PERL_UNUSED_ARG(mg);
1961 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1966 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1968 PERL_UNUSED_ARG(mg);
1969 do_vecset(sv); /* XXX slurp this routine */
1974 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1977 if (LvTARGLEN(sv)) {
1979 SV * const ahv = LvTARG(sv);
1980 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1985 AV* const av = (AV*)LvTARG(sv);
1986 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1987 targ = AvARRAY(av)[LvTARGOFF(sv)];
1989 if (targ && targ != &PL_sv_undef) {
1990 /* somebody else defined it for us */
1991 SvREFCNT_dec(LvTARG(sv));
1992 LvTARG(sv) = SvREFCNT_inc(targ);
1994 SvREFCNT_dec(mg->mg_obj);
1995 mg->mg_obj = Nullsv;
1996 mg->mg_flags &= ~MGf_REFCOUNTED;
2001 sv_setsv(sv, targ ? targ : &PL_sv_undef);
2006 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2008 PERL_UNUSED_ARG(mg);
2012 sv_setsv(LvTARG(sv), sv);
2013 SvSETMAGIC(LvTARG(sv));
2019 Perl_vivify_defelem(pTHX_ SV *sv)
2024 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2027 SV * const ahv = LvTARG(sv);
2028 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2031 if (!value || value == &PL_sv_undef)
2032 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2035 AV* const av = (AV*)LvTARG(sv);
2036 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2037 LvTARG(sv) = Nullsv; /* array can't be extended */
2039 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2040 if (!svp || (value = *svp) == &PL_sv_undef)
2041 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2044 (void)SvREFCNT_inc(value);
2045 SvREFCNT_dec(LvTARG(sv));
2048 SvREFCNT_dec(mg->mg_obj);
2049 mg->mg_obj = Nullsv;
2050 mg->mg_flags &= ~MGf_REFCOUNTED;
2054 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2056 AV *const av = (AV*)mg->mg_obj;
2057 SV **svp = AvARRAY(av);
2058 PERL_UNUSED_ARG(sv);
2061 SV *const *const last = svp + AvFILLp(av);
2063 while (svp <= last) {
2065 SV *const referrer = *svp;
2066 if (SvWEAKREF(referrer)) {
2067 /* XXX Should we check that it hasn't changed? */
2068 SvRV_set(referrer, 0);
2070 SvWEAKREF_off(referrer);
2071 } else if (SvTYPE(referrer) == SVt_PVGV ||
2072 SvTYPE(referrer) == SVt_PVLV) {
2073 /* You lookin' at me? */
2074 assert(GvSTASH(referrer));
2075 assert(GvSTASH(referrer) == (HV*)sv);
2076 GvSTASH(referrer) = 0;
2079 "panic: magic_killbackrefs (flags=%"UVxf")",
2080 (UV)SvFLAGS(referrer));
2088 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2093 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2101 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2103 PERL_UNUSED_ARG(mg);
2104 sv_unmagic(sv, PERL_MAGIC_bm);
2110 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2112 PERL_UNUSED_ARG(mg);
2113 sv_unmagic(sv, PERL_MAGIC_fm);
2119 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2121 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2123 if (uf && uf->uf_set)
2124 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2129 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2131 PERL_UNUSED_ARG(mg);
2132 sv_unmagic(sv, PERL_MAGIC_qr);
2137 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2139 regexp * const re = (regexp *)mg->mg_obj;
2140 PERL_UNUSED_ARG(sv);
2146 #ifdef USE_LOCALE_COLLATE
2148 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2151 * RenE<eacute> Descartes said "I think not."
2152 * and vanished with a faint plop.
2154 PERL_UNUSED_ARG(sv);
2156 Safefree(mg->mg_ptr);
2162 #endif /* USE_LOCALE_COLLATE */
2164 /* Just clear the UTF-8 cache data. */
2166 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2168 PERL_UNUSED_ARG(sv);
2169 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2171 mg->mg_len = -1; /* The mg_len holds the len cache. */
2176 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2178 register const char *s;
2181 switch (*mg->mg_ptr) {
2182 case '\001': /* ^A */
2183 sv_setsv(PL_bodytarget, sv);
2185 case '\003': /* ^C */
2186 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2189 case '\004': /* ^D */
2191 s = SvPV_nolen_const(sv);
2192 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2193 DEBUG_x(dump_all());
2195 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2198 case '\005': /* ^E */
2199 if (*(mg->mg_ptr+1) == '\0') {
2200 #ifdef MACOS_TRADITIONAL
2201 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2204 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2207 SetLastError( SvIV(sv) );
2210 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2212 /* will anyone ever use this? */
2213 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2219 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2221 SvREFCNT_dec(PL_encoding);
2222 if (SvOK(sv) || SvGMAGICAL(sv)) {
2223 PL_encoding = newSVsv(sv);
2226 PL_encoding = Nullsv;
2230 case '\006': /* ^F */
2231 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2233 case '\010': /* ^H */
2234 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2236 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2237 Safefree(PL_inplace);
2238 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2240 case '\017': /* ^O */
2241 if (*(mg->mg_ptr+1) == '\0') {
2242 Safefree(PL_osname);
2245 TAINT_PROPER("assigning to $^O");
2246 PL_osname = savesvpv(sv);
2249 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2250 if (!PL_compiling.cop_io)
2251 PL_compiling.cop_io = newSVsv(sv);
2253 sv_setsv(PL_compiling.cop_io,sv);
2256 case '\020': /* ^P */
2257 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2258 if (PL_perldb && !PL_DBsingle)
2261 case '\024': /* ^T */
2263 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2265 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2268 case '\027': /* ^W & $^WARNING_BITS */
2269 if (*(mg->mg_ptr+1) == '\0') {
2270 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2271 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2272 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2273 | (i ? G_WARN_ON : G_WARN_OFF) ;
2276 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2277 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2278 if (!SvPOK(sv) && PL_localizing) {
2279 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2280 PL_compiling.cop_warnings = pWARN_NONE;
2285 int accumulate = 0 ;
2286 int any_fatals = 0 ;
2287 const char * const ptr = SvPV_const(sv, len) ;
2288 for (i = 0 ; i < len ; ++i) {
2289 accumulate |= ptr[i] ;
2290 any_fatals |= (ptr[i] & 0xAA) ;
2293 PL_compiling.cop_warnings = pWARN_NONE;
2294 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2295 PL_compiling.cop_warnings = pWARN_ALL;
2296 PL_dowarn |= G_WARN_ONCE ;
2299 if (specialWARN(PL_compiling.cop_warnings))
2300 PL_compiling.cop_warnings = newSVsv(sv) ;
2302 sv_setsv(PL_compiling.cop_warnings, sv);
2303 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2304 PL_dowarn |= G_WARN_ONCE ;
2312 if (PL_localizing) {
2313 if (PL_localizing == 1)
2314 SAVESPTR(PL_last_in_gv);
2316 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2317 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2320 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2321 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2322 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2325 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2326 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2327 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2330 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2333 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2334 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2335 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2338 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2342 IO * const io = GvIOp(PL_defoutgv);
2345 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2346 IoFLAGS(io) &= ~IOf_FLUSH;
2348 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2349 PerlIO *ofp = IoOFP(io);
2351 (void)PerlIO_flush(ofp);
2352 IoFLAGS(io) |= IOf_FLUSH;
2358 SvREFCNT_dec(PL_rs);
2359 PL_rs = newSVsv(sv);
2363 SvREFCNT_dec(PL_ors_sv);
2364 if (SvOK(sv) || SvGMAGICAL(sv)) {
2365 PL_ors_sv = newSVsv(sv);
2373 SvREFCNT_dec(PL_ofs_sv);
2374 if (SvOK(sv) || SvGMAGICAL(sv)) {
2375 PL_ofs_sv = newSVsv(sv);
2382 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2385 #ifdef COMPLEX_STATUS
2386 if (PL_localizing == 2) {
2387 PL_statusvalue = LvTARGOFF(sv);
2388 PL_statusvalue_vms = LvTARGLEN(sv);
2392 #ifdef VMSISH_STATUS
2394 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2397 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2402 # define PERL_VMS_BANG vaxc$errno
2404 # define PERL_VMS_BANG 0
2406 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2407 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2411 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2412 if (PL_delaymagic) {
2413 PL_delaymagic |= DM_RUID;
2414 break; /* don't do magic till later */
2417 (void)setruid((Uid_t)PL_uid);
2420 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2422 #ifdef HAS_SETRESUID
2423 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2425 if (PL_uid == PL_euid) { /* special case $< = $> */
2427 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2428 if (PL_uid != 0 && PerlProc_getuid() == 0)
2429 (void)PerlProc_setuid(0);
2431 (void)PerlProc_setuid(PL_uid);
2433 PL_uid = PerlProc_getuid();
2434 Perl_croak(aTHX_ "setruid() not implemented");
2439 PL_uid = PerlProc_getuid();
2440 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2443 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2444 if (PL_delaymagic) {
2445 PL_delaymagic |= DM_EUID;
2446 break; /* don't do magic till later */
2449 (void)seteuid((Uid_t)PL_euid);
2452 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2454 #ifdef HAS_SETRESUID
2455 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2457 if (PL_euid == PL_uid) /* special case $> = $< */
2458 PerlProc_setuid(PL_euid);
2460 PL_euid = PerlProc_geteuid();
2461 Perl_croak(aTHX_ "seteuid() not implemented");
2466 PL_euid = PerlProc_geteuid();
2467 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2470 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2471 if (PL_delaymagic) {
2472 PL_delaymagic |= DM_RGID;
2473 break; /* don't do magic till later */
2476 (void)setrgid((Gid_t)PL_gid);
2479 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2481 #ifdef HAS_SETRESGID
2482 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2484 if (PL_gid == PL_egid) /* special case $( = $) */
2485 (void)PerlProc_setgid(PL_gid);
2487 PL_gid = PerlProc_getgid();
2488 Perl_croak(aTHX_ "setrgid() not implemented");
2493 PL_gid = PerlProc_getgid();
2494 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2497 #ifdef HAS_SETGROUPS
2499 const char *p = SvPV_const(sv, len);
2500 Groups_t gary[NGROUPS];
2505 for (i = 0; i < NGROUPS; ++i) {
2506 while (*p && !isSPACE(*p))
2515 (void)setgroups(i, gary);
2517 #else /* HAS_SETGROUPS */
2518 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2519 #endif /* HAS_SETGROUPS */
2520 if (PL_delaymagic) {
2521 PL_delaymagic |= DM_EGID;
2522 break; /* don't do magic till later */
2525 (void)setegid((Gid_t)PL_egid);
2528 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2530 #ifdef HAS_SETRESGID
2531 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2533 if (PL_egid == PL_gid) /* special case $) = $( */
2534 (void)PerlProc_setgid(PL_egid);
2536 PL_egid = PerlProc_getegid();
2537 Perl_croak(aTHX_ "setegid() not implemented");
2542 PL_egid = PerlProc_getegid();
2543 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2546 PL_chopset = SvPV_force(sv,len);
2548 #ifndef MACOS_TRADITIONAL
2550 LOCK_DOLLARZERO_MUTEX;
2551 #ifdef HAS_SETPROCTITLE
2552 /* The BSDs don't show the argv[] in ps(1) output, they
2553 * show a string from the process struct and provide
2554 * the setproctitle() routine to manipulate that. */
2556 s = SvPV_const(sv, len);
2557 # if __FreeBSD_version > 410001
2558 /* The leading "-" removes the "perl: " prefix,
2559 * but not the "(perl) suffix from the ps(1)
2560 * output, because that's what ps(1) shows if the
2561 * argv[] is modified. */
2562 setproctitle("-%s", s);
2563 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2564 /* This doesn't really work if you assume that
2565 * $0 = 'foobar'; will wipe out 'perl' from the $0
2566 * because in ps(1) output the result will be like
2567 * sprintf("perl: %s (perl)", s)
2568 * I guess this is a security feature:
2569 * one (a user process) cannot get rid of the original name.
2571 setproctitle("%s", s);
2575 #if defined(__hpux) && defined(PSTAT_SETCMD)
2578 s = SvPV_const(sv, len);
2579 un.pst_command = (char *)s;
2580 pstat(PSTAT_SETCMD, un, len, 0, 0);
2583 /* PL_origalen is set in perl_parse(). */
2584 s = SvPV_force(sv,len);
2585 if (len >= (STRLEN)PL_origalen-1) {
2586 /* Longer than original, will be truncated. We assume that
2587 * PL_origalen bytes are available. */
2588 Copy(s, PL_origargv[0], PL_origalen-1, char);
2591 /* Shorter than original, will be padded. */
2592 Copy(s, PL_origargv[0], len, char);
2593 PL_origargv[0][len] = 0;
2594 memset(PL_origargv[0] + len + 1,
2595 /* Is the space counterintuitive? Yes.
2596 * (You were expecting \0?)
2597 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2600 PL_origalen - len - 1);
2602 PL_origargv[0][PL_origalen-1] = 0;
2603 for (i = 1; i < PL_origargc; i++)
2605 UNLOCK_DOLLARZERO_MUTEX;
2613 Perl_whichsig(pTHX_ const char *sig)
2615 register char* const* sigv;
2617 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2618 if (strEQ(sig,*sigv))
2619 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2621 if (strEQ(sig,"CHLD"))
2625 if (strEQ(sig,"CLD"))
2632 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2633 Perl_sighandler(int sig, ...)
2635 Perl_sighandler(int sig)
2638 #ifdef PERL_GET_SIG_CONTEXT
2639 dTHXa(PERL_GET_SIG_CONTEXT);
2646 SV * const tSv = PL_Sv;
2650 XPV * const tXpv = PL_Xpv;
2652 if (PL_savestack_ix + 15 <= PL_savestack_max)
2654 if (PL_markstack_ptr < PL_markstack_max - 2)
2656 if (PL_scopestack_ix < PL_scopestack_max - 3)
2659 if (!PL_psig_ptr[sig]) {
2660 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2665 /* Max number of items pushed there is 3*n or 4. We cannot fix
2666 infinity, so we fix 4 (in fact 5): */
2668 PL_savestack_ix += 5; /* Protect save in progress. */
2669 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2672 PL_markstack_ptr++; /* Protect mark. */
2674 PL_scopestack_ix += 1;
2675 /* sv_2cv is too complicated, try a simpler variant first: */
2676 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2677 || SvTYPE(cv) != SVt_PVCV) {
2679 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2682 if (!cv || !CvROOT(cv)) {
2683 if (ckWARN(WARN_SIGNAL))
2684 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2685 PL_sig_name[sig], (gv ? GvENAME(gv)
2692 if(PL_psig_name[sig]) {
2693 sv = SvREFCNT_inc(PL_psig_name[sig]);
2695 #if !defined(PERL_IMPLICIT_CONTEXT)
2699 sv = sv_newmortal();
2700 sv_setpv(sv,PL_sig_name[sig]);
2703 PUSHSTACKi(PERLSI_SIGNAL);
2706 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2708 struct sigaction oact;
2710 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2714 va_start(args, sig);
2715 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2718 SV *rv = newRV_noinc((SV*)sih);
2719 /* The siginfo fields signo, code, errno, pid, uid,
2720 * addr, status, and band are defined by POSIX/SUSv3. */
2721 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2722 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2723 #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. */
2724 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2725 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2726 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2727 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2728 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2729 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2733 PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2740 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2743 if (SvTRUE(ERRSV)) {
2745 #ifdef HAS_SIGPROCMASK
2746 /* Handler "died", for example to get out of a restart-able read().
2747 * Before we re-do that on its behalf re-enable the signal which was
2748 * blocked by the system when we entered.
2752 sigaddset(&set,sig);
2753 sigprocmask(SIG_UNBLOCK, &set, NULL);
2755 /* Not clear if this will work */
2756 (void)rsignal(sig, SIG_IGN);
2757 (void)rsignal(sig, PL_csighandlerp);
2759 #endif /* !PERL_MICRO */
2760 Perl_die(aTHX_ Nullch);
2764 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2768 PL_scopestack_ix -= 1;
2771 PL_op = myop; /* Apparently not needed... */
2773 PL_Sv = tSv; /* Restore global temporaries. */
2780 S_restore_magic(pTHX_ const void *p)
2782 MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2783 SV* const sv = mgs->mgs_sv;
2788 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2790 #ifdef PERL_OLD_COPY_ON_WRITE
2791 /* While magic was saved (and off) sv_setsv may well have seen
2792 this SV as a prime candidate for COW. */
2794 sv_force_normal(sv);
2798 SvFLAGS(sv) |= mgs->mgs_flags;
2801 if (SvGMAGICAL(sv)) {
2802 /* downgrade public flags to private,
2803 and discard any other private flags */
2805 U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2807 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2808 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2813 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2815 /* If we're still on top of the stack, pop us off. (That condition
2816 * will be satisfied if restore_magic was called explicitly, but *not*
2817 * if it's being called via leave_scope.)
2818 * The reason for doing this is that otherwise, things like sv_2cv()
2819 * may leave alloc gunk on the savestack, and some code
2820 * (e.g. sighandler) doesn't expect that...
2822 if (PL_savestack_ix == mgs->mgs_ss_ix)
2824 I32 popval = SSPOPINT;
2825 assert(popval == SAVEt_DESTRUCTOR_X);
2826 PL_savestack_ix -= 2;
2828 assert(popval == SAVEt_ALLOC);
2830 PL_savestack_ix -= popval;
2836 S_unwind_handler_stack(pTHX_ const void *p)
2839 const U32 flags = *(const U32*)p;
2842 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2843 /* cxstack_ix-- Not needed, die already unwound it. */
2844 #if !defined(PERL_IMPLICIT_CONTEXT)
2846 SvREFCNT_dec(PL_sig_sv);
2852 * c-indentation-style: bsd
2854 * indent-tabs-mode: t
2857 * ex: set ts=8 sts=4 sw=4 noet: