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_ const void *p);
67 static void unwind_handler_stack(pTHX_ const 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 const MGVTBL* const 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)
147 const I32 mgs_ix = SSNEW(sizeof(MGS));
148 const bool was_temp = SvTEMP(sv);
150 MAGIC *newmg, *head, *cur, *mg;
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 const MGVTBL * const 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)
227 const I32 mgs_ix = SSNEW(sizeof(MGS));
231 save_magic(mgs_ix, sv);
233 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
234 MGVTBL* vtbl = mg->mg_virtual;
235 nextmg = mg->mg_moremagic; /* it may delete itself */
236 if (mg->mg_flags & MGf_GSKIP) {
237 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
238 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
240 if (vtbl && vtbl->svt_set)
241 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
244 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
249 =for apidoc mg_length
251 Report on the SV's length. See C<sv_magic>.
257 Perl_mg_length(pTHX_ SV *sv)
262 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
263 const MGVTBL * const vtbl = mg->mg_virtual;
264 if (vtbl && vtbl->svt_len) {
265 const I32 mgs_ix = SSNEW(sizeof(MGS));
266 save_magic(mgs_ix, sv);
267 /* omit MGf_GSKIP -- not changed here */
268 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
269 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
275 U8 *s = (U8*)SvPV(sv, len);
276 len = Perl_utf8_length(aTHX_ s, s + len);
284 Perl_mg_size(pTHX_ SV *sv)
288 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
289 const MGVTBL* const vtbl = mg->mg_virtual;
290 if (vtbl && vtbl->svt_len) {
291 const I32 mgs_ix = SSNEW(sizeof(MGS));
293 save_magic(mgs_ix, sv);
294 /* omit MGf_GSKIP -- not changed here */
295 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
296 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
303 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
307 Perl_croak(aTHX_ "Size magic not implemented");
316 Clear something magical that the SV represents. See C<sv_magic>.
322 Perl_mg_clear(pTHX_ SV *sv)
324 const I32 mgs_ix = SSNEW(sizeof(MGS));
327 save_magic(mgs_ix, sv);
329 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
330 const MGVTBL* const vtbl = mg->mg_virtual;
331 /* omit GSKIP -- never set here */
333 if (vtbl && vtbl->svt_clear)
334 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
337 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
344 Finds the magic pointer for type matching the SV. See C<sv_magic>.
350 Perl_mg_find(pTHX_ const SV *sv, int type)
354 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
355 if (mg->mg_type == type)
365 Copies the magic from one SV to another. See C<sv_magic>.
371 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
375 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
376 const MGVTBL* const vtbl = mg->mg_virtual;
377 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
378 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
380 else if (isUPPER(mg->mg_type)) {
382 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
383 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
385 toLOWER(mg->mg_type), key, klen);
395 Free any magic storage used by the SV. See C<sv_magic>.
401 Perl_mg_free(pTHX_ SV *sv)
405 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
406 const MGVTBL* const vtbl = mg->mg_virtual;
407 moremagic = mg->mg_moremagic;
408 if (vtbl && vtbl->svt_free)
409 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
410 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
411 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
412 Safefree(mg->mg_ptr);
413 else if (mg->mg_len == HEf_SVKEY)
414 SvREFCNT_dec((SV*)mg->mg_ptr);
416 if (mg->mg_flags & MGf_REFCOUNTED)
417 SvREFCNT_dec(mg->mg_obj);
427 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
429 register const REGEXP *rx;
431 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
432 if (mg->mg_obj) /* @+ */
435 return rx->lastparen;
442 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
446 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
447 register const I32 paren = mg->mg_len;
452 if (paren <= (I32)rx->nparens &&
453 (s = rx->startp[paren]) != -1 &&
454 (t = rx->endp[paren]) != -1)
457 if (mg->mg_obj) /* @+ */
462 if (i > 0 && RX_MATCH_UTF8(rx)) {
463 char *b = rx->subbeg;
465 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
475 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
477 Perl_croak(aTHX_ PL_no_modify);
483 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
490 switch (*mg->mg_ptr) {
491 case '1': case '2': case '3': case '4':
492 case '5': case '6': case '7': case '8': case '9': case '&':
493 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
495 paren = atoi(mg->mg_ptr); /* $& is in [0] */
497 if (paren <= (I32)rx->nparens &&
498 (s1 = rx->startp[paren]) != -1 &&
499 (t1 = rx->endp[paren]) != -1)
503 if (i > 0 && RX_MATCH_UTF8(rx)) {
504 char *s = rx->subbeg + s1;
505 char *send = rx->subbeg + t1;
508 if (is_utf8_string((U8*)s, i))
509 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
512 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
516 if (ckWARN(WARN_UNINITIALIZED))
521 if (ckWARN(WARN_UNINITIALIZED))
526 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
527 paren = rx->lastparen;
532 case '\016': /* ^N */
533 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
534 paren = rx->lastcloseparen;
540 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
541 if (rx->startp[0] != -1) {
552 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
553 if (rx->endp[0] != -1) {
554 i = rx->sublen - rx->endp[0];
565 if (!SvPOK(sv) && SvNIOK(sv)) {
575 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
578 register char *s = NULL;
582 switch (*mg->mg_ptr) {
583 case '\001': /* ^A */
584 sv_setsv(sv, PL_bodytarget);
586 case '\003': /* ^C */
587 sv_setiv(sv, (IV)PL_minus_c);
590 case '\004': /* ^D */
591 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
593 case '\005': /* ^E */
594 if (*(mg->mg_ptr+1) == '\0') {
595 #ifdef MACOS_TRADITIONAL
599 sv_setnv(sv,(double)gMacPerl_OSErr);
600 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
605 # include <descrip.h>
606 # include <starlet.h>
608 $DESCRIPTOR(msgdsc,msg);
609 sv_setnv(sv,(NV) vaxc$errno);
610 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
611 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
617 if (!(_emx_env & 0x200)) { /* Under DOS */
618 sv_setnv(sv, (NV)errno);
619 sv_setpv(sv, errno ? Strerror(errno) : "");
621 if (errno != errno_isOS2) {
622 int tmp = _syserrno();
623 if (tmp) /* 2nd call to _syserrno() makes it 0 */
626 sv_setnv(sv, (NV)Perl_rc);
627 sv_setpv(sv, os2error(Perl_rc));
632 DWORD dwErr = GetLastError();
633 sv_setnv(sv, (NV)dwErr);
636 PerlProc_GetOSError(sv, dwErr);
644 int saveerrno = errno;
645 sv_setnv(sv, (NV)errno);
646 sv_setpv(sv, errno ? Strerror(errno) : "");
653 SvNOK_on(sv); /* what a wonderful hack! */
655 else if (strEQ(mg->mg_ptr+1, "NCODING"))
656 sv_setsv(sv, PL_encoding);
658 case '\006': /* ^F */
659 sv_setiv(sv, (IV)PL_maxsysfd);
661 case '\010': /* ^H */
662 sv_setiv(sv, (IV)PL_hints);
664 case '\011': /* ^I */ /* NOT \t in EBCDIC */
666 sv_setpv(sv, PL_inplace);
668 sv_setsv(sv, &PL_sv_undef);
670 case '\017': /* ^O & ^OPEN */
671 if (*(mg->mg_ptr+1) == '\0') {
672 sv_setpv(sv, PL_osname);
675 else if (strEQ(mg->mg_ptr, "\017PEN")) {
676 if (!PL_compiling.cop_io)
677 sv_setsv(sv, &PL_sv_undef);
679 sv_setsv(sv, PL_compiling.cop_io);
683 case '\020': /* ^P */
684 sv_setiv(sv, (IV)PL_perldb);
686 case '\023': /* ^S */
687 if (*(mg->mg_ptr+1) == '\0') {
688 if (PL_lex_state != LEX_NOTPARSING)
691 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
696 case '\024': /* ^T */
697 if (*(mg->mg_ptr+1) == '\0') {
699 sv_setnv(sv, PL_basetime);
701 sv_setiv(sv, (IV)PL_basetime);
704 else if (strEQ(mg->mg_ptr, "\024AINT"))
705 sv_setiv(sv, PL_tainting
706 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
709 case '\025': /* $^UNICODE, $^UTF8LOCALE */
710 if (strEQ(mg->mg_ptr, "\025NICODE"))
711 sv_setuv(sv, (UV) PL_unicode);
712 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
713 sv_setuv(sv, (UV) PL_utf8locale);
715 case '\027': /* ^W & $^WARNING_BITS */
716 if (*(mg->mg_ptr+1) == '\0')
717 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
718 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
719 if (PL_compiling.cop_warnings == pWARN_NONE ||
720 PL_compiling.cop_warnings == pWARN_STD)
722 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
724 else if (PL_compiling.cop_warnings == pWARN_ALL) {
725 /* Get the bit mask for $warnings::Bits{all}, because
726 * it could have been extended by warnings::register */
728 HV *bits=get_hv("warnings::Bits", FALSE);
729 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
730 sv_setsv(sv, *bits_all);
733 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
737 sv_setsv(sv, PL_compiling.cop_warnings);
742 case '1': case '2': case '3': case '4':
743 case '5': case '6': case '7': case '8': case '9': case '&':
744 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
748 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
749 * XXX Does the new way break anything?
751 paren = atoi(mg->mg_ptr); /* $& is in [0] */
753 if (paren <= (I32)rx->nparens &&
754 (s1 = rx->startp[paren]) != -1 &&
755 (t1 = rx->endp[paren]) != -1)
765 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
770 if (RX_MATCH_TAINTED(rx)) {
771 MAGIC* mg = SvMAGIC(sv);
774 SvMAGIC(sv) = mg->mg_moremagic;
776 if ((mgt = SvMAGIC(sv))) {
777 mg->mg_moremagic = mgt;
787 sv_setsv(sv,&PL_sv_undef);
790 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
791 paren = rx->lastparen;
795 sv_setsv(sv,&PL_sv_undef);
797 case '\016': /* ^N */
798 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
799 paren = rx->lastcloseparen;
803 sv_setsv(sv,&PL_sv_undef);
806 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
807 if ((s = rx->subbeg) && rx->startp[0] != -1) {
812 sv_setsv(sv,&PL_sv_undef);
815 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
816 if (rx->subbeg && rx->endp[0] != -1) {
817 s = rx->subbeg + rx->endp[0];
818 i = rx->sublen - rx->endp[0];
822 sv_setsv(sv,&PL_sv_undef);
826 if (GvIO(PL_last_in_gv)) {
827 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
833 sv_setiv(sv, (IV)STATUS_CURRENT);
834 #ifdef COMPLEX_STATUS
835 LvTARGOFF(sv) = PL_statusvalue;
836 LvTARGLEN(sv) = PL_statusvalue_vms;
841 if (GvIOp(PL_defoutgv))
842 s = IoTOP_NAME(GvIOp(PL_defoutgv));
846 sv_setpv(sv,GvENAME(PL_defoutgv));
851 if (GvIOp(PL_defoutgv))
852 s = IoFMT_NAME(GvIOp(PL_defoutgv));
854 s = GvENAME(PL_defoutgv);
859 if (GvIOp(PL_defoutgv))
860 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
863 if (GvIOp(PL_defoutgv))
864 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
867 if (GvIOp(PL_defoutgv))
868 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
876 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
879 if (GvIOp(PL_defoutgv))
880 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
886 sv_copypv(sv, PL_ors_sv);
889 sv_setpv(sv,PL_ofmt);
893 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
894 sv_setpv(sv, errno ? Strerror(errno) : "");
897 int saveerrno = errno;
898 sv_setnv(sv, (NV)errno);
900 if (errno == errno_isOS2 || errno == errno_isOS2_set)
901 sv_setpv(sv, os2error(Perl_rc));
904 sv_setpv(sv, errno ? Strerror(errno) : "");
908 SvNOK_on(sv); /* what a wonderful hack! */
911 sv_setiv(sv, (IV)PL_uid);
914 sv_setiv(sv, (IV)PL_euid);
917 sv_setiv(sv, (IV)PL_gid);
919 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
923 sv_setiv(sv, (IV)PL_egid);
925 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
930 Groups_t gary[NGROUPS];
931 i = getgroups(NGROUPS,gary);
933 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
936 (void)SvIOK_on(sv); /* what a wonderful hack! */
938 #ifndef MACOS_TRADITIONAL
947 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
949 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
951 if (uf && uf->uf_val)
952 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
957 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
967 #ifdef DYNAMIC_ENV_FETCH
968 /* We just undefd an environment var. Is a replacement */
969 /* waiting in the wings? */
972 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
973 s = SvPV(*valp, len);
977 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
978 /* And you'll never guess what the dog had */
979 /* in its mouth... */
981 MgTAINTEDDIR_off(mg);
983 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
984 char pathbuf[256], eltbuf[256], *cp, *elt = s;
988 do { /* DCL$PATH may be a search list */
989 while (1) { /* as may dev portion of any element */
990 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
991 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
992 cando_by_name(S_IWUSR,0,elt) ) {
997 if ((cp = strchr(elt, ':')) != Nullch)
999 if (my_trnlnm(elt, eltbuf, j++))
1005 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1008 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1009 char *strend = s + len;
1011 while (s < strend) {
1015 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1016 s, strend, ':', &i);
1018 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1020 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1021 MgTAINTEDDIR_on(mg);
1027 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1033 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1036 my_setenv(MgPV(mg,n_a),Nullch);
1041 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1044 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1046 if (PL_localizing) {
1049 magic_clear_all_env(sv,mg);
1050 hv_iterinit((HV*)sv);
1051 while ((entry = hv_iternext((HV*)sv))) {
1053 my_setenv(hv_iterkey(entry, &keylen),
1054 SvPV(hv_iterval((HV*)sv, entry), n_a));
1062 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1065 #if defined(VMS) || defined(EPOC)
1066 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1068 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1071 # ifdef USE_ENVIRON_ARRAY
1072 # if defined(USE_ITHREADS)
1073 /* only the parent thread can clobber the process environment */
1074 if (PL_curinterp == aTHX)
1077 # ifndef PERL_USE_SAFE_PUTENV
1078 if (!PL_use_safe_putenv) {
1081 if (environ == PL_origenviron)
1082 environ = (char**)safesysmalloc(sizeof(char*));
1084 for (i = 0; environ[i]; i++)
1085 safesysfree(environ[i]);
1087 # endif /* PERL_USE_SAFE_PUTENV */
1089 environ[0] = Nullch;
1091 # endif /* USE_ENVIRON_ARRAY */
1092 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1093 #endif /* VMS || EPOC */
1094 #endif /* !PERL_MICRO */
1098 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1099 static int sig_handlers_initted = 0;
1101 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1102 static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
1104 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1105 static int sig_defaulting[SIG_SIZE];
1109 #ifdef HAS_SIGPROCMASK
1111 restore_sigmask(pTHX_ SV *save_sv)
1113 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1114 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1118 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1122 /* Are we fetching a signal entry? */
1123 i = whichsig(MgPV(mg,n_a));
1126 sv_setsv(sv,PL_psig_ptr[i]);
1128 Sighandler_t sigstate;
1129 sigstate = rsignal_state(i);
1130 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1131 if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1133 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1134 if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
1136 /* cache state so we don't fetch it again */
1137 if(sigstate == SIG_IGN)
1138 sv_setpv(sv,"IGNORE");
1140 sv_setsv(sv,&PL_sv_undef);
1141 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1148 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1150 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1151 * refactoring might be in order.
1155 register const char *s = MgPV(mg,n_a);
1158 if (strEQ(s,"__DIE__"))
1160 else if (strEQ(s,"__WARN__"))
1163 Perl_croak(aTHX_ "No such hook: %s", s);
1167 SvREFCNT_dec(to_dec);
1172 /* Are we clearing a signal entry? */
1175 #ifdef HAS_SIGPROCMASK
1178 /* Avoid having the signal arrive at a bad time, if possible. */
1181 sigprocmask(SIG_BLOCK, &set, &save);
1183 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1184 SAVEFREESV(save_sv);
1185 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1188 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1189 if (!sig_handlers_initted) Perl_csighandler_init();
1191 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1192 sig_defaulting[i] = 1;
1193 (void)rsignal(i, PL_csighandlerp);
1195 (void)rsignal(i, SIG_DFL);
1197 if(PL_psig_name[i]) {
1198 SvREFCNT_dec(PL_psig_name[i]);
1201 if(PL_psig_ptr[i]) {
1202 to_dec=PL_psig_ptr[i];
1205 SvREFCNT_dec(to_dec);
1215 Perl_raise_signal(pTHX_ int sig)
1217 /* Set a flag to say this signal is pending */
1218 PL_psig_pend[sig]++;
1219 /* And one to say _a_ signal is pending */
1224 Perl_csighandler(int sig)
1226 #ifdef PERL_GET_SIG_CONTEXT
1227 dTHXa(PERL_GET_SIG_CONTEXT);
1231 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1232 (void) rsignal(sig, PL_csighandlerp);
1233 if (sig_ignoring[sig]) return;
1235 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1236 if (sig_defaulting[sig])
1237 #ifdef KILL_BY_SIGPRC
1238 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1243 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1244 /* Call the perl level handler now--
1245 * with risk we may be in malloc() etc. */
1246 (*PL_sighandlerp)(sig);
1248 Perl_raise_signal(aTHX_ sig);
1251 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1253 Perl_csighandler_init(void)
1256 if (sig_handlers_initted) return;
1258 for (sig = 1; sig < SIG_SIZE; sig++) {
1259 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1261 sig_defaulting[sig] = 1;
1262 (void) rsignal(sig, PL_csighandlerp);
1264 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1265 sig_ignoring[sig] = 0;
1268 sig_handlers_initted = 1;
1273 Perl_despatch_signals(pTHX)
1277 for (sig = 1; sig < SIG_SIZE; sig++) {
1278 if (PL_psig_pend[sig]) {
1279 PERL_BLOCKSIG_ADD(set, sig);
1280 PL_psig_pend[sig] = 0;
1281 PERL_BLOCKSIG_BLOCK(set);
1282 (*PL_sighandlerp)(sig);
1283 PERL_BLOCKSIG_UNBLOCK(set);
1289 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1293 /* Need to be careful with SvREFCNT_dec(), because that can have side
1294 * effects (due to closures). We must make sure that the new disposition
1295 * is in place before it is called.
1299 #ifdef HAS_SIGPROCMASK
1304 register const char *s = MgPV(mg,len);
1306 if (strEQ(s,"__DIE__"))
1308 else if (strEQ(s,"__WARN__"))
1311 Perl_croak(aTHX_ "No such hook: %s", s);
1319 i = whichsig(s); /* ...no, a brick */
1321 if (ckWARN(WARN_SIGNAL))
1322 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1325 #ifdef HAS_SIGPROCMASK
1326 /* Avoid having the signal arrive at a bad time, if possible. */
1329 sigprocmask(SIG_BLOCK, &set, &save);
1331 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1332 SAVEFREESV(save_sv);
1333 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1336 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1337 if (!sig_handlers_initted) Perl_csighandler_init();
1339 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1340 sig_ignoring[i] = 0;
1342 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1343 sig_defaulting[i] = 0;
1345 SvREFCNT_dec(PL_psig_name[i]);
1346 to_dec = PL_psig_ptr[i];
1347 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1348 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1349 PL_psig_name[i] = newSVpvn(s, len);
1350 SvREADONLY_on(PL_psig_name[i]);
1352 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1354 (void)rsignal(i, PL_csighandlerp);
1355 #ifdef HAS_SIGPROCMASK
1360 *svp = SvREFCNT_inc(sv);
1362 SvREFCNT_dec(to_dec);
1365 s = SvPV_force(sv,len);
1366 if (strEQ(s,"IGNORE")) {
1368 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1369 sig_ignoring[i] = 1;
1370 (void)rsignal(i, PL_csighandlerp);
1372 (void)rsignal(i, SIG_IGN);
1376 else if (strEQ(s,"DEFAULT") || !*s) {
1378 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1380 sig_defaulting[i] = 1;
1381 (void)rsignal(i, PL_csighandlerp);
1384 (void)rsignal(i, SIG_DFL);
1389 * We should warn if HINT_STRICT_REFS, but without
1390 * access to a known hint bit in a known OP, we can't
1391 * tell whether HINT_STRICT_REFS is in force or not.
1393 if (!strchr(s,':') && !strchr(s,'\''))
1394 sv_insert(sv, 0, 0, "main::", 6);
1396 (void)rsignal(i, PL_csighandlerp);
1398 *svp = SvREFCNT_inc(sv);
1400 #ifdef HAS_SIGPROCMASK
1405 SvREFCNT_dec(to_dec);
1408 #endif /* !PERL_MICRO */
1411 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1413 PL_sub_generation++;
1418 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1420 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1421 PL_amagic_generation++;
1427 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1429 HV *hv = (HV*)LvTARG(sv);
1433 (void) hv_iterinit(hv);
1434 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1437 while (hv_iternext(hv))
1442 sv_setiv(sv, (IV)i);
1447 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1450 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1455 /* caller is responsible for stack switching/cleanup */
1457 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1463 PUSHs(SvTIED_obj(sv, mg));
1466 if (mg->mg_len >= 0)
1467 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1468 else if (mg->mg_len == HEf_SVKEY)
1469 PUSHs((SV*)mg->mg_ptr);
1471 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1472 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1480 return call_method(meth, flags);
1484 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
1490 PUSHSTACKi(PERLSI_MAGIC);
1492 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1493 sv_setsv(sv, *PL_stack_sp--);
1503 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1506 mg->mg_flags |= MGf_GSKIP;
1507 magic_methpack(sv,mg,"FETCH");
1512 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1516 PUSHSTACKi(PERLSI_MAGIC);
1517 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1524 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1526 return magic_methpack(sv,mg,"DELETE");
1531 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1538 PUSHSTACKi(PERLSI_MAGIC);
1539 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1540 sv = *PL_stack_sp--;
1541 retval = (U32) SvIV(sv)-1;
1550 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1555 PUSHSTACKi(PERLSI_MAGIC);
1557 XPUSHs(SvTIED_obj(sv, mg));
1559 call_method("CLEAR", G_SCALAR|G_DISCARD);
1567 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1570 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1574 PUSHSTACKi(PERLSI_MAGIC);
1577 PUSHs(SvTIED_obj(sv, mg));
1582 if (call_method(meth, G_SCALAR))
1583 sv_setsv(key, *PL_stack_sp--);
1592 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1594 return magic_methpack(sv,mg,"EXISTS");
1598 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1601 SV *retval = &PL_sv_undef;
1602 SV *tied = SvTIED_obj((SV*)hv, mg);
1603 HV *pkg = SvSTASH((SV*)SvRV(tied));
1605 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1608 /* we are in an iteration so the hash cannot be empty */
1610 /* no xhv_eiter so now use FIRSTKEY */
1611 key = sv_newmortal();
1612 magic_nextpack((SV*)hv, mg, key);
1613 HvEITER(hv) = NULL; /* need to reset iterator */
1614 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1617 /* there is a SCALAR method that we can call */
1619 PUSHSTACKi(PERLSI_MAGIC);
1625 if (call_method("SCALAR", G_SCALAR))
1626 retval = *PL_stack_sp--;
1633 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1643 svp = av_fetch(GvAV(gv),
1644 atoi(MgPV(mg,n_a)), FALSE);
1645 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1646 /* set or clear breakpoint in the relevant control op */
1648 o->op_flags |= OPf_SPECIAL;
1650 o->op_flags &= ~OPf_SPECIAL;
1656 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1658 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1663 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1665 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1670 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1672 SV* lsv = LvTARG(sv);
1674 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1675 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1676 if (mg && mg->mg_len >= 0) {
1679 sv_pos_b2u(lsv, &i);
1680 sv_setiv(sv, i + PL_curcop->cop_arybase);
1689 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1691 SV* lsv = LvTARG(sv);
1698 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1699 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1703 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1704 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1706 else if (!SvOK(sv)) {
1710 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1712 pos = SvIV(sv) - PL_curcop->cop_arybase;
1715 ulen = sv_len_utf8(lsv);
1725 else if (pos > (SSize_t)len)
1730 sv_pos_u2b(lsv, &p, 0);
1735 mg->mg_flags &= ~MGf_MINMATCH;
1741 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1743 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1745 gv_efullname3(sv,((GV*)sv), "*");
1749 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1754 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1760 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1765 GvGP(sv) = gp_ref(GvGP(gv));
1770 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1773 SV * const lsv = LvTARG(sv);
1774 const char * const tmps = SvPV(lsv,len);
1775 I32 offs = LvTARGOFF(sv);
1776 I32 rem = LvTARGLEN(sv);
1779 sv_pos_u2b(lsv, &offs, &rem);
1780 if (offs > (I32)len)
1782 if (rem + offs > (I32)len)
1784 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1791 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1794 char *tmps = SvPV(sv, len);
1795 SV *lsv = LvTARG(sv);
1796 I32 lvoff = LvTARGOFF(sv);
1797 I32 lvlen = LvTARGLEN(sv);
1800 sv_utf8_upgrade(lsv);
1801 sv_pos_u2b(lsv, &lvoff, &lvlen);
1802 sv_insert(lsv, lvoff, lvlen, tmps, len);
1803 LvTARGLEN(sv) = sv_len_utf8(sv);
1806 else if (lsv && SvUTF8(lsv)) {
1807 sv_pos_u2b(lsv, &lvoff, &lvlen);
1808 LvTARGLEN(sv) = len;
1809 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1810 sv_insert(lsv, lvoff, lvlen, tmps, len);
1814 sv_insert(lsv, lvoff, lvlen, tmps, len);
1815 LvTARGLEN(sv) = len;
1823 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1825 TAINT_IF((mg->mg_len & 1) ||
1826 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1831 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1833 if (PL_localizing) {
1834 if (PL_localizing == 1)
1839 else if (PL_tainted)
1847 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1849 SV * const lsv = LvTARG(sv);
1856 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1861 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1863 do_vecset(sv); /* XXX slurp this routine */
1868 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1871 if (LvTARGLEN(sv)) {
1873 SV *ahv = LvTARG(sv);
1874 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1879 AV* av = (AV*)LvTARG(sv);
1880 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1881 targ = AvARRAY(av)[LvTARGOFF(sv)];
1883 if (targ && targ != &PL_sv_undef) {
1884 /* somebody else defined it for us */
1885 SvREFCNT_dec(LvTARG(sv));
1886 LvTARG(sv) = SvREFCNT_inc(targ);
1888 SvREFCNT_dec(mg->mg_obj);
1889 mg->mg_obj = Nullsv;
1890 mg->mg_flags &= ~MGf_REFCOUNTED;
1895 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1900 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1905 sv_setsv(LvTARG(sv), sv);
1906 SvSETMAGIC(LvTARG(sv));
1912 Perl_vivify_defelem(pTHX_ SV *sv)
1917 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1920 SV *ahv = LvTARG(sv);
1922 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1925 if (!value || value == &PL_sv_undef)
1926 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1929 AV* av = (AV*)LvTARG(sv);
1930 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1931 LvTARG(sv) = Nullsv; /* array can't be extended */
1933 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1934 if (!svp || (value = *svp) == &PL_sv_undef)
1935 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1938 (void)SvREFCNT_inc(value);
1939 SvREFCNT_dec(LvTARG(sv));
1942 SvREFCNT_dec(mg->mg_obj);
1943 mg->mg_obj = Nullsv;
1944 mg->mg_flags &= ~MGf_REFCOUNTED;
1948 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1950 AV *av = (AV*)mg->mg_obj;
1951 SV **svp = AvARRAY(av);
1952 I32 i = AvFILLp(av);
1955 if (!SvWEAKREF(svp[i]))
1956 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1957 /* XXX Should we check that it hasn't changed? */
1960 SvWEAKREF_off(svp[i]);
1965 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1970 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1978 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1980 sv_unmagic(sv, PERL_MAGIC_bm);
1986 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
1988 sv_unmagic(sv, PERL_MAGIC_fm);
1994 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
1996 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1998 if (uf && uf->uf_set)
1999 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2004 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2006 sv_unmagic(sv, PERL_MAGIC_qr);
2011 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2013 regexp *re = (regexp *)mg->mg_obj;
2018 #ifdef USE_LOCALE_COLLATE
2020 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2023 * RenE<eacute> Descartes said "I think not."
2024 * and vanished with a faint plop.
2027 Safefree(mg->mg_ptr);
2033 #endif /* USE_LOCALE_COLLATE */
2035 /* Just clear the UTF-8 cache data. */
2037 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2039 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2041 mg->mg_len = -1; /* The mg_len holds the len cache. */
2046 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2051 switch (*mg->mg_ptr) {
2052 case '\001': /* ^A */
2053 sv_setsv(PL_bodytarget, sv);
2055 case '\003': /* ^C */
2056 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2059 case '\004': /* ^D */
2062 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2063 DEBUG_x(dump_all());
2065 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2068 case '\005': /* ^E */
2069 if (*(mg->mg_ptr+1) == '\0') {
2070 #ifdef MACOS_TRADITIONAL
2071 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2074 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2077 SetLastError( SvIV(sv) );
2080 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2082 /* will anyone ever use this? */
2083 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2089 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2091 SvREFCNT_dec(PL_encoding);
2092 if (SvOK(sv) || SvGMAGICAL(sv)) {
2093 PL_encoding = newSVsv(sv);
2096 PL_encoding = Nullsv;
2100 case '\006': /* ^F */
2101 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2103 case '\010': /* ^H */
2104 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2106 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2108 Safefree(PL_inplace);
2110 PL_inplace = savesvpv(sv);
2112 PL_inplace = Nullch;
2114 case '\017': /* ^O */
2115 if (*(mg->mg_ptr+1) == '\0') {
2117 Safefree(PL_osname);
2121 TAINT_PROPER("assigning to $^O");
2122 PL_osname = savesvpv(sv);
2125 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2126 if (!PL_compiling.cop_io)
2127 PL_compiling.cop_io = newSVsv(sv);
2129 sv_setsv(PL_compiling.cop_io,sv);
2132 case '\020': /* ^P */
2133 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2134 if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
2138 case '\024': /* ^T */
2140 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2142 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2145 case '\027': /* ^W & $^WARNING_BITS */
2146 if (*(mg->mg_ptr+1) == '\0') {
2147 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2148 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2149 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2150 | (i ? G_WARN_ON : G_WARN_OFF) ;
2153 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2154 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2155 if (!SvPOK(sv) && PL_localizing) {
2156 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2157 PL_compiling.cop_warnings = pWARN_NONE;
2162 int accumulate = 0 ;
2163 int any_fatals = 0 ;
2164 const char * const ptr = (char*)SvPV(sv, len) ;
2165 for (i = 0 ; i < len ; ++i) {
2166 accumulate |= ptr[i] ;
2167 any_fatals |= (ptr[i] & 0xAA) ;
2170 PL_compiling.cop_warnings = pWARN_NONE;
2171 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2172 PL_compiling.cop_warnings = pWARN_ALL;
2173 PL_dowarn |= G_WARN_ONCE ;
2176 if (specialWARN(PL_compiling.cop_warnings))
2177 PL_compiling.cop_warnings = newSVsv(sv) ;
2179 sv_setsv(PL_compiling.cop_warnings, sv);
2180 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2181 PL_dowarn |= G_WARN_ONCE ;
2189 if (PL_localizing) {
2190 if (PL_localizing == 1)
2191 SAVESPTR(PL_last_in_gv);
2193 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2194 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2197 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2198 IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savesvpv(sv);
2199 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2202 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2203 IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savesvpv(sv);
2204 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2207 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2210 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2211 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2212 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2215 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2219 IO *io = GvIOp(PL_defoutgv);
2222 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2223 IoFLAGS(io) &= ~IOf_FLUSH;
2225 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2226 PerlIO *ofp = IoOFP(io);
2228 (void)PerlIO_flush(ofp);
2229 IoFLAGS(io) |= IOf_FLUSH;
2235 SvREFCNT_dec(PL_rs);
2236 PL_rs = newSVsv(sv);
2240 SvREFCNT_dec(PL_ors_sv);
2241 if (SvOK(sv) || SvGMAGICAL(sv)) {
2242 PL_ors_sv = newSVsv(sv);
2250 SvREFCNT_dec(PL_ofs_sv);
2251 if (SvOK(sv) || SvGMAGICAL(sv)) {
2252 PL_ofs_sv = newSVsv(sv);
2261 PL_ofmt = savesvpv(sv);
2264 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2267 #ifdef COMPLEX_STATUS
2268 if (PL_localizing == 2) {
2269 PL_statusvalue = LvTARGOFF(sv);
2270 PL_statusvalue_vms = LvTARGLEN(sv);
2274 #ifdef VMSISH_STATUS
2276 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2279 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2284 # define PERL_VMS_BANG vaxc$errno
2286 # define PERL_VMS_BANG 0
2288 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2289 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2293 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2294 if (PL_delaymagic) {
2295 PL_delaymagic |= DM_RUID;
2296 break; /* don't do magic till later */
2299 (void)setruid((Uid_t)PL_uid);
2302 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2304 #ifdef HAS_SETRESUID
2305 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2307 if (PL_uid == PL_euid) { /* special case $< = $> */
2309 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2310 if (PL_uid != 0 && PerlProc_getuid() == 0)
2311 (void)PerlProc_setuid(0);
2313 (void)PerlProc_setuid(PL_uid);
2315 PL_uid = PerlProc_getuid();
2316 Perl_croak(aTHX_ "setruid() not implemented");
2321 PL_uid = PerlProc_getuid();
2322 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2325 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2326 if (PL_delaymagic) {
2327 PL_delaymagic |= DM_EUID;
2328 break; /* don't do magic till later */
2331 (void)seteuid((Uid_t)PL_euid);
2334 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2336 #ifdef HAS_SETRESUID
2337 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2339 if (PL_euid == PL_uid) /* special case $> = $< */
2340 PerlProc_setuid(PL_euid);
2342 PL_euid = PerlProc_geteuid();
2343 Perl_croak(aTHX_ "seteuid() not implemented");
2348 PL_euid = PerlProc_geteuid();
2349 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2352 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2353 if (PL_delaymagic) {
2354 PL_delaymagic |= DM_RGID;
2355 break; /* don't do magic till later */
2358 (void)setrgid((Gid_t)PL_gid);
2361 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2363 #ifdef HAS_SETRESGID
2364 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2366 if (PL_gid == PL_egid) /* special case $( = $) */
2367 (void)PerlProc_setgid(PL_gid);
2369 PL_gid = PerlProc_getgid();
2370 Perl_croak(aTHX_ "setrgid() not implemented");
2375 PL_gid = PerlProc_getgid();
2376 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2379 #ifdef HAS_SETGROUPS
2381 const char *p = SvPV(sv, len);
2382 Groups_t gary[NGROUPS];
2387 for (i = 0; i < NGROUPS; ++i) {
2388 while (*p && !isSPACE(*p))
2397 (void)setgroups(i, gary);
2399 #else /* HAS_SETGROUPS */
2400 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2401 #endif /* HAS_SETGROUPS */
2402 if (PL_delaymagic) {
2403 PL_delaymagic |= DM_EGID;
2404 break; /* don't do magic till later */
2407 (void)setegid((Gid_t)PL_egid);
2410 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2412 #ifdef HAS_SETRESGID
2413 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2415 if (PL_egid == PL_gid) /* special case $) = $( */
2416 (void)PerlProc_setgid(PL_egid);
2418 PL_egid = PerlProc_getegid();
2419 Perl_croak(aTHX_ "setegid() not implemented");
2424 PL_egid = PerlProc_getegid();
2425 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2428 PL_chopset = SvPV_force(sv,len);
2430 #ifndef MACOS_TRADITIONAL
2432 LOCK_DOLLARZERO_MUTEX;
2433 #ifdef HAS_SETPROCTITLE
2434 /* The BSDs don't show the argv[] in ps(1) output, they
2435 * show a string from the process struct and provide
2436 * the setproctitle() routine to manipulate that. */
2439 # if __FreeBSD_version > 410001
2440 /* The leading "-" removes the "perl: " prefix,
2441 * but not the "(perl) suffix from the ps(1)
2442 * output, because that's what ps(1) shows if the
2443 * argv[] is modified. */
2444 setproctitle("-%s", s);
2445 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2446 /* This doesn't really work if you assume that
2447 * $0 = 'foobar'; will wipe out 'perl' from the $0
2448 * because in ps(1) output the result will be like
2449 * sprintf("perl: %s (perl)", s)
2450 * I guess this is a security feature:
2451 * one (a user process) cannot get rid of the original name.
2453 setproctitle("%s", s);
2457 #if defined(__hpux) && defined(PSTAT_SETCMD)
2462 pstat(PSTAT_SETCMD, un, len, 0, 0);
2465 /* PL_origalen is set in perl_parse(). */
2466 s = SvPV_force(sv,len);
2467 if (len >= (STRLEN)PL_origalen-1) {
2468 /* Longer than original, will be truncated. We assume that
2469 * PL_origalen bytes are available. */
2470 Copy(s, PL_origargv[0], PL_origalen-1, char);
2473 /* Shorter than original, will be padded. */
2474 Copy(s, PL_origargv[0], len, char);
2475 PL_origargv[0][len] = 0;
2476 memset(PL_origargv[0] + len + 1,
2477 /* Is the space counterintuitive? Yes.
2478 * (You were expecting \0?)
2479 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2482 PL_origalen - len - 1);
2484 PL_origargv[0][PL_origalen-1] = 0;
2485 for (i = 1; i < PL_origargc; i++)
2487 UNLOCK_DOLLARZERO_MUTEX;
2495 Perl_whichsig(pTHX_ const char *sig)
2497 register char **sigv;
2499 for (sigv = PL_sig_name; *sigv; sigv++)
2500 if (strEQ(sig,*sigv))
2501 return PL_sig_num[sigv - PL_sig_name];
2503 if (strEQ(sig,"CHLD"))
2507 if (strEQ(sig,"CLD"))
2513 #if !defined(PERL_IMPLICIT_CONTEXT)
2518 Perl_sighandler(int sig)
2520 #ifdef PERL_GET_SIG_CONTEXT
2521 dTHXa(PERL_GET_SIG_CONTEXT);
2528 SV *sv = Nullsv, *tSv = PL_Sv;
2534 if (PL_savestack_ix + 15 <= PL_savestack_max)
2536 if (PL_markstack_ptr < PL_markstack_max - 2)
2538 if (PL_scopestack_ix < PL_scopestack_max - 3)
2541 if (!PL_psig_ptr[sig]) {
2542 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2547 /* Max number of items pushed there is 3*n or 4. We cannot fix
2548 infinity, so we fix 4 (in fact 5): */
2550 PL_savestack_ix += 5; /* Protect save in progress. */
2551 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2554 PL_markstack_ptr++; /* Protect mark. */
2556 PL_scopestack_ix += 1;
2557 /* sv_2cv is too complicated, try a simpler variant first: */
2558 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2559 || SvTYPE(cv) != SVt_PVCV)
2560 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2562 if (!cv || !CvROOT(cv)) {
2563 if (ckWARN(WARN_SIGNAL))
2564 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2565 PL_sig_name[sig], (gv ? GvENAME(gv)
2572 if(PL_psig_name[sig]) {
2573 sv = SvREFCNT_inc(PL_psig_name[sig]);
2575 #if !defined(PERL_IMPLICIT_CONTEXT)
2579 sv = sv_newmortal();
2580 sv_setpv(sv,PL_sig_name[sig]);
2583 PUSHSTACKi(PERLSI_SIGNAL);
2588 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2591 if (SvTRUE(ERRSV)) {
2593 #ifdef HAS_SIGPROCMASK
2594 /* Handler "died", for example to get out of a restart-able read().
2595 * Before we re-do that on its behalf re-enable the signal which was
2596 * blocked by the system when we entered.
2600 sigaddset(&set,sig);
2601 sigprocmask(SIG_UNBLOCK, &set, NULL);
2603 /* Not clear if this will work */
2604 (void)rsignal(sig, SIG_IGN);
2605 (void)rsignal(sig, PL_csighandlerp);
2607 #endif /* !PERL_MICRO */
2612 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2616 PL_scopestack_ix -= 1;
2619 PL_op = myop; /* Apparently not needed... */
2621 PL_Sv = tSv; /* Restore global temporaries. */
2628 restore_magic(pTHX_ const void *p)
2630 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2631 SV* sv = mgs->mgs_sv;
2636 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2638 #ifdef PERL_COPY_ON_WRITE
2639 /* While magic was saved (and off) sv_setsv may well have seen
2640 this SV as a prime candidate for COW. */
2642 sv_force_normal(sv);
2646 SvFLAGS(sv) |= mgs->mgs_flags;
2650 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2653 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2655 /* If we're still on top of the stack, pop us off. (That condition
2656 * will be satisfied if restore_magic was called explicitly, but *not*
2657 * if it's being called via leave_scope.)
2658 * The reason for doing this is that otherwise, things like sv_2cv()
2659 * may leave alloc gunk on the savestack, and some code
2660 * (e.g. sighandler) doesn't expect that...
2662 if (PL_savestack_ix == mgs->mgs_ss_ix)
2664 I32 popval = SSPOPINT;
2665 assert(popval == SAVEt_DESTRUCTOR_X);
2666 PL_savestack_ix -= 2;
2668 assert(popval == SAVEt_ALLOC);
2670 PL_savestack_ix -= popval;
2676 unwind_handler_stack(pTHX_ const void *p)
2678 const U32 flags = *(U32*)p;
2681 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2682 /* cxstack_ix-- Not needed, die already unwound it. */
2683 #if !defined(PERL_IMPLICIT_CONTEXT)
2685 SvREFCNT_dec(sig_sv);