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
1085 if (!PL_use_safe_putenv) {
1088 if (environ == PL_origenviron)
1089 environ = (char**)safesysmalloc(sizeof(char*));
1091 for (i = 0; environ[i]; i++)
1092 safesysfree(environ[i]);
1094 # endif /* PERL_USE_SAFE_PUTENV */
1096 environ[0] = Nullch;
1098 # endif /* USE_ENVIRON_ARRAY */
1099 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1100 #endif /* VMS || EPOC */
1101 #endif /* !PERL_MICRO */
1105 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1106 static int sig_handlers_initted = 0;
1108 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1109 static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
1111 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1112 static int sig_defaulting[SIG_SIZE];
1116 #ifdef HAS_SIGPROCMASK
1118 restore_sigmask(pTHX_ SV *save_sv)
1120 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1121 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1125 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1129 /* Are we fetching a signal entry? */
1130 i = whichsig(MgPV(mg,n_a));
1133 sv_setsv(sv,PL_psig_ptr[i]);
1135 Sighandler_t sigstate;
1136 sigstate = rsignal_state(i);
1137 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1138 if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1140 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1141 if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
1143 /* cache state so we don't fetch it again */
1144 if(sigstate == SIG_IGN)
1145 sv_setpv(sv,"IGNORE");
1147 sv_setsv(sv,&PL_sv_undef);
1148 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1155 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1157 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1158 * refactoring might be in order.
1166 if (strEQ(s,"__DIE__"))
1168 else if (strEQ(s,"__WARN__"))
1171 Perl_croak(aTHX_ "No such hook: %s", s);
1175 SvREFCNT_dec(to_dec);
1180 /* Are we clearing a signal entry? */
1183 #ifdef HAS_SIGPROCMASK
1186 /* Avoid having the signal arrive at a bad time, if possible. */
1189 sigprocmask(SIG_BLOCK, &set, &save);
1191 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1192 SAVEFREESV(save_sv);
1193 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1196 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1197 if (!sig_handlers_initted) Perl_csighandler_init();
1199 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1200 sig_defaulting[i] = 1;
1201 (void)rsignal(i, PL_csighandlerp);
1203 (void)rsignal(i, SIG_DFL);
1205 if(PL_psig_name[i]) {
1206 SvREFCNT_dec(PL_psig_name[i]);
1209 if(PL_psig_ptr[i]) {
1210 to_dec=PL_psig_ptr[i];
1213 SvREFCNT_dec(to_dec);
1223 Perl_raise_signal(pTHX_ int sig)
1225 /* Set a flag to say this signal is pending */
1226 PL_psig_pend[sig]++;
1227 /* And one to say _a_ signal is pending */
1232 Perl_csighandler(int sig)
1234 #ifdef PERL_GET_SIG_CONTEXT
1235 dTHXa(PERL_GET_SIG_CONTEXT);
1239 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1240 (void) rsignal(sig, PL_csighandlerp);
1241 if (sig_ignoring[sig]) return;
1243 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1244 if (sig_defaulting[sig])
1245 #ifdef KILL_BY_SIGPRC
1246 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1251 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1252 /* Call the perl level handler now--
1253 * with risk we may be in malloc() etc. */
1254 (*PL_sighandlerp)(sig);
1256 Perl_raise_signal(aTHX_ sig);
1259 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1261 Perl_csighandler_init(void)
1264 if (sig_handlers_initted) return;
1266 for (sig = 1; sig < SIG_SIZE; sig++) {
1267 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1269 sig_defaulting[sig] = 1;
1270 (void) rsignal(sig, PL_csighandlerp);
1272 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1273 sig_ignoring[sig] = 0;
1276 sig_handlers_initted = 1;
1281 Perl_despatch_signals(pTHX)
1285 for (sig = 1; sig < SIG_SIZE; sig++) {
1286 if (PL_psig_pend[sig]) {
1287 PERL_BLOCKSIG_ADD(set, sig);
1288 PL_psig_pend[sig] = 0;
1289 PERL_BLOCKSIG_BLOCK(set);
1290 (*PL_sighandlerp)(sig);
1291 PERL_BLOCKSIG_UNBLOCK(set);
1297 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1302 /* Need to be careful with SvREFCNT_dec(), because that can have side
1303 * effects (due to closures). We must make sure that the new disposition
1304 * is in place before it is called.
1308 #ifdef HAS_SIGPROCMASK
1315 if (strEQ(s,"__DIE__"))
1317 else if (strEQ(s,"__WARN__"))
1320 Perl_croak(aTHX_ "No such hook: %s", s);
1328 i = whichsig(s); /* ...no, a brick */
1330 if (ckWARN(WARN_SIGNAL))
1331 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1334 #ifdef HAS_SIGPROCMASK
1335 /* Avoid having the signal arrive at a bad time, if possible. */
1338 sigprocmask(SIG_BLOCK, &set, &save);
1340 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1341 SAVEFREESV(save_sv);
1342 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1345 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1346 if (!sig_handlers_initted) Perl_csighandler_init();
1348 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1349 sig_ignoring[i] = 0;
1351 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1352 sig_defaulting[i] = 0;
1354 SvREFCNT_dec(PL_psig_name[i]);
1355 to_dec = PL_psig_ptr[i];
1356 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1357 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1358 PL_psig_name[i] = newSVpvn(s, len);
1359 SvREADONLY_on(PL_psig_name[i]);
1361 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1363 (void)rsignal(i, PL_csighandlerp);
1364 #ifdef HAS_SIGPROCMASK
1369 *svp = SvREFCNT_inc(sv);
1371 SvREFCNT_dec(to_dec);
1374 s = SvPV_force(sv,len);
1375 if (strEQ(s,"IGNORE")) {
1377 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1378 sig_ignoring[i] = 1;
1379 (void)rsignal(i, PL_csighandlerp);
1381 (void)rsignal(i, SIG_IGN);
1385 else if (strEQ(s,"DEFAULT") || !*s) {
1387 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1389 sig_defaulting[i] = 1;
1390 (void)rsignal(i, PL_csighandlerp);
1393 (void)rsignal(i, SIG_DFL);
1398 * We should warn if HINT_STRICT_REFS, but without
1399 * access to a known hint bit in a known OP, we can't
1400 * tell whether HINT_STRICT_REFS is in force or not.
1402 if (!strchr(s,':') && !strchr(s,'\''))
1403 sv_insert(sv, 0, 0, "main::", 6);
1405 (void)rsignal(i, PL_csighandlerp);
1407 *svp = SvREFCNT_inc(sv);
1409 #ifdef HAS_SIGPROCMASK
1414 SvREFCNT_dec(to_dec);
1417 #endif /* !PERL_MICRO */
1420 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1422 PL_sub_generation++;
1427 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1429 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1430 PL_amagic_generation++;
1436 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1438 HV *hv = (HV*)LvTARG(sv);
1442 (void) hv_iterinit(hv);
1443 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1446 while (hv_iternext(hv))
1451 sv_setiv(sv, (IV)i);
1456 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1459 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1464 /* caller is responsible for stack switching/cleanup */
1466 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1472 PUSHs(SvTIED_obj(sv, mg));
1475 if (mg->mg_len >= 0)
1476 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1477 else if (mg->mg_len == HEf_SVKEY)
1478 PUSHs((SV*)mg->mg_ptr);
1480 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1481 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1489 return call_method(meth, flags);
1493 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
1499 PUSHSTACKi(PERLSI_MAGIC);
1501 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1502 sv_setsv(sv, *PL_stack_sp--);
1512 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1515 mg->mg_flags |= MGf_GSKIP;
1516 magic_methpack(sv,mg,"FETCH");
1521 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1525 PUSHSTACKi(PERLSI_MAGIC);
1526 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1533 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1535 return magic_methpack(sv,mg,"DELETE");
1540 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1547 PUSHSTACKi(PERLSI_MAGIC);
1548 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1549 sv = *PL_stack_sp--;
1550 retval = (U32) SvIV(sv)-1;
1559 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1564 PUSHSTACKi(PERLSI_MAGIC);
1566 XPUSHs(SvTIED_obj(sv, mg));
1568 call_method("CLEAR", G_SCALAR|G_DISCARD);
1576 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1579 const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1583 PUSHSTACKi(PERLSI_MAGIC);
1586 PUSHs(SvTIED_obj(sv, mg));
1591 if (call_method(meth, G_SCALAR))
1592 sv_setsv(key, *PL_stack_sp--);
1601 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1603 return magic_methpack(sv,mg,"EXISTS");
1607 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1610 SV *retval = &PL_sv_undef;
1611 SV *tied = SvTIED_obj((SV*)hv, mg);
1612 HV *pkg = SvSTASH((SV*)SvRV(tied));
1614 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1617 /* we are in an iteration so the hash cannot be empty */
1619 /* no xhv_eiter so now use FIRSTKEY */
1620 key = sv_newmortal();
1621 magic_nextpack((SV*)hv, mg, key);
1622 HvEITER(hv) = NULL; /* need to reset iterator */
1623 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1626 /* there is a SCALAR method that we can call */
1628 PUSHSTACKi(PERLSI_MAGIC);
1634 if (call_method("SCALAR", G_SCALAR))
1635 retval = *PL_stack_sp--;
1642 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1652 svp = av_fetch(GvAV(gv),
1653 atoi(MgPV(mg,n_a)), FALSE);
1654 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1655 /* set or clear breakpoint in the relevant control op */
1657 o->op_flags |= OPf_SPECIAL;
1659 o->op_flags &= ~OPf_SPECIAL;
1665 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1667 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1672 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1674 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1679 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1681 SV* lsv = LvTARG(sv);
1683 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1684 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1685 if (mg && mg->mg_len >= 0) {
1688 sv_pos_b2u(lsv, &i);
1689 sv_setiv(sv, i + PL_curcop->cop_arybase);
1698 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1700 SV* lsv = LvTARG(sv);
1707 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1708 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1712 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1713 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1715 else if (!SvOK(sv)) {
1719 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1721 pos = SvIV(sv) - PL_curcop->cop_arybase;
1724 ulen = sv_len_utf8(lsv);
1734 else if (pos > (SSize_t)len)
1739 sv_pos_u2b(lsv, &p, 0);
1744 mg->mg_flags &= ~MGf_MINMATCH;
1750 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1752 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1754 gv_efullname3(sv,((GV*)sv), "*");
1758 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1763 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1772 if (*s == '*' && s[1])
1774 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1779 GvGP(sv) = gp_ref(GvGP(gv));
1784 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1787 SV *lsv = LvTARG(sv);
1788 char *tmps = SvPV(lsv,len);
1789 I32 offs = LvTARGOFF(sv);
1790 I32 rem = LvTARGLEN(sv);
1793 sv_pos_u2b(lsv, &offs, &rem);
1794 if (offs > (I32)len)
1796 if (rem + offs > (I32)len)
1798 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1805 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1808 char *tmps = SvPV(sv, len);
1809 SV *lsv = LvTARG(sv);
1810 I32 lvoff = LvTARGOFF(sv);
1811 I32 lvlen = LvTARGLEN(sv);
1814 sv_utf8_upgrade(lsv);
1815 sv_pos_u2b(lsv, &lvoff, &lvlen);
1816 sv_insert(lsv, lvoff, lvlen, tmps, len);
1817 LvTARGLEN(sv) = sv_len_utf8(sv);
1820 else if (lsv && SvUTF8(lsv)) {
1821 sv_pos_u2b(lsv, &lvoff, &lvlen);
1822 LvTARGLEN(sv) = len;
1823 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1824 sv_insert(lsv, lvoff, lvlen, tmps, len);
1828 sv_insert(lsv, lvoff, lvlen, tmps, len);
1829 LvTARGLEN(sv) = len;
1837 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1839 TAINT_IF((mg->mg_len & 1) ||
1840 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1845 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1847 if (PL_localizing) {
1848 if (PL_localizing == 1)
1853 else if (PL_tainted)
1861 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1863 SV *lsv = LvTARG(sv);
1870 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1875 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1877 do_vecset(sv); /* XXX slurp this routine */
1882 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1885 if (LvTARGLEN(sv)) {
1887 SV *ahv = LvTARG(sv);
1888 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1893 AV* av = (AV*)LvTARG(sv);
1894 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1895 targ = AvARRAY(av)[LvTARGOFF(sv)];
1897 if (targ && targ != &PL_sv_undef) {
1898 /* somebody else defined it for us */
1899 SvREFCNT_dec(LvTARG(sv));
1900 LvTARG(sv) = SvREFCNT_inc(targ);
1902 SvREFCNT_dec(mg->mg_obj);
1903 mg->mg_obj = Nullsv;
1904 mg->mg_flags &= ~MGf_REFCOUNTED;
1909 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1914 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1919 sv_setsv(LvTARG(sv), sv);
1920 SvSETMAGIC(LvTARG(sv));
1926 Perl_vivify_defelem(pTHX_ SV *sv)
1931 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1934 SV *ahv = LvTARG(sv);
1936 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1939 if (!value || value == &PL_sv_undef)
1940 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1943 AV* av = (AV*)LvTARG(sv);
1944 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1945 LvTARG(sv) = Nullsv; /* array can't be extended */
1947 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1948 if (!svp || (value = *svp) == &PL_sv_undef)
1949 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1952 (void)SvREFCNT_inc(value);
1953 SvREFCNT_dec(LvTARG(sv));
1956 SvREFCNT_dec(mg->mg_obj);
1957 mg->mg_obj = Nullsv;
1958 mg->mg_flags &= ~MGf_REFCOUNTED;
1962 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1964 AV *av = (AV*)mg->mg_obj;
1965 SV **svp = AvARRAY(av);
1966 I32 i = AvFILLp(av);
1969 if (!SvWEAKREF(svp[i]))
1970 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1971 /* XXX Should we check that it hasn't changed? */
1974 SvWEAKREF_off(svp[i]);
1979 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1984 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1992 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1994 sv_unmagic(sv, PERL_MAGIC_bm);
2000 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2002 sv_unmagic(sv, PERL_MAGIC_fm);
2008 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2010 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
2012 if (uf && uf->uf_set)
2013 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2018 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2020 sv_unmagic(sv, PERL_MAGIC_qr);
2025 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2027 regexp *re = (regexp *)mg->mg_obj;
2032 #ifdef USE_LOCALE_COLLATE
2034 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2037 * RenE<eacute> Descartes said "I think not."
2038 * and vanished with a faint plop.
2041 Safefree(mg->mg_ptr);
2047 #endif /* USE_LOCALE_COLLATE */
2049 /* Just clear the UTF-8 cache data. */
2051 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2053 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2055 mg->mg_len = -1; /* The mg_len holds the len cache. */
2060 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2065 switch (*mg->mg_ptr) {
2066 case '\001': /* ^A */
2067 sv_setsv(PL_bodytarget, sv);
2069 case '\003': /* ^C */
2070 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2073 case '\004': /* ^D */
2076 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2077 DEBUG_x(dump_all());
2079 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2082 case '\005': /* ^E */
2083 if (*(mg->mg_ptr+1) == '\0') {
2084 #ifdef MACOS_TRADITIONAL
2085 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2088 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2091 SetLastError( SvIV(sv) );
2094 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2096 /* will anyone ever use this? */
2097 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2103 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2105 SvREFCNT_dec(PL_encoding);
2106 if (SvOK(sv) || SvGMAGICAL(sv)) {
2107 PL_encoding = newSVsv(sv);
2110 PL_encoding = Nullsv;
2114 case '\006': /* ^F */
2115 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2117 case '\010': /* ^H */
2118 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2120 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2122 Safefree(PL_inplace);
2124 PL_inplace = savepv(SvPV(sv,len));
2126 PL_inplace = Nullch;
2128 case '\017': /* ^O */
2129 if (*(mg->mg_ptr+1) == '\0') {
2131 Safefree(PL_osname);
2135 TAINT_PROPER("assigning to $^O");
2136 PL_osname = savepv(SvPV(sv,len));
2139 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2140 if (!PL_compiling.cop_io)
2141 PL_compiling.cop_io = newSVsv(sv);
2143 sv_setsv(PL_compiling.cop_io,sv);
2146 case '\020': /* ^P */
2147 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2148 if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
2152 case '\024': /* ^T */
2154 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2156 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2159 case '\027': /* ^W & $^WARNING_BITS */
2160 if (*(mg->mg_ptr+1) == '\0') {
2161 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2162 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2163 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2164 | (i ? G_WARN_ON : G_WARN_OFF) ;
2167 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2168 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2169 if (!SvPOK(sv) && PL_localizing) {
2170 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2171 PL_compiling.cop_warnings = pWARN_NONE;
2176 int accumulate = 0 ;
2177 int any_fatals = 0 ;
2178 char * ptr = (char*)SvPV(sv, len) ;
2179 for (i = 0 ; i < len ; ++i) {
2180 accumulate |= ptr[i] ;
2181 any_fatals |= (ptr[i] & 0xAA) ;
2184 PL_compiling.cop_warnings = pWARN_NONE;
2185 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2186 PL_compiling.cop_warnings = pWARN_ALL;
2187 PL_dowarn |= G_WARN_ONCE ;
2190 if (specialWARN(PL_compiling.cop_warnings))
2191 PL_compiling.cop_warnings = newSVsv(sv) ;
2193 sv_setsv(PL_compiling.cop_warnings, sv);
2194 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2195 PL_dowarn |= G_WARN_ONCE ;
2203 if (PL_localizing) {
2204 if (PL_localizing == 1)
2205 SAVESPTR(PL_last_in_gv);
2207 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2208 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2211 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2212 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2213 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2216 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2217 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2218 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2221 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2224 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2225 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2226 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2229 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2233 IO *io = GvIOp(PL_defoutgv);
2236 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2237 IoFLAGS(io) &= ~IOf_FLUSH;
2239 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2240 PerlIO *ofp = IoOFP(io);
2242 (void)PerlIO_flush(ofp);
2243 IoFLAGS(io) |= IOf_FLUSH;
2249 SvREFCNT_dec(PL_rs);
2250 PL_rs = newSVsv(sv);
2254 SvREFCNT_dec(PL_ors_sv);
2255 if (SvOK(sv) || SvGMAGICAL(sv)) {
2256 PL_ors_sv = newSVsv(sv);
2264 SvREFCNT_dec(PL_ofs_sv);
2265 if (SvOK(sv) || SvGMAGICAL(sv)) {
2266 PL_ofs_sv = newSVsv(sv);
2275 PL_ofmt = savepv(SvPV(sv,len));
2278 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2281 #ifdef COMPLEX_STATUS
2282 if (PL_localizing == 2) {
2283 PL_statusvalue = LvTARGOFF(sv);
2284 PL_statusvalue_vms = LvTARGLEN(sv);
2288 #ifdef VMSISH_STATUS
2290 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2293 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2298 # define PERL_VMS_BANG vaxc$errno
2300 # define PERL_VMS_BANG 0
2302 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2303 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2307 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2308 if (PL_delaymagic) {
2309 PL_delaymagic |= DM_RUID;
2310 break; /* don't do magic till later */
2313 (void)setruid((Uid_t)PL_uid);
2316 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2318 #ifdef HAS_SETRESUID
2319 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2321 if (PL_uid == PL_euid) { /* special case $< = $> */
2323 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2324 if (PL_uid != 0 && PerlProc_getuid() == 0)
2325 (void)PerlProc_setuid(0);
2327 (void)PerlProc_setuid(PL_uid);
2329 PL_uid = PerlProc_getuid();
2330 Perl_croak(aTHX_ "setruid() not implemented");
2335 PL_uid = PerlProc_getuid();
2336 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2339 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2340 if (PL_delaymagic) {
2341 PL_delaymagic |= DM_EUID;
2342 break; /* don't do magic till later */
2345 (void)seteuid((Uid_t)PL_euid);
2348 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2350 #ifdef HAS_SETRESUID
2351 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2353 if (PL_euid == PL_uid) /* special case $> = $< */
2354 PerlProc_setuid(PL_euid);
2356 PL_euid = PerlProc_geteuid();
2357 Perl_croak(aTHX_ "seteuid() not implemented");
2362 PL_euid = PerlProc_geteuid();
2363 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2366 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2367 if (PL_delaymagic) {
2368 PL_delaymagic |= DM_RGID;
2369 break; /* don't do magic till later */
2372 (void)setrgid((Gid_t)PL_gid);
2375 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2377 #ifdef HAS_SETRESGID
2378 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2380 if (PL_gid == PL_egid) /* special case $( = $) */
2381 (void)PerlProc_setgid(PL_gid);
2383 PL_gid = PerlProc_getgid();
2384 Perl_croak(aTHX_ "setrgid() not implemented");
2389 PL_gid = PerlProc_getgid();
2390 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2393 #ifdef HAS_SETGROUPS
2395 char *p = SvPV(sv, len);
2396 Groups_t gary[NGROUPS];
2401 for (i = 0; i < NGROUPS; ++i) {
2402 while (*p && !isSPACE(*p))
2411 (void)setgroups(i, gary);
2413 #else /* HAS_SETGROUPS */
2414 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2415 #endif /* HAS_SETGROUPS */
2416 if (PL_delaymagic) {
2417 PL_delaymagic |= DM_EGID;
2418 break; /* don't do magic till later */
2421 (void)setegid((Gid_t)PL_egid);
2424 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2426 #ifdef HAS_SETRESGID
2427 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2429 if (PL_egid == PL_gid) /* special case $) = $( */
2430 (void)PerlProc_setgid(PL_egid);
2432 PL_egid = PerlProc_getegid();
2433 Perl_croak(aTHX_ "setegid() not implemented");
2438 PL_egid = PerlProc_getegid();
2439 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2442 PL_chopset = SvPV_force(sv,len);
2444 #ifndef MACOS_TRADITIONAL
2446 LOCK_DOLLARZERO_MUTEX;
2447 #ifdef HAS_SETPROCTITLE
2448 /* The BSDs don't show the argv[] in ps(1) output, they
2449 * show a string from the process struct and provide
2450 * the setproctitle() routine to manipulate that. */
2453 # if __FreeBSD_version > 410001
2454 /* The leading "-" removes the "perl: " prefix,
2455 * but not the "(perl) suffix from the ps(1)
2456 * output, because that's what ps(1) shows if the
2457 * argv[] is modified. */
2458 setproctitle("-%s", s);
2459 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2460 /* This doesn't really work if you assume that
2461 * $0 = 'foobar'; will wipe out 'perl' from the $0
2462 * because in ps(1) output the result will be like
2463 * sprintf("perl: %s (perl)", s)
2464 * I guess this is a security feature:
2465 * one (a user process) cannot get rid of the original name.
2467 setproctitle("%s", s);
2471 #if defined(__hpux) && defined(PSTAT_SETCMD)
2476 pstat(PSTAT_SETCMD, un, len, 0, 0);
2479 /* PL_origalen is set in perl_parse(). */
2480 s = SvPV_force(sv,len);
2481 if (len >= (STRLEN)PL_origalen-1) {
2482 /* Longer than original, will be truncated. We assume that
2483 * PL_origalen bytes are available. */
2484 Copy(s, PL_origargv[0], PL_origalen-1, char);
2487 /* Shorter than original, will be padded. */
2488 Copy(s, PL_origargv[0], len, char);
2489 PL_origargv[0][len] = 0;
2490 memset(PL_origargv[0] + len + 1,
2491 /* Is the space counterintuitive? Yes.
2492 * (You were expecting \0?)
2493 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2496 PL_origalen - len - 1);
2498 PL_origargv[0][PL_origalen-1] = 0;
2499 for (i = 1; i < PL_origargc; i++)
2501 UNLOCK_DOLLARZERO_MUTEX;
2509 Perl_whichsig(pTHX_ char *sig)
2511 register char **sigv;
2513 for (sigv = PL_sig_name; *sigv; sigv++)
2514 if (strEQ(sig,*sigv))
2515 return PL_sig_num[sigv - PL_sig_name];
2517 if (strEQ(sig,"CHLD"))
2521 if (strEQ(sig,"CLD"))
2527 #if !defined(PERL_IMPLICIT_CONTEXT)
2532 Perl_sighandler(int sig)
2534 #ifdef PERL_GET_SIG_CONTEXT
2535 dTHXa(PERL_GET_SIG_CONTEXT);
2542 SV *sv = Nullsv, *tSv = PL_Sv;
2548 if (PL_savestack_ix + 15 <= PL_savestack_max)
2550 if (PL_markstack_ptr < PL_markstack_max - 2)
2552 if (PL_scopestack_ix < PL_scopestack_max - 3)
2555 if (!PL_psig_ptr[sig]) {
2556 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2561 /* Max number of items pushed there is 3*n or 4. We cannot fix
2562 infinity, so we fix 4 (in fact 5): */
2564 PL_savestack_ix += 5; /* Protect save in progress. */
2565 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2568 PL_markstack_ptr++; /* Protect mark. */
2570 PL_scopestack_ix += 1;
2571 /* sv_2cv is too complicated, try a simpler variant first: */
2572 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2573 || SvTYPE(cv) != SVt_PVCV)
2574 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2576 if (!cv || !CvROOT(cv)) {
2577 if (ckWARN(WARN_SIGNAL))
2578 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2579 PL_sig_name[sig], (gv ? GvENAME(gv)
2586 if(PL_psig_name[sig]) {
2587 sv = SvREFCNT_inc(PL_psig_name[sig]);
2589 #if !defined(PERL_IMPLICIT_CONTEXT)
2593 sv = sv_newmortal();
2594 sv_setpv(sv,PL_sig_name[sig]);
2597 PUSHSTACKi(PERLSI_SIGNAL);
2602 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2605 if (SvTRUE(ERRSV)) {
2607 #ifdef HAS_SIGPROCMASK
2608 /* Handler "died", for example to get out of a restart-able read().
2609 * Before we re-do that on its behalf re-enable the signal which was
2610 * blocked by the system when we entered.
2614 sigaddset(&set,sig);
2615 sigprocmask(SIG_UNBLOCK, &set, NULL);
2617 /* Not clear if this will work */
2618 (void)rsignal(sig, SIG_IGN);
2619 (void)rsignal(sig, PL_csighandlerp);
2621 #endif /* !PERL_MICRO */
2622 Perl_die(aTHX_ Nullformat);
2626 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2630 PL_scopestack_ix -= 1;
2633 PL_op = myop; /* Apparently not needed... */
2635 PL_Sv = tSv; /* Restore global temporaries. */
2642 restore_magic(pTHX_ void *p)
2644 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2645 SV* sv = mgs->mgs_sv;
2650 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2652 #ifdef PERL_COPY_ON_WRITE
2653 /* While magic was saved (and off) sv_setsv may well have seen
2654 this SV as a prime candidate for COW. */
2656 sv_force_normal(sv);
2660 SvFLAGS(sv) |= mgs->mgs_flags;
2664 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2667 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2669 /* If we're still on top of the stack, pop us off. (That condition
2670 * will be satisfied if restore_magic was called explicitly, but *not*
2671 * if it's being called via leave_scope.)
2672 * The reason for doing this is that otherwise, things like sv_2cv()
2673 * may leave alloc gunk on the savestack, and some code
2674 * (e.g. sighandler) doesn't expect that...
2676 if (PL_savestack_ix == mgs->mgs_ss_ix)
2678 I32 popval = SSPOPINT;
2679 assert(popval == SAVEt_DESTRUCTOR_X);
2680 PL_savestack_ix -= 2;
2682 assert(popval == SAVEt_ALLOC);
2684 PL_savestack_ix -= popval;
2690 unwind_handler_stack(pTHX_ void *p)
2692 U32 flags = *(U32*)p;
2695 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2696 /* cxstack_ix-- Not needed, die already unwound it. */
2697 #if !defined(PERL_IMPLICIT_CONTEXT)
2699 SvREFCNT_dec(sig_sv);