3 * Copyright (c) 1991-2002, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
12 * come here, and I don't want to see no more magic,' he said, and fell silent."
16 =head1 Magical Functions
23 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
32 /* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
33 #if !defined(HAS_SIGACTION) && defined(VMS)
34 # define FAKE_PERSISTENT_SIGNAL_HANDLERS
36 /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
37 #if defined(KILL_BY_SIGPRC)
38 # define FAKE_DEFAULT_SIGNAL_HANDLERS
41 static void restore_magic(pTHX_ void *p);
42 static void unwind_handler_stack(pTHX_ void *p);
45 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
53 /* MGS is typedef'ed to struct magic_state in perl.h */
56 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
59 assert(SvMAGICAL(sv));
61 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
63 mgs = SSPTR(mgs_ix, MGS*);
65 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
66 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
70 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
74 =for apidoc mg_magical
76 Turns on the magical status of an SV. See C<sv_magic>.
82 Perl_mg_magical(pTHX_ SV *sv)
85 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
86 MGVTBL* vtbl = mg->mg_virtual;
88 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
92 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
101 Do magic after a value is retrieved from the SV. See C<sv_magic>.
107 Perl_mg_get(pTHX_ SV *sv)
110 MAGIC *newmg, *head, *cur, *mg;
111 I32 mgs_ix = SSNEW(sizeof(MGS));
113 save_magic(mgs_ix, sv);
115 /* We must call svt_get(sv, mg) for each valid entry in the linked
116 list of magic. svt_get() may delete the current entry, add new
117 magic to the head of the list, or upgrade the SV. AMS 20010810 */
119 newmg = cur = head = mg = SvMAGIC(sv);
121 MGVTBL *vtbl = mg->mg_virtual;
123 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
124 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
125 /* Don't restore the flags for this entry if it was deleted. */
126 if (mg->mg_flags & MGf_GSKIP)
127 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
130 mg = mg->mg_moremagic;
133 /* Have we finished with the new entries we saw? Start again
134 where we left off (unless there are more new entries). */
142 /* Were any new entries added? */
143 if (!new && (newmg = SvMAGIC(sv)) != head) {
150 restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
157 Do magic after a value is assigned to the SV. See C<sv_magic>.
163 Perl_mg_set(pTHX_ SV *sv)
169 mgs_ix = SSNEW(sizeof(MGS));
170 save_magic(mgs_ix, sv);
172 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
173 MGVTBL* vtbl = mg->mg_virtual;
174 nextmg = mg->mg_moremagic; /* it may delete itself */
175 if (mg->mg_flags & MGf_GSKIP) {
176 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
177 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
179 if (vtbl && vtbl->svt_set)
180 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
183 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
188 =for apidoc mg_length
190 Report on the SV's length. See C<sv_magic>.
196 Perl_mg_length(pTHX_ SV *sv)
201 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
202 MGVTBL* vtbl = mg->mg_virtual;
203 if (vtbl && vtbl->svt_len) {
206 mgs_ix = SSNEW(sizeof(MGS));
207 save_magic(mgs_ix, sv);
208 /* omit MGf_GSKIP -- not changed here */
209 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
210 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
217 U8 *s = (U8*)SvPV(sv, len);
218 len = Perl_utf8_length(aTHX_ s, s + len);
226 Perl_mg_size(pTHX_ SV *sv)
231 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
232 MGVTBL* vtbl = mg->mg_virtual;
233 if (vtbl && vtbl->svt_len) {
236 mgs_ix = SSNEW(sizeof(MGS));
237 save_magic(mgs_ix, sv);
238 /* omit MGf_GSKIP -- not changed here */
239 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
240 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
247 len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
252 Perl_croak(aTHX_ "Size magic not implemented");
261 Clear something magical that the SV represents. See C<sv_magic>.
267 Perl_mg_clear(pTHX_ SV *sv)
272 mgs_ix = SSNEW(sizeof(MGS));
273 save_magic(mgs_ix, sv);
275 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
276 MGVTBL* vtbl = mg->mg_virtual;
277 /* omit GSKIP -- never set here */
279 if (vtbl && vtbl->svt_clear)
280 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
283 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
290 Finds the magic pointer for type matching the SV. See C<sv_magic>.
296 Perl_mg_find(pTHX_ SV *sv, int type)
301 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
302 if (mg->mg_type == type)
311 Copies the magic from one SV to another. See C<sv_magic>.
317 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
321 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
322 MGVTBL* vtbl = mg->mg_virtual;
323 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
324 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
326 else if (isUPPER(mg->mg_type)) {
328 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
329 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
331 toLOWER(mg->mg_type), key, klen);
341 Free any magic storage used by the SV. See C<sv_magic>.
347 Perl_mg_free(pTHX_ SV *sv)
351 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
352 MGVTBL* vtbl = mg->mg_virtual;
353 moremagic = mg->mg_moremagic;
354 if (vtbl && vtbl->svt_free)
355 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
356 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
358 Safefree(mg->mg_ptr);
359 else if (mg->mg_len == HEf_SVKEY)
360 SvREFCNT_dec((SV*)mg->mg_ptr);
362 if (mg->mg_flags & MGf_REFCOUNTED) {
363 SV *obj = mg->mg_obj;
364 if (mg->mg_type == PERL_MAGIC_tiedscalar && SvROK(obj) &&
365 (SvRV(obj) == sv || GvIO(SvRV(obj)) == (IO *) sv)) {
366 /* We are already free'ing the self-tied thing
367 so SvREFCNT_dec must not.
380 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
385 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
389 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
390 if (mg->mg_obj) /* @+ */
393 return rx->lastparen;
400 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
408 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
412 if (paren <= (I32)rx->nparens &&
413 (s = rx->startp[paren]) != -1 &&
414 (t = rx->endp[paren]) != -1)
416 if (mg->mg_obj) /* @+ */
421 if (i > 0 && PL_reg_match_utf8) {
422 char *b = rx->subbeg;
424 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
434 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
436 Perl_croak(aTHX_ PL_no_modify);
442 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
449 switch (*mg->mg_ptr) {
450 case '1': case '2': case '3': case '4':
451 case '5': case '6': case '7': case '8': case '9': case '&':
452 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
454 paren = atoi(mg->mg_ptr); /* $& is in [0] */
456 if (paren <= (I32)rx->nparens &&
457 (s1 = rx->startp[paren]) != -1 &&
458 (t1 = rx->endp[paren]) != -1)
462 if (i > 0 && PL_reg_match_utf8) {
463 char *s = rx->subbeg + s1;
464 char *send = rx->subbeg + t1;
467 if (is_utf8_string((U8*)s, i))
468 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
471 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
475 if (ckWARN(WARN_UNINITIALIZED))
480 if (ckWARN(WARN_UNINITIALIZED))
485 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
486 paren = rx->lastparen;
491 case '\016': /* ^N */
492 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
493 paren = rx->lastcloseparen;
499 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
500 if (rx->startp[0] != -1) {
511 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
512 if (rx->endp[0] != -1) {
513 i = rx->sublen - rx->endp[0];
524 if (!SvPOK(sv) && SvNIOK(sv)) {
534 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
541 switch (*mg->mg_ptr) {
542 case '\001': /* ^A */
543 sv_setsv(sv, PL_bodytarget);
545 case '\003': /* ^C */
546 sv_setiv(sv, (IV)PL_minus_c);
549 case '\004': /* ^D */
550 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
551 #if defined(YYDEBUG) && defined(DEBUGGING)
552 PL_yydebug = DEBUG_p_TEST;
555 case '\005': /* ^E */
556 if (*(mg->mg_ptr+1) == '\0') {
557 #ifdef MACOS_TRADITIONAL
561 sv_setnv(sv,(double)gMacPerl_OSErr);
562 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
567 # include <descrip.h>
568 # include <starlet.h>
570 $DESCRIPTOR(msgdsc,msg);
571 sv_setnv(sv,(NV) vaxc$errno);
572 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
573 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
579 if (!(_emx_env & 0x200)) { /* Under DOS */
580 sv_setnv(sv, (NV)errno);
581 sv_setpv(sv, errno ? Strerror(errno) : "");
583 if (errno != errno_isOS2) {
584 int tmp = _syserrno();
585 if (tmp) /* 2nd call to _syserrno() makes it 0 */
588 sv_setnv(sv, (NV)Perl_rc);
589 sv_setpv(sv, os2error(Perl_rc));
594 DWORD dwErr = GetLastError();
595 sv_setnv(sv, (NV)dwErr);
598 PerlProc_GetOSError(sv, dwErr);
605 sv_setnv(sv, (NV)errno);
606 sv_setpv(sv, errno ? Strerror(errno) : "");
611 SvNOK_on(sv); /* what a wonderful hack! */
613 else if (strEQ(mg->mg_ptr+1, "NCODING"))
614 sv_setsv(sv, PL_encoding);
616 case '\006': /* ^F */
617 sv_setiv(sv, (IV)PL_maxsysfd);
619 case '\010': /* ^H */
620 sv_setiv(sv, (IV)PL_hints);
622 case '\011': /* ^I */ /* NOT \t in EBCDIC */
624 sv_setpv(sv, PL_inplace);
626 sv_setsv(sv, &PL_sv_undef);
628 case '\017': /* ^O & ^OPEN */
629 if (*(mg->mg_ptr+1) == '\0')
630 sv_setpv(sv, PL_osname);
631 else if (strEQ(mg->mg_ptr, "\017PEN")) {
632 if (!PL_compiling.cop_io)
633 sv_setsv(sv, &PL_sv_undef);
635 sv_setsv(sv, PL_compiling.cop_io);
639 case '\020': /* ^P */
640 sv_setiv(sv, (IV)PL_perldb);
642 case '\023': /* ^S */
644 if (PL_lex_state != LEX_NOTPARSING)
647 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
652 case '\024': /* ^T */
653 if (*(mg->mg_ptr+1) == '\0') {
655 sv_setnv(sv, PL_basetime);
657 sv_setiv(sv, (IV)PL_basetime);
660 else if (strEQ(mg->mg_ptr, "\024AINT"))
661 sv_setiv(sv, PL_tainting);
663 case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
664 if (*(mg->mg_ptr+1) == '\0')
665 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
666 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
667 if (PL_compiling.cop_warnings == pWARN_NONE ||
668 PL_compiling.cop_warnings == pWARN_STD)
670 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
672 else if (PL_compiling.cop_warnings == pWARN_ALL) {
673 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
676 sv_setsv(sv, PL_compiling.cop_warnings);
680 else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS"))
681 sv_setiv(sv, (IV)PL_widesyscalls);
683 case '1': case '2': case '3': case '4':
684 case '5': case '6': case '7': case '8': case '9': case '&':
685 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
689 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
690 * XXX Does the new way break anything?
692 paren = atoi(mg->mg_ptr); /* $& is in [0] */
694 if (paren <= (I32)rx->nparens &&
695 (s1 = rx->startp[paren]) != -1 &&
696 (t1 = rx->endp[paren]) != -1)
705 bool was_tainted = FALSE;
707 was_tainted = PL_tainted;
711 if (PL_reg_match_utf8 && is_utf8_string((U8*)s, i))
716 PL_tainted = (was_tainted || RX_MATCH_TAINTED(rx));
721 sv_setsv(sv,&PL_sv_undef);
724 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
725 paren = rx->lastparen;
729 sv_setsv(sv,&PL_sv_undef);
731 case '\016': /* ^N */
732 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
733 paren = rx->lastcloseparen;
737 sv_setsv(sv,&PL_sv_undef);
740 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
741 if ((s = rx->subbeg) && rx->startp[0] != -1) {
746 sv_setsv(sv,&PL_sv_undef);
749 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
750 if (rx->subbeg && rx->endp[0] != -1) {
751 s = rx->subbeg + rx->endp[0];
752 i = rx->sublen - rx->endp[0];
756 sv_setsv(sv,&PL_sv_undef);
760 if (GvIO(PL_last_in_gv)) {
761 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
767 sv_setiv(sv, (IV)STATUS_CURRENT);
768 #ifdef COMPLEX_STATUS
769 LvTARGOFF(sv) = PL_statusvalue;
770 LvTARGLEN(sv) = PL_statusvalue_vms;
775 s = IoTOP_NAME(GvIOp(PL_defoutgv));
779 sv_setpv(sv,GvENAME(PL_defoutgv));
784 s = IoFMT_NAME(GvIOp(PL_defoutgv));
786 s = GvENAME(PL_defoutgv);
791 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
794 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
797 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
805 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
808 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
814 sv_setpv(sv,SvPVX(PL_ors_sv));
817 sv_setpv(sv,PL_ofmt);
821 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
822 sv_setpv(sv, errno ? Strerror(errno) : "");
825 int saveerrno = errno;
826 sv_setnv(sv, (NV)errno);
828 if (errno == errno_isOS2 || errno == errno_isOS2_set)
829 sv_setpv(sv, os2error(Perl_rc));
832 sv_setpv(sv, errno ? Strerror(errno) : "");
836 SvNOK_on(sv); /* what a wonderful hack! */
839 sv_setiv(sv, (IV)PL_uid);
842 sv_setiv(sv, (IV)PL_euid);
845 sv_setiv(sv, (IV)PL_gid);
847 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
851 sv_setiv(sv, (IV)PL_egid);
853 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
858 Groups_t gary[NGROUPS];
859 i = getgroups(NGROUPS,gary);
861 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
864 (void)SvIOK_on(sv); /* what a wonderful hack! */
868 #ifndef MACOS_TRADITIONAL
872 #ifdef USE_5005THREADS
874 sv_setsv(sv, thr->errsv);
876 #endif /* USE_5005THREADS */
882 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
884 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
886 if (uf && uf->uf_val)
887 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
892 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
902 #ifdef DYNAMIC_ENV_FETCH
903 /* We just undefd an environment var. Is a replacement */
904 /* waiting in the wings? */
907 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
908 s = SvPV(*valp, len);
912 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
913 /* And you'll never guess what the dog had */
914 /* in its mouth... */
916 MgTAINTEDDIR_off(mg);
918 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
919 char pathbuf[256], eltbuf[256], *cp, *elt = s;
923 do { /* DCL$PATH may be a search list */
924 while (1) { /* as may dev portion of any element */
925 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
926 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
927 cando_by_name(S_IWUSR,0,elt) ) {
932 if ((cp = strchr(elt, ':')) != Nullch)
934 if (my_trnlnm(elt, eltbuf, j++))
940 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
943 if (s && klen == 4 && strEQ(ptr,"PATH")) {
944 char *strend = s + len;
950 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
953 if (i >= sizeof tmpbuf /* too long -- assume the worst */
955 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
962 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
968 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
971 my_setenv(MgPV(mg,n_a),Nullch);
976 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
979 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
984 magic_clear_all_env(sv,mg);
985 hv_iterinit((HV*)sv);
986 while ((entry = hv_iternext((HV*)sv))) {
988 my_setenv(hv_iterkey(entry, &keylen),
989 SvPV(hv_iterval((HV*)sv, entry), n_a));
997 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
999 #if defined(VMS) || defined(EPOC)
1000 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1002 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1005 # ifdef USE_ENVIRON_ARRAY
1006 # if defined(USE_ITHREADS)
1007 /* only the parent thread can clobber the process environment */
1008 if (PL_curinterp == aTHX)
1011 # ifndef PERL_USE_SAFE_PUTENV
1014 if (environ == PL_origenviron)
1015 environ = (char**)safesysmalloc(sizeof(char*));
1017 for (i = 0; environ[i]; i++)
1018 safesysfree(environ[i]);
1019 # endif /* PERL_USE_SAFE_PUTENV */
1021 environ[0] = Nullch;
1023 # endif /* USE_ENVIRON_ARRAY */
1024 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1025 #endif /* VMS || EPC */
1029 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1030 static int sig_handlers_initted = 0;
1032 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1033 static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
1035 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1036 static int sig_defaulting[SIG_SIZE];
1041 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1045 /* Are we fetching a signal entry? */
1046 i = whichsig(MgPV(mg,n_a));
1049 sv_setsv(sv,PL_psig_ptr[i]);
1051 Sighandler_t sigstate;
1052 sigstate = rsignal_state(i);
1053 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1054 if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1056 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1057 if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
1059 /* cache state so we don't fetch it again */
1060 if(sigstate == SIG_IGN)
1061 sv_setpv(sv,"IGNORE");
1063 sv_setsv(sv,&PL_sv_undef);
1064 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1071 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1075 /* Are we clearing a signal entry? */
1076 i = whichsig(MgPV(mg,n_a));
1078 if(PL_psig_ptr[i]) {
1079 SvREFCNT_dec(PL_psig_ptr[i]);
1082 if(PL_psig_name[i]) {
1083 SvREFCNT_dec(PL_psig_name[i]);
1091 Perl_raise_signal(pTHX_ int sig)
1093 /* Set a flag to say this signal is pending */
1094 PL_psig_pend[sig]++;
1095 /* And one to say _a_ signal is pending */
1100 Perl_csighandler(int sig)
1102 #ifdef PERL_GET_SIG_CONTEXT
1103 dTHXa(PERL_GET_SIG_CONTEXT);
1107 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1108 (void) rsignal(sig, &Perl_csighandler);
1109 if (sig_ignoring[sig]) return;
1111 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1112 if (sig_defaulting[sig])
1113 #ifdef KILL_BY_SIGPRC
1114 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1120 #ifdef PERL_OLD_SIGNALS
1121 /* Call the perl level handler now with risk we may be in malloc() etc. */
1122 (*PL_sighandlerp)(sig);
1124 Perl_raise_signal(aTHX_ sig);
1128 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1130 Perl_csighandler_init(void)
1133 if (sig_handlers_initted) return;
1135 for (sig = 1; sig < SIG_SIZE; sig++) {
1136 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1138 sig_defaulting[sig] = 1;
1139 (void) rsignal(sig, &Perl_csighandler);
1141 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1142 sig_ignoring[sig] = 0;
1145 sig_handlers_initted = 1;
1150 Perl_despatch_signals(pTHX)
1154 for (sig = 1; sig < SIG_SIZE; sig++) {
1155 if (PL_psig_pend[sig]) {
1156 PL_psig_pend[sig] = 0;
1157 (*PL_sighandlerp)(sig);
1163 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1172 if (strEQ(s,"__DIE__"))
1174 else if (strEQ(s,"__WARN__"))
1177 Perl_croak(aTHX_ "No such hook: %s", s);
1185 i = whichsig(s); /* ...no, a brick */
1187 if (ckWARN(WARN_SIGNAL))
1188 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1191 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1192 if (!sig_handlers_initted) Perl_csighandler_init();
1194 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1195 sig_ignoring[i] = 0;
1197 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1198 sig_defaulting[i] = 0;
1200 SvREFCNT_dec(PL_psig_name[i]);
1201 SvREFCNT_dec(PL_psig_ptr[i]);
1202 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1203 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1204 PL_psig_name[i] = newSVpvn(s, len);
1205 SvREADONLY_on(PL_psig_name[i]);
1207 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1209 (void)rsignal(i, &Perl_csighandler);
1211 *svp = SvREFCNT_inc(sv);
1214 s = SvPV_force(sv,len);
1215 if (strEQ(s,"IGNORE")) {
1217 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1218 sig_ignoring[i] = 1;
1219 (void)rsignal(i, &Perl_csighandler);
1221 (void)rsignal(i, SIG_IGN);
1226 else if (strEQ(s,"DEFAULT") || !*s) {
1228 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1230 sig_defaulting[i] = 1;
1231 (void)rsignal(i, &Perl_csighandler);
1234 (void)rsignal(i, SIG_DFL);
1241 * We should warn if HINT_STRICT_REFS, but without
1242 * access to a known hint bit in a known OP, we can't
1243 * tell whether HINT_STRICT_REFS is in force or not.
1245 if (!strchr(s,':') && !strchr(s,'\''))
1246 sv_insert(sv, 0, 0, "main::", 6);
1248 (void)rsignal(i, &Perl_csighandler);
1250 *svp = SvREFCNT_inc(sv);
1254 #endif /* !PERL_MICRO */
1257 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1259 PL_sub_generation++;
1264 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1266 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1267 PL_amagic_generation++;
1273 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1275 HV *hv = (HV*)LvTARG(sv);
1279 (void) hv_iterinit(hv);
1280 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1283 while (hv_iternext(hv))
1288 sv_setiv(sv, (IV)i);
1293 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1296 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1301 /* caller is responsible for stack switching/cleanup */
1303 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1309 PUSHs(SvTIED_obj(sv, mg));
1312 if (mg->mg_len >= 0)
1313 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1314 else if (mg->mg_len == HEf_SVKEY)
1315 PUSHs((SV*)mg->mg_ptr);
1317 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1318 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1326 return call_method(meth, flags);
1330 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
1336 PUSHSTACKi(PERLSI_MAGIC);
1338 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1339 sv_setsv(sv, *PL_stack_sp--);
1349 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1351 magic_methpack(sv,mg,"FETCH");
1353 mg->mg_flags |= MGf_GSKIP;
1358 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1362 PUSHSTACKi(PERLSI_MAGIC);
1363 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1370 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1372 return magic_methpack(sv,mg,"DELETE");
1377 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1384 PUSHSTACKi(PERLSI_MAGIC);
1385 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1386 sv = *PL_stack_sp--;
1387 retval = (U32) SvIV(sv)-1;
1396 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1401 PUSHSTACKi(PERLSI_MAGIC);
1403 XPUSHs(SvTIED_obj(sv, mg));
1405 call_method("CLEAR", G_SCALAR|G_DISCARD);
1412 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1415 const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1419 PUSHSTACKi(PERLSI_MAGIC);
1422 PUSHs(SvTIED_obj(sv, mg));
1427 if (call_method(meth, G_SCALAR))
1428 sv_setsv(key, *PL_stack_sp--);
1437 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1439 return magic_methpack(sv,mg,"EXISTS");
1443 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1453 svp = av_fetch(GvAV(gv),
1454 atoi(MgPV(mg,n_a)), FALSE);
1455 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp))))
1456 o->op_private = (U8)i;
1461 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1463 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1468 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1470 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1475 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1477 SV* lsv = LvTARG(sv);
1479 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1480 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1481 if (mg && mg->mg_len >= 0) {
1484 sv_pos_b2u(lsv, &i);
1485 sv_setiv(sv, i + PL_curcop->cop_arybase);
1494 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1496 SV* lsv = LvTARG(sv);
1503 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1504 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1508 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1509 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1511 else if (!SvOK(sv)) {
1515 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1517 pos = SvIV(sv) - PL_curcop->cop_arybase;
1520 ulen = sv_len_utf8(lsv);
1530 else if (pos > (SSize_t)len)
1535 sv_pos_u2b(lsv, &p, 0);
1540 mg->mg_flags &= ~MGf_MINMATCH;
1546 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1548 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1550 gv_efullname3(sv,((GV*)sv), "*");
1554 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1559 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1568 if (*s == '*' && s[1])
1570 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1575 GvGP(sv) = gp_ref(GvGP(gv));
1580 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1583 SV *lsv = LvTARG(sv);
1584 char *tmps = SvPV(lsv,len);
1585 I32 offs = LvTARGOFF(sv);
1586 I32 rem = LvTARGLEN(sv);
1589 sv_pos_u2b(lsv, &offs, &rem);
1590 if (offs > (I32)len)
1592 if (rem + offs > (I32)len)
1594 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1601 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1604 char *tmps = SvPV(sv, len);
1605 SV *lsv = LvTARG(sv);
1606 I32 lvoff = LvTARGOFF(sv);
1607 I32 lvlen = LvTARGLEN(sv);
1610 sv_utf8_upgrade(lsv);
1611 sv_pos_u2b(lsv, &lvoff, &lvlen);
1612 sv_insert(lsv, lvoff, lvlen, tmps, len);
1615 else if (lsv && SvUTF8(lsv)) {
1616 sv_pos_u2b(lsv, &lvoff, &lvlen);
1617 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1618 sv_insert(lsv, lvoff, lvlen, tmps, len);
1622 sv_insert(lsv, lvoff, lvlen, tmps, len);
1628 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1630 TAINT_IF((mg->mg_len & 1) ||
1631 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1636 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1638 if (PL_localizing) {
1639 if (PL_localizing == 1)
1644 else if (PL_tainted)
1652 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1654 SV *lsv = LvTARG(sv);
1661 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1666 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1668 do_vecset(sv); /* XXX slurp this routine */
1673 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1676 if (LvTARGLEN(sv)) {
1678 SV *ahv = LvTARG(sv);
1679 if (SvTYPE(ahv) == SVt_PVHV) {
1680 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1685 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0);
1691 AV* av = (AV*)LvTARG(sv);
1692 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1693 targ = AvARRAY(av)[LvTARGOFF(sv)];
1695 if (targ && targ != &PL_sv_undef) {
1696 /* somebody else defined it for us */
1697 SvREFCNT_dec(LvTARG(sv));
1698 LvTARG(sv) = SvREFCNT_inc(targ);
1700 SvREFCNT_dec(mg->mg_obj);
1701 mg->mg_obj = Nullsv;
1702 mg->mg_flags &= ~MGf_REFCOUNTED;
1707 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1712 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1717 sv_setsv(LvTARG(sv), sv);
1718 SvSETMAGIC(LvTARG(sv));
1724 Perl_vivify_defelem(pTHX_ SV *sv)
1729 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1732 SV *ahv = LvTARG(sv);
1734 if (SvTYPE(ahv) == SVt_PVHV) {
1735 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1740 SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0);
1744 if (!value || value == &PL_sv_undef)
1745 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1748 AV* av = (AV*)LvTARG(sv);
1749 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1750 LvTARG(sv) = Nullsv; /* array can't be extended */
1752 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1753 if (!svp || (value = *svp) == &PL_sv_undef)
1754 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1757 (void)SvREFCNT_inc(value);
1758 SvREFCNT_dec(LvTARG(sv));
1761 SvREFCNT_dec(mg->mg_obj);
1762 mg->mg_obj = Nullsv;
1763 mg->mg_flags &= ~MGf_REFCOUNTED;
1767 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1769 AV *av = (AV*)mg->mg_obj;
1770 SV **svp = AvARRAY(av);
1771 I32 i = AvFILLp(av);
1773 if (svp[i] && svp[i] != &PL_sv_undef) {
1774 if (!SvWEAKREF(svp[i]))
1775 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1776 /* XXX Should we check that it hasn't changed? */
1778 (void)SvOK_off(svp[i]);
1779 SvWEAKREF_off(svp[i]);
1780 svp[i] = &PL_sv_undef;
1788 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1796 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1798 sv_unmagic(sv, PERL_MAGIC_bm);
1804 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
1806 sv_unmagic(sv, PERL_MAGIC_fm);
1812 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
1814 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1816 if (uf && uf->uf_set)
1817 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
1822 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
1824 regexp *re = (regexp *)mg->mg_obj;
1829 #ifdef USE_LOCALE_COLLATE
1831 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
1834 * RenE<eacute> Descartes said "I think not."
1835 * and vanished with a faint plop.
1838 Safefree(mg->mg_ptr);
1844 #endif /* USE_LOCALE_COLLATE */
1847 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
1852 switch (*mg->mg_ptr) {
1853 case '\001': /* ^A */
1854 sv_setsv(PL_bodytarget, sv);
1856 case '\003': /* ^C */
1857 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1860 case '\004': /* ^D */
1861 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
1862 DEBUG_x(dump_all());
1864 case '\005': /* ^E */
1865 if (*(mg->mg_ptr+1) == '\0') {
1866 #ifdef MACOS_TRADITIONAL
1867 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1870 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1873 SetLastError( SvIV(sv) );
1876 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1878 /* will anyone ever use this? */
1879 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
1885 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
1887 sv_setsv(PL_encoding, sv);
1889 PL_encoding = newSVsv(sv);
1891 case '\006': /* ^F */
1892 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1894 case '\010': /* ^H */
1895 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1897 case '\011': /* ^I */ /* NOT \t in EBCDIC */
1899 Safefree(PL_inplace);
1901 PL_inplace = savepv(SvPV(sv,len));
1903 PL_inplace = Nullch;
1905 case '\017': /* ^O */
1906 if (*(mg->mg_ptr+1) == '\0') {
1908 Safefree(PL_osname);
1910 PL_osname = savepv(SvPV(sv,len));
1914 else if (strEQ(mg->mg_ptr, "\017PEN")) {
1915 if (!PL_compiling.cop_io)
1916 PL_compiling.cop_io = newSVsv(sv);
1918 sv_setsv(PL_compiling.cop_io,sv);
1921 case '\020': /* ^P */
1922 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1923 if (PL_perldb && !PL_DBsingle)
1926 case '\024': /* ^T */
1928 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1930 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1933 case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
1934 if (*(mg->mg_ptr+1) == '\0') {
1935 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1936 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1937 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
1938 | (i ? G_WARN_ON : G_WARN_OFF) ;
1941 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
1942 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1943 if (!SvPOK(sv) && PL_localizing) {
1944 sv_setpvn(sv, WARN_NONEstring, WARNsize);
1945 PL_compiling.cop_warnings = pWARN_NONE;
1950 int accumulate = 0 ;
1951 int any_fatals = 0 ;
1952 char * ptr = (char*)SvPV(sv, len) ;
1953 for (i = 0 ; i < len ; ++i) {
1954 accumulate |= ptr[i] ;
1955 any_fatals |= (ptr[i] & 0xAA) ;
1958 PL_compiling.cop_warnings = pWARN_NONE;
1959 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
1960 PL_compiling.cop_warnings = pWARN_ALL;
1961 PL_dowarn |= G_WARN_ONCE ;
1964 if (specialWARN(PL_compiling.cop_warnings))
1965 PL_compiling.cop_warnings = newSVsv(sv) ;
1967 sv_setsv(PL_compiling.cop_warnings, sv);
1968 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
1969 PL_dowarn |= G_WARN_ONCE ;
1975 else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS"))
1976 PL_widesyscalls = (bool)SvTRUE(sv);
1979 if (PL_localizing) {
1980 if (PL_localizing == 1)
1981 SAVESPTR(PL_last_in_gv);
1983 else if (SvOK(sv) && GvIO(PL_last_in_gv))
1984 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
1987 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
1988 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
1989 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1992 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
1993 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
1994 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1997 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2000 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2001 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2002 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2005 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2009 IO *io = GvIOp(PL_defoutgv);
2012 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2013 IoFLAGS(io) &= ~IOf_FLUSH;
2015 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2016 PerlIO *ofp = IoOFP(io);
2018 (void)PerlIO_flush(ofp);
2019 IoFLAGS(io) |= IOf_FLUSH;
2025 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2026 PL_multiline = (i != 0);
2029 SvREFCNT_dec(PL_rs);
2030 PL_rs = newSVsv(sv);
2034 SvREFCNT_dec(PL_ors_sv);
2035 if (SvOK(sv) || SvGMAGICAL(sv)) {
2036 PL_ors_sv = newSVsv(sv);
2044 SvREFCNT_dec(PL_ofs_sv);
2045 if (SvOK(sv) || SvGMAGICAL(sv)) {
2046 PL_ofs_sv = newSVsv(sv);
2055 PL_ofmt = savepv(SvPV(sv,len));
2058 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2061 #ifdef COMPLEX_STATUS
2062 if (PL_localizing == 2) {
2063 PL_statusvalue = LvTARGOFF(sv);
2064 PL_statusvalue_vms = LvTARGLEN(sv);
2068 #ifdef VMSISH_STATUS
2070 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2073 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2076 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2077 (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
2080 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2081 if (PL_delaymagic) {
2082 PL_delaymagic |= DM_RUID;
2083 break; /* don't do magic till later */
2086 (void)setruid((Uid_t)PL_uid);
2089 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2091 #ifdef HAS_SETRESUID
2092 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2094 if (PL_uid == PL_euid) /* special case $< = $> */
2095 (void)PerlProc_setuid(PL_uid);
2097 PL_uid = PerlProc_getuid();
2098 Perl_croak(aTHX_ "setruid() not implemented");
2103 PL_uid = PerlProc_getuid();
2104 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2107 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2108 if (PL_delaymagic) {
2109 PL_delaymagic |= DM_EUID;
2110 break; /* don't do magic till later */
2113 (void)seteuid((Uid_t)PL_euid);
2116 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2118 #ifdef HAS_SETRESUID
2119 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2121 if (PL_euid == PL_uid) /* special case $> = $< */
2122 PerlProc_setuid(PL_euid);
2124 PL_euid = PerlProc_geteuid();
2125 Perl_croak(aTHX_ "seteuid() not implemented");
2130 PL_euid = PerlProc_geteuid();
2131 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2134 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2135 if (PL_delaymagic) {
2136 PL_delaymagic |= DM_RGID;
2137 break; /* don't do magic till later */
2140 (void)setrgid((Gid_t)PL_gid);
2143 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2145 #ifdef HAS_SETRESGID
2146 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2148 if (PL_gid == PL_egid) /* special case $( = $) */
2149 (void)PerlProc_setgid(PL_gid);
2151 PL_gid = PerlProc_getgid();
2152 Perl_croak(aTHX_ "setrgid() not implemented");
2157 PL_gid = PerlProc_getgid();
2158 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2161 #ifdef HAS_SETGROUPS
2163 char *p = SvPV(sv, len);
2164 Groups_t gary[NGROUPS];
2169 for (i = 0; i < NGROUPS; ++i) {
2170 while (*p && !isSPACE(*p))
2179 (void)setgroups(i, gary);
2181 #else /* HAS_SETGROUPS */
2182 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2183 #endif /* HAS_SETGROUPS */
2184 if (PL_delaymagic) {
2185 PL_delaymagic |= DM_EGID;
2186 break; /* don't do magic till later */
2189 (void)setegid((Gid_t)PL_egid);
2192 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2194 #ifdef HAS_SETRESGID
2195 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2197 if (PL_egid == PL_gid) /* special case $) = $( */
2198 (void)PerlProc_setgid(PL_egid);
2200 PL_egid = PerlProc_getegid();
2201 Perl_croak(aTHX_ "setegid() not implemented");
2206 PL_egid = PerlProc_getegid();
2207 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2210 PL_chopset = SvPV_force(sv,len);
2212 #ifndef MACOS_TRADITIONAL
2214 #ifdef HAS_SETPROCTITLE
2215 /* The BSDs don't show the argv[] in ps(1) output, they
2216 * show a string from the process struct and provide
2217 * the setproctitle() routine to manipulate that. */
2220 # if __FreeBSD_version > 410001
2221 /* The leading "-" removes the "perl: " prefix,
2222 * but not the "(perl) suffix from the ps(1)
2223 * output, because that's what ps(1) shows if the
2224 * argv[] is modified. */
2225 setproctitle("-%s", s);
2226 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2227 /* This doesn't really work if you assume that
2228 * $0 = 'foobar'; will wipe out 'perl' from the $0
2229 * because in ps(1) output the result will be like
2230 * sprintf("perl: %s (perl)", s)
2231 * I guess this is a security feature:
2232 * one (a user process) cannot get rid of the original name.
2234 setproctitle("%s", s);
2241 /* See if all the arguments are contiguous in memory */
2242 for (i = 1; i < PL_origargc; i++) {
2243 if (PL_origargv[i] == s + 1
2245 || PL_origargv[i] == s + 2
2250 s += strlen(s); /* this one is ok too */
2255 /* can grab env area too? */
2258 && PL_curinterp == aTHX
2260 && (PL_origenviron[0] == s + 1))
2262 my_setenv("NoNe SuCh", Nullch);
2263 /* force copy of environment */
2264 for (i = 0; PL_origenviron[i]; i++)
2265 if (PL_origenviron[i] == s + 1) {
2272 PL_origalen = s - PL_origargv[0];
2274 s = SvPV_force(sv,len);
2276 if (i >= (I32)PL_origalen) {
2278 /* don't allow system to limit $0 seen by script */
2279 /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
2280 Copy(s, PL_origargv[0], i, char);
2281 s = PL_origargv[0]+i;
2285 Copy(s, PL_origargv[0], i, char);
2286 s = PL_origargv[0]+i;
2288 while (++i < (I32)PL_origalen)
2290 for (i = 1; i < PL_origargc; i++)
2291 PL_origargv[i] = Nullch;
2295 #ifdef USE_5005THREADS
2297 sv_setsv(thr->errsv, sv);
2299 #endif /* USE_5005THREADS */
2304 #ifdef USE_5005THREADS
2306 Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
2308 DEBUG_S(PerlIO_printf(Perl_debug_log,
2309 "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
2310 PTR2UV(thr), PTR2UV(sv)));
2312 Perl_croak(aTHX_ "panic: magic_mutexfree");
2313 MUTEX_DESTROY(MgMUTEXP(mg));
2314 COND_DESTROY(MgCONDP(mg));
2317 #endif /* USE_5005THREADS */
2320 Perl_whichsig(pTHX_ char *sig)
2322 register char **sigv;
2324 for (sigv = PL_sig_name+1; *sigv; sigv++)
2325 if (strEQ(sig,*sigv))
2326 return PL_sig_num[sigv - PL_sig_name];
2328 if (strEQ(sig,"CHLD"))
2332 if (strEQ(sig,"CLD"))
2338 #if !defined(PERL_IMPLICIT_CONTEXT)
2343 Perl_sighandler(int sig)
2345 #ifdef PERL_GET_SIG_CONTEXT
2346 dTHXa(PERL_GET_SIG_CONTEXT);
2353 SV *sv = Nullsv, *tSv = PL_Sv;
2359 if (PL_savestack_ix + 15 <= PL_savestack_max)
2361 if (PL_markstack_ptr < PL_markstack_max - 2)
2363 if (PL_retstack_ix < PL_retstack_max - 2)
2365 if (PL_scopestack_ix < PL_scopestack_max - 3)
2368 if (!PL_psig_ptr[sig]) {
2369 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2374 /* Max number of items pushed there is 3*n or 4. We cannot fix
2375 infinity, so we fix 4 (in fact 5): */
2377 PL_savestack_ix += 5; /* Protect save in progress. */
2378 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2381 PL_markstack_ptr++; /* Protect mark. */
2384 PL_retstack[PL_retstack_ix] = NULL;
2387 PL_scopestack_ix += 1;
2388 /* sv_2cv is too complicated, try a simpler variant first: */
2389 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2390 || SvTYPE(cv) != SVt_PVCV)
2391 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2393 if (!cv || !CvROOT(cv)) {
2394 if (ckWARN(WARN_SIGNAL))
2395 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2396 PL_sig_name[sig], (gv ? GvENAME(gv)
2403 if(PL_psig_name[sig]) {
2404 sv = SvREFCNT_inc(PL_psig_name[sig]);
2406 #if !defined(PERL_IMPLICIT_CONTEXT)
2410 sv = sv_newmortal();
2411 sv_setpv(sv,PL_sig_name[sig]);
2414 PUSHSTACKi(PERLSI_SIGNAL);
2419 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2422 if (SvTRUE(ERRSV)) {
2424 #ifdef HAS_SIGPROCMASK
2425 /* Handler "died", for example to get out of a restart-able read().
2426 * Before we re-do that on its behalf re-enable the signal which was
2427 * blocked by the system when we entered.
2431 sigaddset(&set,sig);
2432 sigprocmask(SIG_UNBLOCK, &set, NULL);
2434 /* Not clear if this will work */
2435 (void)rsignal(sig, SIG_IGN);
2436 (void)rsignal(sig, &Perl_csighandler);
2438 #endif /* !PERL_MICRO */
2439 Perl_die(aTHX_ Nullformat);
2443 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2449 PL_scopestack_ix -= 1;
2452 PL_op = myop; /* Apparently not needed... */
2454 PL_Sv = tSv; /* Restore global temporaries. */
2461 restore_magic(pTHX_ void *p)
2463 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2464 SV* sv = mgs->mgs_sv;
2469 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2472 SvFLAGS(sv) |= mgs->mgs_flags;
2476 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2479 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2481 /* If we're still on top of the stack, pop us off. (That condition
2482 * will be satisfied if restore_magic was called explicitly, but *not*
2483 * if it's being called via leave_scope.)
2484 * The reason for doing this is that otherwise, things like sv_2cv()
2485 * may leave alloc gunk on the savestack, and some code
2486 * (e.g. sighandler) doesn't expect that...
2488 if (PL_savestack_ix == mgs->mgs_ss_ix)
2490 I32 popval = SSPOPINT;
2491 assert(popval == SAVEt_DESTRUCTOR_X);
2492 PL_savestack_ix -= 2;
2494 assert(popval == SAVEt_ALLOC);
2496 PL_savestack_ix -= popval;
2502 unwind_handler_stack(pTHX_ void *p)
2504 U32 flags = *(U32*)p;
2507 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2508 /* cxstack_ix-- Not needed, die already unwound it. */
2509 #if !defined(PERL_IMPLICIT_CONTEXT)
2511 SvREFCNT_dec(sig_sv);