3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
52 # include <sys/pstat.h>
55 Signal_t Perl_csighandler(int sig);
57 /* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
58 #if !defined(HAS_SIGACTION) && defined(VMS)
59 # define FAKE_PERSISTENT_SIGNAL_HANDLERS
61 /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
62 #if defined(KILL_BY_SIGPRC)
63 # define FAKE_DEFAULT_SIGNAL_HANDLERS
66 static void restore_magic(pTHX_ void *p);
67 static void unwind_handler_stack(pTHX_ void *p);
70 /* Missing protos on LynxOS */
71 void setruid(uid_t id);
72 void seteuid(uid_t id);
73 void setrgid(uid_t id);
74 void setegid(uid_t id);
78 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
86 /* MGS is typedef'ed to struct magic_state in perl.h */
89 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
92 assert(SvMAGICAL(sv));
93 #ifdef PERL_COPY_ON_WRITE
94 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
99 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
101 mgs = SSPTR(mgs_ix, MGS*);
103 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
104 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
108 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
112 =for apidoc mg_magical
114 Turns on the magical status of an SV. See C<sv_magic>.
120 Perl_mg_magical(pTHX_ SV *sv)
123 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
124 MGVTBL* vtbl = mg->mg_virtual;
126 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
130 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
139 Do magic after a value is retrieved from the SV. See C<sv_magic>.
145 Perl_mg_get(pTHX_ SV *sv)
148 MAGIC *newmg, *head, *cur, *mg;
149 I32 mgs_ix = SSNEW(sizeof(MGS));
150 int was_temp = SvTEMP(sv);
151 /* guard against sv having being freed midway by holding a private
154 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
155 cause the SV's buffer to get stolen (and maybe other stuff).
158 sv_2mortal(SvREFCNT_inc(sv));
163 save_magic(mgs_ix, sv);
165 /* We must call svt_get(sv, mg) for each valid entry in the linked
166 list of magic. svt_get() may delete the current entry, add new
167 magic to the head of the list, or upgrade the SV. AMS 20010810 */
169 newmg = cur = head = mg = SvMAGIC(sv);
171 MGVTBL *vtbl = mg->mg_virtual;
173 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
174 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
176 /* guard against magic having been deleted - eg FETCH calling
181 /* Don't restore the flags for this entry if it was deleted. */
182 if (mg->mg_flags & MGf_GSKIP)
183 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
186 mg = mg->mg_moremagic;
189 /* Have we finished with the new entries we saw? Start again
190 where we left off (unless there are more new entries). */
198 /* Were any new entries added? */
199 if (!new && (newmg = SvMAGIC(sv)) != head) {
206 restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
208 if (SvREFCNT(sv) == 1) {
209 /* We hold the last reference to this SV, which implies that the
210 SV was deleted as a side effect of the routines we called. */
219 Do magic after a value is assigned to the SV. See C<sv_magic>.
225 Perl_mg_set(pTHX_ SV *sv)
231 mgs_ix = SSNEW(sizeof(MGS));
232 save_magic(mgs_ix, sv);
234 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
235 MGVTBL* vtbl = mg->mg_virtual;
236 nextmg = mg->mg_moremagic; /* it may delete itself */
237 if (mg->mg_flags & MGf_GSKIP) {
238 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
239 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
241 if (vtbl && vtbl->svt_set)
242 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
245 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
250 =for apidoc mg_length
252 Report on the SV's length. See C<sv_magic>.
258 Perl_mg_length(pTHX_ SV *sv)
263 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
264 MGVTBL* vtbl = mg->mg_virtual;
265 if (vtbl && vtbl->svt_len) {
268 mgs_ix = SSNEW(sizeof(MGS));
269 save_magic(mgs_ix, sv);
270 /* omit MGf_GSKIP -- not changed here */
271 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
272 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
279 U8 *s = (U8*)SvPV(sv, len);
280 len = Perl_utf8_length(aTHX_ s, s + len);
288 Perl_mg_size(pTHX_ SV *sv)
293 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
294 MGVTBL* vtbl = mg->mg_virtual;
295 if (vtbl && vtbl->svt_len) {
298 mgs_ix = SSNEW(sizeof(MGS));
299 save_magic(mgs_ix, sv);
300 /* omit MGf_GSKIP -- not changed here */
301 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
302 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
309 len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
314 Perl_croak(aTHX_ "Size magic not implemented");
323 Clear something magical that the SV represents. See C<sv_magic>.
329 Perl_mg_clear(pTHX_ SV *sv)
334 mgs_ix = SSNEW(sizeof(MGS));
335 save_magic(mgs_ix, sv);
337 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
338 MGVTBL* vtbl = mg->mg_virtual;
339 /* omit GSKIP -- never set here */
341 if (vtbl && vtbl->svt_clear)
342 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
345 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
352 Finds the magic pointer for type matching the SV. See C<sv_magic>.
358 Perl_mg_find(pTHX_ SV *sv, int type)
363 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
364 if (mg->mg_type == type)
373 Copies the magic from one SV to another. See C<sv_magic>.
379 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
383 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
384 MGVTBL* vtbl = mg->mg_virtual;
385 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
386 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
388 else if (isUPPER(mg->mg_type)) {
390 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
391 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
393 toLOWER(mg->mg_type), key, klen);
403 Free any magic storage used by the SV. See C<sv_magic>.
409 Perl_mg_free(pTHX_ SV *sv)
413 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
414 MGVTBL* vtbl = mg->mg_virtual;
415 moremagic = mg->mg_moremagic;
416 if (vtbl && vtbl->svt_free)
417 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
418 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
419 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
420 Safefree(mg->mg_ptr);
421 else if (mg->mg_len == HEf_SVKEY)
422 SvREFCNT_dec((SV*)mg->mg_ptr);
424 if (mg->mg_flags & MGf_REFCOUNTED)
425 SvREFCNT_dec(mg->mg_obj);
435 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
439 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
440 if (mg->mg_obj) /* @+ */
443 return rx->lastparen;
450 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
458 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
462 if (paren <= (I32)rx->nparens &&
463 (s = rx->startp[paren]) != -1 &&
464 (t = rx->endp[paren]) != -1)
466 if (mg->mg_obj) /* @+ */
471 if (i > 0 && RX_MATCH_UTF8(rx)) {
472 char *b = rx->subbeg;
474 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
484 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
486 Perl_croak(aTHX_ PL_no_modify);
492 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
499 switch (*mg->mg_ptr) {
500 case '1': case '2': case '3': case '4':
501 case '5': case '6': case '7': case '8': case '9': case '&':
502 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
504 paren = atoi(mg->mg_ptr); /* $& is in [0] */
506 if (paren <= (I32)rx->nparens &&
507 (s1 = rx->startp[paren]) != -1 &&
508 (t1 = rx->endp[paren]) != -1)
512 if (i > 0 && RX_MATCH_UTF8(rx)) {
513 char *s = rx->subbeg + s1;
514 char *send = rx->subbeg + t1;
517 if (is_utf8_string((U8*)s, i))
518 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
521 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
525 if (ckWARN(WARN_UNINITIALIZED))
530 if (ckWARN(WARN_UNINITIALIZED))
535 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
536 paren = rx->lastparen;
541 case '\016': /* ^N */
542 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
543 paren = rx->lastcloseparen;
549 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
550 if (rx->startp[0] != -1) {
561 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
562 if (rx->endp[0] != -1) {
563 i = rx->sublen - rx->endp[0];
574 if (!SvPOK(sv) && SvNIOK(sv)) {
584 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
587 register char *s = NULL;
591 switch (*mg->mg_ptr) {
592 case '\001': /* ^A */
593 sv_setsv(sv, PL_bodytarget);
595 case '\003': /* ^C */
596 sv_setiv(sv, (IV)PL_minus_c);
599 case '\004': /* ^D */
600 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
602 case '\005': /* ^E */
603 if (*(mg->mg_ptr+1) == '\0') {
604 #ifdef MACOS_TRADITIONAL
608 sv_setnv(sv,(double)gMacPerl_OSErr);
609 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
614 # include <descrip.h>
615 # include <starlet.h>
617 $DESCRIPTOR(msgdsc,msg);
618 sv_setnv(sv,(NV) vaxc$errno);
619 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
620 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
626 if (!(_emx_env & 0x200)) { /* Under DOS */
627 sv_setnv(sv, (NV)errno);
628 sv_setpv(sv, errno ? Strerror(errno) : "");
630 if (errno != errno_isOS2) {
631 int tmp = _syserrno();
632 if (tmp) /* 2nd call to _syserrno() makes it 0 */
635 sv_setnv(sv, (NV)Perl_rc);
636 sv_setpv(sv, os2error(Perl_rc));
641 DWORD dwErr = GetLastError();
642 sv_setnv(sv, (NV)dwErr);
645 PerlProc_GetOSError(sv, dwErr);
653 int saveerrno = errno;
654 sv_setnv(sv, (NV)errno);
655 sv_setpv(sv, errno ? Strerror(errno) : "");
662 SvNOK_on(sv); /* what a wonderful hack! */
664 else if (strEQ(mg->mg_ptr+1, "NCODING"))
665 sv_setsv(sv, PL_encoding);
667 case '\006': /* ^F */
668 sv_setiv(sv, (IV)PL_maxsysfd);
670 case '\010': /* ^H */
671 sv_setiv(sv, (IV)PL_hints);
673 case '\011': /* ^I */ /* NOT \t in EBCDIC */
675 sv_setpv(sv, PL_inplace);
677 sv_setsv(sv, &PL_sv_undef);
679 case '\017': /* ^O & ^OPEN */
680 if (*(mg->mg_ptr+1) == '\0') {
681 sv_setpv(sv, PL_osname);
684 else if (strEQ(mg->mg_ptr, "\017PEN")) {
685 if (!PL_compiling.cop_io)
686 sv_setsv(sv, &PL_sv_undef);
688 sv_setsv(sv, PL_compiling.cop_io);
692 case '\020': /* ^P */
693 sv_setiv(sv, (IV)PL_perldb);
695 case '\023': /* ^S */
696 if (*(mg->mg_ptr+1) == '\0') {
697 if (PL_lex_state != LEX_NOTPARSING)
700 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
705 case '\024': /* ^T */
706 if (*(mg->mg_ptr+1) == '\0') {
708 sv_setnv(sv, PL_basetime);
710 sv_setiv(sv, (IV)PL_basetime);
713 else if (strEQ(mg->mg_ptr, "\024AINT"))
714 sv_setiv(sv, PL_tainting
715 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
718 case '\025': /* $^UNICODE */
719 if (strEQ(mg->mg_ptr, "\025NICODE"))
720 sv_setuv(sv, (UV) PL_unicode);
722 case '\027': /* ^W & $^WARNING_BITS */
723 if (*(mg->mg_ptr+1) == '\0')
724 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
725 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
726 if (PL_compiling.cop_warnings == pWARN_NONE ||
727 PL_compiling.cop_warnings == pWARN_STD)
729 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
731 else if (PL_compiling.cop_warnings == pWARN_ALL) {
732 /* Get the bit mask for $warnings::Bits{all}, because
733 * it could have been extended by warnings::register */
735 HV *bits=get_hv("warnings::Bits", FALSE);
736 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
737 sv_setsv(sv, *bits_all);
740 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
744 sv_setsv(sv, PL_compiling.cop_warnings);
749 case '1': case '2': case '3': case '4':
750 case '5': case '6': case '7': case '8': case '9': case '&':
751 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
755 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
756 * XXX Does the new way break anything?
758 paren = atoi(mg->mg_ptr); /* $& is in [0] */
760 if (paren <= (I32)rx->nparens &&
761 (s1 = rx->startp[paren]) != -1 &&
762 (t1 = rx->endp[paren]) != -1)
772 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
777 if (RX_MATCH_TAINTED(rx)) {
778 MAGIC* mg = SvMAGIC(sv);
781 SvMAGIC(sv) = mg->mg_moremagic;
783 if ((mgt = SvMAGIC(sv))) {
784 mg->mg_moremagic = mgt;
794 sv_setsv(sv,&PL_sv_undef);
797 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
798 paren = rx->lastparen;
802 sv_setsv(sv,&PL_sv_undef);
804 case '\016': /* ^N */
805 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
806 paren = rx->lastcloseparen;
810 sv_setsv(sv,&PL_sv_undef);
813 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
814 if ((s = rx->subbeg) && rx->startp[0] != -1) {
819 sv_setsv(sv,&PL_sv_undef);
822 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
823 if (rx->subbeg && rx->endp[0] != -1) {
824 s = rx->subbeg + rx->endp[0];
825 i = rx->sublen - rx->endp[0];
829 sv_setsv(sv,&PL_sv_undef);
833 if (GvIO(PL_last_in_gv)) {
834 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
840 sv_setiv(sv, (IV)STATUS_CURRENT);
841 #ifdef COMPLEX_STATUS
842 LvTARGOFF(sv) = PL_statusvalue;
843 LvTARGLEN(sv) = PL_statusvalue_vms;
848 if (GvIOp(PL_defoutgv))
849 s = IoTOP_NAME(GvIOp(PL_defoutgv));
853 sv_setpv(sv,GvENAME(PL_defoutgv));
858 if (GvIOp(PL_defoutgv))
859 s = IoFMT_NAME(GvIOp(PL_defoutgv));
861 s = GvENAME(PL_defoutgv);
866 if (GvIOp(PL_defoutgv))
867 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
870 if (GvIOp(PL_defoutgv))
871 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
874 if (GvIOp(PL_defoutgv))
875 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
883 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
886 if (GvIOp(PL_defoutgv))
887 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
893 sv_copypv(sv, PL_ors_sv);
896 sv_setpv(sv,PL_ofmt);
900 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
901 sv_setpv(sv, errno ? Strerror(errno) : "");
904 int saveerrno = errno;
905 sv_setnv(sv, (NV)errno);
907 if (errno == errno_isOS2 || errno == errno_isOS2_set)
908 sv_setpv(sv, os2error(Perl_rc));
911 sv_setpv(sv, errno ? Strerror(errno) : "");
915 SvNOK_on(sv); /* what a wonderful hack! */
918 sv_setiv(sv, (IV)PL_uid);
921 sv_setiv(sv, (IV)PL_euid);
924 sv_setiv(sv, (IV)PL_gid);
926 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
930 sv_setiv(sv, (IV)PL_egid);
932 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
937 Groups_t gary[NGROUPS];
938 i = getgroups(NGROUPS,gary);
940 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
943 (void)SvIOK_on(sv); /* what a wonderful hack! */
945 #ifndef MACOS_TRADITIONAL
954 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
956 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
958 if (uf && uf->uf_val)
959 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
964 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
974 #ifdef DYNAMIC_ENV_FETCH
975 /* We just undefd an environment var. Is a replacement */
976 /* waiting in the wings? */
979 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
980 s = SvPV(*valp, len);
984 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
985 /* And you'll never guess what the dog had */
986 /* in its mouth... */
988 MgTAINTEDDIR_off(mg);
990 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
991 char pathbuf[256], eltbuf[256], *cp, *elt = s;
995 do { /* DCL$PATH may be a search list */
996 while (1) { /* as may dev portion of any element */
997 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
998 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
999 cando_by_name(S_IWUSR,0,elt) ) {
1000 MgTAINTEDDIR_on(mg);
1004 if ((cp = strchr(elt, ':')) != Nullch)
1006 if (my_trnlnm(elt, eltbuf, j++))
1012 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1015 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1016 char *strend = s + len;
1018 while (s < strend) {
1022 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1023 s, strend, ':', &i);
1025 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1027 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1028 MgTAINTEDDIR_on(mg);
1034 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1040 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1043 my_setenv(MgPV(mg,n_a),Nullch);
1048 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1051 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1053 if (PL_localizing) {
1056 magic_clear_all_env(sv,mg);
1057 hv_iterinit((HV*)sv);
1058 while ((entry = hv_iternext((HV*)sv))) {
1060 my_setenv(hv_iterkey(entry, &keylen),
1061 SvPV(hv_iterval((HV*)sv, entry), n_a));
1069 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1072 #if defined(VMS) || defined(EPOC)
1073 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1075 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1078 # ifdef USE_ENVIRON_ARRAY
1079 # if defined(USE_ITHREADS)
1080 /* only the parent thread can clobber the process environment */
1081 if (PL_curinterp == aTHX)
1084 # ifndef PERL_USE_SAFE_PUTENV
1087 if (environ == PL_origenviron)
1088 environ = (char**)safesysmalloc(sizeof(char*));
1090 for (i = 0; environ[i]; i++)
1091 safesysfree(environ[i]);
1092 # endif /* PERL_USE_SAFE_PUTENV */
1094 environ[0] = Nullch;
1096 # endif /* USE_ENVIRON_ARRAY */
1097 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1098 #endif /* VMS || EPOC */
1099 #endif /* !PERL_MICRO */
1103 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1104 static int sig_handlers_initted = 0;
1106 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1107 static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
1109 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1110 static int sig_defaulting[SIG_SIZE];
1114 #ifdef HAS_SIGPROCMASK
1116 restore_sigmask(pTHX_ SV *save_sv)
1118 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1119 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1123 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1127 /* Are we fetching a signal entry? */
1128 i = whichsig(MgPV(mg,n_a));
1131 sv_setsv(sv,PL_psig_ptr[i]);
1133 Sighandler_t sigstate;
1134 sigstate = rsignal_state(i);
1135 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1136 if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1138 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1139 if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
1141 /* cache state so we don't fetch it again */
1142 if(sigstate == SIG_IGN)
1143 sv_setpv(sv,"IGNORE");
1145 sv_setsv(sv,&PL_sv_undef);
1146 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1153 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1155 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1156 * refactoring might be in order.
1164 if (strEQ(s,"__DIE__"))
1166 else if (strEQ(s,"__WARN__"))
1169 Perl_croak(aTHX_ "No such hook: %s", s);
1173 SvREFCNT_dec(to_dec);
1178 /* Are we clearing a signal entry? */
1181 #ifdef HAS_SIGPROCMASK
1184 /* Avoid having the signal arrive at a bad time, if possible. */
1187 sigprocmask(SIG_BLOCK, &set, &save);
1189 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1190 SAVEFREESV(save_sv);
1191 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1194 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1195 if (!sig_handlers_initted) Perl_csighandler_init();
1197 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1198 sig_defaulting[i] = 1;
1199 (void)rsignal(i, PL_csighandlerp);
1201 (void)rsignal(i, SIG_DFL);
1203 if(PL_psig_name[i]) {
1204 SvREFCNT_dec(PL_psig_name[i]);
1207 if(PL_psig_ptr[i]) {
1208 to_dec=PL_psig_ptr[i];
1211 SvREFCNT_dec(to_dec);
1221 Perl_raise_signal(pTHX_ int sig)
1223 /* Set a flag to say this signal is pending */
1224 PL_psig_pend[sig]++;
1225 /* And one to say _a_ signal is pending */
1230 Perl_csighandler(int sig)
1232 #ifdef PERL_GET_SIG_CONTEXT
1233 dTHXa(PERL_GET_SIG_CONTEXT);
1237 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1238 (void) rsignal(sig, PL_csighandlerp);
1239 if (sig_ignoring[sig]) return;
1241 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1242 if (sig_defaulting[sig])
1243 #ifdef KILL_BY_SIGPRC
1244 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1249 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1250 /* Call the perl level handler now--
1251 * with risk we may be in malloc() etc. */
1252 (*PL_sighandlerp)(sig);
1254 Perl_raise_signal(aTHX_ sig);
1257 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1259 Perl_csighandler_init(void)
1262 if (sig_handlers_initted) return;
1264 for (sig = 1; sig < SIG_SIZE; sig++) {
1265 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1267 sig_defaulting[sig] = 1;
1268 (void) rsignal(sig, PL_csighandlerp);
1270 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1271 sig_ignoring[sig] = 0;
1274 sig_handlers_initted = 1;
1279 Perl_despatch_signals(pTHX)
1283 for (sig = 1; sig < SIG_SIZE; sig++) {
1284 if (PL_psig_pend[sig]) {
1285 PERL_BLOCKSIG_ADD(set, sig);
1286 PL_psig_pend[sig] = 0;
1287 PERL_BLOCKSIG_BLOCK(set);
1288 (*PL_sighandlerp)(sig);
1289 PERL_BLOCKSIG_UNBLOCK(set);
1295 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1300 /* Need to be careful with SvREFCNT_dec(), because that can have side
1301 * effects (due to closures). We must make sure that the new disposition
1302 * is in place before it is called.
1306 #ifdef HAS_SIGPROCMASK
1313 if (strEQ(s,"__DIE__"))
1315 else if (strEQ(s,"__WARN__"))
1318 Perl_croak(aTHX_ "No such hook: %s", s);
1326 i = whichsig(s); /* ...no, a brick */
1328 if (ckWARN(WARN_SIGNAL))
1329 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1332 #ifdef HAS_SIGPROCMASK
1333 /* Avoid having the signal arrive at a bad time, if possible. */
1336 sigprocmask(SIG_BLOCK, &set, &save);
1338 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1339 SAVEFREESV(save_sv);
1340 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1343 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1344 if (!sig_handlers_initted) Perl_csighandler_init();
1346 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1347 sig_ignoring[i] = 0;
1349 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1350 sig_defaulting[i] = 0;
1352 SvREFCNT_dec(PL_psig_name[i]);
1353 to_dec = PL_psig_ptr[i];
1354 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1355 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1356 PL_psig_name[i] = newSVpvn(s, len);
1357 SvREADONLY_on(PL_psig_name[i]);
1359 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1361 (void)rsignal(i, PL_csighandlerp);
1362 #ifdef HAS_SIGPROCMASK
1367 *svp = SvREFCNT_inc(sv);
1369 SvREFCNT_dec(to_dec);
1372 s = SvPV_force(sv,len);
1373 if (strEQ(s,"IGNORE")) {
1375 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1376 sig_ignoring[i] = 1;
1377 (void)rsignal(i, PL_csighandlerp);
1379 (void)rsignal(i, SIG_IGN);
1383 else if (strEQ(s,"DEFAULT") || !*s) {
1385 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1387 sig_defaulting[i] = 1;
1388 (void)rsignal(i, PL_csighandlerp);
1391 (void)rsignal(i, SIG_DFL);
1396 * We should warn if HINT_STRICT_REFS, but without
1397 * access to a known hint bit in a known OP, we can't
1398 * tell whether HINT_STRICT_REFS is in force or not.
1400 if (!strchr(s,':') && !strchr(s,'\''))
1401 sv_insert(sv, 0, 0, "main::", 6);
1403 (void)rsignal(i, PL_csighandlerp);
1405 *svp = SvREFCNT_inc(sv);
1407 #ifdef HAS_SIGPROCMASK
1412 SvREFCNT_dec(to_dec);
1415 #endif /* !PERL_MICRO */
1418 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1420 PL_sub_generation++;
1425 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1427 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1428 PL_amagic_generation++;
1434 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1436 HV *hv = (HV*)LvTARG(sv);
1440 (void) hv_iterinit(hv);
1441 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1444 while (hv_iternext(hv))
1449 sv_setiv(sv, (IV)i);
1454 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1457 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1462 /* caller is responsible for stack switching/cleanup */
1464 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1470 PUSHs(SvTIED_obj(sv, mg));
1473 if (mg->mg_len >= 0)
1474 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1475 else if (mg->mg_len == HEf_SVKEY)
1476 PUSHs((SV*)mg->mg_ptr);
1478 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1479 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1487 return call_method(meth, flags);
1491 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
1497 PUSHSTACKi(PERLSI_MAGIC);
1499 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1500 sv_setsv(sv, *PL_stack_sp--);
1510 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1513 mg->mg_flags |= MGf_GSKIP;
1514 magic_methpack(sv,mg,"FETCH");
1519 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1523 PUSHSTACKi(PERLSI_MAGIC);
1524 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1531 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1533 return magic_methpack(sv,mg,"DELETE");
1538 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1545 PUSHSTACKi(PERLSI_MAGIC);
1546 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1547 sv = *PL_stack_sp--;
1548 retval = (U32) SvIV(sv)-1;
1557 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1562 PUSHSTACKi(PERLSI_MAGIC);
1564 XPUSHs(SvTIED_obj(sv, mg));
1566 call_method("CLEAR", G_SCALAR|G_DISCARD);
1574 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1577 const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1581 PUSHSTACKi(PERLSI_MAGIC);
1584 PUSHs(SvTIED_obj(sv, mg));
1589 if (call_method(meth, G_SCALAR))
1590 sv_setsv(key, *PL_stack_sp--);
1599 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1601 return magic_methpack(sv,mg,"EXISTS");
1605 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1608 SV *retval = &PL_sv_undef;
1609 SV *tied = SvTIED_obj((SV*)hv, mg);
1610 HV *pkg = SvSTASH((SV*)SvRV(tied));
1612 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1615 /* we are in an iteration so the hash cannot be empty */
1617 /* no xhv_eiter so now use FIRSTKEY */
1618 key = sv_newmortal();
1619 magic_nextpack((SV*)hv, mg, key);
1620 HvEITER(hv) = NULL; /* need to reset iterator */
1621 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1624 /* there is a SCALAR method that we can call */
1626 PUSHSTACKi(PERLSI_MAGIC);
1632 if (call_method("SCALAR", G_SCALAR))
1633 retval = *PL_stack_sp--;
1640 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1650 svp = av_fetch(GvAV(gv),
1651 atoi(MgPV(mg,n_a)), FALSE);
1652 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1653 /* set or clear breakpoint in the relevant control op */
1655 o->op_flags |= OPf_SPECIAL;
1657 o->op_flags &= ~OPf_SPECIAL;
1663 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1665 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1670 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1672 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1677 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1679 SV* lsv = LvTARG(sv);
1681 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1682 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1683 if (mg && mg->mg_len >= 0) {
1686 sv_pos_b2u(lsv, &i);
1687 sv_setiv(sv, i + PL_curcop->cop_arybase);
1696 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1698 SV* lsv = LvTARG(sv);
1705 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1706 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1710 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1711 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1713 else if (!SvOK(sv)) {
1717 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1719 pos = SvIV(sv) - PL_curcop->cop_arybase;
1722 ulen = sv_len_utf8(lsv);
1732 else if (pos > (SSize_t)len)
1737 sv_pos_u2b(lsv, &p, 0);
1742 mg->mg_flags &= ~MGf_MINMATCH;
1748 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1750 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1752 gv_efullname3(sv,((GV*)sv), "*");
1756 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1761 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1770 if (*s == '*' && s[1])
1772 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1777 GvGP(sv) = gp_ref(GvGP(gv));
1782 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1785 SV *lsv = LvTARG(sv);
1786 char *tmps = SvPV(lsv,len);
1787 I32 offs = LvTARGOFF(sv);
1788 I32 rem = LvTARGLEN(sv);
1791 sv_pos_u2b(lsv, &offs, &rem);
1792 if (offs > (I32)len)
1794 if (rem + offs > (I32)len)
1796 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1803 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1806 char *tmps = SvPV(sv, len);
1807 SV *lsv = LvTARG(sv);
1808 I32 lvoff = LvTARGOFF(sv);
1809 I32 lvlen = LvTARGLEN(sv);
1812 sv_utf8_upgrade(lsv);
1813 sv_pos_u2b(lsv, &lvoff, &lvlen);
1814 sv_insert(lsv, lvoff, lvlen, tmps, len);
1815 LvTARGLEN(sv) = sv_len_utf8(sv);
1818 else if (lsv && SvUTF8(lsv)) {
1819 sv_pos_u2b(lsv, &lvoff, &lvlen);
1820 LvTARGLEN(sv) = len;
1821 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1822 sv_insert(lsv, lvoff, lvlen, tmps, len);
1826 sv_insert(lsv, lvoff, lvlen, tmps, len);
1827 LvTARGLEN(sv) = len;
1835 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1837 TAINT_IF((mg->mg_len & 1) ||
1838 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1843 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1845 if (PL_localizing) {
1846 if (PL_localizing == 1)
1851 else if (PL_tainted)
1859 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1861 SV *lsv = LvTARG(sv);
1868 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1873 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1875 do_vecset(sv); /* XXX slurp this routine */
1880 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1883 if (LvTARGLEN(sv)) {
1885 SV *ahv = LvTARG(sv);
1886 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1891 AV* av = (AV*)LvTARG(sv);
1892 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1893 targ = AvARRAY(av)[LvTARGOFF(sv)];
1895 if (targ && targ != &PL_sv_undef) {
1896 /* somebody else defined it for us */
1897 SvREFCNT_dec(LvTARG(sv));
1898 LvTARG(sv) = SvREFCNT_inc(targ);
1900 SvREFCNT_dec(mg->mg_obj);
1901 mg->mg_obj = Nullsv;
1902 mg->mg_flags &= ~MGf_REFCOUNTED;
1907 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1912 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1917 sv_setsv(LvTARG(sv), sv);
1918 SvSETMAGIC(LvTARG(sv));
1924 Perl_vivify_defelem(pTHX_ SV *sv)
1929 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1932 SV *ahv = LvTARG(sv);
1934 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1937 if (!value || value == &PL_sv_undef)
1938 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1941 AV* av = (AV*)LvTARG(sv);
1942 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1943 LvTARG(sv) = Nullsv; /* array can't be extended */
1945 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1946 if (!svp || (value = *svp) == &PL_sv_undef)
1947 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1950 (void)SvREFCNT_inc(value);
1951 SvREFCNT_dec(LvTARG(sv));
1954 SvREFCNT_dec(mg->mg_obj);
1955 mg->mg_obj = Nullsv;
1956 mg->mg_flags &= ~MGf_REFCOUNTED;
1960 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1962 AV *av = (AV*)mg->mg_obj;
1963 SV **svp = AvARRAY(av);
1964 I32 i = AvFILLp(av);
1967 if (!SvWEAKREF(svp[i]))
1968 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1969 /* XXX Should we check that it hasn't changed? */
1972 SvWEAKREF_off(svp[i]);
1977 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1982 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1990 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1992 sv_unmagic(sv, PERL_MAGIC_bm);
1998 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2000 sv_unmagic(sv, PERL_MAGIC_fm);
2006 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2008 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
2010 if (uf && uf->uf_set)
2011 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2016 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2018 sv_unmagic(sv, PERL_MAGIC_qr);
2023 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2025 regexp *re = (regexp *)mg->mg_obj;
2030 #ifdef USE_LOCALE_COLLATE
2032 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2035 * RenE<eacute> Descartes said "I think not."
2036 * and vanished with a faint plop.
2039 Safefree(mg->mg_ptr);
2045 #endif /* USE_LOCALE_COLLATE */
2047 /* Just clear the UTF-8 cache data. */
2049 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2051 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2053 mg->mg_len = -1; /* The mg_len holds the len cache. */
2058 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2063 switch (*mg->mg_ptr) {
2064 case '\001': /* ^A */
2065 sv_setsv(PL_bodytarget, sv);
2067 case '\003': /* ^C */
2068 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2071 case '\004': /* ^D */
2074 PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
2075 DEBUG_x(dump_all());
2077 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2080 case '\005': /* ^E */
2081 if (*(mg->mg_ptr+1) == '\0') {
2082 #ifdef MACOS_TRADITIONAL
2083 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2086 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2089 SetLastError( SvIV(sv) );
2092 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2094 /* will anyone ever use this? */
2095 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2101 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2103 SvREFCNT_dec(PL_encoding);
2104 if (SvOK(sv) || SvGMAGICAL(sv)) {
2105 PL_encoding = newSVsv(sv);
2108 PL_encoding = Nullsv;
2112 case '\006': /* ^F */
2113 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2115 case '\010': /* ^H */
2116 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2118 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2120 Safefree(PL_inplace);
2122 PL_inplace = savepv(SvPV(sv,len));
2124 PL_inplace = Nullch;
2126 case '\017': /* ^O */
2127 if (*(mg->mg_ptr+1) == '\0') {
2129 Safefree(PL_osname);
2133 TAINT_PROPER("assigning to $^O");
2134 PL_osname = savepv(SvPV(sv,len));
2137 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2138 if (!PL_compiling.cop_io)
2139 PL_compiling.cop_io = newSVsv(sv);
2141 sv_setsv(PL_compiling.cop_io,sv);
2144 case '\020': /* ^P */
2145 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2146 if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
2150 case '\024': /* ^T */
2152 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2154 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2157 case '\027': /* ^W & $^WARNING_BITS */
2158 if (*(mg->mg_ptr+1) == '\0') {
2159 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2160 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2161 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2162 | (i ? G_WARN_ON : G_WARN_OFF) ;
2165 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2166 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2167 if (!SvPOK(sv) && PL_localizing) {
2168 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2169 PL_compiling.cop_warnings = pWARN_NONE;
2174 int accumulate = 0 ;
2175 int any_fatals = 0 ;
2176 char * ptr = (char*)SvPV(sv, len) ;
2177 for (i = 0 ; i < len ; ++i) {
2178 accumulate |= ptr[i] ;
2179 any_fatals |= (ptr[i] & 0xAA) ;
2182 PL_compiling.cop_warnings = pWARN_NONE;
2183 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2184 PL_compiling.cop_warnings = pWARN_ALL;
2185 PL_dowarn |= G_WARN_ONCE ;
2188 if (specialWARN(PL_compiling.cop_warnings))
2189 PL_compiling.cop_warnings = newSVsv(sv) ;
2191 sv_setsv(PL_compiling.cop_warnings, sv);
2192 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2193 PL_dowarn |= G_WARN_ONCE ;
2201 if (PL_localizing) {
2202 if (PL_localizing == 1)
2203 SAVESPTR(PL_last_in_gv);
2205 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2206 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2209 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2210 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2211 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2214 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2215 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2216 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2219 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2222 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2223 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2224 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2227 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2231 IO *io = GvIOp(PL_defoutgv);
2234 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2235 IoFLAGS(io) &= ~IOf_FLUSH;
2237 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2238 PerlIO *ofp = IoOFP(io);
2240 (void)PerlIO_flush(ofp);
2241 IoFLAGS(io) |= IOf_FLUSH;
2247 SvREFCNT_dec(PL_rs);
2248 PL_rs = newSVsv(sv);
2252 SvREFCNT_dec(PL_ors_sv);
2253 if (SvOK(sv) || SvGMAGICAL(sv)) {
2254 PL_ors_sv = newSVsv(sv);
2262 SvREFCNT_dec(PL_ofs_sv);
2263 if (SvOK(sv) || SvGMAGICAL(sv)) {
2264 PL_ofs_sv = newSVsv(sv);
2273 PL_ofmt = savepv(SvPV(sv,len));
2276 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2279 #ifdef COMPLEX_STATUS
2280 if (PL_localizing == 2) {
2281 PL_statusvalue = LvTARGOFF(sv);
2282 PL_statusvalue_vms = LvTARGLEN(sv);
2286 #ifdef VMSISH_STATUS
2288 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2291 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2296 # define PERL_VMS_BANG vaxc$errno
2298 # define PERL_VMS_BANG 0
2300 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2301 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2305 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2306 if (PL_delaymagic) {
2307 PL_delaymagic |= DM_RUID;
2308 break; /* don't do magic till later */
2311 (void)setruid((Uid_t)PL_uid);
2314 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2316 #ifdef HAS_SETRESUID
2317 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2319 if (PL_uid == PL_euid) { /* special case $< = $> */
2321 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2322 if (PL_uid != 0 && PerlProc_getuid() == 0)
2323 (void)PerlProc_setuid(0);
2325 (void)PerlProc_setuid(PL_uid);
2327 PL_uid = PerlProc_getuid();
2328 Perl_croak(aTHX_ "setruid() not implemented");
2333 PL_uid = PerlProc_getuid();
2334 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2337 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2338 if (PL_delaymagic) {
2339 PL_delaymagic |= DM_EUID;
2340 break; /* don't do magic till later */
2343 (void)seteuid((Uid_t)PL_euid);
2346 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2348 #ifdef HAS_SETRESUID
2349 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2351 if (PL_euid == PL_uid) /* special case $> = $< */
2352 PerlProc_setuid(PL_euid);
2354 PL_euid = PerlProc_geteuid();
2355 Perl_croak(aTHX_ "seteuid() not implemented");
2360 PL_euid = PerlProc_geteuid();
2361 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2364 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2365 if (PL_delaymagic) {
2366 PL_delaymagic |= DM_RGID;
2367 break; /* don't do magic till later */
2370 (void)setrgid((Gid_t)PL_gid);
2373 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2375 #ifdef HAS_SETRESGID
2376 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2378 if (PL_gid == PL_egid) /* special case $( = $) */
2379 (void)PerlProc_setgid(PL_gid);
2381 PL_gid = PerlProc_getgid();
2382 Perl_croak(aTHX_ "setrgid() not implemented");
2387 PL_gid = PerlProc_getgid();
2388 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2391 #ifdef HAS_SETGROUPS
2393 char *p = SvPV(sv, len);
2394 Groups_t gary[NGROUPS];
2399 for (i = 0; i < NGROUPS; ++i) {
2400 while (*p && !isSPACE(*p))
2409 (void)setgroups(i, gary);
2411 #else /* HAS_SETGROUPS */
2412 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2413 #endif /* HAS_SETGROUPS */
2414 if (PL_delaymagic) {
2415 PL_delaymagic |= DM_EGID;
2416 break; /* don't do magic till later */
2419 (void)setegid((Gid_t)PL_egid);
2422 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2424 #ifdef HAS_SETRESGID
2425 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2427 if (PL_egid == PL_gid) /* special case $) = $( */
2428 (void)PerlProc_setgid(PL_egid);
2430 PL_egid = PerlProc_getegid();
2431 Perl_croak(aTHX_ "setegid() not implemented");
2436 PL_egid = PerlProc_getegid();
2437 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2440 PL_chopset = SvPV_force(sv,len);
2442 #ifndef MACOS_TRADITIONAL
2444 LOCK_DOLLARZERO_MUTEX;
2445 #ifdef HAS_SETPROCTITLE
2446 /* The BSDs don't show the argv[] in ps(1) output, they
2447 * show a string from the process struct and provide
2448 * the setproctitle() routine to manipulate that. */
2451 # if __FreeBSD_version > 410001
2452 /* The leading "-" removes the "perl: " prefix,
2453 * but not the "(perl) suffix from the ps(1)
2454 * output, because that's what ps(1) shows if the
2455 * argv[] is modified. */
2456 setproctitle("-%s", s);
2457 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2458 /* This doesn't really work if you assume that
2459 * $0 = 'foobar'; will wipe out 'perl' from the $0
2460 * because in ps(1) output the result will be like
2461 * sprintf("perl: %s (perl)", s)
2462 * I guess this is a security feature:
2463 * one (a user process) cannot get rid of the original name.
2465 setproctitle("%s", s);
2469 #if defined(__hpux) && defined(PSTAT_SETCMD)
2474 pstat(PSTAT_SETCMD, un, len, 0, 0);
2477 /* PL_origalen is set in perl_parse(). */
2478 s = SvPV_force(sv,len);
2479 if (len >= (STRLEN)PL_origalen-1) {
2480 /* Longer than original, will be truncated. We assume that
2481 * PL_origalen bytes are available. */
2482 Copy(s, PL_origargv[0], PL_origalen-1, char);
2485 /* Shorter than original, will be padded. */
2486 Copy(s, PL_origargv[0], len, char);
2487 PL_origargv[0][len] = 0;
2488 memset(PL_origargv[0] + len + 1,
2489 /* Is the space counterintuitive? Yes.
2490 * (You were expecting \0?)
2491 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2494 PL_origalen - len - 1);
2496 PL_origargv[0][PL_origalen-1] = 0;
2497 for (i = 1; i < PL_origargc; i++)
2499 UNLOCK_DOLLARZERO_MUTEX;
2507 Perl_whichsig(pTHX_ char *sig)
2509 register char **sigv;
2511 for (sigv = PL_sig_name; *sigv; sigv++)
2512 if (strEQ(sig,*sigv))
2513 return PL_sig_num[sigv - PL_sig_name];
2515 if (strEQ(sig,"CHLD"))
2519 if (strEQ(sig,"CLD"))
2525 #if !defined(PERL_IMPLICIT_CONTEXT)
2530 Perl_sighandler(int sig)
2532 #ifdef PERL_GET_SIG_CONTEXT
2533 dTHXa(PERL_GET_SIG_CONTEXT);
2540 SV *sv = Nullsv, *tSv = PL_Sv;
2546 if (PL_savestack_ix + 15 <= PL_savestack_max)
2548 if (PL_markstack_ptr < PL_markstack_max - 2)
2550 if (PL_scopestack_ix < PL_scopestack_max - 3)
2553 if (!PL_psig_ptr[sig]) {
2554 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2559 /* Max number of items pushed there is 3*n or 4. We cannot fix
2560 infinity, so we fix 4 (in fact 5): */
2562 PL_savestack_ix += 5; /* Protect save in progress. */
2563 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2566 PL_markstack_ptr++; /* Protect mark. */
2568 PL_scopestack_ix += 1;
2569 /* sv_2cv is too complicated, try a simpler variant first: */
2570 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2571 || SvTYPE(cv) != SVt_PVCV)
2572 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2574 if (!cv || !CvROOT(cv)) {
2575 if (ckWARN(WARN_SIGNAL))
2576 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2577 PL_sig_name[sig], (gv ? GvENAME(gv)
2584 if(PL_psig_name[sig]) {
2585 sv = SvREFCNT_inc(PL_psig_name[sig]);
2587 #if !defined(PERL_IMPLICIT_CONTEXT)
2591 sv = sv_newmortal();
2592 sv_setpv(sv,PL_sig_name[sig]);
2595 PUSHSTACKi(PERLSI_SIGNAL);
2600 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2603 if (SvTRUE(ERRSV)) {
2605 #ifdef HAS_SIGPROCMASK
2606 /* Handler "died", for example to get out of a restart-able read().
2607 * Before we re-do that on its behalf re-enable the signal which was
2608 * blocked by the system when we entered.
2612 sigaddset(&set,sig);
2613 sigprocmask(SIG_UNBLOCK, &set, NULL);
2615 /* Not clear if this will work */
2616 (void)rsignal(sig, SIG_IGN);
2617 (void)rsignal(sig, PL_csighandlerp);
2619 #endif /* !PERL_MICRO */
2620 Perl_die(aTHX_ Nullformat);
2624 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2628 PL_scopestack_ix -= 1;
2631 PL_op = myop; /* Apparently not needed... */
2633 PL_Sv = tSv; /* Restore global temporaries. */
2640 restore_magic(pTHX_ void *p)
2642 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2643 SV* sv = mgs->mgs_sv;
2648 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2650 #ifdef PERL_COPY_ON_WRITE
2651 /* While magic was saved (and off) sv_setsv may well have seen
2652 this SV as a prime candidate for COW. */
2654 sv_force_normal(sv);
2658 SvFLAGS(sv) |= mgs->mgs_flags;
2662 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2665 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2667 /* If we're still on top of the stack, pop us off. (That condition
2668 * will be satisfied if restore_magic was called explicitly, but *not*
2669 * if it's being called via leave_scope.)
2670 * The reason for doing this is that otherwise, things like sv_2cv()
2671 * may leave alloc gunk on the savestack, and some code
2672 * (e.g. sighandler) doesn't expect that...
2674 if (PL_savestack_ix == mgs->mgs_ss_ix)
2676 I32 popval = SSPOPINT;
2677 assert(popval == SAVEt_DESTRUCTOR_X);
2678 PL_savestack_ix -= 2;
2680 assert(popval == SAVEt_ALLOC);
2682 PL_savestack_ix -= popval;
2688 unwind_handler_stack(pTHX_ void *p)
2690 U32 flags = *(U32*)p;
2693 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2694 /* cxstack_ix-- Not needed, die already unwound it. */
2695 #if !defined(PERL_IMPLICIT_CONTEXT)
2697 SvREFCNT_dec(sig_sv);