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 static void restore_magic(pTHX_ const void *p);
58 static void unwind_handler_stack(pTHX_ const void *p);
61 /* Missing protos on LynxOS */
62 void setruid(uid_t id);
63 void seteuid(uid_t id);
64 void setrgid(uid_t id);
65 void setegid(uid_t id);
69 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
77 /* MGS is typedef'ed to struct magic_state in perl.h */
80 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
83 assert(SvMAGICAL(sv));
84 #ifdef PERL_COPY_ON_WRITE
85 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
90 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
92 mgs = SSPTR(mgs_ix, MGS*);
94 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
95 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
99 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
103 =for apidoc mg_magical
105 Turns on the magical status of an SV. See C<sv_magic>.
111 Perl_mg_magical(pTHX_ SV *sv)
114 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
115 const MGVTBL* const vtbl = mg->mg_virtual;
117 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
121 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
130 Do magic after a value is retrieved from the SV. See C<sv_magic>.
136 Perl_mg_get(pTHX_ SV *sv)
138 const I32 mgs_ix = SSNEW(sizeof(MGS));
139 const bool was_temp = (bool)SvTEMP(sv);
141 MAGIC *newmg, *head, *cur, *mg;
142 /* guard against sv having being freed midway by holding a private
145 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
146 cause the SV's buffer to get stolen (and maybe other stuff).
149 sv_2mortal(SvREFCNT_inc(sv));
154 save_magic(mgs_ix, sv);
156 /* We must call svt_get(sv, mg) for each valid entry in the linked
157 list of magic. svt_get() may delete the current entry, add new
158 magic to the head of the list, or upgrade the SV. AMS 20010810 */
160 newmg = cur = head = mg = SvMAGIC(sv);
162 const MGVTBL * const vtbl = mg->mg_virtual;
164 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
165 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
167 /* guard against magic having been deleted - eg FETCH calling
172 /* Don't restore the flags for this entry if it was deleted. */
173 if (mg->mg_flags & MGf_GSKIP)
174 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
177 mg = mg->mg_moremagic;
180 /* Have we finished with the new entries we saw? Start again
181 where we left off (unless there are more new entries). */
189 /* Were any new entries added? */
190 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
197 restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
199 if (SvREFCNT(sv) == 1) {
200 /* We hold the last reference to this SV, which implies that the
201 SV was deleted as a side effect of the routines we called. */
210 Do magic after a value is assigned to the SV. See C<sv_magic>.
216 Perl_mg_set(pTHX_ SV *sv)
218 const I32 mgs_ix = SSNEW(sizeof(MGS));
222 save_magic(mgs_ix, sv);
224 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
225 const MGVTBL* vtbl = mg->mg_virtual;
226 nextmg = mg->mg_moremagic; /* it may delete itself */
227 if (mg->mg_flags & MGf_GSKIP) {
228 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
229 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
231 if (vtbl && vtbl->svt_set)
232 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
235 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
240 =for apidoc mg_length
242 Report on the SV's length. See C<sv_magic>.
248 Perl_mg_length(pTHX_ SV *sv)
253 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
254 const MGVTBL * const vtbl = mg->mg_virtual;
255 if (vtbl && vtbl->svt_len) {
256 const I32 mgs_ix = SSNEW(sizeof(MGS));
257 save_magic(mgs_ix, sv);
258 /* omit MGf_GSKIP -- not changed here */
259 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
260 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
266 U8 *s = (U8*)SvPV(sv, len);
267 len = Perl_utf8_length(aTHX_ s, s + len);
275 Perl_mg_size(pTHX_ SV *sv)
279 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
280 const MGVTBL* const vtbl = mg->mg_virtual;
281 if (vtbl && vtbl->svt_len) {
282 const I32 mgs_ix = SSNEW(sizeof(MGS));
284 save_magic(mgs_ix, sv);
285 /* omit MGf_GSKIP -- not changed here */
286 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
287 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
294 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
298 Perl_croak(aTHX_ "Size magic not implemented");
307 Clear something magical that the SV represents. See C<sv_magic>.
313 Perl_mg_clear(pTHX_ SV *sv)
315 const I32 mgs_ix = SSNEW(sizeof(MGS));
318 save_magic(mgs_ix, sv);
320 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
321 const MGVTBL* const vtbl = mg->mg_virtual;
322 /* omit GSKIP -- never set here */
324 if (vtbl && vtbl->svt_clear)
325 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
328 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
335 Finds the magic pointer for type matching the SV. See C<sv_magic>.
341 Perl_mg_find(pTHX_ const SV *sv, int type)
345 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
346 if (mg->mg_type == type)
356 Copies the magic from one SV to another. See C<sv_magic>.
362 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
366 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
367 const MGVTBL* const vtbl = mg->mg_virtual;
368 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
369 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
371 else if (isUPPER(mg->mg_type)) {
373 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
374 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
376 toLOWER(mg->mg_type), key, klen);
386 Free any magic storage used by the SV. See C<sv_magic>.
392 Perl_mg_free(pTHX_ SV *sv)
396 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
397 const MGVTBL* const vtbl = mg->mg_virtual;
398 moremagic = mg->mg_moremagic;
399 if (vtbl && vtbl->svt_free)
400 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
401 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
402 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
403 Safefree(mg->mg_ptr);
404 else if (mg->mg_len == HEf_SVKEY)
405 SvREFCNT_dec((SV*)mg->mg_ptr);
407 if (mg->mg_flags & MGf_REFCOUNTED)
408 SvREFCNT_dec(mg->mg_obj);
411 SvMAGIC_set(sv, NULL);
418 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
420 register const REGEXP *rx;
423 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
424 if (mg->mg_obj) /* @+ */
427 return rx->lastparen;
434 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
438 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
439 register const I32 paren = mg->mg_len;
444 if (paren <= (I32)rx->nparens &&
445 (s = rx->startp[paren]) != -1 &&
446 (t = rx->endp[paren]) != -1)
449 if (mg->mg_obj) /* @+ */
454 if (i > 0 && RX_MATCH_UTF8(rx)) {
455 char *b = rx->subbeg;
457 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
467 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
470 Perl_croak(aTHX_ PL_no_modify);
473 /* No __attribute__, so the compiler doesn't know that croak never returns
480 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
484 register const REGEXP *rx;
487 switch (*mg->mg_ptr) {
488 case '1': case '2': case '3': case '4':
489 case '5': case '6': case '7': case '8': case '9': case '&':
490 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
492 paren = atoi(mg->mg_ptr); /* $& is in [0] */
494 if (paren <= (I32)rx->nparens &&
495 (s1 = rx->startp[paren]) != -1 &&
496 (t1 = rx->endp[paren]) != -1)
500 if (i > 0 && RX_MATCH_UTF8(rx)) {
501 char *s = rx->subbeg + s1;
502 char *send = rx->subbeg + t1;
505 if (is_utf8_string((U8*)s, i))
506 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
509 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
513 if (ckWARN(WARN_UNINITIALIZED))
518 if (ckWARN(WARN_UNINITIALIZED))
523 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
524 paren = rx->lastparen;
529 case '\016': /* ^N */
530 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
531 paren = rx->lastcloseparen;
537 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
538 if (rx->startp[0] != -1) {
549 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
550 if (rx->endp[0] != -1) {
551 i = rx->sublen - rx->endp[0];
562 if (!SvPOK(sv) && SvNIOK(sv)) {
572 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
576 register char *s = NULL;
580 switch (*mg->mg_ptr) {
581 case '\001': /* ^A */
582 sv_setsv(sv, PL_bodytarget);
584 case '\003': /* ^C */
585 sv_setiv(sv, (IV)PL_minus_c);
588 case '\004': /* ^D */
589 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
591 case '\005': /* ^E */
592 if (*(mg->mg_ptr+1) == '\0') {
593 #ifdef MACOS_TRADITIONAL
597 sv_setnv(sv,(double)gMacPerl_OSErr);
598 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
603 # include <descrip.h>
604 # include <starlet.h>
606 $DESCRIPTOR(msgdsc,msg);
607 sv_setnv(sv,(NV) vaxc$errno);
608 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
609 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
615 if (!(_emx_env & 0x200)) { /* Under DOS */
616 sv_setnv(sv, (NV)errno);
617 sv_setpv(sv, errno ? Strerror(errno) : "");
619 if (errno != errno_isOS2) {
620 int tmp = _syserrno();
621 if (tmp) /* 2nd call to _syserrno() makes it 0 */
624 sv_setnv(sv, (NV)Perl_rc);
625 sv_setpv(sv, os2error(Perl_rc));
630 DWORD dwErr = GetLastError();
631 sv_setnv(sv, (NV)dwErr);
634 PerlProc_GetOSError(sv, dwErr);
637 sv_setpvn(sv, "", 0);
642 int saveerrno = errno;
643 sv_setnv(sv, (NV)errno);
644 sv_setpv(sv, errno ? Strerror(errno) : "");
651 SvNOK_on(sv); /* what a wonderful hack! */
653 else if (strEQ(mg->mg_ptr+1, "NCODING"))
654 sv_setsv(sv, PL_encoding);
656 case '\006': /* ^F */
657 sv_setiv(sv, (IV)PL_maxsysfd);
659 case '\010': /* ^H */
660 sv_setiv(sv, (IV)PL_hints);
662 case '\011': /* ^I */ /* NOT \t in EBCDIC */
664 sv_setpv(sv, PL_inplace);
666 sv_setsv(sv, &PL_sv_undef);
668 case '\017': /* ^O & ^OPEN */
669 if (*(mg->mg_ptr+1) == '\0') {
670 sv_setpv(sv, PL_osname);
673 else if (strEQ(mg->mg_ptr, "\017PEN")) {
674 if (!PL_compiling.cop_io)
675 sv_setsv(sv, &PL_sv_undef);
677 sv_setsv(sv, PL_compiling.cop_io);
681 case '\020': /* ^P */
682 sv_setiv(sv, (IV)PL_perldb);
684 case '\023': /* ^S */
685 if (*(mg->mg_ptr+1) == '\0') {
686 if (PL_lex_state != LEX_NOTPARSING)
689 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
694 case '\024': /* ^T */
695 if (*(mg->mg_ptr+1) == '\0') {
697 sv_setnv(sv, PL_basetime);
699 sv_setiv(sv, (IV)PL_basetime);
702 else if (strEQ(mg->mg_ptr, "\024AINT"))
703 sv_setiv(sv, PL_tainting
704 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
707 case '\025': /* $^UNICODE, $^UTF8LOCALE */
708 if (strEQ(mg->mg_ptr, "\025NICODE"))
709 sv_setuv(sv, (UV) PL_unicode);
710 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
711 sv_setuv(sv, (UV) PL_utf8locale);
713 case '\027': /* ^W & $^WARNING_BITS */
714 if (*(mg->mg_ptr+1) == '\0')
715 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
716 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
717 if (PL_compiling.cop_warnings == pWARN_NONE ||
718 PL_compiling.cop_warnings == pWARN_STD)
720 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
722 else if (PL_compiling.cop_warnings == pWARN_ALL) {
723 /* Get the bit mask for $warnings::Bits{all}, because
724 * it could have been extended by warnings::register */
726 HV *bits=get_hv("warnings::Bits", FALSE);
727 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
728 sv_setsv(sv, *bits_all);
731 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
735 sv_setsv(sv, PL_compiling.cop_warnings);
740 case '1': case '2': case '3': case '4':
741 case '5': case '6': case '7': case '8': case '9': case '&':
742 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
746 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
747 * XXX Does the new way break anything?
749 paren = atoi(mg->mg_ptr); /* $& is in [0] */
751 if (paren <= (I32)rx->nparens &&
752 (s1 = rx->startp[paren]) != -1 &&
753 (t1 = rx->endp[paren]) != -1)
763 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
768 if (RX_MATCH_TAINTED(rx)) {
769 MAGIC* mg = SvMAGIC(sv);
772 SvMAGIC_set(sv, mg->mg_moremagic);
774 if ((mgt = SvMAGIC(sv))) {
775 mg->mg_moremagic = mgt;
785 sv_setsv(sv,&PL_sv_undef);
788 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
789 paren = rx->lastparen;
793 sv_setsv(sv,&PL_sv_undef);
795 case '\016': /* ^N */
796 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
797 paren = rx->lastcloseparen;
801 sv_setsv(sv,&PL_sv_undef);
804 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
805 if ((s = rx->subbeg) && rx->startp[0] != -1) {
810 sv_setsv(sv,&PL_sv_undef);
813 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
814 if (rx->subbeg && rx->endp[0] != -1) {
815 s = rx->subbeg + rx->endp[0];
816 i = rx->sublen - rx->endp[0];
820 sv_setsv(sv,&PL_sv_undef);
824 if (GvIO(PL_last_in_gv)) {
825 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
831 sv_setiv(sv, (IV)STATUS_CURRENT);
832 #ifdef COMPLEX_STATUS
833 LvTARGOFF(sv) = PL_statusvalue;
834 LvTARGLEN(sv) = PL_statusvalue_vms;
839 if (GvIOp(PL_defoutgv))
840 s = IoTOP_NAME(GvIOp(PL_defoutgv));
844 sv_setpv(sv,GvENAME(PL_defoutgv));
849 if (GvIOp(PL_defoutgv))
850 s = IoFMT_NAME(GvIOp(PL_defoutgv));
852 s = GvENAME(PL_defoutgv);
857 if (GvIOp(PL_defoutgv))
858 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
861 if (GvIOp(PL_defoutgv))
862 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
865 if (GvIOp(PL_defoutgv))
866 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
874 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
877 if (GvIOp(PL_defoutgv))
878 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
884 sv_copypv(sv, PL_ors_sv);
887 sv_setpv(sv,PL_ofmt);
891 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
892 sv_setpv(sv, errno ? Strerror(errno) : "");
895 int saveerrno = errno;
896 sv_setnv(sv, (NV)errno);
898 if (errno == errno_isOS2 || errno == errno_isOS2_set)
899 sv_setpv(sv, os2error(Perl_rc));
902 sv_setpv(sv, errno ? Strerror(errno) : "");
906 SvNOK_on(sv); /* what a wonderful hack! */
909 sv_setiv(sv, (IV)PL_uid);
912 sv_setiv(sv, (IV)PL_euid);
915 sv_setiv(sv, (IV)PL_gid);
917 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
921 sv_setiv(sv, (IV)PL_egid);
923 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
928 Groups_t gary[NGROUPS];
929 I32 j = getgroups(NGROUPS,gary);
931 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
934 (void)SvIOK_on(sv); /* what a wonderful hack! */
936 #ifndef MACOS_TRADITIONAL
945 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
947 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
949 if (uf && uf->uf_val)
950 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
955 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
966 #ifdef DYNAMIC_ENV_FETCH
967 /* We just undefd an environment var. Is a replacement */
968 /* waiting in the wings? */
971 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
972 s = SvPV(*valp, len);
976 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
977 /* And you'll never guess what the dog had */
978 /* in its mouth... */
980 MgTAINTEDDIR_off(mg);
982 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
983 char pathbuf[256], eltbuf[256], *cp, *elt = s;
987 do { /* DCL$PATH may be a search list */
988 while (1) { /* as may dev portion of any element */
989 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
990 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
991 cando_by_name(S_IWUSR,0,elt) ) {
996 if ((cp = strchr(elt, ':')) != Nullch)
998 if (my_trnlnm(elt, eltbuf, j++))
1004 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1007 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1008 char *strend = s + len;
1010 while (s < strend) {
1014 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1015 s, strend, ':', &i);
1017 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1019 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1020 MgTAINTEDDIR_on(mg);
1026 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1032 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1036 my_setenv(MgPV(mg,n_a),Nullch);
1041 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1043 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1044 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1046 if (PL_localizing) {
1049 magic_clear_all_env(sv,mg);
1050 hv_iterinit((HV*)sv);
1051 while ((entry = hv_iternext((HV*)sv))) {
1053 my_setenv(hv_iterkey(entry, &keylen),
1054 SvPV(hv_iterval((HV*)sv, entry), n_a));
1062 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1066 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1067 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1069 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1072 # ifdef USE_ENVIRON_ARRAY
1073 # if defined(USE_ITHREADS)
1074 /* only the parent thread can clobber the process environment */
1075 if (PL_curinterp == aTHX)
1078 # ifndef PERL_USE_SAFE_PUTENV
1079 if (!PL_use_safe_putenv) {
1082 if (environ == PL_origenviron)
1083 environ = (char**)safesysmalloc(sizeof(char*));
1085 for (i = 0; environ[i]; i++)
1086 safesysfree(environ[i]);
1088 # endif /* PERL_USE_SAFE_PUTENV */
1090 environ[0] = Nullch;
1092 # endif /* USE_ENVIRON_ARRAY */
1093 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1094 #endif /* VMS || EPOC */
1095 #endif /* !PERL_MICRO */
1102 #ifdef HAS_SIGPROCMASK
1104 restore_sigmask(pTHX_ SV *save_sv)
1106 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1107 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1111 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1115 /* Are we fetching a signal entry? */
1116 i = whichsig(MgPV(mg,n_a));
1119 sv_setsv(sv,PL_psig_ptr[i]);
1121 Sighandler_t sigstate;
1122 sigstate = rsignal_state(i);
1123 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1124 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1126 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1127 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1129 /* cache state so we don't fetch it again */
1130 if(sigstate == SIG_IGN)
1131 sv_setpv(sv,"IGNORE");
1133 sv_setsv(sv,&PL_sv_undef);
1134 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1141 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1143 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1144 * refactoring might be in order.
1148 register const char *s = MgPV(mg,n_a);
1152 if (strEQ(s,"__DIE__"))
1154 else if (strEQ(s,"__WARN__"))
1157 Perl_croak(aTHX_ "No such hook: %s", s);
1161 SvREFCNT_dec(to_dec);
1166 /* Are we clearing a signal entry? */
1169 #ifdef HAS_SIGPROCMASK
1172 /* Avoid having the signal arrive at a bad time, if possible. */
1175 sigprocmask(SIG_BLOCK, &set, &save);
1177 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1178 SAVEFREESV(save_sv);
1179 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1182 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1183 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1185 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1186 PL_sig_defaulting[i] = 1;
1187 (void)rsignal(i, PL_csighandlerp);
1189 (void)rsignal(i, SIG_DFL);
1191 if(PL_psig_name[i]) {
1192 SvREFCNT_dec(PL_psig_name[i]);
1195 if(PL_psig_ptr[i]) {
1196 SV *to_dec=PL_psig_ptr[i];
1199 SvREFCNT_dec(to_dec);
1209 S_raise_signal(pTHX_ int sig)
1211 /* Set a flag to say this signal is pending */
1212 PL_psig_pend[sig]++;
1213 /* And one to say _a_ signal is pending */
1218 Perl_csighandler(int sig)
1220 #ifdef PERL_GET_SIG_CONTEXT
1221 dTHXa(PERL_GET_SIG_CONTEXT);
1225 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1226 (void) rsignal(sig, PL_csighandlerp);
1227 if (PL_sig_ignoring[sig]) return;
1229 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1230 if (PL_sig_defaulting[sig])
1231 #ifdef KILL_BY_SIGPRC
1232 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1237 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1238 /* Call the perl level handler now--
1239 * with risk we may be in malloc() etc. */
1240 (*PL_sighandlerp)(sig);
1242 S_raise_signal(aTHX_ sig);
1245 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1247 Perl_csighandler_init(void)
1250 if (PL_sig_handlers_initted) return;
1252 for (sig = 1; sig < SIG_SIZE; sig++) {
1253 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1255 PL_sig_defaulting[sig] = 1;
1256 (void) rsignal(sig, PL_csighandlerp);
1258 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1259 PL_sig_ignoring[sig] = 0;
1262 PL_sig_handlers_initted = 1;
1267 Perl_despatch_signals(pTHX)
1271 for (sig = 1; sig < SIG_SIZE; sig++) {
1272 if (PL_psig_pend[sig]) {
1273 PERL_BLOCKSIG_ADD(set, sig);
1274 PL_psig_pend[sig] = 0;
1275 PERL_BLOCKSIG_BLOCK(set);
1276 (*PL_sighandlerp)(sig);
1277 PERL_BLOCKSIG_UNBLOCK(set);
1283 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1288 /* Need to be careful with SvREFCNT_dec(), because that can have side
1289 * effects (due to closures). We must make sure that the new disposition
1290 * is in place before it is called.
1294 #ifdef HAS_SIGPROCMASK
1299 register const char *s = MgPV(mg,len);
1301 if (strEQ(s,"__DIE__"))
1303 else if (strEQ(s,"__WARN__"))
1306 Perl_croak(aTHX_ "No such hook: %s", s);
1314 i = whichsig(s); /* ...no, a brick */
1316 if (ckWARN(WARN_SIGNAL))
1317 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1320 #ifdef HAS_SIGPROCMASK
1321 /* Avoid having the signal arrive at a bad time, if possible. */
1324 sigprocmask(SIG_BLOCK, &set, &save);
1326 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1327 SAVEFREESV(save_sv);
1328 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1331 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1332 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1334 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1335 PL_sig_ignoring[i] = 0;
1337 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1338 PL_sig_defaulting[i] = 0;
1340 SvREFCNT_dec(PL_psig_name[i]);
1341 to_dec = PL_psig_ptr[i];
1342 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1343 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1344 PL_psig_name[i] = newSVpvn(s, len);
1345 SvREADONLY_on(PL_psig_name[i]);
1347 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1349 (void)rsignal(i, PL_csighandlerp);
1350 #ifdef HAS_SIGPROCMASK
1355 *svp = SvREFCNT_inc(sv);
1357 SvREFCNT_dec(to_dec);
1360 s = SvPV_force(sv,len);
1361 if (strEQ(s,"IGNORE")) {
1363 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1364 PL_sig_ignoring[i] = 1;
1365 (void)rsignal(i, PL_csighandlerp);
1367 (void)rsignal(i, SIG_IGN);
1371 else if (strEQ(s,"DEFAULT") || !*s) {
1373 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1375 PL_sig_defaulting[i] = 1;
1376 (void)rsignal(i, PL_csighandlerp);
1379 (void)rsignal(i, SIG_DFL);
1384 * We should warn if HINT_STRICT_REFS, but without
1385 * access to a known hint bit in a known OP, we can't
1386 * tell whether HINT_STRICT_REFS is in force or not.
1388 if (!strchr(s,':') && !strchr(s,'\''))
1389 sv_insert(sv, 0, 0, "main::", 6);
1391 (void)rsignal(i, PL_csighandlerp);
1393 *svp = SvREFCNT_inc(sv);
1395 #ifdef HAS_SIGPROCMASK
1400 SvREFCNT_dec(to_dec);
1403 #endif /* !PERL_MICRO */
1406 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1410 PL_sub_generation++;
1415 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1419 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1420 PL_amagic_generation++;
1426 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1428 HV * const hv = (HV*)LvTARG(sv);
1433 (void) hv_iterinit(hv);
1434 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1437 while (hv_iternext(hv))
1442 sv_setiv(sv, (IV)i);
1447 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1451 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1456 /* caller is responsible for stack switching/cleanup */
1458 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1464 PUSHs(SvTIED_obj(sv, mg));
1467 if (mg->mg_len >= 0)
1468 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1469 else if (mg->mg_len == HEf_SVKEY)
1470 PUSHs((SV*)mg->mg_ptr);
1472 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1473 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1481 return call_method(meth, flags);
1485 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1491 PUSHSTACKi(PERLSI_MAGIC);
1493 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1494 sv_setsv(sv, *PL_stack_sp--);
1504 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1507 mg->mg_flags |= MGf_GSKIP;
1508 magic_methpack(sv,mg,"FETCH");
1513 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1517 PUSHSTACKi(PERLSI_MAGIC);
1518 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1525 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1527 return magic_methpack(sv,mg,"DELETE");
1532 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1539 PUSHSTACKi(PERLSI_MAGIC);
1540 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1541 sv = *PL_stack_sp--;
1542 retval = (U32) SvIV(sv)-1;
1551 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1556 PUSHSTACKi(PERLSI_MAGIC);
1558 XPUSHs(SvTIED_obj(sv, mg));
1560 call_method("CLEAR", G_SCALAR|G_DISCARD);
1568 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1571 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1575 PUSHSTACKi(PERLSI_MAGIC);
1578 PUSHs(SvTIED_obj(sv, mg));
1583 if (call_method(meth, G_SCALAR))
1584 sv_setsv(key, *PL_stack_sp--);
1593 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1595 return magic_methpack(sv,mg,"EXISTS");
1599 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1602 SV *retval = &PL_sv_undef;
1603 SV *tied = SvTIED_obj((SV*)hv, mg);
1604 HV *pkg = SvSTASH((SV*)SvRV(tied));
1606 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1609 /* we are in an iteration so the hash cannot be empty */
1611 /* no xhv_eiter so now use FIRSTKEY */
1612 key = sv_newmortal();
1613 magic_nextpack((SV*)hv, mg, key);
1614 HvEITER(hv) = NULL; /* need to reset iterator */
1615 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1618 /* there is a SCALAR method that we can call */
1620 PUSHSTACKi(PERLSI_MAGIC);
1626 if (call_method("SCALAR", G_SCALAR))
1627 retval = *PL_stack_sp--;
1634 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1644 svp = av_fetch(GvAV(gv),
1645 atoi(MgPV(mg,n_a)), FALSE);
1646 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1647 /* set or clear breakpoint in the relevant control op */
1649 o->op_flags |= OPf_SPECIAL;
1651 o->op_flags &= ~OPf_SPECIAL;
1657 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1659 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1664 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1666 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1671 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1673 SV* lsv = LvTARG(sv);
1675 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1676 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1677 if (mg && mg->mg_len >= 0) {
1680 sv_pos_b2u(lsv, &i);
1681 sv_setiv(sv, i + PL_curcop->cop_arybase);
1690 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1692 SV* lsv = LvTARG(sv);
1699 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1700 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1704 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1705 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1707 else if (!SvOK(sv)) {
1711 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1713 pos = SvIV(sv) - PL_curcop->cop_arybase;
1716 ulen = sv_len_utf8(lsv);
1726 else if (pos > (SSize_t)len)
1731 sv_pos_u2b(lsv, &p, 0);
1736 mg->mg_flags &= ~MGf_MINMATCH;
1742 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1745 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1747 gv_efullname3(sv,((GV*)sv), "*");
1751 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1756 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1763 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1768 GvGP(sv) = gp_ref(GvGP(gv));
1773 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1776 SV * const lsv = LvTARG(sv);
1777 const char * const tmps = SvPV(lsv,len);
1778 I32 offs = LvTARGOFF(sv);
1779 I32 rem = LvTARGLEN(sv);
1783 sv_pos_u2b(lsv, &offs, &rem);
1784 if (offs > (I32)len)
1786 if (rem + offs > (I32)len)
1788 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1795 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1798 char *tmps = SvPV(sv, len);
1799 SV * const lsv = LvTARG(sv);
1800 I32 lvoff = LvTARGOFF(sv);
1801 I32 lvlen = LvTARGLEN(sv);
1805 sv_utf8_upgrade(lsv);
1806 sv_pos_u2b(lsv, &lvoff, &lvlen);
1807 sv_insert(lsv, lvoff, lvlen, tmps, len);
1808 LvTARGLEN(sv) = sv_len_utf8(sv);
1811 else if (lsv && SvUTF8(lsv)) {
1812 sv_pos_u2b(lsv, &lvoff, &lvlen);
1813 LvTARGLEN(sv) = len;
1814 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1815 sv_insert(lsv, lvoff, lvlen, tmps, len);
1819 sv_insert(lsv, lvoff, lvlen, tmps, len);
1820 LvTARGLEN(sv) = len;
1828 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1830 TAINT_IF((mg->mg_len & 1) ||
1831 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1836 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1839 if (PL_localizing) {
1840 if (PL_localizing == 1)
1845 else if (PL_tainted)
1853 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1855 SV * const lsv = LvTARG(sv);
1863 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1868 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1871 do_vecset(sv); /* XXX slurp this routine */
1876 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1879 if (LvTARGLEN(sv)) {
1881 SV *ahv = LvTARG(sv);
1882 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1887 AV* av = (AV*)LvTARG(sv);
1888 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1889 targ = AvARRAY(av)[LvTARGOFF(sv)];
1891 if (targ && targ != &PL_sv_undef) {
1892 /* somebody else defined it for us */
1893 SvREFCNT_dec(LvTARG(sv));
1894 LvTARG(sv) = SvREFCNT_inc(targ);
1896 SvREFCNT_dec(mg->mg_obj);
1897 mg->mg_obj = Nullsv;
1898 mg->mg_flags &= ~MGf_REFCOUNTED;
1903 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1908 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1914 sv_setsv(LvTARG(sv), sv);
1915 SvSETMAGIC(LvTARG(sv));
1921 Perl_vivify_defelem(pTHX_ SV *sv)
1926 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1929 SV *ahv = LvTARG(sv);
1930 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1933 if (!value || value == &PL_sv_undef)
1934 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
1937 AV* av = (AV*)LvTARG(sv);
1938 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1939 LvTARG(sv) = Nullsv; /* array can't be extended */
1941 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1942 if (!svp || (value = *svp) == &PL_sv_undef)
1943 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1946 (void)SvREFCNT_inc(value);
1947 SvREFCNT_dec(LvTARG(sv));
1950 SvREFCNT_dec(mg->mg_obj);
1951 mg->mg_obj = Nullsv;
1952 mg->mg_flags &= ~MGf_REFCOUNTED;
1956 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1958 AV *av = (AV*)mg->mg_obj;
1959 SV **svp = AvARRAY(av);
1960 I32 i = AvFILLp(av);
1965 if (!SvWEAKREF(svp[i]))
1966 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1967 /* XXX Should we check that it hasn't changed? */
1968 SvRV_set(svp[i], 0);
1970 SvWEAKREF_off(svp[i]);
1975 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1980 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1988 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1991 sv_unmagic(sv, PERL_MAGIC_bm);
1997 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2000 sv_unmagic(sv, PERL_MAGIC_fm);
2006 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2008 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2010 if (uf && uf->uf_set)
2011 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2016 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2019 sv_unmagic(sv, PERL_MAGIC_qr);
2024 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2026 regexp *re = (regexp *)mg->mg_obj;
2032 #ifdef USE_LOCALE_COLLATE
2034 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2037 * RenE<eacute> Descartes said "I think not."
2038 * and vanished with a faint plop.
2042 Safefree(mg->mg_ptr);
2048 #endif /* USE_LOCALE_COLLATE */
2050 /* Just clear the UTF-8 cache data. */
2052 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2055 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2057 mg->mg_len = -1; /* The mg_len holds the len cache. */
2062 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2064 register const char *s;
2067 switch (*mg->mg_ptr) {
2068 case '\001': /* ^A */
2069 sv_setsv(PL_bodytarget, sv);
2071 case '\003': /* ^C */
2072 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2075 case '\004': /* ^D */
2078 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2079 DEBUG_x(dump_all());
2081 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2084 case '\005': /* ^E */
2085 if (*(mg->mg_ptr+1) == '\0') {
2086 #ifdef MACOS_TRADITIONAL
2087 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2090 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2093 SetLastError( SvIV(sv) );
2096 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2098 /* will anyone ever use this? */
2099 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2105 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2107 SvREFCNT_dec(PL_encoding);
2108 if (SvOK(sv) || SvGMAGICAL(sv)) {
2109 PL_encoding = newSVsv(sv);
2112 PL_encoding = Nullsv;
2116 case '\006': /* ^F */
2117 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2119 case '\010': /* ^H */
2120 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2122 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2124 Safefree(PL_inplace);
2126 PL_inplace = savesvpv(sv);
2128 PL_inplace = Nullch;
2130 case '\017': /* ^O */
2131 if (*(mg->mg_ptr+1) == '\0') {
2133 Safefree(PL_osname);
2137 TAINT_PROPER("assigning to $^O");
2138 PL_osname = savesvpv(sv);
2141 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2142 if (!PL_compiling.cop_io)
2143 PL_compiling.cop_io = newSVsv(sv);
2145 sv_setsv(PL_compiling.cop_io,sv);
2148 case '\020': /* ^P */
2149 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2150 if (PL_perldb && !PL_DBsingle)
2153 case '\024': /* ^T */
2155 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2157 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2160 case '\027': /* ^W & $^WARNING_BITS */
2161 if (*(mg->mg_ptr+1) == '\0') {
2162 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2163 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2164 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2165 | (i ? G_WARN_ON : G_WARN_OFF) ;
2168 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2169 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2170 if (!SvPOK(sv) && PL_localizing) {
2171 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2172 PL_compiling.cop_warnings = pWARN_NONE;
2177 int accumulate = 0 ;
2178 int any_fatals = 0 ;
2179 const char * const ptr = (char*)SvPV(sv, len) ;
2180 for (i = 0 ; i < len ; ++i) {
2181 accumulate |= ptr[i] ;
2182 any_fatals |= (ptr[i] & 0xAA) ;
2185 PL_compiling.cop_warnings = pWARN_NONE;
2186 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2187 PL_compiling.cop_warnings = pWARN_ALL;
2188 PL_dowarn |= G_WARN_ONCE ;
2191 if (specialWARN(PL_compiling.cop_warnings))
2192 PL_compiling.cop_warnings = newSVsv(sv) ;
2194 sv_setsv(PL_compiling.cop_warnings, sv);
2195 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2196 PL_dowarn |= G_WARN_ONCE ;
2204 if (PL_localizing) {
2205 if (PL_localizing == 1)
2206 SAVESPTR(PL_last_in_gv);
2208 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2209 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2212 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2213 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2214 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2217 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2218 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2219 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2222 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2225 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2226 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2227 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2230 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2234 IO *io = GvIOp(PL_defoutgv);
2237 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2238 IoFLAGS(io) &= ~IOf_FLUSH;
2240 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2241 PerlIO *ofp = IoOFP(io);
2243 (void)PerlIO_flush(ofp);
2244 IoFLAGS(io) |= IOf_FLUSH;
2250 SvREFCNT_dec(PL_rs);
2251 PL_rs = newSVsv(sv);
2255 SvREFCNT_dec(PL_ors_sv);
2256 if (SvOK(sv) || SvGMAGICAL(sv)) {
2257 PL_ors_sv = newSVsv(sv);
2265 SvREFCNT_dec(PL_ofs_sv);
2266 if (SvOK(sv) || SvGMAGICAL(sv)) {
2267 PL_ofs_sv = newSVsv(sv);
2276 PL_ofmt = savesvpv(sv);
2279 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2282 #ifdef COMPLEX_STATUS
2283 if (PL_localizing == 2) {
2284 PL_statusvalue = LvTARGOFF(sv);
2285 PL_statusvalue_vms = LvTARGLEN(sv);
2289 #ifdef VMSISH_STATUS
2291 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2294 STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2299 # define PERL_VMS_BANG vaxc$errno
2301 # define PERL_VMS_BANG 0
2303 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2304 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2308 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2309 if (PL_delaymagic) {
2310 PL_delaymagic |= DM_RUID;
2311 break; /* don't do magic till later */
2314 (void)setruid((Uid_t)PL_uid);
2317 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2319 #ifdef HAS_SETRESUID
2320 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2322 if (PL_uid == PL_euid) { /* special case $< = $> */
2324 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2325 if (PL_uid != 0 && PerlProc_getuid() == 0)
2326 (void)PerlProc_setuid(0);
2328 (void)PerlProc_setuid(PL_uid);
2330 PL_uid = PerlProc_getuid();
2331 Perl_croak(aTHX_ "setruid() not implemented");
2336 PL_uid = PerlProc_getuid();
2337 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2340 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2341 if (PL_delaymagic) {
2342 PL_delaymagic |= DM_EUID;
2343 break; /* don't do magic till later */
2346 (void)seteuid((Uid_t)PL_euid);
2349 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2351 #ifdef HAS_SETRESUID
2352 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2354 if (PL_euid == PL_uid) /* special case $> = $< */
2355 PerlProc_setuid(PL_euid);
2357 PL_euid = PerlProc_geteuid();
2358 Perl_croak(aTHX_ "seteuid() not implemented");
2363 PL_euid = PerlProc_geteuid();
2364 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2367 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2368 if (PL_delaymagic) {
2369 PL_delaymagic |= DM_RGID;
2370 break; /* don't do magic till later */
2373 (void)setrgid((Gid_t)PL_gid);
2376 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2378 #ifdef HAS_SETRESGID
2379 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2381 if (PL_gid == PL_egid) /* special case $( = $) */
2382 (void)PerlProc_setgid(PL_gid);
2384 PL_gid = PerlProc_getgid();
2385 Perl_croak(aTHX_ "setrgid() not implemented");
2390 PL_gid = PerlProc_getgid();
2391 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2394 #ifdef HAS_SETGROUPS
2396 const char *p = SvPV(sv, len);
2397 Groups_t gary[NGROUPS];
2402 for (i = 0; i < NGROUPS; ++i) {
2403 while (*p && !isSPACE(*p))
2412 (void)setgroups(i, gary);
2414 #else /* HAS_SETGROUPS */
2415 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2416 #endif /* HAS_SETGROUPS */
2417 if (PL_delaymagic) {
2418 PL_delaymagic |= DM_EGID;
2419 break; /* don't do magic till later */
2422 (void)setegid((Gid_t)PL_egid);
2425 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2427 #ifdef HAS_SETRESGID
2428 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2430 if (PL_egid == PL_gid) /* special case $) = $( */
2431 (void)PerlProc_setgid(PL_egid);
2433 PL_egid = PerlProc_getegid();
2434 Perl_croak(aTHX_ "setegid() not implemented");
2439 PL_egid = PerlProc_getegid();
2440 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2443 PL_chopset = SvPV_force(sv,len);
2445 #ifndef MACOS_TRADITIONAL
2447 LOCK_DOLLARZERO_MUTEX;
2448 #ifdef HAS_SETPROCTITLE
2449 /* The BSDs don't show the argv[] in ps(1) output, they
2450 * show a string from the process struct and provide
2451 * the setproctitle() routine to manipulate that. */
2454 # if __FreeBSD_version > 410001
2455 /* The leading "-" removes the "perl: " prefix,
2456 * but not the "(perl) suffix from the ps(1)
2457 * output, because that's what ps(1) shows if the
2458 * argv[] is modified. */
2459 setproctitle("-%s", s);
2460 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2461 /* This doesn't really work if you assume that
2462 * $0 = 'foobar'; will wipe out 'perl' from the $0
2463 * because in ps(1) output the result will be like
2464 * sprintf("perl: %s (perl)", s)
2465 * I guess this is a security feature:
2466 * one (a user process) cannot get rid of the original name.
2468 setproctitle("%s", s);
2472 #if defined(__hpux) && defined(PSTAT_SETCMD)
2476 un.pst_command = (char *)s;
2477 pstat(PSTAT_SETCMD, un, len, 0, 0);
2480 /* PL_origalen is set in perl_parse(). */
2481 s = SvPV_force(sv,len);
2482 if (len >= (STRLEN)PL_origalen-1) {
2483 /* Longer than original, will be truncated. We assume that
2484 * PL_origalen bytes are available. */
2485 Copy(s, PL_origargv[0], PL_origalen-1, char);
2488 /* Shorter than original, will be padded. */
2489 Copy(s, PL_origargv[0], len, char);
2490 PL_origargv[0][len] = 0;
2491 memset(PL_origargv[0] + len + 1,
2492 /* Is the space counterintuitive? Yes.
2493 * (You were expecting \0?)
2494 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2497 PL_origalen - len - 1);
2499 PL_origargv[0][PL_origalen-1] = 0;
2500 for (i = 1; i < PL_origargc; i++)
2502 UNLOCK_DOLLARZERO_MUTEX;
2510 Perl_whichsig(pTHX_ const char *sig)
2512 register char* const* sigv;
2514 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2515 if (strEQ(sig,*sigv))
2516 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2518 if (strEQ(sig,"CHLD"))
2522 if (strEQ(sig,"CLD"))
2529 Perl_sighandler(int sig)
2531 #ifdef PERL_GET_SIG_CONTEXT
2532 dTHXa(PERL_GET_SIG_CONTEXT);
2539 SV *sv = Nullsv, *tSv = PL_Sv;
2545 if (PL_savestack_ix + 15 <= PL_savestack_max)
2547 if (PL_markstack_ptr < PL_markstack_max - 2)
2549 if (PL_scopestack_ix < PL_scopestack_max - 3)
2552 if (!PL_psig_ptr[sig]) {
2553 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2558 /* Max number of items pushed there is 3*n or 4. We cannot fix
2559 infinity, so we fix 4 (in fact 5): */
2561 PL_savestack_ix += 5; /* Protect save in progress. */
2562 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2565 PL_markstack_ptr++; /* Protect mark. */
2567 PL_scopestack_ix += 1;
2568 /* sv_2cv is too complicated, try a simpler variant first: */
2569 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2570 || SvTYPE(cv) != SVt_PVCV)
2571 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2573 if (!cv || !CvROOT(cv)) {
2574 if (ckWARN(WARN_SIGNAL))
2575 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2576 PL_sig_name[sig], (gv ? GvENAME(gv)
2583 if(PL_psig_name[sig]) {
2584 sv = SvREFCNT_inc(PL_psig_name[sig]);
2586 #if !defined(PERL_IMPLICIT_CONTEXT)
2590 sv = sv_newmortal();
2591 sv_setpv(sv,PL_sig_name[sig]);
2594 PUSHSTACKi(PERLSI_SIGNAL);
2599 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2602 if (SvTRUE(ERRSV)) {
2604 #ifdef HAS_SIGPROCMASK
2605 /* Handler "died", for example to get out of a restart-able read().
2606 * Before we re-do that on its behalf re-enable the signal which was
2607 * blocked by the system when we entered.
2611 sigaddset(&set,sig);
2612 sigprocmask(SIG_UNBLOCK, &set, NULL);
2614 /* Not clear if this will work */
2615 (void)rsignal(sig, SIG_IGN);
2616 (void)rsignal(sig, PL_csighandlerp);
2618 #endif /* !PERL_MICRO */
2623 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2627 PL_scopestack_ix -= 1;
2630 PL_op = myop; /* Apparently not needed... */
2632 PL_Sv = tSv; /* Restore global temporaries. */
2639 restore_magic(pTHX_ const void *p)
2641 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2642 SV* sv = mgs->mgs_sv;
2647 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2649 #ifdef PERL_COPY_ON_WRITE
2650 /* While magic was saved (and off) sv_setsv may well have seen
2651 this SV as a prime candidate for COW. */
2653 sv_force_normal(sv);
2657 SvFLAGS(sv) |= mgs->mgs_flags;
2661 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2664 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2666 /* If we're still on top of the stack, pop us off. (That condition
2667 * will be satisfied if restore_magic was called explicitly, but *not*
2668 * if it's being called via leave_scope.)
2669 * The reason for doing this is that otherwise, things like sv_2cv()
2670 * may leave alloc gunk on the savestack, and some code
2671 * (e.g. sighandler) doesn't expect that...
2673 if (PL_savestack_ix == mgs->mgs_ss_ix)
2675 I32 popval = SSPOPINT;
2676 assert(popval == SAVEt_DESTRUCTOR_X);
2677 PL_savestack_ix -= 2;
2679 assert(popval == SAVEt_ALLOC);
2681 PL_savestack_ix -= popval;
2687 unwind_handler_stack(pTHX_ const void *p)
2690 const U32 flags = *(const U32*)p;
2693 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2694 /* cxstack_ix-- Not needed, die already unwound it. */
2695 #if !defined(PERL_IMPLICIT_CONTEXT)
2697 SvREFCNT_dec(PL_sig_sv);
2703 * c-indentation-style: bsd
2705 * indent-tabs-mode: t
2708 * ex: set ts=8 sts=4 sw=4 noet: