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);
420 SvMAGIC_set(sv, NULL);
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_set(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? */
1983 SvRV_set(svp[i], 0);
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 (PL_perldb && !PL_DBsingle)
2168 case '\024': /* ^T */
2170 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2172 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2175 case '\027': /* ^W & $^WARNING_BITS */
2176 if (*(mg->mg_ptr+1) == '\0') {
2177 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2178 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2179 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2180 | (i ? G_WARN_ON : G_WARN_OFF) ;
2183 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2184 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2185 if (!SvPOK(sv) && PL_localizing) {
2186 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2187 PL_compiling.cop_warnings = pWARN_NONE;
2192 int accumulate = 0 ;
2193 int any_fatals = 0 ;
2194 const char * const ptr = (char*)SvPV(sv, len) ;
2195 for (i = 0 ; i < len ; ++i) {
2196 accumulate |= ptr[i] ;
2197 any_fatals |= (ptr[i] & 0xAA) ;
2200 PL_compiling.cop_warnings = pWARN_NONE;
2201 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2202 PL_compiling.cop_warnings = pWARN_ALL;
2203 PL_dowarn |= G_WARN_ONCE ;
2206 if (specialWARN(PL_compiling.cop_warnings))
2207 PL_compiling.cop_warnings = newSVsv(sv) ;
2209 sv_setsv(PL_compiling.cop_warnings, sv);
2210 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2211 PL_dowarn |= G_WARN_ONCE ;
2219 if (PL_localizing) {
2220 if (PL_localizing == 1)
2221 SAVESPTR(PL_last_in_gv);
2223 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2224 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2227 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2228 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2229 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2232 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2233 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2234 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2237 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2240 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2241 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2242 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2245 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2249 IO *io = GvIOp(PL_defoutgv);
2252 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2253 IoFLAGS(io) &= ~IOf_FLUSH;
2255 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2256 PerlIO *ofp = IoOFP(io);
2258 (void)PerlIO_flush(ofp);
2259 IoFLAGS(io) |= IOf_FLUSH;
2265 SvREFCNT_dec(PL_rs);
2266 PL_rs = newSVsv(sv);
2270 SvREFCNT_dec(PL_ors_sv);
2271 if (SvOK(sv) || SvGMAGICAL(sv)) {
2272 PL_ors_sv = newSVsv(sv);
2280 SvREFCNT_dec(PL_ofs_sv);
2281 if (SvOK(sv) || SvGMAGICAL(sv)) {
2282 PL_ofs_sv = newSVsv(sv);
2291 PL_ofmt = savesvpv(sv);
2294 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2297 #ifdef COMPLEX_STATUS
2298 if (PL_localizing == 2) {
2299 PL_statusvalue = LvTARGOFF(sv);
2300 PL_statusvalue_vms = LvTARGLEN(sv);
2304 #ifdef VMSISH_STATUS
2306 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2309 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2314 # define PERL_VMS_BANG vaxc$errno
2316 # define PERL_VMS_BANG 0
2318 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2319 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2323 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2324 if (PL_delaymagic) {
2325 PL_delaymagic |= DM_RUID;
2326 break; /* don't do magic till later */
2329 (void)setruid((Uid_t)PL_uid);
2332 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2334 #ifdef HAS_SETRESUID
2335 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2337 if (PL_uid == PL_euid) { /* special case $< = $> */
2339 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2340 if (PL_uid != 0 && PerlProc_getuid() == 0)
2341 (void)PerlProc_setuid(0);
2343 (void)PerlProc_setuid(PL_uid);
2345 PL_uid = PerlProc_getuid();
2346 Perl_croak(aTHX_ "setruid() not implemented");
2351 PL_uid = PerlProc_getuid();
2352 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2355 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2356 if (PL_delaymagic) {
2357 PL_delaymagic |= DM_EUID;
2358 break; /* don't do magic till later */
2361 (void)seteuid((Uid_t)PL_euid);
2364 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2366 #ifdef HAS_SETRESUID
2367 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2369 if (PL_euid == PL_uid) /* special case $> = $< */
2370 PerlProc_setuid(PL_euid);
2372 PL_euid = PerlProc_geteuid();
2373 Perl_croak(aTHX_ "seteuid() not implemented");
2378 PL_euid = PerlProc_geteuid();
2379 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2382 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2383 if (PL_delaymagic) {
2384 PL_delaymagic |= DM_RGID;
2385 break; /* don't do magic till later */
2388 (void)setrgid((Gid_t)PL_gid);
2391 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2393 #ifdef HAS_SETRESGID
2394 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2396 if (PL_gid == PL_egid) /* special case $( = $) */
2397 (void)PerlProc_setgid(PL_gid);
2399 PL_gid = PerlProc_getgid();
2400 Perl_croak(aTHX_ "setrgid() not implemented");
2405 PL_gid = PerlProc_getgid();
2406 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2409 #ifdef HAS_SETGROUPS
2411 const char *p = SvPV(sv, len);
2412 Groups_t gary[NGROUPS];
2417 for (i = 0; i < NGROUPS; ++i) {
2418 while (*p && !isSPACE(*p))
2427 (void)setgroups(i, gary);
2429 #else /* HAS_SETGROUPS */
2430 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2431 #endif /* HAS_SETGROUPS */
2432 if (PL_delaymagic) {
2433 PL_delaymagic |= DM_EGID;
2434 break; /* don't do magic till later */
2437 (void)setegid((Gid_t)PL_egid);
2440 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2442 #ifdef HAS_SETRESGID
2443 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2445 if (PL_egid == PL_gid) /* special case $) = $( */
2446 (void)PerlProc_setgid(PL_egid);
2448 PL_egid = PerlProc_getegid();
2449 Perl_croak(aTHX_ "setegid() not implemented");
2454 PL_egid = PerlProc_getegid();
2455 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2458 PL_chopset = SvPV_force(sv,len);
2460 #ifndef MACOS_TRADITIONAL
2462 LOCK_DOLLARZERO_MUTEX;
2463 #ifdef HAS_SETPROCTITLE
2464 /* The BSDs don't show the argv[] in ps(1) output, they
2465 * show a string from the process struct and provide
2466 * the setproctitle() routine to manipulate that. */
2469 # if __FreeBSD_version > 410001
2470 /* The leading "-" removes the "perl: " prefix,
2471 * but not the "(perl) suffix from the ps(1)
2472 * output, because that's what ps(1) shows if the
2473 * argv[] is modified. */
2474 setproctitle("-%s", s);
2475 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2476 /* This doesn't really work if you assume that
2477 * $0 = 'foobar'; will wipe out 'perl' from the $0
2478 * because in ps(1) output the result will be like
2479 * sprintf("perl: %s (perl)", s)
2480 * I guess this is a security feature:
2481 * one (a user process) cannot get rid of the original name.
2483 setproctitle("%s", s);
2487 #if defined(__hpux) && defined(PSTAT_SETCMD)
2491 un.pst_command = (char *)s;
2492 pstat(PSTAT_SETCMD, un, len, 0, 0);
2495 /* PL_origalen is set in perl_parse(). */
2496 s = SvPV_force(sv,len);
2497 if (len >= (STRLEN)PL_origalen-1) {
2498 /* Longer than original, will be truncated. We assume that
2499 * PL_origalen bytes are available. */
2500 Copy(s, PL_origargv[0], PL_origalen-1, char);
2503 /* Shorter than original, will be padded. */
2504 Copy(s, PL_origargv[0], len, char);
2505 PL_origargv[0][len] = 0;
2506 memset(PL_origargv[0] + len + 1,
2507 /* Is the space counterintuitive? Yes.
2508 * (You were expecting \0?)
2509 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2512 PL_origalen - len - 1);
2514 PL_origargv[0][PL_origalen-1] = 0;
2515 for (i = 1; i < PL_origargc; i++)
2517 UNLOCK_DOLLARZERO_MUTEX;
2525 Perl_whichsig(pTHX_ const char *sig)
2527 register const char **sigv;
2529 for (sigv = PL_sig_name; *sigv; sigv++)
2530 if (strEQ(sig,*sigv))
2531 return PL_sig_num[sigv - PL_sig_name];
2533 if (strEQ(sig,"CHLD"))
2537 if (strEQ(sig,"CLD"))
2543 #if !defined(PERL_IMPLICIT_CONTEXT)
2548 Perl_sighandler(int sig)
2550 #ifdef PERL_GET_SIG_CONTEXT
2551 dTHXa(PERL_GET_SIG_CONTEXT);
2558 SV *sv = Nullsv, *tSv = PL_Sv;
2564 if (PL_savestack_ix + 15 <= PL_savestack_max)
2566 if (PL_markstack_ptr < PL_markstack_max - 2)
2568 if (PL_scopestack_ix < PL_scopestack_max - 3)
2571 if (!PL_psig_ptr[sig]) {
2572 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2577 /* Max number of items pushed there is 3*n or 4. We cannot fix
2578 infinity, so we fix 4 (in fact 5): */
2580 PL_savestack_ix += 5; /* Protect save in progress. */
2581 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2584 PL_markstack_ptr++; /* Protect mark. */
2586 PL_scopestack_ix += 1;
2587 /* sv_2cv is too complicated, try a simpler variant first: */
2588 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2589 || SvTYPE(cv) != SVt_PVCV)
2590 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2592 if (!cv || !CvROOT(cv)) {
2593 if (ckWARN(WARN_SIGNAL))
2594 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2595 PL_sig_name[sig], (gv ? GvENAME(gv)
2602 if(PL_psig_name[sig]) {
2603 sv = SvREFCNT_inc(PL_psig_name[sig]);
2605 #if !defined(PERL_IMPLICIT_CONTEXT)
2609 sv = sv_newmortal();
2610 sv_setpv(sv,PL_sig_name[sig]);
2613 PUSHSTACKi(PERLSI_SIGNAL);
2618 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2621 if (SvTRUE(ERRSV)) {
2623 #ifdef HAS_SIGPROCMASK
2624 /* Handler "died", for example to get out of a restart-able read().
2625 * Before we re-do that on its behalf re-enable the signal which was
2626 * blocked by the system when we entered.
2630 sigaddset(&set,sig);
2631 sigprocmask(SIG_UNBLOCK, &set, NULL);
2633 /* Not clear if this will work */
2634 (void)rsignal(sig, SIG_IGN);
2635 (void)rsignal(sig, PL_csighandlerp);
2637 #endif /* !PERL_MICRO */
2642 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2646 PL_scopestack_ix -= 1;
2649 PL_op = myop; /* Apparently not needed... */
2651 PL_Sv = tSv; /* Restore global temporaries. */
2658 restore_magic(pTHX_ const void *p)
2660 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2661 SV* sv = mgs->mgs_sv;
2666 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2668 #ifdef PERL_COPY_ON_WRITE
2669 /* While magic was saved (and off) sv_setsv may well have seen
2670 this SV as a prime candidate for COW. */
2672 sv_force_normal(sv);
2676 SvFLAGS(sv) |= mgs->mgs_flags;
2680 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2683 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2685 /* If we're still on top of the stack, pop us off. (That condition
2686 * will be satisfied if restore_magic was called explicitly, but *not*
2687 * if it's being called via leave_scope.)
2688 * The reason for doing this is that otherwise, things like sv_2cv()
2689 * may leave alloc gunk on the savestack, and some code
2690 * (e.g. sighandler) doesn't expect that...
2692 if (PL_savestack_ix == mgs->mgs_ss_ix)
2694 I32 popval = SSPOPINT;
2695 assert(popval == SAVEt_DESTRUCTOR_X);
2696 PL_savestack_ix -= 2;
2698 assert(popval == SAVEt_ALLOC);
2700 PL_savestack_ix -= popval;
2706 unwind_handler_stack(pTHX_ const void *p)
2708 const U32 flags = *(const U32*)p;
2711 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2712 /* cxstack_ix-- Not needed, die already unwound it. */
2713 #if !defined(PERL_IMPLICIT_CONTEXT)
2715 SvREFCNT_dec(sig_sv);