3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
52 # include <sys/pstat.h>
55 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, $^UTF8LOCALE */
719 if (strEQ(mg->mg_ptr, "\025NICODE"))
720 sv_setuv(sv, (UV) PL_unicode);
721 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
722 sv_setuv(sv, (UV) PL_utf8locale);
724 case '\027': /* ^W & $^WARNING_BITS */
725 if (*(mg->mg_ptr+1) == '\0')
726 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
727 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
728 if (PL_compiling.cop_warnings == pWARN_NONE ||
729 PL_compiling.cop_warnings == pWARN_STD)
731 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
733 else if (PL_compiling.cop_warnings == pWARN_ALL) {
734 /* Get the bit mask for $warnings::Bits{all}, because
735 * it could have been extended by warnings::register */
737 HV *bits=get_hv("warnings::Bits", FALSE);
738 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
739 sv_setsv(sv, *bits_all);
742 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
746 sv_setsv(sv, PL_compiling.cop_warnings);
751 case '1': case '2': case '3': case '4':
752 case '5': case '6': case '7': case '8': case '9': case '&':
753 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
757 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
758 * XXX Does the new way break anything?
760 paren = atoi(mg->mg_ptr); /* $& is in [0] */
762 if (paren <= (I32)rx->nparens &&
763 (s1 = rx->startp[paren]) != -1 &&
764 (t1 = rx->endp[paren]) != -1)
774 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
779 if (RX_MATCH_TAINTED(rx)) {
780 MAGIC* mg = SvMAGIC(sv);
783 SvMAGIC(sv) = mg->mg_moremagic;
785 if ((mgt = SvMAGIC(sv))) {
786 mg->mg_moremagic = mgt;
796 sv_setsv(sv,&PL_sv_undef);
799 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
800 paren = rx->lastparen;
804 sv_setsv(sv,&PL_sv_undef);
806 case '\016': /* ^N */
807 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
808 paren = rx->lastcloseparen;
812 sv_setsv(sv,&PL_sv_undef);
815 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
816 if ((s = rx->subbeg) && rx->startp[0] != -1) {
821 sv_setsv(sv,&PL_sv_undef);
824 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
825 if (rx->subbeg && rx->endp[0] != -1) {
826 s = rx->subbeg + rx->endp[0];
827 i = rx->sublen - rx->endp[0];
831 sv_setsv(sv,&PL_sv_undef);
835 if (GvIO(PL_last_in_gv)) {
836 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
842 sv_setiv(sv, (IV)STATUS_CURRENT);
843 #ifdef COMPLEX_STATUS
844 LvTARGOFF(sv) = PL_statusvalue;
845 LvTARGLEN(sv) = PL_statusvalue_vms;
850 if (GvIOp(PL_defoutgv))
851 s = IoTOP_NAME(GvIOp(PL_defoutgv));
855 sv_setpv(sv,GvENAME(PL_defoutgv));
860 if (GvIOp(PL_defoutgv))
861 s = IoFMT_NAME(GvIOp(PL_defoutgv));
863 s = GvENAME(PL_defoutgv);
868 if (GvIOp(PL_defoutgv))
869 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
872 if (GvIOp(PL_defoutgv))
873 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
876 if (GvIOp(PL_defoutgv))
877 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
885 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
888 if (GvIOp(PL_defoutgv))
889 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
895 sv_copypv(sv, PL_ors_sv);
898 sv_setpv(sv,PL_ofmt);
902 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
903 sv_setpv(sv, errno ? Strerror(errno) : "");
906 int saveerrno = errno;
907 sv_setnv(sv, (NV)errno);
909 if (errno == errno_isOS2 || errno == errno_isOS2_set)
910 sv_setpv(sv, os2error(Perl_rc));
913 sv_setpv(sv, errno ? Strerror(errno) : "");
917 SvNOK_on(sv); /* what a wonderful hack! */
920 sv_setiv(sv, (IV)PL_uid);
923 sv_setiv(sv, (IV)PL_euid);
926 sv_setiv(sv, (IV)PL_gid);
928 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
932 sv_setiv(sv, (IV)PL_egid);
934 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
939 Groups_t gary[NGROUPS];
940 i = getgroups(NGROUPS,gary);
942 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
945 (void)SvIOK_on(sv); /* what a wonderful hack! */
947 #ifndef MACOS_TRADITIONAL
956 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
958 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
960 if (uf && uf->uf_val)
961 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
966 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
976 #ifdef DYNAMIC_ENV_FETCH
977 /* We just undefd an environment var. Is a replacement */
978 /* waiting in the wings? */
981 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
982 s = SvPV(*valp, len);
986 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
987 /* And you'll never guess what the dog had */
988 /* in its mouth... */
990 MgTAINTEDDIR_off(mg);
992 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
993 char pathbuf[256], eltbuf[256], *cp, *elt = s;
997 do { /* DCL$PATH may be a search list */
998 while (1) { /* as may dev portion of any element */
999 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1000 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1001 cando_by_name(S_IWUSR,0,elt) ) {
1002 MgTAINTEDDIR_on(mg);
1006 if ((cp = strchr(elt, ':')) != Nullch)
1008 if (my_trnlnm(elt, eltbuf, j++))
1014 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1017 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1018 char *strend = s + len;
1020 while (s < strend) {
1024 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1025 s, strend, ':', &i);
1027 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1029 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1030 MgTAINTEDDIR_on(mg);
1036 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1042 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1045 my_setenv(MgPV(mg,n_a),Nullch);
1050 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1053 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1055 if (PL_localizing) {
1058 magic_clear_all_env(sv,mg);
1059 hv_iterinit((HV*)sv);
1060 while ((entry = hv_iternext((HV*)sv))) {
1062 my_setenv(hv_iterkey(entry, &keylen),
1063 SvPV(hv_iterval((HV*)sv, entry), n_a));
1071 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1074 #if defined(VMS) || defined(EPOC)
1075 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1077 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1080 # ifdef USE_ENVIRON_ARRAY
1081 # if defined(USE_ITHREADS)
1082 /* only the parent thread can clobber the process environment */
1083 if (PL_curinterp == aTHX)
1086 # ifndef PERL_USE_SAFE_PUTENV
1087 if (!PL_use_safe_putenv) {
1090 if (environ == PL_origenviron)
1091 environ = (char**)safesysmalloc(sizeof(char*));
1093 for (i = 0; environ[i]; i++)
1094 safesysfree(environ[i]);
1096 # endif /* PERL_USE_SAFE_PUTENV */
1098 environ[0] = Nullch;
1100 # endif /* USE_ENVIRON_ARRAY */
1101 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1102 #endif /* VMS || EPOC */
1103 #endif /* !PERL_MICRO */
1107 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1108 static int sig_handlers_initted = 0;
1110 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1111 static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
1113 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1114 static int sig_defaulting[SIG_SIZE];
1118 #ifdef HAS_SIGPROCMASK
1120 restore_sigmask(pTHX_ SV *save_sv)
1122 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1123 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1127 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1131 /* Are we fetching a signal entry? */
1132 i = whichsig(MgPV(mg,n_a));
1135 sv_setsv(sv,PL_psig_ptr[i]);
1137 Sighandler_t sigstate;
1138 sigstate = rsignal_state(i);
1139 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1140 if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1142 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1143 if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
1145 /* cache state so we don't fetch it again */
1146 if(sigstate == SIG_IGN)
1147 sv_setpv(sv,"IGNORE");
1149 sv_setsv(sv,&PL_sv_undef);
1150 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1157 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1159 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1160 * refactoring might be in order.
1168 if (strEQ(s,"__DIE__"))
1170 else if (strEQ(s,"__WARN__"))
1173 Perl_croak(aTHX_ "No such hook: %s", s);
1177 SvREFCNT_dec(to_dec);
1182 /* Are we clearing a signal entry? */
1185 #ifdef HAS_SIGPROCMASK
1188 /* Avoid having the signal arrive at a bad time, if possible. */
1191 sigprocmask(SIG_BLOCK, &set, &save);
1193 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1194 SAVEFREESV(save_sv);
1195 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1198 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1199 if (!sig_handlers_initted) Perl_csighandler_init();
1201 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1202 sig_defaulting[i] = 1;
1203 (void)rsignal(i, PL_csighandlerp);
1205 (void)rsignal(i, SIG_DFL);
1207 if(PL_psig_name[i]) {
1208 SvREFCNT_dec(PL_psig_name[i]);
1211 if(PL_psig_ptr[i]) {
1212 to_dec=PL_psig_ptr[i];
1215 SvREFCNT_dec(to_dec);
1225 Perl_raise_signal(pTHX_ int sig)
1227 /* Set a flag to say this signal is pending */
1228 PL_psig_pend[sig]++;
1229 /* And one to say _a_ signal is pending */
1234 Perl_csighandler(int sig)
1236 #ifdef PERL_GET_SIG_CONTEXT
1237 dTHXa(PERL_GET_SIG_CONTEXT);
1241 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1242 (void) rsignal(sig, PL_csighandlerp);
1243 if (sig_ignoring[sig]) return;
1245 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1246 if (sig_defaulting[sig])
1247 #ifdef KILL_BY_SIGPRC
1248 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1253 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1254 /* Call the perl level handler now--
1255 * with risk we may be in malloc() etc. */
1256 (*PL_sighandlerp)(sig);
1258 Perl_raise_signal(aTHX_ sig);
1261 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1263 Perl_csighandler_init(void)
1266 if (sig_handlers_initted) return;
1268 for (sig = 1; sig < SIG_SIZE; sig++) {
1269 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1271 sig_defaulting[sig] = 1;
1272 (void) rsignal(sig, PL_csighandlerp);
1274 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1275 sig_ignoring[sig] = 0;
1278 sig_handlers_initted = 1;
1283 Perl_despatch_signals(pTHX)
1287 for (sig = 1; sig < SIG_SIZE; sig++) {
1288 if (PL_psig_pend[sig]) {
1289 PERL_BLOCKSIG_ADD(set, sig);
1290 PL_psig_pend[sig] = 0;
1291 PERL_BLOCKSIG_BLOCK(set);
1292 (*PL_sighandlerp)(sig);
1293 PERL_BLOCKSIG_UNBLOCK(set);
1299 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1304 /* Need to be careful with SvREFCNT_dec(), because that can have side
1305 * effects (due to closures). We must make sure that the new disposition
1306 * is in place before it is called.
1310 #ifdef HAS_SIGPROCMASK
1317 if (strEQ(s,"__DIE__"))
1319 else if (strEQ(s,"__WARN__"))
1322 Perl_croak(aTHX_ "No such hook: %s", s);
1330 i = whichsig(s); /* ...no, a brick */
1332 if (ckWARN(WARN_SIGNAL))
1333 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1336 #ifdef HAS_SIGPROCMASK
1337 /* Avoid having the signal arrive at a bad time, if possible. */
1340 sigprocmask(SIG_BLOCK, &set, &save);
1342 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1343 SAVEFREESV(save_sv);
1344 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1347 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1348 if (!sig_handlers_initted) Perl_csighandler_init();
1350 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1351 sig_ignoring[i] = 0;
1353 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1354 sig_defaulting[i] = 0;
1356 SvREFCNT_dec(PL_psig_name[i]);
1357 to_dec = PL_psig_ptr[i];
1358 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1359 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1360 PL_psig_name[i] = newSVpvn(s, len);
1361 SvREADONLY_on(PL_psig_name[i]);
1363 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1365 (void)rsignal(i, PL_csighandlerp);
1366 #ifdef HAS_SIGPROCMASK
1371 *svp = SvREFCNT_inc(sv);
1373 SvREFCNT_dec(to_dec);
1376 s = SvPV_force(sv,len);
1377 if (strEQ(s,"IGNORE")) {
1379 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1380 sig_ignoring[i] = 1;
1381 (void)rsignal(i, PL_csighandlerp);
1383 (void)rsignal(i, SIG_IGN);
1387 else if (strEQ(s,"DEFAULT") || !*s) {
1389 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1391 sig_defaulting[i] = 1;
1392 (void)rsignal(i, PL_csighandlerp);
1395 (void)rsignal(i, SIG_DFL);
1400 * We should warn if HINT_STRICT_REFS, but without
1401 * access to a known hint bit in a known OP, we can't
1402 * tell whether HINT_STRICT_REFS is in force or not.
1404 if (!strchr(s,':') && !strchr(s,'\''))
1405 sv_insert(sv, 0, 0, "main::", 6);
1407 (void)rsignal(i, PL_csighandlerp);
1409 *svp = SvREFCNT_inc(sv);
1411 #ifdef HAS_SIGPROCMASK
1416 SvREFCNT_dec(to_dec);
1419 #endif /* !PERL_MICRO */
1422 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1424 PL_sub_generation++;
1429 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1431 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1432 PL_amagic_generation++;
1438 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1440 HV *hv = (HV*)LvTARG(sv);
1444 (void) hv_iterinit(hv);
1445 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1448 while (hv_iternext(hv))
1453 sv_setiv(sv, (IV)i);
1458 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1461 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1466 /* caller is responsible for stack switching/cleanup */
1468 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1474 PUSHs(SvTIED_obj(sv, mg));
1477 if (mg->mg_len >= 0)
1478 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1479 else if (mg->mg_len == HEf_SVKEY)
1480 PUSHs((SV*)mg->mg_ptr);
1482 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1483 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1491 return call_method(meth, flags);
1495 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
1501 PUSHSTACKi(PERLSI_MAGIC);
1503 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1504 sv_setsv(sv, *PL_stack_sp--);
1514 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1517 mg->mg_flags |= MGf_GSKIP;
1518 magic_methpack(sv,mg,"FETCH");
1523 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1527 PUSHSTACKi(PERLSI_MAGIC);
1528 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1535 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1537 return magic_methpack(sv,mg,"DELETE");
1542 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1549 PUSHSTACKi(PERLSI_MAGIC);
1550 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1551 sv = *PL_stack_sp--;
1552 retval = (U32) SvIV(sv)-1;
1561 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1566 PUSHSTACKi(PERLSI_MAGIC);
1568 XPUSHs(SvTIED_obj(sv, mg));
1570 call_method("CLEAR", G_SCALAR|G_DISCARD);
1578 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1581 const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1585 PUSHSTACKi(PERLSI_MAGIC);
1588 PUSHs(SvTIED_obj(sv, mg));
1593 if (call_method(meth, G_SCALAR))
1594 sv_setsv(key, *PL_stack_sp--);
1603 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1605 return magic_methpack(sv,mg,"EXISTS");
1609 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1612 SV *retval = &PL_sv_undef;
1613 SV *tied = SvTIED_obj((SV*)hv, mg);
1614 HV *pkg = SvSTASH((SV*)SvRV(tied));
1616 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1619 /* we are in an iteration so the hash cannot be empty */
1621 /* no xhv_eiter so now use FIRSTKEY */
1622 key = sv_newmortal();
1623 magic_nextpack((SV*)hv, mg, key);
1624 HvEITER(hv) = NULL; /* need to reset iterator */
1625 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1628 /* there is a SCALAR method that we can call */
1630 PUSHSTACKi(PERLSI_MAGIC);
1636 if (call_method("SCALAR", G_SCALAR))
1637 retval = *PL_stack_sp--;
1644 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1654 svp = av_fetch(GvAV(gv),
1655 atoi(MgPV(mg,n_a)), FALSE);
1656 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1657 /* set or clear breakpoint in the relevant control op */
1659 o->op_flags |= OPf_SPECIAL;
1661 o->op_flags &= ~OPf_SPECIAL;
1667 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1669 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1674 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1676 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1681 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1683 SV* lsv = LvTARG(sv);
1685 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1686 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1687 if (mg && mg->mg_len >= 0) {
1690 sv_pos_b2u(lsv, &i);
1691 sv_setiv(sv, i + PL_curcop->cop_arybase);
1700 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1702 SV* lsv = LvTARG(sv);
1709 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1710 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1714 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1715 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1717 else if (!SvOK(sv)) {
1721 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1723 pos = SvIV(sv) - PL_curcop->cop_arybase;
1726 ulen = sv_len_utf8(lsv);
1736 else if (pos > (SSize_t)len)
1741 sv_pos_u2b(lsv, &p, 0);
1746 mg->mg_flags &= ~MGf_MINMATCH;
1752 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1754 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1756 gv_efullname3(sv,((GV*)sv), "*");
1760 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1765 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1774 if (*s == '*' && s[1])
1776 gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1781 GvGP(sv) = gp_ref(GvGP(gv));
1786 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1789 SV *lsv = LvTARG(sv);
1790 char *tmps = SvPV(lsv,len);
1791 I32 offs = LvTARGOFF(sv);
1792 I32 rem = LvTARGLEN(sv);
1795 sv_pos_u2b(lsv, &offs, &rem);
1796 if (offs > (I32)len)
1798 if (rem + offs > (I32)len)
1800 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1807 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1810 char *tmps = SvPV(sv, len);
1811 SV *lsv = LvTARG(sv);
1812 I32 lvoff = LvTARGOFF(sv);
1813 I32 lvlen = LvTARGLEN(sv);
1816 sv_utf8_upgrade(lsv);
1817 sv_pos_u2b(lsv, &lvoff, &lvlen);
1818 sv_insert(lsv, lvoff, lvlen, tmps, len);
1819 LvTARGLEN(sv) = sv_len_utf8(sv);
1822 else if (lsv && SvUTF8(lsv)) {
1823 sv_pos_u2b(lsv, &lvoff, &lvlen);
1824 LvTARGLEN(sv) = len;
1825 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1826 sv_insert(lsv, lvoff, lvlen, tmps, len);
1830 sv_insert(lsv, lvoff, lvlen, tmps, len);
1831 LvTARGLEN(sv) = len;
1839 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1841 TAINT_IF((mg->mg_len & 1) ||
1842 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1847 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1849 if (PL_localizing) {
1850 if (PL_localizing == 1)
1855 else if (PL_tainted)
1863 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1865 SV *lsv = LvTARG(sv);
1872 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1877 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1879 do_vecset(sv); /* XXX slurp this routine */
1884 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1887 if (LvTARGLEN(sv)) {
1889 SV *ahv = LvTARG(sv);
1890 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1895 AV* av = (AV*)LvTARG(sv);
1896 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1897 targ = AvARRAY(av)[LvTARGOFF(sv)];
1899 if (targ && targ != &PL_sv_undef) {
1900 /* somebody else defined it for us */
1901 SvREFCNT_dec(LvTARG(sv));
1902 LvTARG(sv) = SvREFCNT_inc(targ);
1904 SvREFCNT_dec(mg->mg_obj);
1905 mg->mg_obj = Nullsv;
1906 mg->mg_flags &= ~MGf_REFCOUNTED;
1911 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1916 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1921 sv_setsv(LvTARG(sv), sv);
1922 SvSETMAGIC(LvTARG(sv));
1928 Perl_vivify_defelem(pTHX_ SV *sv)
1933 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1936 SV *ahv = LvTARG(sv);
1938 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1941 if (!value || value == &PL_sv_undef)
1942 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1945 AV* av = (AV*)LvTARG(sv);
1946 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1947 LvTARG(sv) = Nullsv; /* array can't be extended */
1949 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1950 if (!svp || (value = *svp) == &PL_sv_undef)
1951 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1954 (void)SvREFCNT_inc(value);
1955 SvREFCNT_dec(LvTARG(sv));
1958 SvREFCNT_dec(mg->mg_obj);
1959 mg->mg_obj = Nullsv;
1960 mg->mg_flags &= ~MGf_REFCOUNTED;
1964 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1966 AV *av = (AV*)mg->mg_obj;
1967 SV **svp = AvARRAY(av);
1968 I32 i = AvFILLp(av);
1971 if (!SvWEAKREF(svp[i]))
1972 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1973 /* XXX Should we check that it hasn't changed? */
1976 SvWEAKREF_off(svp[i]);
1981 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1986 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1994 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1996 sv_unmagic(sv, PERL_MAGIC_bm);
2002 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2004 sv_unmagic(sv, PERL_MAGIC_fm);
2010 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2012 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
2014 if (uf && uf->uf_set)
2015 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2020 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2022 sv_unmagic(sv, PERL_MAGIC_qr);
2027 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2029 regexp *re = (regexp *)mg->mg_obj;
2034 #ifdef USE_LOCALE_COLLATE
2036 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2039 * RenE<eacute> Descartes said "I think not."
2040 * and vanished with a faint plop.
2043 Safefree(mg->mg_ptr);
2049 #endif /* USE_LOCALE_COLLATE */
2051 /* Just clear the UTF-8 cache data. */
2053 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2055 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2057 mg->mg_len = -1; /* The mg_len holds the len cache. */
2062 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2067 switch (*mg->mg_ptr) {
2068 case '\001': /* ^A */
2069 sv_setsv(PL_bodytarget, sv);
2071 case '\003': /* ^C */
2072 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2075 case '\004': /* ^D */
2078 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2079 DEBUG_x(dump_all());
2081 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2084 case '\005': /* ^E */
2085 if (*(mg->mg_ptr+1) == '\0') {
2086 #ifdef MACOS_TRADITIONAL
2087 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2090 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2093 SetLastError( SvIV(sv) );
2096 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2098 /* will anyone ever use this? */
2099 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2105 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2107 SvREFCNT_dec(PL_encoding);
2108 if (SvOK(sv) || SvGMAGICAL(sv)) {
2109 PL_encoding = newSVsv(sv);
2112 PL_encoding = Nullsv;
2116 case '\006': /* ^F */
2117 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2119 case '\010': /* ^H */
2120 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2122 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2124 Safefree(PL_inplace);
2126 PL_inplace = savepv(SvPV(sv,len));
2128 PL_inplace = Nullch;
2130 case '\017': /* ^O */
2131 if (*(mg->mg_ptr+1) == '\0') {
2133 Safefree(PL_osname);
2137 TAINT_PROPER("assigning to $^O");
2138 PL_osname = savepv(SvPV(sv,len));
2141 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2142 if (!PL_compiling.cop_io)
2143 PL_compiling.cop_io = newSVsv(sv);
2145 sv_setsv(PL_compiling.cop_io,sv);
2148 case '\020': /* ^P */
2149 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2150 if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
2154 case '\024': /* ^T */
2156 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2158 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2161 case '\027': /* ^W & $^WARNING_BITS */
2162 if (*(mg->mg_ptr+1) == '\0') {
2163 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2164 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2165 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2166 | (i ? G_WARN_ON : G_WARN_OFF) ;
2169 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2170 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2171 if (!SvPOK(sv) && PL_localizing) {
2172 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2173 PL_compiling.cop_warnings = pWARN_NONE;
2178 int accumulate = 0 ;
2179 int any_fatals = 0 ;
2180 char * ptr = (char*)SvPV(sv, len) ;
2181 for (i = 0 ; i < len ; ++i) {
2182 accumulate |= ptr[i] ;
2183 any_fatals |= (ptr[i] & 0xAA) ;
2186 PL_compiling.cop_warnings = pWARN_NONE;
2187 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2188 PL_compiling.cop_warnings = pWARN_ALL;
2189 PL_dowarn |= G_WARN_ONCE ;
2192 if (specialWARN(PL_compiling.cop_warnings))
2193 PL_compiling.cop_warnings = newSVsv(sv) ;
2195 sv_setsv(PL_compiling.cop_warnings, sv);
2196 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2197 PL_dowarn |= G_WARN_ONCE ;
2205 if (PL_localizing) {
2206 if (PL_localizing == 1)
2207 SAVESPTR(PL_last_in_gv);
2209 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2210 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2213 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2214 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2215 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2218 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2219 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2220 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2223 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2226 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2227 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2228 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2231 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2235 IO *io = GvIOp(PL_defoutgv);
2238 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2239 IoFLAGS(io) &= ~IOf_FLUSH;
2241 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2242 PerlIO *ofp = IoOFP(io);
2244 (void)PerlIO_flush(ofp);
2245 IoFLAGS(io) |= IOf_FLUSH;
2251 SvREFCNT_dec(PL_rs);
2252 PL_rs = newSVsv(sv);
2256 SvREFCNT_dec(PL_ors_sv);
2257 if (SvOK(sv) || SvGMAGICAL(sv)) {
2258 PL_ors_sv = newSVsv(sv);
2266 SvREFCNT_dec(PL_ofs_sv);
2267 if (SvOK(sv) || SvGMAGICAL(sv)) {
2268 PL_ofs_sv = newSVsv(sv);
2277 PL_ofmt = savepv(SvPV(sv,len));
2280 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2283 #ifdef COMPLEX_STATUS
2284 if (PL_localizing == 2) {
2285 PL_statusvalue = LvTARGOFF(sv);
2286 PL_statusvalue_vms = LvTARGLEN(sv);
2290 #ifdef VMSISH_STATUS
2292 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2295 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2300 # define PERL_VMS_BANG vaxc$errno
2302 # define PERL_VMS_BANG 0
2304 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2305 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2309 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2310 if (PL_delaymagic) {
2311 PL_delaymagic |= DM_RUID;
2312 break; /* don't do magic till later */
2315 (void)setruid((Uid_t)PL_uid);
2318 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2320 #ifdef HAS_SETRESUID
2321 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2323 if (PL_uid == PL_euid) { /* special case $< = $> */
2325 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2326 if (PL_uid != 0 && PerlProc_getuid() == 0)
2327 (void)PerlProc_setuid(0);
2329 (void)PerlProc_setuid(PL_uid);
2331 PL_uid = PerlProc_getuid();
2332 Perl_croak(aTHX_ "setruid() not implemented");
2337 PL_uid = PerlProc_getuid();
2338 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2341 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2342 if (PL_delaymagic) {
2343 PL_delaymagic |= DM_EUID;
2344 break; /* don't do magic till later */
2347 (void)seteuid((Uid_t)PL_euid);
2350 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2352 #ifdef HAS_SETRESUID
2353 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2355 if (PL_euid == PL_uid) /* special case $> = $< */
2356 PerlProc_setuid(PL_euid);
2358 PL_euid = PerlProc_geteuid();
2359 Perl_croak(aTHX_ "seteuid() not implemented");
2364 PL_euid = PerlProc_geteuid();
2365 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2368 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2369 if (PL_delaymagic) {
2370 PL_delaymagic |= DM_RGID;
2371 break; /* don't do magic till later */
2374 (void)setrgid((Gid_t)PL_gid);
2377 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2379 #ifdef HAS_SETRESGID
2380 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2382 if (PL_gid == PL_egid) /* special case $( = $) */
2383 (void)PerlProc_setgid(PL_gid);
2385 PL_gid = PerlProc_getgid();
2386 Perl_croak(aTHX_ "setrgid() not implemented");
2391 PL_gid = PerlProc_getgid();
2392 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2395 #ifdef HAS_SETGROUPS
2397 char *p = SvPV(sv, len);
2398 Groups_t gary[NGROUPS];
2403 for (i = 0; i < NGROUPS; ++i) {
2404 while (*p && !isSPACE(*p))
2413 (void)setgroups(i, gary);
2415 #else /* HAS_SETGROUPS */
2416 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2417 #endif /* HAS_SETGROUPS */
2418 if (PL_delaymagic) {
2419 PL_delaymagic |= DM_EGID;
2420 break; /* don't do magic till later */
2423 (void)setegid((Gid_t)PL_egid);
2426 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2428 #ifdef HAS_SETRESGID
2429 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2431 if (PL_egid == PL_gid) /* special case $) = $( */
2432 (void)PerlProc_setgid(PL_egid);
2434 PL_egid = PerlProc_getegid();
2435 Perl_croak(aTHX_ "setegid() not implemented");
2440 PL_egid = PerlProc_getegid();
2441 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2444 PL_chopset = SvPV_force(sv,len);
2446 #ifndef MACOS_TRADITIONAL
2448 LOCK_DOLLARZERO_MUTEX;
2449 #ifdef HAS_SETPROCTITLE
2450 /* The BSDs don't show the argv[] in ps(1) output, they
2451 * show a string from the process struct and provide
2452 * the setproctitle() routine to manipulate that. */
2455 # if __FreeBSD_version > 410001
2456 /* The leading "-" removes the "perl: " prefix,
2457 * but not the "(perl) suffix from the ps(1)
2458 * output, because that's what ps(1) shows if the
2459 * argv[] is modified. */
2460 setproctitle("-%s", s);
2461 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2462 /* This doesn't really work if you assume that
2463 * $0 = 'foobar'; will wipe out 'perl' from the $0
2464 * because in ps(1) output the result will be like
2465 * sprintf("perl: %s (perl)", s)
2466 * I guess this is a security feature:
2467 * one (a user process) cannot get rid of the original name.
2469 setproctitle("%s", s);
2473 #if defined(__hpux) && defined(PSTAT_SETCMD)
2478 pstat(PSTAT_SETCMD, un, len, 0, 0);
2481 /* PL_origalen is set in perl_parse(). */
2482 s = SvPV_force(sv,len);
2483 if (len >= (STRLEN)PL_origalen-1) {
2484 /* Longer than original, will be truncated. We assume that
2485 * PL_origalen bytes are available. */
2486 Copy(s, PL_origargv[0], PL_origalen-1, char);
2489 /* Shorter than original, will be padded. */
2490 Copy(s, PL_origargv[0], len, char);
2491 PL_origargv[0][len] = 0;
2492 memset(PL_origargv[0] + len + 1,
2493 /* Is the space counterintuitive? Yes.
2494 * (You were expecting \0?)
2495 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2498 PL_origalen - len - 1);
2500 PL_origargv[0][PL_origalen-1] = 0;
2501 for (i = 1; i < PL_origargc; i++)
2503 UNLOCK_DOLLARZERO_MUTEX;
2511 Perl_whichsig(pTHX_ char *sig)
2513 register char **sigv;
2515 for (sigv = PL_sig_name; *sigv; sigv++)
2516 if (strEQ(sig,*sigv))
2517 return PL_sig_num[sigv - PL_sig_name];
2519 if (strEQ(sig,"CHLD"))
2523 if (strEQ(sig,"CLD"))
2529 #if !defined(PERL_IMPLICIT_CONTEXT)
2534 Perl_sighandler(int sig)
2536 #ifdef PERL_GET_SIG_CONTEXT
2537 dTHXa(PERL_GET_SIG_CONTEXT);
2544 SV *sv = Nullsv, *tSv = PL_Sv;
2550 if (PL_savestack_ix + 15 <= PL_savestack_max)
2552 if (PL_markstack_ptr < PL_markstack_max - 2)
2554 if (PL_scopestack_ix < PL_scopestack_max - 3)
2557 if (!PL_psig_ptr[sig]) {
2558 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2563 /* Max number of items pushed there is 3*n or 4. We cannot fix
2564 infinity, so we fix 4 (in fact 5): */
2566 PL_savestack_ix += 5; /* Protect save in progress. */
2567 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2570 PL_markstack_ptr++; /* Protect mark. */
2572 PL_scopestack_ix += 1;
2573 /* sv_2cv is too complicated, try a simpler variant first: */
2574 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2575 || SvTYPE(cv) != SVt_PVCV)
2576 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2578 if (!cv || !CvROOT(cv)) {
2579 if (ckWARN(WARN_SIGNAL))
2580 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2581 PL_sig_name[sig], (gv ? GvENAME(gv)
2588 if(PL_psig_name[sig]) {
2589 sv = SvREFCNT_inc(PL_psig_name[sig]);
2591 #if !defined(PERL_IMPLICIT_CONTEXT)
2595 sv = sv_newmortal();
2596 sv_setpv(sv,PL_sig_name[sig]);
2599 PUSHSTACKi(PERLSI_SIGNAL);
2604 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2607 if (SvTRUE(ERRSV)) {
2609 #ifdef HAS_SIGPROCMASK
2610 /* Handler "died", for example to get out of a restart-able read().
2611 * Before we re-do that on its behalf re-enable the signal which was
2612 * blocked by the system when we entered.
2616 sigaddset(&set,sig);
2617 sigprocmask(SIG_UNBLOCK, &set, NULL);
2619 /* Not clear if this will work */
2620 (void)rsignal(sig, SIG_IGN);
2621 (void)rsignal(sig, PL_csighandlerp);
2623 #endif /* !PERL_MICRO */
2624 Perl_die(aTHX_ Nullformat);
2628 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2632 PL_scopestack_ix -= 1;
2635 PL_op = myop; /* Apparently not needed... */
2637 PL_Sv = tSv; /* Restore global temporaries. */
2644 restore_magic(pTHX_ void *p)
2646 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2647 SV* sv = mgs->mgs_sv;
2652 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2654 #ifdef PERL_COPY_ON_WRITE
2655 /* While magic was saved (and off) sv_setsv may well have seen
2656 this SV as a prime candidate for COW. */
2658 sv_force_normal(sv);
2662 SvFLAGS(sv) |= mgs->mgs_flags;
2666 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2669 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2671 /* If we're still on top of the stack, pop us off. (That condition
2672 * will be satisfied if restore_magic was called explicitly, but *not*
2673 * if it's being called via leave_scope.)
2674 * The reason for doing this is that otherwise, things like sv_2cv()
2675 * may leave alloc gunk on the savestack, and some code
2676 * (e.g. sighandler) doesn't expect that...
2678 if (PL_savestack_ix == mgs->mgs_ss_ix)
2680 I32 popval = SSPOPINT;
2681 assert(popval == SAVEt_DESTRUCTOR_X);
2682 PL_savestack_ix -= 2;
2684 assert(popval == SAVEt_ALLOC);
2686 PL_savestack_ix -= popval;
2692 unwind_handler_stack(pTHX_ void *p)
2694 U32 flags = *(U32*)p;
2697 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2698 /* cxstack_ix-- Not needed, die already unwound it. */
2699 #if !defined(PERL_IMPLICIT_CONTEXT)
2701 SvREFCNT_dec(sig_sv);