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 = (bool)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 (!have_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 const 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;
432 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
433 if (mg->mg_obj) /* @+ */
436 return rx->lastparen;
443 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
447 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
448 register const I32 paren = mg->mg_len;
453 if (paren <= (I32)rx->nparens &&
454 (s = rx->startp[paren]) != -1 &&
455 (t = rx->endp[paren]) != -1)
458 if (mg->mg_obj) /* @+ */
463 if (i > 0 && RX_MATCH_UTF8(rx)) {
464 char *b = rx->subbeg;
466 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
476 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
479 Perl_croak(aTHX_ PL_no_modify);
482 /* No __attribute__, so the compiler doesn't know that croak never returns
489 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
493 register const REGEXP *rx;
496 switch (*mg->mg_ptr) {
497 case '1': case '2': case '3': case '4':
498 case '5': case '6': case '7': case '8': case '9': case '&':
499 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
501 paren = atoi(mg->mg_ptr); /* $& is in [0] */
503 if (paren <= (I32)rx->nparens &&
504 (s1 = rx->startp[paren]) != -1 &&
505 (t1 = rx->endp[paren]) != -1)
509 if (i > 0 && RX_MATCH_UTF8(rx)) {
510 char *s = rx->subbeg + s1;
511 char *send = rx->subbeg + t1;
514 if (is_utf8_string((U8*)s, i))
515 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
518 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
522 if (ckWARN(WARN_UNINITIALIZED))
527 if (ckWARN(WARN_UNINITIALIZED))
532 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
533 paren = rx->lastparen;
538 case '\016': /* ^N */
539 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
540 paren = rx->lastcloseparen;
546 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
547 if (rx->startp[0] != -1) {
558 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
559 if (rx->endp[0] != -1) {
560 i = rx->sublen - rx->endp[0];
571 if (!SvPOK(sv) && SvNIOK(sv)) {
581 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
584 register char *s = NULL;
588 switch (*mg->mg_ptr) {
589 case '\001': /* ^A */
590 sv_setsv(sv, PL_bodytarget);
592 case '\003': /* ^C */
593 sv_setiv(sv, (IV)PL_minus_c);
596 case '\004': /* ^D */
597 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
599 case '\005': /* ^E */
600 if (*(mg->mg_ptr+1) == '\0') {
601 #ifdef MACOS_TRADITIONAL
605 sv_setnv(sv,(double)gMacPerl_OSErr);
606 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
611 # include <descrip.h>
612 # include <starlet.h>
614 $DESCRIPTOR(msgdsc,msg);
615 sv_setnv(sv,(NV) vaxc$errno);
616 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
617 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
623 if (!(_emx_env & 0x200)) { /* Under DOS */
624 sv_setnv(sv, (NV)errno);
625 sv_setpv(sv, errno ? Strerror(errno) : "");
627 if (errno != errno_isOS2) {
628 int tmp = _syserrno();
629 if (tmp) /* 2nd call to _syserrno() makes it 0 */
632 sv_setnv(sv, (NV)Perl_rc);
633 sv_setpv(sv, os2error(Perl_rc));
638 DWORD dwErr = GetLastError();
639 sv_setnv(sv, (NV)dwErr);
642 PerlProc_GetOSError(sv, dwErr);
650 int saveerrno = errno;
651 sv_setnv(sv, (NV)errno);
652 sv_setpv(sv, errno ? Strerror(errno) : "");
659 SvNOK_on(sv); /* what a wonderful hack! */
661 else if (strEQ(mg->mg_ptr+1, "NCODING"))
662 sv_setsv(sv, PL_encoding);
664 case '\006': /* ^F */
665 sv_setiv(sv, (IV)PL_maxsysfd);
667 case '\010': /* ^H */
668 sv_setiv(sv, (IV)PL_hints);
670 case '\011': /* ^I */ /* NOT \t in EBCDIC */
672 sv_setpv(sv, PL_inplace);
674 sv_setsv(sv, &PL_sv_undef);
676 case '\017': /* ^O & ^OPEN */
677 if (*(mg->mg_ptr+1) == '\0') {
678 sv_setpv(sv, PL_osname);
681 else if (strEQ(mg->mg_ptr, "\017PEN")) {
682 if (!PL_compiling.cop_io)
683 sv_setsv(sv, &PL_sv_undef);
685 sv_setsv(sv, PL_compiling.cop_io);
689 case '\020': /* ^P */
690 sv_setiv(sv, (IV)PL_perldb);
692 case '\023': /* ^S */
693 if (*(mg->mg_ptr+1) == '\0') {
694 if (PL_lex_state != LEX_NOTPARSING)
697 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
702 case '\024': /* ^T */
703 if (*(mg->mg_ptr+1) == '\0') {
705 sv_setnv(sv, PL_basetime);
707 sv_setiv(sv, (IV)PL_basetime);
710 else if (strEQ(mg->mg_ptr, "\024AINT"))
711 sv_setiv(sv, PL_tainting
712 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
715 case '\025': /* $^UNICODE, $^UTF8LOCALE */
716 if (strEQ(mg->mg_ptr, "\025NICODE"))
717 sv_setuv(sv, (UV) PL_unicode);
718 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
719 sv_setuv(sv, (UV) PL_utf8locale);
721 case '\027': /* ^W & $^WARNING_BITS */
722 if (*(mg->mg_ptr+1) == '\0')
723 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
724 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
725 if (PL_compiling.cop_warnings == pWARN_NONE ||
726 PL_compiling.cop_warnings == pWARN_STD)
728 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
730 else if (PL_compiling.cop_warnings == pWARN_ALL) {
731 /* Get the bit mask for $warnings::Bits{all}, because
732 * it could have been extended by warnings::register */
734 HV *bits=get_hv("warnings::Bits", FALSE);
735 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
736 sv_setsv(sv, *bits_all);
739 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
743 sv_setsv(sv, PL_compiling.cop_warnings);
748 case '1': case '2': case '3': case '4':
749 case '5': case '6': case '7': case '8': case '9': case '&':
750 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
754 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
755 * XXX Does the new way break anything?
757 paren = atoi(mg->mg_ptr); /* $& is in [0] */
759 if (paren <= (I32)rx->nparens &&
760 (s1 = rx->startp[paren]) != -1 &&
761 (t1 = rx->endp[paren]) != -1)
771 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
776 if (RX_MATCH_TAINTED(rx)) {
777 MAGIC* mg = SvMAGIC(sv);
780 SvMAGIC(sv) = mg->mg_moremagic;
782 if ((mgt = SvMAGIC(sv))) {
783 mg->mg_moremagic = mgt;
793 sv_setsv(sv,&PL_sv_undef);
796 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
797 paren = rx->lastparen;
801 sv_setsv(sv,&PL_sv_undef);
803 case '\016': /* ^N */
804 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
805 paren = rx->lastcloseparen;
809 sv_setsv(sv,&PL_sv_undef);
812 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
813 if ((s = rx->subbeg) && rx->startp[0] != -1) {
818 sv_setsv(sv,&PL_sv_undef);
821 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
822 if (rx->subbeg && rx->endp[0] != -1) {
823 s = rx->subbeg + rx->endp[0];
824 i = rx->sublen - rx->endp[0];
828 sv_setsv(sv,&PL_sv_undef);
832 if (GvIO(PL_last_in_gv)) {
833 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
839 sv_setiv(sv, (IV)STATUS_CURRENT);
840 #ifdef COMPLEX_STATUS
841 LvTARGOFF(sv) = PL_statusvalue;
842 LvTARGLEN(sv) = PL_statusvalue_vms;
847 if (GvIOp(PL_defoutgv))
848 s = IoTOP_NAME(GvIOp(PL_defoutgv));
852 sv_setpv(sv,GvENAME(PL_defoutgv));
857 if (GvIOp(PL_defoutgv))
858 s = IoFMT_NAME(GvIOp(PL_defoutgv));
860 s = GvENAME(PL_defoutgv);
865 if (GvIOp(PL_defoutgv))
866 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
869 if (GvIOp(PL_defoutgv))
870 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
873 if (GvIOp(PL_defoutgv))
874 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
882 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
885 if (GvIOp(PL_defoutgv))
886 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
892 sv_copypv(sv, PL_ors_sv);
895 sv_setpv(sv,PL_ofmt);
899 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
900 sv_setpv(sv, errno ? Strerror(errno) : "");
903 int saveerrno = errno;
904 sv_setnv(sv, (NV)errno);
906 if (errno == errno_isOS2 || errno == errno_isOS2_set)
907 sv_setpv(sv, os2error(Perl_rc));
910 sv_setpv(sv, errno ? Strerror(errno) : "");
914 SvNOK_on(sv); /* what a wonderful hack! */
917 sv_setiv(sv, (IV)PL_uid);
920 sv_setiv(sv, (IV)PL_euid);
923 sv_setiv(sv, (IV)PL_gid);
925 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
929 sv_setiv(sv, (IV)PL_egid);
931 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
936 Groups_t gary[NGROUPS];
937 i = getgroups(NGROUPS,gary);
939 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
942 (void)SvIOK_on(sv); /* what a wonderful hack! */
944 #ifndef MACOS_TRADITIONAL
953 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
955 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
957 if (uf && uf->uf_val)
958 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
963 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
973 #ifdef DYNAMIC_ENV_FETCH
974 /* We just undefd an environment var. Is a replacement */
975 /* waiting in the wings? */
978 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
979 s = SvPV(*valp, len);
983 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
984 /* And you'll never guess what the dog had */
985 /* in its mouth... */
987 MgTAINTEDDIR_off(mg);
989 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
990 char pathbuf[256], eltbuf[256], *cp, *elt = s;
994 do { /* DCL$PATH may be a search list */
995 while (1) { /* as may dev portion of any element */
996 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
997 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
998 cando_by_name(S_IWUSR,0,elt) ) {
1003 if ((cp = strchr(elt, ':')) != Nullch)
1005 if (my_trnlnm(elt, eltbuf, j++))
1011 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1014 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1015 char *strend = s + len;
1017 while (s < strend) {
1021 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1022 s, strend, ':', &i);
1024 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1026 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1027 MgTAINTEDDIR_on(mg);
1033 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1039 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1043 my_setenv(MgPV(mg,n_a),Nullch);
1048 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1051 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1053 if (PL_localizing) {
1056 magic_clear_all_env(sv,mg);
1057 hv_iterinit((HV*)sv);
1058 while ((entry = hv_iternext((HV*)sv))) {
1060 my_setenv(hv_iterkey(entry, &keylen),
1061 SvPV(hv_iterval((HV*)sv, entry), n_a));
1069 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1072 #if defined(VMS) || defined(EPOC)
1073 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1075 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1078 # ifdef USE_ENVIRON_ARRAY
1079 # if defined(USE_ITHREADS)
1080 /* only the parent thread can clobber the process environment */
1081 if (PL_curinterp == aTHX)
1084 # ifndef PERL_USE_SAFE_PUTENV
1085 if (!PL_use_safe_putenv) {
1088 if (environ == PL_origenviron)
1089 environ = (char**)safesysmalloc(sizeof(char*));
1091 for (i = 0; environ[i]; i++)
1092 safesysfree(environ[i]);
1094 # endif /* PERL_USE_SAFE_PUTENV */
1096 environ[0] = Nullch;
1098 # endif /* USE_ENVIRON_ARRAY */
1099 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1100 #endif /* VMS || EPOC */
1101 #endif /* !PERL_MICRO */
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.
1163 register const char *s = MgPV(mg,n_a);
1167 if (strEQ(s,"__DIE__"))
1169 else if (strEQ(s,"__WARN__"))
1172 Perl_croak(aTHX_ "No such hook: %s", s);
1176 SvREFCNT_dec(to_dec);
1181 /* Are we clearing a signal entry? */
1184 #ifdef HAS_SIGPROCMASK
1187 /* Avoid having the signal arrive at a bad time, if possible. */
1190 sigprocmask(SIG_BLOCK, &set, &save);
1192 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1193 SAVEFREESV(save_sv);
1194 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1197 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1198 if (!sig_handlers_initted) Perl_csighandler_init();
1200 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1201 sig_defaulting[i] = 1;
1202 (void)rsignal(i, PL_csighandlerp);
1204 (void)rsignal(i, SIG_DFL);
1206 if(PL_psig_name[i]) {
1207 SvREFCNT_dec(PL_psig_name[i]);
1210 if(PL_psig_ptr[i]) {
1211 SV *to_dec=PL_psig_ptr[i];
1214 SvREFCNT_dec(to_dec);
1224 S_raise_signal(pTHX_ int sig)
1226 /* Set a flag to say this signal is pending */
1227 PL_psig_pend[sig]++;
1228 /* And one to say _a_ signal is pending */
1233 Perl_csighandler(int sig)
1235 #ifdef PERL_GET_SIG_CONTEXT
1236 dTHXa(PERL_GET_SIG_CONTEXT);
1240 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1241 (void) rsignal(sig, PL_csighandlerp);
1242 if (sig_ignoring[sig]) return;
1244 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1245 if (sig_defaulting[sig])
1246 #ifdef KILL_BY_SIGPRC
1247 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1252 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1253 /* Call the perl level handler now--
1254 * with risk we may be in malloc() etc. */
1255 (*PL_sighandlerp)(sig);
1257 S_raise_signal(aTHX_ sig);
1260 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1262 Perl_csighandler_init(void)
1265 if (sig_handlers_initted) return;
1267 for (sig = 1; sig < SIG_SIZE; sig++) {
1268 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1270 sig_defaulting[sig] = 1;
1271 (void) rsignal(sig, PL_csighandlerp);
1273 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1274 sig_ignoring[sig] = 0;
1277 sig_handlers_initted = 1;
1282 Perl_despatch_signals(pTHX)
1286 for (sig = 1; sig < SIG_SIZE; sig++) {
1287 if (PL_psig_pend[sig]) {
1288 PERL_BLOCKSIG_ADD(set, sig);
1289 PL_psig_pend[sig] = 0;
1290 PERL_BLOCKSIG_BLOCK(set);
1291 (*PL_sighandlerp)(sig);
1292 PERL_BLOCKSIG_UNBLOCK(set);
1298 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1302 /* Need to be careful with SvREFCNT_dec(), because that can have side
1303 * effects (due to closures). We must make sure that the new disposition
1304 * is in place before it is called.
1308 #ifdef HAS_SIGPROCMASK
1313 register const char *s = MgPV(mg,len);
1315 if (strEQ(s,"__DIE__"))
1317 else if (strEQ(s,"__WARN__"))
1320 Perl_croak(aTHX_ "No such hook: %s", s);
1328 i = whichsig(s); /* ...no, a brick */
1330 if (ckWARN(WARN_SIGNAL))
1331 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1334 #ifdef HAS_SIGPROCMASK
1335 /* Avoid having the signal arrive at a bad time, if possible. */
1338 sigprocmask(SIG_BLOCK, &set, &save);
1340 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1341 SAVEFREESV(save_sv);
1342 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1345 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1346 if (!sig_handlers_initted) Perl_csighandler_init();
1348 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1349 sig_ignoring[i] = 0;
1351 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1352 sig_defaulting[i] = 0;
1354 SvREFCNT_dec(PL_psig_name[i]);
1355 to_dec = PL_psig_ptr[i];
1356 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1357 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1358 PL_psig_name[i] = newSVpvn(s, len);
1359 SvREADONLY_on(PL_psig_name[i]);
1361 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1363 (void)rsignal(i, PL_csighandlerp);
1364 #ifdef HAS_SIGPROCMASK
1369 *svp = SvREFCNT_inc(sv);
1371 SvREFCNT_dec(to_dec);
1374 s = SvPV_force(sv,len);
1375 if (strEQ(s,"IGNORE")) {
1377 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1378 sig_ignoring[i] = 1;
1379 (void)rsignal(i, PL_csighandlerp);
1381 (void)rsignal(i, SIG_IGN);
1385 else if (strEQ(s,"DEFAULT") || !*s) {
1387 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1389 sig_defaulting[i] = 1;
1390 (void)rsignal(i, PL_csighandlerp);
1393 (void)rsignal(i, SIG_DFL);
1398 * We should warn if HINT_STRICT_REFS, but without
1399 * access to a known hint bit in a known OP, we can't
1400 * tell whether HINT_STRICT_REFS is in force or not.
1402 if (!strchr(s,':') && !strchr(s,'\''))
1403 sv_insert(sv, 0, 0, "main::", 6);
1405 (void)rsignal(i, PL_csighandlerp);
1407 *svp = SvREFCNT_inc(sv);
1409 #ifdef HAS_SIGPROCMASK
1414 SvREFCNT_dec(to_dec);
1417 #endif /* !PERL_MICRO */
1420 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1424 PL_sub_generation++;
1429 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1433 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1434 PL_amagic_generation++;
1440 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1442 HV * const hv = (HV*)LvTARG(sv);
1447 (void) hv_iterinit(hv);
1448 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1451 while (hv_iternext(hv))
1456 sv_setiv(sv, (IV)i);
1461 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1465 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1470 /* caller is responsible for stack switching/cleanup */
1472 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1478 PUSHs(SvTIED_obj(sv, mg));
1481 if (mg->mg_len >= 0)
1482 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1483 else if (mg->mg_len == HEf_SVKEY)
1484 PUSHs((SV*)mg->mg_ptr);
1486 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1487 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1495 return call_method(meth, flags);
1499 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1505 PUSHSTACKi(PERLSI_MAGIC);
1507 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1508 sv_setsv(sv, *PL_stack_sp--);
1518 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1521 mg->mg_flags |= MGf_GSKIP;
1522 magic_methpack(sv,mg,"FETCH");
1527 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1531 PUSHSTACKi(PERLSI_MAGIC);
1532 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1539 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1541 return magic_methpack(sv,mg,"DELETE");
1546 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1553 PUSHSTACKi(PERLSI_MAGIC);
1554 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1555 sv = *PL_stack_sp--;
1556 retval = (U32) SvIV(sv)-1;
1565 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1570 PUSHSTACKi(PERLSI_MAGIC);
1572 XPUSHs(SvTIED_obj(sv, mg));
1574 call_method("CLEAR", G_SCALAR|G_DISCARD);
1582 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1585 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1589 PUSHSTACKi(PERLSI_MAGIC);
1592 PUSHs(SvTIED_obj(sv, mg));
1597 if (call_method(meth, G_SCALAR))
1598 sv_setsv(key, *PL_stack_sp--);
1607 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1609 return magic_methpack(sv,mg,"EXISTS");
1613 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1616 SV *retval = &PL_sv_undef;
1617 SV *tied = SvTIED_obj((SV*)hv, mg);
1618 HV *pkg = SvSTASH((SV*)SvRV(tied));
1620 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1623 /* we are in an iteration so the hash cannot be empty */
1625 /* no xhv_eiter so now use FIRSTKEY */
1626 key = sv_newmortal();
1627 magic_nextpack((SV*)hv, mg, key);
1628 HvEITER(hv) = NULL; /* need to reset iterator */
1629 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1632 /* there is a SCALAR method that we can call */
1634 PUSHSTACKi(PERLSI_MAGIC);
1640 if (call_method("SCALAR", G_SCALAR))
1641 retval = *PL_stack_sp--;
1648 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1658 svp = av_fetch(GvAV(gv),
1659 atoi(MgPV(mg,n_a)), FALSE);
1660 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1661 /* set or clear breakpoint in the relevant control op */
1663 o->op_flags |= OPf_SPECIAL;
1665 o->op_flags &= ~OPf_SPECIAL;
1671 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1673 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1678 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1680 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1685 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1687 SV* lsv = LvTARG(sv);
1689 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1690 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1691 if (mg && mg->mg_len >= 0) {
1694 sv_pos_b2u(lsv, &i);
1695 sv_setiv(sv, i + PL_curcop->cop_arybase);
1704 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1706 SV* lsv = LvTARG(sv);
1713 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1714 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1718 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1719 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1721 else if (!SvOK(sv)) {
1725 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1727 pos = SvIV(sv) - PL_curcop->cop_arybase;
1730 ulen = sv_len_utf8(lsv);
1740 else if (pos > (SSize_t)len)
1745 sv_pos_u2b(lsv, &p, 0);
1750 mg->mg_flags &= ~MGf_MINMATCH;
1756 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1759 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1761 gv_efullname3(sv,((GV*)sv), "*");
1765 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1770 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1777 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1782 GvGP(sv) = gp_ref(GvGP(gv));
1787 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1790 SV * const lsv = LvTARG(sv);
1791 const char * const tmps = SvPV(lsv,len);
1792 I32 offs = LvTARGOFF(sv);
1793 I32 rem = LvTARGLEN(sv);
1797 sv_pos_u2b(lsv, &offs, &rem);
1798 if (offs > (I32)len)
1800 if (rem + offs > (I32)len)
1802 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1809 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1812 char *tmps = SvPV(sv, len);
1813 SV * const lsv = LvTARG(sv);
1814 I32 lvoff = LvTARGOFF(sv);
1815 I32 lvlen = LvTARGLEN(sv);
1819 sv_utf8_upgrade(lsv);
1820 sv_pos_u2b(lsv, &lvoff, &lvlen);
1821 sv_insert(lsv, lvoff, lvlen, tmps, len);
1822 LvTARGLEN(sv) = sv_len_utf8(sv);
1825 else if (lsv && SvUTF8(lsv)) {
1826 sv_pos_u2b(lsv, &lvoff, &lvlen);
1827 LvTARGLEN(sv) = len;
1828 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1829 sv_insert(lsv, lvoff, lvlen, tmps, len);
1833 sv_insert(lsv, lvoff, lvlen, tmps, len);
1834 LvTARGLEN(sv) = len;
1842 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1844 TAINT_IF((mg->mg_len & 1) ||
1845 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1850 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1853 if (PL_localizing) {
1854 if (PL_localizing == 1)
1859 else if (PL_tainted)
1867 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1869 SV * const lsv = LvTARG(sv);
1877 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1882 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1885 do_vecset(sv); /* XXX slurp this routine */
1890 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1893 if (LvTARGLEN(sv)) {
1895 SV *ahv = LvTARG(sv);
1896 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1901 AV* av = (AV*)LvTARG(sv);
1902 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1903 targ = AvARRAY(av)[LvTARGOFF(sv)];
1905 if (targ && targ != &PL_sv_undef) {
1906 /* somebody else defined it for us */
1907 SvREFCNT_dec(LvTARG(sv));
1908 LvTARG(sv) = SvREFCNT_inc(targ);
1910 SvREFCNT_dec(mg->mg_obj);
1911 mg->mg_obj = Nullsv;
1912 mg->mg_flags &= ~MGf_REFCOUNTED;
1917 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1922 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1928 sv_setsv(LvTARG(sv), sv);
1929 SvSETMAGIC(LvTARG(sv));
1935 Perl_vivify_defelem(pTHX_ SV *sv)
1940 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1943 SV *ahv = LvTARG(sv);
1945 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1948 if (!value || value == &PL_sv_undef)
1949 Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1952 AV* av = (AV*)LvTARG(sv);
1953 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1954 LvTARG(sv) = Nullsv; /* array can't be extended */
1956 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1957 if (!svp || (value = *svp) == &PL_sv_undef)
1958 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1961 (void)SvREFCNT_inc(value);
1962 SvREFCNT_dec(LvTARG(sv));
1965 SvREFCNT_dec(mg->mg_obj);
1966 mg->mg_obj = Nullsv;
1967 mg->mg_flags &= ~MGf_REFCOUNTED;
1971 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1973 AV *av = (AV*)mg->mg_obj;
1974 SV **svp = AvARRAY(av);
1975 I32 i = AvFILLp(av);
1980 if (!SvWEAKREF(svp[i]))
1981 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1982 /* XXX Should we check that it hasn't changed? */
1985 SvWEAKREF_off(svp[i]);
1990 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1995 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2003 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2006 sv_unmagic(sv, PERL_MAGIC_bm);
2012 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2015 sv_unmagic(sv, PERL_MAGIC_fm);
2021 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2023 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2025 if (uf && uf->uf_set)
2026 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2031 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2034 sv_unmagic(sv, PERL_MAGIC_qr);
2039 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2041 regexp *re = (regexp *)mg->mg_obj;
2047 #ifdef USE_LOCALE_COLLATE
2049 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2052 * RenE<eacute> Descartes said "I think not."
2053 * and vanished with a faint plop.
2057 Safefree(mg->mg_ptr);
2063 #endif /* USE_LOCALE_COLLATE */
2065 /* Just clear the UTF-8 cache data. */
2067 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2070 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2072 mg->mg_len = -1; /* The mg_len holds the len cache. */
2077 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2079 register const char *s;
2082 switch (*mg->mg_ptr) {
2083 case '\001': /* ^A */
2084 sv_setsv(PL_bodytarget, sv);
2086 case '\003': /* ^C */
2087 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2090 case '\004': /* ^D */
2093 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2094 DEBUG_x(dump_all());
2096 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2099 case '\005': /* ^E */
2100 if (*(mg->mg_ptr+1) == '\0') {
2101 #ifdef MACOS_TRADITIONAL
2102 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2105 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2108 SetLastError( SvIV(sv) );
2111 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2113 /* will anyone ever use this? */
2114 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2120 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2122 SvREFCNT_dec(PL_encoding);
2123 if (SvOK(sv) || SvGMAGICAL(sv)) {
2124 PL_encoding = newSVsv(sv);
2127 PL_encoding = Nullsv;
2131 case '\006': /* ^F */
2132 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2134 case '\010': /* ^H */
2135 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2137 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2139 Safefree(PL_inplace);
2141 PL_inplace = savesvpv(sv);
2143 PL_inplace = Nullch;
2145 case '\017': /* ^O */
2146 if (*(mg->mg_ptr+1) == '\0') {
2148 Safefree(PL_osname);
2152 TAINT_PROPER("assigning to $^O");
2153 PL_osname = savesvpv(sv);
2156 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2157 if (!PL_compiling.cop_io)
2158 PL_compiling.cop_io = newSVsv(sv);
2160 sv_setsv(PL_compiling.cop_io,sv);
2163 case '\020': /* ^P */
2164 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2165 if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
2169 case '\024': /* ^T */
2171 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2173 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2176 case '\027': /* ^W & $^WARNING_BITS */
2177 if (*(mg->mg_ptr+1) == '\0') {
2178 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2179 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2180 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2181 | (i ? G_WARN_ON : G_WARN_OFF) ;
2184 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2185 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2186 if (!SvPOK(sv) && PL_localizing) {
2187 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2188 PL_compiling.cop_warnings = pWARN_NONE;
2193 int accumulate = 0 ;
2194 int any_fatals = 0 ;
2195 const char * const ptr = (char*)SvPV(sv, len) ;
2196 for (i = 0 ; i < len ; ++i) {
2197 accumulate |= ptr[i] ;
2198 any_fatals |= (ptr[i] & 0xAA) ;
2201 PL_compiling.cop_warnings = pWARN_NONE;
2202 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2203 PL_compiling.cop_warnings = pWARN_ALL;
2204 PL_dowarn |= G_WARN_ONCE ;
2207 if (specialWARN(PL_compiling.cop_warnings))
2208 PL_compiling.cop_warnings = newSVsv(sv) ;
2210 sv_setsv(PL_compiling.cop_warnings, sv);
2211 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2212 PL_dowarn |= G_WARN_ONCE ;
2220 if (PL_localizing) {
2221 if (PL_localizing == 1)
2222 SAVESPTR(PL_last_in_gv);
2224 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2225 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2228 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2229 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2230 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2233 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2234 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2235 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2238 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2241 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2242 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2243 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2246 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2250 IO *io = GvIOp(PL_defoutgv);
2253 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2254 IoFLAGS(io) &= ~IOf_FLUSH;
2256 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2257 PerlIO *ofp = IoOFP(io);
2259 (void)PerlIO_flush(ofp);
2260 IoFLAGS(io) |= IOf_FLUSH;
2266 SvREFCNT_dec(PL_rs);
2267 PL_rs = newSVsv(sv);
2271 SvREFCNT_dec(PL_ors_sv);
2272 if (SvOK(sv) || SvGMAGICAL(sv)) {
2273 PL_ors_sv = newSVsv(sv);
2281 SvREFCNT_dec(PL_ofs_sv);
2282 if (SvOK(sv) || SvGMAGICAL(sv)) {
2283 PL_ofs_sv = newSVsv(sv);
2292 PL_ofmt = savesvpv(sv);
2295 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2298 #ifdef COMPLEX_STATUS
2299 if (PL_localizing == 2) {
2300 PL_statusvalue = LvTARGOFF(sv);
2301 PL_statusvalue_vms = LvTARGLEN(sv);
2305 #ifdef VMSISH_STATUS
2307 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2310 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2315 # define PERL_VMS_BANG vaxc$errno
2317 # define PERL_VMS_BANG 0
2319 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2320 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2324 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2325 if (PL_delaymagic) {
2326 PL_delaymagic |= DM_RUID;
2327 break; /* don't do magic till later */
2330 (void)setruid((Uid_t)PL_uid);
2333 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2335 #ifdef HAS_SETRESUID
2336 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2338 if (PL_uid == PL_euid) { /* special case $< = $> */
2340 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2341 if (PL_uid != 0 && PerlProc_getuid() == 0)
2342 (void)PerlProc_setuid(0);
2344 (void)PerlProc_setuid(PL_uid);
2346 PL_uid = PerlProc_getuid();
2347 Perl_croak(aTHX_ "setruid() not implemented");
2352 PL_uid = PerlProc_getuid();
2353 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2356 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2357 if (PL_delaymagic) {
2358 PL_delaymagic |= DM_EUID;
2359 break; /* don't do magic till later */
2362 (void)seteuid((Uid_t)PL_euid);
2365 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2367 #ifdef HAS_SETRESUID
2368 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2370 if (PL_euid == PL_uid) /* special case $> = $< */
2371 PerlProc_setuid(PL_euid);
2373 PL_euid = PerlProc_geteuid();
2374 Perl_croak(aTHX_ "seteuid() not implemented");
2379 PL_euid = PerlProc_geteuid();
2380 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2383 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2384 if (PL_delaymagic) {
2385 PL_delaymagic |= DM_RGID;
2386 break; /* don't do magic till later */
2389 (void)setrgid((Gid_t)PL_gid);
2392 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2394 #ifdef HAS_SETRESGID
2395 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2397 if (PL_gid == PL_egid) /* special case $( = $) */
2398 (void)PerlProc_setgid(PL_gid);
2400 PL_gid = PerlProc_getgid();
2401 Perl_croak(aTHX_ "setrgid() not implemented");
2406 PL_gid = PerlProc_getgid();
2407 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2410 #ifdef HAS_SETGROUPS
2412 const char *p = SvPV(sv, len);
2413 Groups_t gary[NGROUPS];
2418 for (i = 0; i < NGROUPS; ++i) {
2419 while (*p && !isSPACE(*p))
2428 (void)setgroups(i, gary);
2430 #else /* HAS_SETGROUPS */
2431 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2432 #endif /* HAS_SETGROUPS */
2433 if (PL_delaymagic) {
2434 PL_delaymagic |= DM_EGID;
2435 break; /* don't do magic till later */
2438 (void)setegid((Gid_t)PL_egid);
2441 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2443 #ifdef HAS_SETRESGID
2444 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2446 if (PL_egid == PL_gid) /* special case $) = $( */
2447 (void)PerlProc_setgid(PL_egid);
2449 PL_egid = PerlProc_getegid();
2450 Perl_croak(aTHX_ "setegid() not implemented");
2455 PL_egid = PerlProc_getegid();
2456 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2459 PL_chopset = SvPV_force(sv,len);
2461 #ifndef MACOS_TRADITIONAL
2463 LOCK_DOLLARZERO_MUTEX;
2464 #ifdef HAS_SETPROCTITLE
2465 /* The BSDs don't show the argv[] in ps(1) output, they
2466 * show a string from the process struct and provide
2467 * the setproctitle() routine to manipulate that. */
2470 # if __FreeBSD_version > 410001
2471 /* The leading "-" removes the "perl: " prefix,
2472 * but not the "(perl) suffix from the ps(1)
2473 * output, because that's what ps(1) shows if the
2474 * argv[] is modified. */
2475 setproctitle("-%s", s);
2476 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2477 /* This doesn't really work if you assume that
2478 * $0 = 'foobar'; will wipe out 'perl' from the $0
2479 * because in ps(1) output the result will be like
2480 * sprintf("perl: %s (perl)", s)
2481 * I guess this is a security feature:
2482 * one (a user process) cannot get rid of the original name.
2484 setproctitle("%s", s);
2488 #if defined(__hpux) && defined(PSTAT_SETCMD)
2492 un.pst_command = (char *)s;
2493 pstat(PSTAT_SETCMD, un, len, 0, 0);
2496 /* PL_origalen is set in perl_parse(). */
2497 s = SvPV_force(sv,len);
2498 if (len >= (STRLEN)PL_origalen-1) {
2499 /* Longer than original, will be truncated. We assume that
2500 * PL_origalen bytes are available. */
2501 Copy(s, PL_origargv[0], PL_origalen-1, char);
2504 /* Shorter than original, will be padded. */
2505 Copy(s, PL_origargv[0], len, char);
2506 PL_origargv[0][len] = 0;
2507 memset(PL_origargv[0] + len + 1,
2508 /* Is the space counterintuitive? Yes.
2509 * (You were expecting \0?)
2510 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2513 PL_origalen - len - 1);
2515 PL_origargv[0][PL_origalen-1] = 0;
2516 for (i = 1; i < PL_origargc; i++)
2518 UNLOCK_DOLLARZERO_MUTEX;
2526 Perl_whichsig(pTHX_ const char *sig)
2528 register const char **sigv;
2530 for (sigv = PL_sig_name; *sigv; sigv++)
2531 if (strEQ(sig,*sigv))
2532 return PL_sig_num[sigv - PL_sig_name];
2534 if (strEQ(sig,"CHLD"))
2538 if (strEQ(sig,"CLD"))
2544 #if !defined(PERL_IMPLICIT_CONTEXT)
2549 Perl_sighandler(int sig)
2551 #ifdef PERL_GET_SIG_CONTEXT
2552 dTHXa(PERL_GET_SIG_CONTEXT);
2559 SV *sv = Nullsv, *tSv = PL_Sv;
2565 if (PL_savestack_ix + 15 <= PL_savestack_max)
2567 if (PL_markstack_ptr < PL_markstack_max - 2)
2569 if (PL_scopestack_ix < PL_scopestack_max - 3)
2572 if (!PL_psig_ptr[sig]) {
2573 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2578 /* Max number of items pushed there is 3*n or 4. We cannot fix
2579 infinity, so we fix 4 (in fact 5): */
2581 PL_savestack_ix += 5; /* Protect save in progress. */
2582 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2585 PL_markstack_ptr++; /* Protect mark. */
2587 PL_scopestack_ix += 1;
2588 /* sv_2cv is too complicated, try a simpler variant first: */
2589 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2590 || SvTYPE(cv) != SVt_PVCV)
2591 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2593 if (!cv || !CvROOT(cv)) {
2594 if (ckWARN(WARN_SIGNAL))
2595 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2596 PL_sig_name[sig], (gv ? GvENAME(gv)
2603 if(PL_psig_name[sig]) {
2604 sv = SvREFCNT_inc(PL_psig_name[sig]);
2606 #if !defined(PERL_IMPLICIT_CONTEXT)
2610 sv = sv_newmortal();
2611 sv_setpv(sv,PL_sig_name[sig]);
2614 PUSHSTACKi(PERLSI_SIGNAL);
2619 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2622 if (SvTRUE(ERRSV)) {
2624 #ifdef HAS_SIGPROCMASK
2625 /* Handler "died", for example to get out of a restart-able read().
2626 * Before we re-do that on its behalf re-enable the signal which was
2627 * blocked by the system when we entered.
2631 sigaddset(&set,sig);
2632 sigprocmask(SIG_UNBLOCK, &set, NULL);
2634 /* Not clear if this will work */
2635 (void)rsignal(sig, SIG_IGN);
2636 (void)rsignal(sig, PL_csighandlerp);
2638 #endif /* !PERL_MICRO */
2643 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2647 PL_scopestack_ix -= 1;
2650 PL_op = myop; /* Apparently not needed... */
2652 PL_Sv = tSv; /* Restore global temporaries. */
2659 restore_magic(pTHX_ const void *p)
2661 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2662 SV* sv = mgs->mgs_sv;
2667 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2669 #ifdef PERL_COPY_ON_WRITE
2670 /* While magic was saved (and off) sv_setsv may well have seen
2671 this SV as a prime candidate for COW. */
2673 sv_force_normal(sv);
2677 SvFLAGS(sv) |= mgs->mgs_flags;
2681 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2684 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2686 /* If we're still on top of the stack, pop us off. (That condition
2687 * will be satisfied if restore_magic was called explicitly, but *not*
2688 * if it's being called via leave_scope.)
2689 * The reason for doing this is that otherwise, things like sv_2cv()
2690 * may leave alloc gunk on the savestack, and some code
2691 * (e.g. sighandler) doesn't expect that...
2693 if (PL_savestack_ix == mgs->mgs_ss_ix)
2695 I32 popval = SSPOPINT;
2696 assert(popval == SAVEt_DESTRUCTOR_X);
2697 PL_savestack_ix -= 2;
2699 assert(popval == SAVEt_ALLOC);
2701 PL_savestack_ix -= popval;
2707 unwind_handler_stack(pTHX_ const void *p)
2709 const U32 flags = *(const U32*)p;
2712 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2713 /* cxstack_ix-- Not needed, die already unwound it. */
2714 #if !defined(PERL_IMPLICIT_CONTEXT)
2716 SvREFCNT_dec(sig_sv);