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)
48 #if defined(HAS_SETGROUPS)
55 # include <sys/pstat.h>
58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
59 Signal_t Perl_csighandler(int sig, ...);
61 Signal_t Perl_csighandler(int sig);
65 /* Missing protos on LynxOS */
66 void setruid(uid_t id);
67 void seteuid(uid_t id);
68 void setrgid(uid_t id);
69 void setegid(uid_t id);
73 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
81 /* MGS is typedef'ed to struct magic_state in perl.h */
84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
87 assert(SvMAGICAL(sv));
88 #ifdef PERL_OLD_COPY_ON_WRITE
89 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
91 sv_force_normal_flags(sv, 0);
94 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
96 mgs = SSPTR(mgs_ix, MGS*);
98 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
99 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
103 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
107 =for apidoc mg_magical
109 Turns on the magical status of an SV. See C<sv_magic>.
115 Perl_mg_magical(pTHX_ SV *sv)
118 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
119 const MGVTBL* const vtbl = mg->mg_virtual;
121 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
125 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
134 Do magic after a value is retrieved from the SV. See C<sv_magic>.
140 Perl_mg_get(pTHX_ SV *sv)
142 const I32 mgs_ix = SSNEW(sizeof(MGS));
143 const bool was_temp = (bool)SvTEMP(sv);
145 MAGIC *newmg, *head, *cur, *mg;
146 /* guard against sv having being freed midway by holding a private
149 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
150 cause the SV's buffer to get stolen (and maybe other stuff).
153 sv_2mortal(SvREFCNT_inc(sv));
158 save_magic(mgs_ix, sv);
160 /* We must call svt_get(sv, mg) for each valid entry in the linked
161 list of magic. svt_get() may delete the current entry, add new
162 magic to the head of the list, or upgrade the SV. AMS 20010810 */
164 newmg = cur = head = mg = SvMAGIC(sv);
166 const MGVTBL * const vtbl = mg->mg_virtual;
168 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
169 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
171 /* guard against magic having been deleted - eg FETCH calling
176 /* Don't restore the flags for this entry if it was deleted. */
177 if (mg->mg_flags & MGf_GSKIP)
178 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
181 mg = mg->mg_moremagic;
184 /* Have we finished with the new entries we saw? Start again
185 where we left off (unless there are more new entries). */
193 /* Were any new entries added? */
194 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
201 restore_magic(INT2PTR(void *, (IV)mgs_ix));
203 if (SvREFCNT(sv) == 1) {
204 /* We hold the last reference to this SV, which implies that the
205 SV was deleted as a side effect of the routines we called. */
214 Do magic after a value is assigned to the SV. See C<sv_magic>.
220 Perl_mg_set(pTHX_ SV *sv)
222 const I32 mgs_ix = SSNEW(sizeof(MGS));
226 save_magic(mgs_ix, sv);
228 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
229 const MGVTBL* vtbl = mg->mg_virtual;
230 nextmg = mg->mg_moremagic; /* it may delete itself */
231 if (mg->mg_flags & MGf_GSKIP) {
232 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
233 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
235 if (vtbl && vtbl->svt_set)
236 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
239 restore_magic(INT2PTR(void*, (IV)mgs_ix));
244 =for apidoc mg_length
246 Report on the SV's length. See C<sv_magic>.
252 Perl_mg_length(pTHX_ SV *sv)
257 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
258 const MGVTBL * const vtbl = mg->mg_virtual;
259 if (vtbl && vtbl->svt_len) {
260 const I32 mgs_ix = SSNEW(sizeof(MGS));
261 save_magic(mgs_ix, sv);
262 /* omit MGf_GSKIP -- not changed here */
263 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
264 restore_magic(INT2PTR(void*, (IV)mgs_ix));
270 const U8 *s = (U8*)SvPV_const(sv, len);
271 len = Perl_utf8_length(aTHX_ s, s + len);
274 (void)SvPV_const(sv, len);
279 Perl_mg_size(pTHX_ SV *sv)
283 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
284 const MGVTBL* const vtbl = mg->mg_virtual;
285 if (vtbl && vtbl->svt_len) {
286 const I32 mgs_ix = SSNEW(sizeof(MGS));
288 save_magic(mgs_ix, sv);
289 /* omit MGf_GSKIP -- not changed here */
290 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
291 restore_magic(INT2PTR(void*, (IV)mgs_ix));
298 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
302 Perl_croak(aTHX_ "Size magic not implemented");
311 Clear something magical that the SV represents. See C<sv_magic>.
317 Perl_mg_clear(pTHX_ SV *sv)
319 const I32 mgs_ix = SSNEW(sizeof(MGS));
322 save_magic(mgs_ix, sv);
324 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
325 const MGVTBL* const vtbl = mg->mg_virtual;
326 /* omit GSKIP -- never set here */
328 if (vtbl && vtbl->svt_clear)
329 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
332 restore_magic(INT2PTR(void*, (IV)mgs_ix));
339 Finds the magic pointer for type matching the SV. See C<sv_magic>.
345 Perl_mg_find(pTHX_ const SV *sv, int type)
349 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
350 if (mg->mg_type == type)
360 Copies the magic from one SV to another. See C<sv_magic>.
366 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
370 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
371 const MGVTBL* const vtbl = mg->mg_virtual;
372 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
373 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
376 const char type = mg->mg_type;
379 (type == PERL_MAGIC_tied)
381 : (type == PERL_MAGIC_regdata && mg->mg_obj)
384 toLOWER(type), key, klen);
393 =for apidoc mg_localize
395 Copy some of the magic from an existing SV to new localized version of
396 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
397 doesn't (eg taint, pos).
403 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
406 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
407 const MGVTBL* const vtbl = mg->mg_virtual;
408 switch (mg->mg_type) {
409 /* value magic types: don't copy */
412 case PERL_MAGIC_regex_global:
413 case PERL_MAGIC_nkeys:
414 #ifdef USE_LOCALE_COLLATE
415 case PERL_MAGIC_collxfrm:
418 case PERL_MAGIC_taint:
420 case PERL_MAGIC_vstring:
421 case PERL_MAGIC_utf8:
422 case PERL_MAGIC_substr:
423 case PERL_MAGIC_defelem:
424 case PERL_MAGIC_arylen:
426 case PERL_MAGIC_backref:
427 case PERL_MAGIC_arylen_p:
428 case PERL_MAGIC_rhash:
429 case PERL_MAGIC_symtab:
433 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
434 /* XXX calling the copy method is probably not correct. DAPM */
435 (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
436 mg->mg_ptr, mg->mg_len);
439 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
440 mg->mg_ptr, mg->mg_len);
442 /* container types should remain read-only across localization */
443 SvFLAGS(nsv) |= SvREADONLY(sv);
446 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
447 SvFLAGS(nsv) |= SvMAGICAL(sv);
457 Free any magic storage used by the SV. See C<sv_magic>.
463 Perl_mg_free(pTHX_ SV *sv)
467 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
468 const MGVTBL* const vtbl = mg->mg_virtual;
469 moremagic = mg->mg_moremagic;
470 if (vtbl && vtbl->svt_free)
471 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
472 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
473 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
474 Safefree(mg->mg_ptr);
475 else if (mg->mg_len == HEf_SVKEY)
476 SvREFCNT_dec((SV*)mg->mg_ptr);
478 if (mg->mg_flags & MGf_REFCOUNTED)
479 SvREFCNT_dec(mg->mg_obj);
482 SvMAGIC_set(sv, NULL);
489 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
494 register const REGEXP * const rx = PM_GETRE(PL_curpm);
497 ? rx->nparens /* @+ */
498 : rx->lastparen; /* @- */
506 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
509 register const REGEXP * const rx = PM_GETRE(PL_curpm);
511 register const I32 paren = mg->mg_len;
516 if (paren <= (I32)rx->nparens &&
517 (s = rx->startp[paren]) != -1 &&
518 (t = rx->endp[paren]) != -1)
521 if (mg->mg_obj) /* @+ */
526 if (i > 0 && RX_MATCH_UTF8(rx)) {
527 const char * const b = rx->subbeg;
529 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
540 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
542 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
543 Perl_croak(aTHX_ PL_no_modify);
544 NORETURN_FUNCTION_END;
548 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
552 register const REGEXP *rx;
555 switch (*mg->mg_ptr) {
556 case '1': case '2': case '3': case '4':
557 case '5': case '6': case '7': case '8': case '9': case '&':
558 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
560 paren = atoi(mg->mg_ptr); /* $& is in [0] */
562 if (paren <= (I32)rx->nparens &&
563 (s1 = rx->startp[paren]) != -1 &&
564 (t1 = rx->endp[paren]) != -1)
568 if (i > 0 && RX_MATCH_UTF8(rx)) {
569 const char * const s = rx->subbeg + s1;
574 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
578 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
582 if (ckWARN(WARN_UNINITIALIZED))
587 if (ckWARN(WARN_UNINITIALIZED))
592 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
593 paren = rx->lastparen;
598 case '\016': /* ^N */
599 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
600 paren = rx->lastcloseparen;
606 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
607 if (rx->startp[0] != -1) {
618 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
619 if (rx->endp[0] != -1) {
620 i = rx->sublen - rx->endp[0];
631 if (!SvPOK(sv) && SvNIOK(sv)) {
639 #define SvRTRIM(sv) STMT_START { \
640 STRLEN len = SvCUR(sv); \
641 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
643 SvCUR_set(sv, len); \
647 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
651 register char *s = NULL;
654 const char * const remaining = mg->mg_ptr + 1;
655 const char nextchar = *remaining;
657 switch (*mg->mg_ptr) {
658 case '\001': /* ^A */
659 sv_setsv(sv, PL_bodytarget);
661 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
662 if (nextchar == '\0') {
663 sv_setiv(sv, (IV)PL_minus_c);
665 else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
666 sv_setiv(sv, (IV)STATUS_NATIVE);
670 case '\004': /* ^D */
671 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
673 case '\005': /* ^E */
674 if (nextchar == '\0') {
675 #ifdef MACOS_TRADITIONAL
679 sv_setnv(sv,(double)gMacPerl_OSErr);
680 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
685 # include <descrip.h>
686 # include <starlet.h>
688 $DESCRIPTOR(msgdsc,msg);
689 sv_setnv(sv,(NV) vaxc$errno);
690 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
691 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
697 if (!(_emx_env & 0x200)) { /* Under DOS */
698 sv_setnv(sv, (NV)errno);
699 sv_setpv(sv, errno ? Strerror(errno) : "");
701 if (errno != errno_isOS2) {
702 const int tmp = _syserrno();
703 if (tmp) /* 2nd call to _syserrno() makes it 0 */
706 sv_setnv(sv, (NV)Perl_rc);
707 sv_setpv(sv, os2error(Perl_rc));
712 DWORD dwErr = GetLastError();
713 sv_setnv(sv, (NV)dwErr);
715 PerlProc_GetOSError(sv, dwErr);
718 sv_setpvn(sv, "", 0);
723 const int saveerrno = errno;
724 sv_setnv(sv, (NV)errno);
725 sv_setpv(sv, errno ? Strerror(errno) : "");
733 SvNOK_on(sv); /* what a wonderful hack! */
735 else if (strEQ(remaining, "NCODING"))
736 sv_setsv(sv, PL_encoding);
738 case '\006': /* ^F */
739 sv_setiv(sv, (IV)PL_maxsysfd);
741 case '\010': /* ^H */
742 sv_setiv(sv, (IV)PL_hints);
744 case '\011': /* ^I */ /* NOT \t in EBCDIC */
746 sv_setpv(sv, PL_inplace);
748 sv_setsv(sv, &PL_sv_undef);
750 case '\017': /* ^O & ^OPEN */
751 if (nextchar == '\0') {
752 sv_setpv(sv, PL_osname);
755 else if (strEQ(remaining, "PEN")) {
756 if (!PL_compiling.cop_io)
757 sv_setsv(sv, &PL_sv_undef);
759 sv_setsv(sv, PL_compiling.cop_io);
763 case '\020': /* ^P */
764 sv_setiv(sv, (IV)PL_perldb);
766 case '\023': /* ^S */
767 if (nextchar == '\0') {
768 if (PL_lex_state != LEX_NOTPARSING)
771 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
776 case '\024': /* ^T */
777 if (nextchar == '\0') {
779 sv_setnv(sv, PL_basetime);
781 sv_setiv(sv, (IV)PL_basetime);
784 else if (strEQ(remaining, "AINT"))
785 sv_setiv(sv, PL_tainting
786 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
789 case '\025': /* $^UNICODE, $^UTF8LOCALE */
790 if (strEQ(remaining, "NICODE"))
791 sv_setuv(sv, (UV) PL_unicode);
792 else if (strEQ(remaining, "TF8LOCALE"))
793 sv_setuv(sv, (UV) PL_utf8locale);
795 case '\027': /* ^W & $^WARNING_BITS */
796 if (nextchar == '\0')
797 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
798 else if (strEQ(remaining, "ARNING_BITS")) {
799 if (PL_compiling.cop_warnings == pWARN_NONE) {
800 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
802 else if (PL_compiling.cop_warnings == pWARN_STD) {
805 (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
809 else if (PL_compiling.cop_warnings == pWARN_ALL) {
810 /* Get the bit mask for $warnings::Bits{all}, because
811 * it could have been extended by warnings::register */
813 HV * const bits=get_hv("warnings::Bits", FALSE);
814 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
815 sv_setsv(sv, *bits_all);
818 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
822 sv_setsv(sv, PL_compiling.cop_warnings);
827 case '1': case '2': case '3': case '4':
828 case '5': case '6': case '7': case '8': case '9': case '&':
829 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
833 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
834 * XXX Does the new way break anything?
836 paren = atoi(mg->mg_ptr); /* $& is in [0] */
838 if (paren <= (I32)rx->nparens &&
839 (s1 = rx->startp[paren]) != -1 &&
840 (t1 = rx->endp[paren]) != -1)
849 const int oldtainted = PL_tainted;
852 PL_tainted = oldtainted;
853 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
858 if (RX_MATCH_TAINTED(rx)) {
859 MAGIC* const mg = SvMAGIC(sv);
862 SvMAGIC_set(sv, mg->mg_moremagic);
864 if ((mgt = SvMAGIC(sv))) {
865 mg->mg_moremagic = mgt;
875 sv_setsv(sv,&PL_sv_undef);
878 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
879 paren = rx->lastparen;
883 sv_setsv(sv,&PL_sv_undef);
885 case '\016': /* ^N */
886 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
887 paren = rx->lastcloseparen;
891 sv_setsv(sv,&PL_sv_undef);
894 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
895 if ((s = rx->subbeg) && rx->startp[0] != -1) {
900 sv_setsv(sv,&PL_sv_undef);
903 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
904 if (rx->subbeg && rx->endp[0] != -1) {
905 s = rx->subbeg + rx->endp[0];
906 i = rx->sublen - rx->endp[0];
910 sv_setsv(sv,&PL_sv_undef);
913 if (GvIO(PL_last_in_gv)) {
914 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
919 sv_setiv(sv, (IV)STATUS_CURRENT);
920 #ifdef COMPLEX_STATUS
921 LvTARGOFF(sv) = PL_statusvalue;
922 LvTARGLEN(sv) = PL_statusvalue_vms;
927 if (GvIOp(PL_defoutgv))
928 s = IoTOP_NAME(GvIOp(PL_defoutgv));
932 sv_setpv(sv,GvENAME(PL_defoutgv));
937 if (GvIOp(PL_defoutgv))
938 s = IoFMT_NAME(GvIOp(PL_defoutgv));
940 s = GvENAME(PL_defoutgv);
944 if (GvIOp(PL_defoutgv))
945 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
948 if (GvIOp(PL_defoutgv))
949 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
952 if (GvIOp(PL_defoutgv))
953 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
960 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
963 if (GvIOp(PL_defoutgv))
964 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
970 sv_copypv(sv, PL_ors_sv);
974 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
975 sv_setpv(sv, errno ? Strerror(errno) : "");
978 const int saveerrno = errno;
979 sv_setnv(sv, (NV)errno);
981 if (errno == errno_isOS2 || errno == errno_isOS2_set)
982 sv_setpv(sv, os2error(Perl_rc));
985 sv_setpv(sv, errno ? Strerror(errno) : "");
990 SvNOK_on(sv); /* what a wonderful hack! */
993 sv_setiv(sv, (IV)PL_uid);
996 sv_setiv(sv, (IV)PL_euid);
999 sv_setiv(sv, (IV)PL_gid);
1000 #ifdef HAS_GETGROUPS
1001 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
1005 sv_setiv(sv, (IV)PL_egid);
1006 #ifdef HAS_GETGROUPS
1007 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
1010 #ifdef HAS_GETGROUPS
1012 Groups_t *gary = NULL;
1013 I32 num_groups = getgroups(0, gary);
1014 Newx(gary, num_groups, Groups_t);
1015 num_groups = getgroups(num_groups, gary);
1016 while (--num_groups >= 0)
1017 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f,
1018 (long unsigned int)gary[num_groups]);
1022 (void)SvIOK_on(sv); /* what a wonderful hack! */
1024 #ifndef MACOS_TRADITIONAL
1033 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1035 struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1037 if (uf && uf->uf_val)
1038 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1043 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1047 const char *s = SvPV_const(sv,len);
1048 const char * const ptr = MgPV_const(mg,klen);
1051 #ifdef DYNAMIC_ENV_FETCH
1052 /* We just undefd an environment var. Is a replacement */
1053 /* waiting in the wings? */
1055 SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1057 s = SvPV_const(*valp, len);
1061 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1062 /* And you'll never guess what the dog had */
1063 /* in its mouth... */
1065 MgTAINTEDDIR_off(mg);
1067 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1068 char pathbuf[256], eltbuf[256], *cp, *elt;
1072 strncpy(eltbuf, s, 255);
1075 do { /* DCL$PATH may be a search list */
1076 while (1) { /* as may dev portion of any element */
1077 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1078 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1079 cando_by_name(S_IWUSR,0,elt) ) {
1080 MgTAINTEDDIR_on(mg);
1084 if ((cp = strchr(elt, ':')) != Nullch)
1086 if (my_trnlnm(elt, eltbuf, j++))
1092 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1095 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1096 const char * const strend = s + len;
1098 while (s < strend) {
1102 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1103 s, strend, ':', &i);
1105 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1107 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1108 MgTAINTEDDIR_on(mg);
1114 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1120 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1122 PERL_UNUSED_ARG(sv);
1123 my_setenv(MgPV_nolen_const(mg),Nullch);
1128 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1130 PERL_UNUSED_ARG(mg);
1132 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1134 if (PL_localizing) {
1137 hv_iterinit((HV*)sv);
1138 while ((entry = hv_iternext((HV*)sv))) {
1140 my_setenv(hv_iterkey(entry, &keylen),
1141 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1149 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1152 PERL_UNUSED_ARG(sv);
1153 PERL_UNUSED_ARG(mg);
1155 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1163 #ifdef HAS_SIGPROCMASK
1165 restore_sigmask(pTHX_ SV *save_sv)
1167 const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1168 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1172 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1174 /* Are we fetching a signal entry? */
1175 const I32 i = whichsig(MgPV_nolen_const(mg));
1178 sv_setsv(sv,PL_psig_ptr[i]);
1180 Sighandler_t sigstate;
1181 sigstate = rsignal_state(i);
1182 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1183 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1185 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1186 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1188 /* cache state so we don't fetch it again */
1189 if(sigstate == (Sighandler_t) SIG_IGN)
1190 sv_setpv(sv,"IGNORE");
1192 sv_setsv(sv,&PL_sv_undef);
1193 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1200 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1202 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1203 * refactoring might be in order.
1206 register const char * const s = MgPV_nolen_const(mg);
1207 PERL_UNUSED_ARG(sv);
1210 if (strEQ(s,"__DIE__"))
1212 else if (strEQ(s,"__WARN__"))
1215 Perl_croak(aTHX_ "No such hook: %s", s);
1217 SV * const to_dec = *svp;
1219 SvREFCNT_dec(to_dec);
1223 /* Are we clearing a signal entry? */
1224 const I32 i = whichsig(s);
1226 #ifdef HAS_SIGPROCMASK
1229 /* Avoid having the signal arrive at a bad time, if possible. */
1232 sigprocmask(SIG_BLOCK, &set, &save);
1234 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1235 SAVEFREESV(save_sv);
1236 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1239 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1240 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1242 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1243 PL_sig_defaulting[i] = 1;
1244 (void)rsignal(i, PL_csighandlerp);
1246 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1248 if(PL_psig_name[i]) {
1249 SvREFCNT_dec(PL_psig_name[i]);
1252 if(PL_psig_ptr[i]) {
1253 SV *to_dec=PL_psig_ptr[i];
1256 SvREFCNT_dec(to_dec);
1266 S_raise_signal(pTHX_ int sig)
1268 /* Set a flag to say this signal is pending */
1269 PL_psig_pend[sig]++;
1270 /* And one to say _a_ signal is pending */
1275 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1276 Perl_csighandler(int sig, ...)
1278 Perl_csighandler(int sig)
1281 #ifdef PERL_GET_SIG_CONTEXT
1282 dTHXa(PERL_GET_SIG_CONTEXT);
1286 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1287 (void) rsignal(sig, PL_csighandlerp);
1288 if (PL_sig_ignoring[sig]) return;
1290 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1291 if (PL_sig_defaulting[sig])
1292 #ifdef KILL_BY_SIGPRC
1293 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1298 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1299 /* Call the perl level handler now--
1300 * with risk we may be in malloc() etc. */
1301 (*PL_sighandlerp)(sig);
1303 S_raise_signal(aTHX_ sig);
1306 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1308 Perl_csighandler_init(void)
1311 if (PL_sig_handlers_initted) return;
1313 for (sig = 1; sig < SIG_SIZE; sig++) {
1314 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1316 PL_sig_defaulting[sig] = 1;
1317 (void) rsignal(sig, PL_csighandlerp);
1319 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1320 PL_sig_ignoring[sig] = 0;
1323 PL_sig_handlers_initted = 1;
1328 Perl_despatch_signals(pTHX)
1332 for (sig = 1; sig < SIG_SIZE; sig++) {
1333 if (PL_psig_pend[sig]) {
1334 PERL_BLOCKSIG_ADD(set, sig);
1335 PL_psig_pend[sig] = 0;
1336 PERL_BLOCKSIG_BLOCK(set);
1337 (*PL_sighandlerp)(sig);
1338 PERL_BLOCKSIG_UNBLOCK(set);
1344 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1349 /* Need to be careful with SvREFCNT_dec(), because that can have side
1350 * effects (due to closures). We must make sure that the new disposition
1351 * is in place before it is called.
1355 #ifdef HAS_SIGPROCMASK
1360 register const char *s = MgPV_const(mg,len);
1362 if (strEQ(s,"__DIE__"))
1364 else if (strEQ(s,"__WARN__"))
1367 Perl_croak(aTHX_ "No such hook: %s", s);
1375 i = whichsig(s); /* ...no, a brick */
1377 if (ckWARN(WARN_SIGNAL))
1378 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1381 #ifdef HAS_SIGPROCMASK
1382 /* Avoid having the signal arrive at a bad time, if possible. */
1385 sigprocmask(SIG_BLOCK, &set, &save);
1387 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1388 SAVEFREESV(save_sv);
1389 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1392 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1393 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1395 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1396 PL_sig_ignoring[i] = 0;
1398 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1399 PL_sig_defaulting[i] = 0;
1401 SvREFCNT_dec(PL_psig_name[i]);
1402 to_dec = PL_psig_ptr[i];
1403 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1404 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1405 PL_psig_name[i] = newSVpvn(s, len);
1406 SvREADONLY_on(PL_psig_name[i]);
1408 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1410 (void)rsignal(i, PL_csighandlerp);
1411 #ifdef HAS_SIGPROCMASK
1416 *svp = SvREFCNT_inc(sv);
1418 SvREFCNT_dec(to_dec);
1421 s = SvPV_force(sv,len);
1422 if (strEQ(s,"IGNORE")) {
1424 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1425 PL_sig_ignoring[i] = 1;
1426 (void)rsignal(i, PL_csighandlerp);
1428 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1432 else if (strEQ(s,"DEFAULT") || !*s) {
1434 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1436 PL_sig_defaulting[i] = 1;
1437 (void)rsignal(i, PL_csighandlerp);
1440 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1445 * We should warn if HINT_STRICT_REFS, but without
1446 * access to a known hint bit in a known OP, we can't
1447 * tell whether HINT_STRICT_REFS is in force or not.
1449 if (!strchr(s,':') && !strchr(s,'\''))
1450 sv_insert(sv, 0, 0, "main::", 6);
1452 (void)rsignal(i, PL_csighandlerp);
1454 *svp = SvREFCNT_inc(sv);
1456 #ifdef HAS_SIGPROCMASK
1461 SvREFCNT_dec(to_dec);
1464 #endif /* !PERL_MICRO */
1467 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1469 PERL_UNUSED_ARG(sv);
1470 PERL_UNUSED_ARG(mg);
1471 PL_sub_generation++;
1476 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1478 PERL_UNUSED_ARG(sv);
1479 PERL_UNUSED_ARG(mg);
1480 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1481 PL_amagic_generation++;
1487 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1489 HV * const hv = (HV*)LvTARG(sv);
1491 PERL_UNUSED_ARG(mg);
1494 (void) hv_iterinit(hv);
1495 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1498 while (hv_iternext(hv))
1503 sv_setiv(sv, (IV)i);
1508 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1510 PERL_UNUSED_ARG(mg);
1512 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1517 /* caller is responsible for stack switching/cleanup */
1519 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1525 PUSHs(SvTIED_obj(sv, mg));
1528 if (mg->mg_len >= 0)
1529 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1530 else if (mg->mg_len == HEf_SVKEY)
1531 PUSHs((SV*)mg->mg_ptr);
1533 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1534 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1542 return call_method(meth, flags);
1546 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1552 PUSHSTACKi(PERLSI_MAGIC);
1554 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1555 sv_setsv(sv, *PL_stack_sp--);
1565 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1568 mg->mg_flags |= MGf_GSKIP;
1569 magic_methpack(sv,mg,"FETCH");
1574 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1578 PUSHSTACKi(PERLSI_MAGIC);
1579 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1586 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1588 return magic_methpack(sv,mg,"DELETE");
1593 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1600 PUSHSTACKi(PERLSI_MAGIC);
1601 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1602 sv = *PL_stack_sp--;
1603 retval = (U32) SvIV(sv)-1;
1612 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1617 PUSHSTACKi(PERLSI_MAGIC);
1619 XPUSHs(SvTIED_obj(sv, mg));
1621 call_method("CLEAR", G_SCALAR|G_DISCARD);
1629 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1632 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1636 PUSHSTACKi(PERLSI_MAGIC);
1639 PUSHs(SvTIED_obj(sv, mg));
1644 if (call_method(meth, G_SCALAR))
1645 sv_setsv(key, *PL_stack_sp--);
1654 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1656 return magic_methpack(sv,mg,"EXISTS");
1660 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1663 SV *retval = &PL_sv_undef;
1664 SV * const tied = SvTIED_obj((SV*)hv, mg);
1665 HV * const pkg = SvSTASH((SV*)SvRV(tied));
1667 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1669 if (HvEITER_get(hv))
1670 /* we are in an iteration so the hash cannot be empty */
1672 /* no xhv_eiter so now use FIRSTKEY */
1673 key = sv_newmortal();
1674 magic_nextpack((SV*)hv, mg, key);
1675 HvEITER_set(hv, NULL); /* need to reset iterator */
1676 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1679 /* there is a SCALAR method that we can call */
1681 PUSHSTACKi(PERLSI_MAGIC);
1687 if (call_method("SCALAR", G_SCALAR))
1688 retval = *PL_stack_sp--;
1695 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1697 GV * const gv = PL_DBline;
1698 const I32 i = SvTRUE(sv);
1699 SV ** const svp = av_fetch(GvAV(gv),
1700 atoi(MgPV_nolen_const(mg)), FALSE);
1701 if (svp && SvIOKp(*svp)) {
1702 OP * const o = INT2PTR(OP*,SvIVX(*svp));
1704 /* set or clear breakpoint in the relevant control op */
1706 o->op_flags |= OPf_SPECIAL;
1708 o->op_flags &= ~OPf_SPECIAL;
1715 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1717 const AV * const obj = (AV*)mg->mg_obj;
1719 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1727 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1729 AV * const obj = (AV*)mg->mg_obj;
1731 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1733 if (ckWARN(WARN_MISC))
1734 Perl_warner(aTHX_ packWARN(WARN_MISC),
1735 "Attempt to set length of freed array");
1741 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1743 PERL_UNUSED_ARG(sv);
1744 /* during global destruction, mg_obj may already have been freed */
1745 if (PL_in_clean_all)
1748 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1751 /* arylen scalar holds a pointer back to the array, but doesn't own a
1752 reference. Hence the we (the array) are about to go away with it
1753 still pointing at us. Clear its pointer, else it would be pointing
1754 at free memory. See the comment in sv_magic about reference loops,
1755 and why it can't own a reference to us. */
1762 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1764 SV* const lsv = LvTARG(sv);
1766 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1767 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1768 if (mg && mg->mg_len >= 0) {
1771 sv_pos_b2u(lsv, &i);
1772 sv_setiv(sv, i + PL_curcop->cop_arybase);
1781 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1783 SV* const lsv = LvTARG(sv);
1790 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1791 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1795 sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1796 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1798 else if (!SvOK(sv)) {
1802 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1804 pos = SvIV(sv) - PL_curcop->cop_arybase;
1807 ulen = sv_len_utf8(lsv);
1817 else if (pos > (SSize_t)len)
1822 sv_pos_u2b(lsv, &p, 0);
1827 mg->mg_flags &= ~MGf_MINMATCH;
1833 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1835 PERL_UNUSED_ARG(mg);
1836 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1838 gv_efullname3(sv,((GV*)sv), "*");
1842 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1847 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1850 PERL_UNUSED_ARG(mg);
1854 gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1859 GvGP(sv) = gp_ref(GvGP(gv));
1864 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1867 SV * const lsv = LvTARG(sv);
1868 const char * const tmps = SvPV_const(lsv,len);
1869 I32 offs = LvTARGOFF(sv);
1870 I32 rem = LvTARGLEN(sv);
1871 PERL_UNUSED_ARG(mg);
1874 sv_pos_u2b(lsv, &offs, &rem);
1875 if (offs > (I32)len)
1877 if (rem + offs > (I32)len)
1879 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1886 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1889 const char *tmps = SvPV_const(sv, len);
1890 SV * const lsv = LvTARG(sv);
1891 I32 lvoff = LvTARGOFF(sv);
1892 I32 lvlen = LvTARGLEN(sv);
1893 PERL_UNUSED_ARG(mg);
1896 sv_utf8_upgrade(lsv);
1897 sv_pos_u2b(lsv, &lvoff, &lvlen);
1898 sv_insert(lsv, lvoff, lvlen, tmps, len);
1899 LvTARGLEN(sv) = sv_len_utf8(sv);
1902 else if (lsv && SvUTF8(lsv)) {
1903 sv_pos_u2b(lsv, &lvoff, &lvlen);
1904 LvTARGLEN(sv) = len;
1905 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1906 sv_insert(lsv, lvoff, lvlen, tmps, len);
1910 sv_insert(lsv, lvoff, lvlen, tmps, len);
1911 LvTARGLEN(sv) = len;
1919 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1921 PERL_UNUSED_ARG(sv);
1922 TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1927 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1929 PERL_UNUSED_ARG(sv);
1930 /* update taint status unless we're restoring at scope exit */
1931 if (PL_localizing != 2) {
1941 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1943 SV * const lsv = LvTARG(sv);
1944 PERL_UNUSED_ARG(mg);
1951 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1956 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1958 PERL_UNUSED_ARG(mg);
1959 do_vecset(sv); /* XXX slurp this routine */
1964 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1967 if (LvTARGLEN(sv)) {
1969 SV * const ahv = LvTARG(sv);
1970 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1975 AV* const av = (AV*)LvTARG(sv);
1976 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1977 targ = AvARRAY(av)[LvTARGOFF(sv)];
1979 if (targ && targ != &PL_sv_undef) {
1980 /* somebody else defined it for us */
1981 SvREFCNT_dec(LvTARG(sv));
1982 LvTARG(sv) = SvREFCNT_inc(targ);
1984 SvREFCNT_dec(mg->mg_obj);
1985 mg->mg_obj = Nullsv;
1986 mg->mg_flags &= ~MGf_REFCOUNTED;
1991 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1996 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1998 PERL_UNUSED_ARG(mg);
2002 sv_setsv(LvTARG(sv), sv);
2003 SvSETMAGIC(LvTARG(sv));
2009 Perl_vivify_defelem(pTHX_ SV *sv)
2014 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2017 SV * const ahv = LvTARG(sv);
2018 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2021 if (!value || value == &PL_sv_undef)
2022 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2025 AV* const av = (AV*)LvTARG(sv);
2026 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2027 LvTARG(sv) = Nullsv; /* array can't be extended */
2029 SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2030 if (!svp || (value = *svp) == &PL_sv_undef)
2031 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2034 (void)SvREFCNT_inc(value);
2035 SvREFCNT_dec(LvTARG(sv));
2038 SvREFCNT_dec(mg->mg_obj);
2039 mg->mg_obj = Nullsv;
2040 mg->mg_flags &= ~MGf_REFCOUNTED;
2044 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2046 AV *const av = (AV*)mg->mg_obj;
2047 SV **svp = AvARRAY(av);
2048 PERL_UNUSED_ARG(sv);
2050 /* Not sure why the av can get freed ahead of its sv, but somehow it does
2051 in ext/B/t/bytecode.t test 15 (involving print <DATA>) */
2052 if (svp && !SvIS_FREED(av)) {
2053 SV *const *const last = svp + AvFILLp(av);
2055 while (svp <= last) {
2057 SV *const referrer = *svp;
2058 if (SvWEAKREF(referrer)) {
2059 /* XXX Should we check that it hasn't changed? */
2060 SvRV_set(referrer, 0);
2062 SvWEAKREF_off(referrer);
2063 } else if (SvTYPE(referrer) == SVt_PVGV ||
2064 SvTYPE(referrer) == SVt_PVLV) {
2065 /* You lookin' at me? */
2066 assert(GvSTASH(referrer));
2067 assert(GvSTASH(referrer) == (HV*)sv);
2068 GvSTASH(referrer) = 0;
2071 "panic: magic_killbackrefs (flags=%"UVxf")",
2072 (UV)SvFLAGS(referrer));
2080 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2085 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2093 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2095 PERL_UNUSED_ARG(mg);
2096 sv_unmagic(sv, PERL_MAGIC_bm);
2102 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2104 PERL_UNUSED_ARG(mg);
2105 sv_unmagic(sv, PERL_MAGIC_fm);
2111 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2113 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2115 if (uf && uf->uf_set)
2116 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2121 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2123 PERL_UNUSED_ARG(mg);
2124 sv_unmagic(sv, PERL_MAGIC_qr);
2129 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2131 regexp * const re = (regexp *)mg->mg_obj;
2132 PERL_UNUSED_ARG(sv);
2138 #ifdef USE_LOCALE_COLLATE
2140 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2143 * RenE<eacute> Descartes said "I think not."
2144 * and vanished with a faint plop.
2146 PERL_UNUSED_ARG(sv);
2148 Safefree(mg->mg_ptr);
2154 #endif /* USE_LOCALE_COLLATE */
2156 /* Just clear the UTF-8 cache data. */
2158 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2160 PERL_UNUSED_ARG(sv);
2161 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2163 mg->mg_len = -1; /* The mg_len holds the len cache. */
2168 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2170 register const char *s;
2173 switch (*mg->mg_ptr) {
2174 case '\001': /* ^A */
2175 sv_setsv(PL_bodytarget, sv);
2177 case '\003': /* ^C */
2178 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2181 case '\004': /* ^D */
2183 s = SvPV_nolen_const(sv);
2184 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2185 DEBUG_x(dump_all());
2187 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2190 case '\005': /* ^E */
2191 if (*(mg->mg_ptr+1) == '\0') {
2192 #ifdef MACOS_TRADITIONAL
2193 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2196 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2199 SetLastError( SvIV(sv) );
2202 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2204 /* will anyone ever use this? */
2205 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2211 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2213 SvREFCNT_dec(PL_encoding);
2214 if (SvOK(sv) || SvGMAGICAL(sv)) {
2215 PL_encoding = newSVsv(sv);
2218 PL_encoding = Nullsv;
2222 case '\006': /* ^F */
2223 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2225 case '\010': /* ^H */
2226 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2228 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2229 Safefree(PL_inplace);
2230 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2232 case '\017': /* ^O */
2233 if (*(mg->mg_ptr+1) == '\0') {
2234 Safefree(PL_osname);
2237 TAINT_PROPER("assigning to $^O");
2238 PL_osname = savesvpv(sv);
2241 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2242 if (!PL_compiling.cop_io)
2243 PL_compiling.cop_io = newSVsv(sv);
2245 sv_setsv(PL_compiling.cop_io,sv);
2248 case '\020': /* ^P */
2249 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2250 if (PL_perldb && !PL_DBsingle)
2253 case '\024': /* ^T */
2255 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2257 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2260 case '\027': /* ^W & $^WARNING_BITS */
2261 if (*(mg->mg_ptr+1) == '\0') {
2262 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2263 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2264 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2265 | (i ? G_WARN_ON : G_WARN_OFF) ;
2268 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2269 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2270 if (!SvPOK(sv) && PL_localizing) {
2271 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2272 PL_compiling.cop_warnings = pWARN_NONE;
2277 int accumulate = 0 ;
2278 int any_fatals = 0 ;
2279 const char * const ptr = SvPV_const(sv, len) ;
2280 for (i = 0 ; i < len ; ++i) {
2281 accumulate |= ptr[i] ;
2282 any_fatals |= (ptr[i] & 0xAA) ;
2285 PL_compiling.cop_warnings = pWARN_NONE;
2286 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2287 PL_compiling.cop_warnings = pWARN_ALL;
2288 PL_dowarn |= G_WARN_ONCE ;
2291 if (specialWARN(PL_compiling.cop_warnings))
2292 PL_compiling.cop_warnings = newSVsv(sv) ;
2294 sv_setsv(PL_compiling.cop_warnings, sv);
2295 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2296 PL_dowarn |= G_WARN_ONCE ;
2304 if (PL_localizing) {
2305 if (PL_localizing == 1)
2306 SAVESPTR(PL_last_in_gv);
2308 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2309 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2312 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2313 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2314 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2317 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2318 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2319 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2322 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2325 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2326 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2327 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2330 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2334 IO * const io = GvIOp(PL_defoutgv);
2337 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2338 IoFLAGS(io) &= ~IOf_FLUSH;
2340 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2341 PerlIO *ofp = IoOFP(io);
2343 (void)PerlIO_flush(ofp);
2344 IoFLAGS(io) |= IOf_FLUSH;
2350 SvREFCNT_dec(PL_rs);
2351 PL_rs = newSVsv(sv);
2355 SvREFCNT_dec(PL_ors_sv);
2356 if (SvOK(sv) || SvGMAGICAL(sv)) {
2357 PL_ors_sv = newSVsv(sv);
2365 SvREFCNT_dec(PL_ofs_sv);
2366 if (SvOK(sv) || SvGMAGICAL(sv)) {
2367 PL_ofs_sv = newSVsv(sv);
2374 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2377 #ifdef COMPLEX_STATUS
2378 if (PL_localizing == 2) {
2379 PL_statusvalue = LvTARGOFF(sv);
2380 PL_statusvalue_vms = LvTARGLEN(sv);
2384 #ifdef VMSISH_STATUS
2386 STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2389 STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2394 # define PERL_VMS_BANG vaxc$errno
2396 # define PERL_VMS_BANG 0
2398 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2399 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2403 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2404 if (PL_delaymagic) {
2405 PL_delaymagic |= DM_RUID;
2406 break; /* don't do magic till later */
2409 (void)setruid((Uid_t)PL_uid);
2412 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2414 #ifdef HAS_SETRESUID
2415 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2417 if (PL_uid == PL_euid) { /* special case $< = $> */
2419 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2420 if (PL_uid != 0 && PerlProc_getuid() == 0)
2421 (void)PerlProc_setuid(0);
2423 (void)PerlProc_setuid(PL_uid);
2425 PL_uid = PerlProc_getuid();
2426 Perl_croak(aTHX_ "setruid() not implemented");
2431 PL_uid = PerlProc_getuid();
2432 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2435 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2436 if (PL_delaymagic) {
2437 PL_delaymagic |= DM_EUID;
2438 break; /* don't do magic till later */
2441 (void)seteuid((Uid_t)PL_euid);
2444 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2446 #ifdef HAS_SETRESUID
2447 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2449 if (PL_euid == PL_uid) /* special case $> = $< */
2450 PerlProc_setuid(PL_euid);
2452 PL_euid = PerlProc_geteuid();
2453 Perl_croak(aTHX_ "seteuid() not implemented");
2458 PL_euid = PerlProc_geteuid();
2459 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2462 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2463 if (PL_delaymagic) {
2464 PL_delaymagic |= DM_RGID;
2465 break; /* don't do magic till later */
2468 (void)setrgid((Gid_t)PL_gid);
2471 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2473 #ifdef HAS_SETRESGID
2474 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2476 if (PL_gid == PL_egid) /* special case $( = $) */
2477 (void)PerlProc_setgid(PL_gid);
2479 PL_gid = PerlProc_getgid();
2480 Perl_croak(aTHX_ "setrgid() not implemented");
2485 PL_gid = PerlProc_getgid();
2486 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2489 #ifdef HAS_SETGROUPS
2491 const char *p = SvPV_const(sv, len);
2492 Groups_t *gary = NULL;
2497 for (i = 0; i < NGROUPS; ++i) {
2498 while (*p && !isSPACE(*p))
2505 Newx(gary, i + 1, Groups_t);
2507 Renew(gary, i + 1, Groups_t);
2511 (void)setgroups(i, gary);
2515 #else /* HAS_SETGROUPS */
2516 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2517 #endif /* HAS_SETGROUPS */
2518 if (PL_delaymagic) {
2519 PL_delaymagic |= DM_EGID;
2520 break; /* don't do magic till later */
2523 (void)setegid((Gid_t)PL_egid);
2526 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2528 #ifdef HAS_SETRESGID
2529 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2531 if (PL_egid == PL_gid) /* special case $) = $( */
2532 (void)PerlProc_setgid(PL_egid);
2534 PL_egid = PerlProc_getegid();
2535 Perl_croak(aTHX_ "setegid() not implemented");
2540 PL_egid = PerlProc_getegid();
2541 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2544 PL_chopset = SvPV_force(sv,len);
2546 #ifndef MACOS_TRADITIONAL
2548 LOCK_DOLLARZERO_MUTEX;
2549 #ifdef HAS_SETPROCTITLE
2550 /* The BSDs don't show the argv[] in ps(1) output, they
2551 * show a string from the process struct and provide
2552 * the setproctitle() routine to manipulate that. */
2554 s = SvPV_const(sv, len);
2555 # if __FreeBSD_version > 410001
2556 /* The leading "-" removes the "perl: " prefix,
2557 * but not the "(perl) suffix from the ps(1)
2558 * output, because that's what ps(1) shows if the
2559 * argv[] is modified. */
2560 setproctitle("-%s", s);
2561 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2562 /* This doesn't really work if you assume that
2563 * $0 = 'foobar'; will wipe out 'perl' from the $0
2564 * because in ps(1) output the result will be like
2565 * sprintf("perl: %s (perl)", s)
2566 * I guess this is a security feature:
2567 * one (a user process) cannot get rid of the original name.
2569 setproctitle("%s", s);
2573 #if defined(__hpux) && defined(PSTAT_SETCMD)
2576 s = SvPV_const(sv, len);
2577 un.pst_command = (char *)s;
2578 pstat(PSTAT_SETCMD, un, len, 0, 0);
2581 /* PL_origalen is set in perl_parse(). */
2582 s = SvPV_force(sv,len);
2583 if (len >= (STRLEN)PL_origalen-1) {
2584 /* Longer than original, will be truncated. We assume that
2585 * PL_origalen bytes are available. */
2586 Copy(s, PL_origargv[0], PL_origalen-1, char);
2589 /* Shorter than original, will be padded. */
2590 Copy(s, PL_origargv[0], len, char);
2591 PL_origargv[0][len] = 0;
2592 memset(PL_origargv[0] + len + 1,
2593 /* Is the space counterintuitive? Yes.
2594 * (You were expecting \0?)
2595 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2598 PL_origalen - len - 1);
2600 PL_origargv[0][PL_origalen-1] = 0;
2601 for (i = 1; i < PL_origargc; i++)
2603 UNLOCK_DOLLARZERO_MUTEX;
2611 Perl_whichsig(pTHX_ const char *sig)
2613 register char* const* sigv;
2615 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2616 if (strEQ(sig,*sigv))
2617 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2619 if (strEQ(sig,"CHLD"))
2623 if (strEQ(sig,"CLD"))
2630 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2631 Perl_sighandler(int sig, ...)
2633 Perl_sighandler(int sig)
2636 #ifdef PERL_GET_SIG_CONTEXT
2637 dTHXa(PERL_GET_SIG_CONTEXT);
2644 SV * const tSv = PL_Sv;
2648 XPV * const tXpv = PL_Xpv;
2650 if (PL_savestack_ix + 15 <= PL_savestack_max)
2652 if (PL_markstack_ptr < PL_markstack_max - 2)
2654 if (PL_scopestack_ix < PL_scopestack_max - 3)
2657 if (!PL_psig_ptr[sig]) {
2658 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2663 /* Max number of items pushed there is 3*n or 4. We cannot fix
2664 infinity, so we fix 4 (in fact 5): */
2666 PL_savestack_ix += 5; /* Protect save in progress. */
2667 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2670 PL_markstack_ptr++; /* Protect mark. */
2672 PL_scopestack_ix += 1;
2673 /* sv_2cv is too complicated, try a simpler variant first: */
2674 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2675 || SvTYPE(cv) != SVt_PVCV) {
2677 cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2680 if (!cv || !CvROOT(cv)) {
2681 if (ckWARN(WARN_SIGNAL))
2682 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2683 PL_sig_name[sig], (gv ? GvENAME(gv)
2690 if(PL_psig_name[sig]) {
2691 sv = SvREFCNT_inc(PL_psig_name[sig]);
2693 #if !defined(PERL_IMPLICIT_CONTEXT)
2697 sv = sv_newmortal();
2698 sv_setpv(sv,PL_sig_name[sig]);
2701 PUSHSTACKi(PERLSI_SIGNAL);
2704 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2706 struct sigaction oact;
2708 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2712 va_start(args, sig);
2713 sip = (siginfo_t*)va_arg(args, siginfo_t*);
2716 SV *rv = newRV_noinc((SV*)sih);
2717 /* The siginfo fields signo, code, errno, pid, uid,
2718 * addr, status, and band are defined by POSIX/SUSv3. */
2719 hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
2720 hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
2721 #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. */
2722 hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
2723 hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
2724 hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
2725 hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
2726 hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
2727 hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
2731 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_flags(sv, 0);
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 #if !defined(PERL_IMPLICIT_CONTEXT)
2845 SvREFCNT_dec(PL_sig_sv);
2851 * c-indentation-style: bsd
2853 * indent-tabs-mode: t
2856 * ex: set ts=8 sts=4 sw=4 noet: