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_OLD_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 const U8 *s = (U8*)SvPV_const(sv, len);
267 len = Perl_utf8_length(aTHX_ s, s + len);
270 (void)SvPV_const(sv, 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);
471 NORETURN_FUNCTION_END;
475 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
479 register const REGEXP *rx;
482 switch (*mg->mg_ptr) {
483 case '1': case '2': case '3': case '4':
484 case '5': case '6': case '7': case '8': case '9': case '&':
485 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
487 paren = atoi(mg->mg_ptr); /* $& is in [0] */
489 if (paren <= (I32)rx->nparens &&
490 (s1 = rx->startp[paren]) != -1 &&
491 (t1 = rx->endp[paren]) != -1)
495 if (i > 0 && RX_MATCH_UTF8(rx)) {
496 const char * const s = rx->subbeg + s1;
501 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
505 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
509 if (ckWARN(WARN_UNINITIALIZED))
514 if (ckWARN(WARN_UNINITIALIZED))
519 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
520 paren = rx->lastparen;
525 case '\016': /* ^N */
526 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
527 paren = rx->lastcloseparen;
533 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
534 if (rx->startp[0] != -1) {
545 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
546 if (rx->endp[0] != -1) {
547 i = rx->sublen - rx->endp[0];
558 if (!SvPOK(sv) && SvNIOK(sv)) {
567 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
571 register char *s = NULL;
575 switch (*mg->mg_ptr) {
576 case '\001': /* ^A */
577 sv_setsv(sv, PL_bodytarget);
579 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
580 if (*(mg->mg_ptr+1) == '\0') {
581 sv_setiv(sv, (IV)PL_minus_c);
583 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
584 sv_setiv(sv, (IV)STATUS_NATIVE);
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);
823 if (GvIO(PL_last_in_gv)) {
824 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
829 sv_setiv(sv, (IV)STATUS_CURRENT);
830 #ifdef COMPLEX_STATUS
831 LvTARGOFF(sv) = PL_statusvalue;
832 LvTARGLEN(sv) = PL_statusvalue_vms;
837 if (GvIOp(PL_defoutgv))
838 s = IoTOP_NAME(GvIOp(PL_defoutgv));
842 sv_setpv(sv,GvENAME(PL_defoutgv));
847 if (GvIOp(PL_defoutgv))
848 s = IoFMT_NAME(GvIOp(PL_defoutgv));
850 s = GvENAME(PL_defoutgv);
854 if (GvIOp(PL_defoutgv))
855 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
858 if (GvIOp(PL_defoutgv))
859 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
862 if (GvIOp(PL_defoutgv))
863 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
870 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
873 if (GvIOp(PL_defoutgv))
874 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
880 sv_copypv(sv, PL_ors_sv);
883 sv_setpv(sv,PL_ofmt);
887 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
888 sv_setpv(sv, errno ? Strerror(errno) : "");
891 int saveerrno = errno;
892 sv_setnv(sv, (NV)errno);
894 if (errno == errno_isOS2 || errno == errno_isOS2_set)
895 sv_setpv(sv, os2error(Perl_rc));
898 sv_setpv(sv, errno ? Strerror(errno) : "");
902 SvNOK_on(sv); /* what a wonderful hack! */
905 sv_setiv(sv, (IV)PL_uid);
908 sv_setiv(sv, (IV)PL_euid);
911 sv_setiv(sv, (IV)PL_gid);
913 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
917 sv_setiv(sv, (IV)PL_egid);
919 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
924 Groups_t gary[NGROUPS];
925 I32 j = getgroups(NGROUPS,gary);
927 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
930 (void)SvIOK_on(sv); /* what a wonderful hack! */
932 #ifndef MACOS_TRADITIONAL
941 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
943 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
945 if (uf && uf->uf_val)
946 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
951 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
958 s = SvPV_const(sv,len);
959 ptr = MgPV_const(mg,klen);
962 #ifdef DYNAMIC_ENV_FETCH
963 /* We just undefd an environment var. Is a replacement */
964 /* waiting in the wings? */
967 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
968 s = SvPV_const(*valp, len);
972 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
973 /* And you'll never guess what the dog had */
974 /* in its mouth... */
976 MgTAINTEDDIR_off(mg);
978 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
979 char pathbuf[256], eltbuf[256], *cp, *elt = s;
983 do { /* DCL$PATH may be a search list */
984 while (1) { /* as may dev portion of any element */
985 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
986 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
987 cando_by_name(S_IWUSR,0,elt) ) {
992 if ((cp = strchr(elt, ':')) != Nullch)
994 if (my_trnlnm(elt, eltbuf, j++))
1000 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1003 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1004 const char *strend = s + len;
1006 while (s < strend) {
1010 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1011 s, strend, ':', &i);
1013 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1015 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1016 MgTAINTEDDIR_on(mg);
1022 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1028 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1031 my_setenv(MgPV_nolen_const(mg),Nullch);
1036 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1038 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1039 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1041 if (PL_localizing) {
1043 magic_clear_all_env(sv,mg);
1044 hv_iterinit((HV*)sv);
1045 while ((entry = hv_iternext((HV*)sv))) {
1047 my_setenv(hv_iterkey(entry, &keylen),
1048 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1056 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1060 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1061 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1063 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1066 # ifdef USE_ENVIRON_ARRAY
1067 # if defined(USE_ITHREADS)
1068 /* only the parent thread can clobber the process environment */
1069 if (PL_curinterp == aTHX)
1072 # ifndef PERL_USE_SAFE_PUTENV
1073 if (!PL_use_safe_putenv) {
1076 if (environ == PL_origenviron)
1077 environ = (char**)safesysmalloc(sizeof(char*));
1079 for (i = 0; environ[i]; i++)
1080 safesysfree(environ[i]);
1082 # endif /* PERL_USE_SAFE_PUTENV */
1084 environ[0] = Nullch;
1086 # endif /* USE_ENVIRON_ARRAY */
1087 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1088 #endif /* VMS || EPOC */
1089 #endif /* !PERL_MICRO */
1096 #ifdef HAS_SIGPROCMASK
1098 restore_sigmask(pTHX_ SV *save_sv)
1100 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1101 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1105 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1108 /* Are we fetching a signal entry? */
1109 i = whichsig(MgPV_nolen_const(mg));
1112 sv_setsv(sv,PL_psig_ptr[i]);
1114 Sighandler_t sigstate;
1115 sigstate = rsignal_state(i);
1116 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1117 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1119 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1120 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1122 /* cache state so we don't fetch it again */
1123 if(sigstate == SIG_IGN)
1124 sv_setpv(sv,"IGNORE");
1126 sv_setsv(sv,&PL_sv_undef);
1127 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1134 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1136 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1137 * refactoring might be in order.
1140 register const char *s = MgPV_nolen_const(mg);
1144 if (strEQ(s,"__DIE__"))
1146 else if (strEQ(s,"__WARN__"))
1149 Perl_croak(aTHX_ "No such hook: %s", s);
1153 SvREFCNT_dec(to_dec);
1158 /* Are we clearing a signal entry? */
1161 #ifdef HAS_SIGPROCMASK
1164 /* Avoid having the signal arrive at a bad time, if possible. */
1167 sigprocmask(SIG_BLOCK, &set, &save);
1169 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1170 SAVEFREESV(save_sv);
1171 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1174 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1175 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1177 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1178 PL_sig_defaulting[i] = 1;
1179 (void)rsignal(i, PL_csighandlerp);
1181 (void)rsignal(i, SIG_DFL);
1183 if(PL_psig_name[i]) {
1184 SvREFCNT_dec(PL_psig_name[i]);
1187 if(PL_psig_ptr[i]) {
1188 SV *to_dec=PL_psig_ptr[i];
1191 SvREFCNT_dec(to_dec);
1201 S_raise_signal(pTHX_ int sig)
1203 /* Set a flag to say this signal is pending */
1204 PL_psig_pend[sig]++;
1205 /* And one to say _a_ signal is pending */
1210 Perl_csighandler(int sig)
1212 #ifdef PERL_GET_SIG_CONTEXT
1213 dTHXa(PERL_GET_SIG_CONTEXT);
1217 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1218 (void) rsignal(sig, PL_csighandlerp);
1219 if (PL_sig_ignoring[sig]) return;
1221 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1222 if (PL_sig_defaulting[sig])
1223 #ifdef KILL_BY_SIGPRC
1224 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1229 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1230 /* Call the perl level handler now--
1231 * with risk we may be in malloc() etc. */
1232 (*PL_sighandlerp)(sig);
1234 S_raise_signal(aTHX_ sig);
1237 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1239 Perl_csighandler_init(void)
1242 if (PL_sig_handlers_initted) return;
1244 for (sig = 1; sig < SIG_SIZE; sig++) {
1245 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1247 PL_sig_defaulting[sig] = 1;
1248 (void) rsignal(sig, PL_csighandlerp);
1250 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1251 PL_sig_ignoring[sig] = 0;
1254 PL_sig_handlers_initted = 1;
1259 Perl_despatch_signals(pTHX)
1263 for (sig = 1; sig < SIG_SIZE; sig++) {
1264 if (PL_psig_pend[sig]) {
1265 PERL_BLOCKSIG_ADD(set, sig);
1266 PL_psig_pend[sig] = 0;
1267 PERL_BLOCKSIG_BLOCK(set);
1268 (*PL_sighandlerp)(sig);
1269 PERL_BLOCKSIG_UNBLOCK(set);
1275 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1280 /* Need to be careful with SvREFCNT_dec(), because that can have side
1281 * effects (due to closures). We must make sure that the new disposition
1282 * is in place before it is called.
1286 #ifdef HAS_SIGPROCMASK
1291 register const char *s = MgPV_const(mg,len);
1293 if (strEQ(s,"__DIE__"))
1295 else if (strEQ(s,"__WARN__"))
1298 Perl_croak(aTHX_ "No such hook: %s", s);
1306 i = whichsig(s); /* ...no, a brick */
1308 if (ckWARN(WARN_SIGNAL))
1309 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1312 #ifdef HAS_SIGPROCMASK
1313 /* Avoid having the signal arrive at a bad time, if possible. */
1316 sigprocmask(SIG_BLOCK, &set, &save);
1318 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1319 SAVEFREESV(save_sv);
1320 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1323 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1324 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1326 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1327 PL_sig_ignoring[i] = 0;
1329 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1330 PL_sig_defaulting[i] = 0;
1332 SvREFCNT_dec(PL_psig_name[i]);
1333 to_dec = PL_psig_ptr[i];
1334 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1335 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1336 PL_psig_name[i] = newSVpvn(s, len);
1337 SvREADONLY_on(PL_psig_name[i]);
1339 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1341 (void)rsignal(i, PL_csighandlerp);
1342 #ifdef HAS_SIGPROCMASK
1347 *svp = SvREFCNT_inc(sv);
1349 SvREFCNT_dec(to_dec);
1352 s = SvPV_force(sv,len);
1353 if (strEQ(s,"IGNORE")) {
1355 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1356 PL_sig_ignoring[i] = 1;
1357 (void)rsignal(i, PL_csighandlerp);
1359 (void)rsignal(i, SIG_IGN);
1363 else if (strEQ(s,"DEFAULT") || !*s) {
1365 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1367 PL_sig_defaulting[i] = 1;
1368 (void)rsignal(i, PL_csighandlerp);
1371 (void)rsignal(i, SIG_DFL);
1376 * We should warn if HINT_STRICT_REFS, but without
1377 * access to a known hint bit in a known OP, we can't
1378 * tell whether HINT_STRICT_REFS is in force or not.
1380 if (!strchr(s,':') && !strchr(s,'\''))
1381 sv_insert(sv, 0, 0, "main::", 6);
1383 (void)rsignal(i, PL_csighandlerp);
1385 *svp = SvREFCNT_inc(sv);
1387 #ifdef HAS_SIGPROCMASK
1392 SvREFCNT_dec(to_dec);
1395 #endif /* !PERL_MICRO */
1398 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1402 PL_sub_generation++;
1407 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1411 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1412 PL_amagic_generation++;
1418 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1420 HV * const hv = (HV*)LvTARG(sv);
1425 (void) hv_iterinit(hv);
1426 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1429 while (hv_iternext(hv))
1434 sv_setiv(sv, (IV)i);
1439 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1443 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1448 /* caller is responsible for stack switching/cleanup */
1450 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1456 PUSHs(SvTIED_obj(sv, mg));
1459 if (mg->mg_len >= 0)
1460 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1461 else if (mg->mg_len == HEf_SVKEY)
1462 PUSHs((SV*)mg->mg_ptr);
1464 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1465 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1473 return call_method(meth, flags);
1477 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1483 PUSHSTACKi(PERLSI_MAGIC);
1485 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1486 sv_setsv(sv, *PL_stack_sp--);
1496 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1499 mg->mg_flags |= MGf_GSKIP;
1500 magic_methpack(sv,mg,"FETCH");
1505 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1509 PUSHSTACKi(PERLSI_MAGIC);
1510 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1517 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1519 return magic_methpack(sv,mg,"DELETE");
1524 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1531 PUSHSTACKi(PERLSI_MAGIC);
1532 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1533 sv = *PL_stack_sp--;
1534 retval = (U32) SvIV(sv)-1;
1543 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1548 PUSHSTACKi(PERLSI_MAGIC);
1550 XPUSHs(SvTIED_obj(sv, mg));
1552 call_method("CLEAR", G_SCALAR|G_DISCARD);
1560 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1563 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1567 PUSHSTACKi(PERLSI_MAGIC);
1570 PUSHs(SvTIED_obj(sv, mg));
1575 if (call_method(meth, G_SCALAR))
1576 sv_setsv(key, *PL_stack_sp--);
1585 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1587 return magic_methpack(sv,mg,"EXISTS");
1591 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1594 SV *retval = &PL_sv_undef;
1595 SV *tied = SvTIED_obj((SV*)hv, mg);
1596 HV *pkg = SvSTASH((SV*)SvRV(tied));
1598 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1600 if (HvEITER_get(hv))
1601 /* we are in an iteration so the hash cannot be empty */
1603 /* no xhv_eiter so now use FIRSTKEY */
1604 key = sv_newmortal();
1605 magic_nextpack((SV*)hv, mg, key);
1606 HvEITER_set(hv, NULL); /* need to reset iterator */
1607 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1610 /* there is a SCALAR method that we can call */
1612 PUSHSTACKi(PERLSI_MAGIC);
1618 if (call_method("SCALAR", G_SCALAR))
1619 retval = *PL_stack_sp--;
1626 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1635 svp = av_fetch(GvAV(gv),
1636 atoi(MgPV_nolen_const(mg)), FALSE);
1637 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1638 /* set or clear breakpoint in the relevant control op */
1640 o->op_flags |= OPf_SPECIAL;
1642 o->op_flags &= ~OPf_SPECIAL;
1648 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1650 AV *obj = (AV*)mg->mg_obj;
1652 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1660 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1662 AV *obj = (AV*)mg->mg_obj;
1664 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1666 if (ckWARN(WARN_MISC))
1667 Perl_warner(aTHX_ packWARN(WARN_MISC),
1668 "Attempt to set length of freed array");
1674 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1676 /* during global destruction, mg_obj may already have been freed */
1677 if (PL_in_clean_all)
1680 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1683 /* arylen scalar holds a pointer back to the array, but doesn't own a
1684 reference. Hence the we (the array) are about to go away with it
1685 still pointing at us. Clear its pointer, else it would be pointing
1686 at free memory. See the comment in sv_magic about reference loops,
1687 and why it can't own a reference to us. */
1694 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1696 SV* lsv = LvTARG(sv);
1698 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1699 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1700 if (mg && mg->mg_len >= 0) {
1703 sv_pos_b2u(lsv, &i);
1704 sv_setiv(sv, i + PL_curcop->cop_arybase);
1713 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1715 SV* lsv = LvTARG(sv);
1722 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1723 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1727 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1728 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1730 else if (!SvOK(sv)) {
1734 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1736 pos = SvIV(sv) - PL_curcop->cop_arybase;
1739 ulen = sv_len_utf8(lsv);
1749 else if (pos > (SSize_t)len)
1754 sv_pos_u2b(lsv, &p, 0);
1759 mg->mg_flags &= ~MGf_MINMATCH;
1765 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1768 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1770 gv_efullname3(sv,((GV*)sv), "*");
1774 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1779 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1786 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1791 GvGP(sv) = gp_ref(GvGP(gv));
1796 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1799 SV * const lsv = LvTARG(sv);
1800 const char * const tmps = SvPV_const(lsv,len);
1801 I32 offs = LvTARGOFF(sv);
1802 I32 rem = LvTARGLEN(sv);
1806 sv_pos_u2b(lsv, &offs, &rem);
1807 if (offs > (I32)len)
1809 if (rem + offs > (I32)len)
1811 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1818 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1821 const char *tmps = SvPV_const(sv, len);
1822 SV * const lsv = LvTARG(sv);
1823 I32 lvoff = LvTARGOFF(sv);
1824 I32 lvlen = LvTARGLEN(sv);
1828 sv_utf8_upgrade(lsv);
1829 sv_pos_u2b(lsv, &lvoff, &lvlen);
1830 sv_insert(lsv, lvoff, lvlen, tmps, len);
1831 LvTARGLEN(sv) = sv_len_utf8(sv);
1834 else if (lsv && SvUTF8(lsv)) {
1835 sv_pos_u2b(lsv, &lvoff, &lvlen);
1836 LvTARGLEN(sv) = len;
1837 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1838 sv_insert(lsv, lvoff, lvlen, tmps, len);
1842 sv_insert(lsv, lvoff, lvlen, tmps, len);
1843 LvTARGLEN(sv) = len;
1851 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1853 TAINT_IF((mg->mg_len & 1) ||
1854 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1859 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1862 if (PL_localizing) {
1863 if (PL_localizing == 1)
1868 else if (PL_tainted)
1876 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1878 SV * const lsv = LvTARG(sv);
1886 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1891 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1894 do_vecset(sv); /* XXX slurp this routine */
1899 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1902 if (LvTARGLEN(sv)) {
1904 SV *ahv = LvTARG(sv);
1905 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1910 AV* av = (AV*)LvTARG(sv);
1911 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1912 targ = AvARRAY(av)[LvTARGOFF(sv)];
1914 if (targ && targ != &PL_sv_undef) {
1915 /* somebody else defined it for us */
1916 SvREFCNT_dec(LvTARG(sv));
1917 LvTARG(sv) = SvREFCNT_inc(targ);
1919 SvREFCNT_dec(mg->mg_obj);
1920 mg->mg_obj = Nullsv;
1921 mg->mg_flags &= ~MGf_REFCOUNTED;
1926 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1931 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1937 sv_setsv(LvTARG(sv), sv);
1938 SvSETMAGIC(LvTARG(sv));
1944 Perl_vivify_defelem(pTHX_ SV *sv)
1949 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1952 SV *ahv = LvTARG(sv);
1953 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1956 if (!value || value == &PL_sv_undef)
1957 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
1960 AV* av = (AV*)LvTARG(sv);
1961 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1962 LvTARG(sv) = Nullsv; /* array can't be extended */
1964 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1965 if (!svp || (value = *svp) == &PL_sv_undef)
1966 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1969 (void)SvREFCNT_inc(value);
1970 SvREFCNT_dec(LvTARG(sv));
1973 SvREFCNT_dec(mg->mg_obj);
1974 mg->mg_obj = Nullsv;
1975 mg->mg_flags &= ~MGf_REFCOUNTED;
1979 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1981 AV *av = (AV*)mg->mg_obj;
1982 SV **svp = AvARRAY(av);
1983 I32 i = AvFILLp(av);
1988 if (!SvWEAKREF(svp[i]))
1989 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1990 /* XXX Should we check that it hasn't changed? */
1991 SvRV_set(svp[i], 0);
1993 SvWEAKREF_off(svp[i]);
1998 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2003 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2011 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2014 sv_unmagic(sv, PERL_MAGIC_bm);
2020 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2023 sv_unmagic(sv, PERL_MAGIC_fm);
2029 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2031 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2033 if (uf && uf->uf_set)
2034 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2039 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2042 sv_unmagic(sv, PERL_MAGIC_qr);
2047 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2049 regexp *re = (regexp *)mg->mg_obj;
2055 #ifdef USE_LOCALE_COLLATE
2057 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2060 * RenE<eacute> Descartes said "I think not."
2061 * and vanished with a faint plop.
2065 Safefree(mg->mg_ptr);
2071 #endif /* USE_LOCALE_COLLATE */
2073 /* Just clear the UTF-8 cache data. */
2075 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2078 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2080 mg->mg_len = -1; /* The mg_len holds the len cache. */
2085 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2087 register const char *s;
2090 switch (*mg->mg_ptr) {
2091 case '\001': /* ^A */
2092 sv_setsv(PL_bodytarget, sv);
2094 case '\003': /* ^C */
2095 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2098 case '\004': /* ^D */
2100 s = SvPV_nolen_const(sv);
2101 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2102 DEBUG_x(dump_all());
2104 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2107 case '\005': /* ^E */
2108 if (*(mg->mg_ptr+1) == '\0') {
2109 #ifdef MACOS_TRADITIONAL
2110 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2113 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2116 SetLastError( SvIV(sv) );
2119 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2121 /* will anyone ever use this? */
2122 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2128 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2130 SvREFCNT_dec(PL_encoding);
2131 if (SvOK(sv) || SvGMAGICAL(sv)) {
2132 PL_encoding = newSVsv(sv);
2135 PL_encoding = Nullsv;
2139 case '\006': /* ^F */
2140 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2142 case '\010': /* ^H */
2143 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2145 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2147 Safefree(PL_inplace);
2149 PL_inplace = savesvpv(sv);
2151 PL_inplace = Nullch;
2153 case '\017': /* ^O */
2154 if (*(mg->mg_ptr+1) == '\0') {
2156 Safefree(PL_osname);
2160 TAINT_PROPER("assigning to $^O");
2161 PL_osname = savesvpv(sv);
2164 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2165 if (!PL_compiling.cop_io)
2166 PL_compiling.cop_io = newSVsv(sv);
2168 sv_setsv(PL_compiling.cop_io,sv);
2171 case '\020': /* ^P */
2172 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2173 if (PL_perldb && !PL_DBsingle)
2176 case '\024': /* ^T */
2178 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2180 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2183 case '\027': /* ^W & $^WARNING_BITS */
2184 if (*(mg->mg_ptr+1) == '\0') {
2185 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2186 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2187 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2188 | (i ? G_WARN_ON : G_WARN_OFF) ;
2191 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2192 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2193 if (!SvPOK(sv) && PL_localizing) {
2194 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2195 PL_compiling.cop_warnings = pWARN_NONE;
2200 int accumulate = 0 ;
2201 int any_fatals = 0 ;
2202 const char * const ptr = SvPV_const(sv, len) ;
2203 for (i = 0 ; i < len ; ++i) {
2204 accumulate |= ptr[i] ;
2205 any_fatals |= (ptr[i] & 0xAA) ;
2208 PL_compiling.cop_warnings = pWARN_NONE;
2209 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2210 PL_compiling.cop_warnings = pWARN_ALL;
2211 PL_dowarn |= G_WARN_ONCE ;
2214 if (specialWARN(PL_compiling.cop_warnings))
2215 PL_compiling.cop_warnings = newSVsv(sv) ;
2217 sv_setsv(PL_compiling.cop_warnings, sv);
2218 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2219 PL_dowarn |= G_WARN_ONCE ;
2227 if (PL_localizing) {
2228 if (PL_localizing == 1)
2229 SAVESPTR(PL_last_in_gv);
2231 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2232 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2235 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2236 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2237 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2240 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2241 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2242 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2245 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2248 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2249 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2250 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2253 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2257 IO *io = GvIOp(PL_defoutgv);
2260 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2261 IoFLAGS(io) &= ~IOf_FLUSH;
2263 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2264 PerlIO *ofp = IoOFP(io);
2266 (void)PerlIO_flush(ofp);
2267 IoFLAGS(io) |= IOf_FLUSH;
2273 SvREFCNT_dec(PL_rs);
2274 PL_rs = newSVsv(sv);
2278 SvREFCNT_dec(PL_ors_sv);
2279 if (SvOK(sv) || SvGMAGICAL(sv)) {
2280 PL_ors_sv = newSVsv(sv);
2288 SvREFCNT_dec(PL_ofs_sv);
2289 if (SvOK(sv) || SvGMAGICAL(sv)) {
2290 PL_ofs_sv = newSVsv(sv);
2299 PL_ofmt = savesvpv(sv);
2302 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2305 #ifdef COMPLEX_STATUS
2306 if (PL_localizing == 2) {
2307 PL_statusvalue = LvTARGOFF(sv);
2308 PL_statusvalue_vms = LvTARGLEN(sv);
2312 #ifdef VMSISH_STATUS
2314 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2317 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2322 # define PERL_VMS_BANG vaxc$errno
2324 # define PERL_VMS_BANG 0
2326 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2327 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2331 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2332 if (PL_delaymagic) {
2333 PL_delaymagic |= DM_RUID;
2334 break; /* don't do magic till later */
2337 (void)setruid((Uid_t)PL_uid);
2340 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2342 #ifdef HAS_SETRESUID
2343 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2345 if (PL_uid == PL_euid) { /* special case $< = $> */
2347 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2348 if (PL_uid != 0 && PerlProc_getuid() == 0)
2349 (void)PerlProc_setuid(0);
2351 (void)PerlProc_setuid(PL_uid);
2353 PL_uid = PerlProc_getuid();
2354 Perl_croak(aTHX_ "setruid() not implemented");
2359 PL_uid = PerlProc_getuid();
2360 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2363 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2364 if (PL_delaymagic) {
2365 PL_delaymagic |= DM_EUID;
2366 break; /* don't do magic till later */
2369 (void)seteuid((Uid_t)PL_euid);
2372 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2374 #ifdef HAS_SETRESUID
2375 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2377 if (PL_euid == PL_uid) /* special case $> = $< */
2378 PerlProc_setuid(PL_euid);
2380 PL_euid = PerlProc_geteuid();
2381 Perl_croak(aTHX_ "seteuid() not implemented");
2386 PL_euid = PerlProc_geteuid();
2387 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2390 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2391 if (PL_delaymagic) {
2392 PL_delaymagic |= DM_RGID;
2393 break; /* don't do magic till later */
2396 (void)setrgid((Gid_t)PL_gid);
2399 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2401 #ifdef HAS_SETRESGID
2402 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2404 if (PL_gid == PL_egid) /* special case $( = $) */
2405 (void)PerlProc_setgid(PL_gid);
2407 PL_gid = PerlProc_getgid();
2408 Perl_croak(aTHX_ "setrgid() not implemented");
2413 PL_gid = PerlProc_getgid();
2414 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2417 #ifdef HAS_SETGROUPS
2419 const char *p = SvPV_const(sv, len);
2420 Groups_t gary[NGROUPS];
2425 for (i = 0; i < NGROUPS; ++i) {
2426 while (*p && !isSPACE(*p))
2435 (void)setgroups(i, gary);
2437 #else /* HAS_SETGROUPS */
2438 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2439 #endif /* HAS_SETGROUPS */
2440 if (PL_delaymagic) {
2441 PL_delaymagic |= DM_EGID;
2442 break; /* don't do magic till later */
2445 (void)setegid((Gid_t)PL_egid);
2448 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2450 #ifdef HAS_SETRESGID
2451 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2453 if (PL_egid == PL_gid) /* special case $) = $( */
2454 (void)PerlProc_setgid(PL_egid);
2456 PL_egid = PerlProc_getegid();
2457 Perl_croak(aTHX_ "setegid() not implemented");
2462 PL_egid = PerlProc_getegid();
2463 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2466 PL_chopset = SvPV_force(sv,len);
2468 #ifndef MACOS_TRADITIONAL
2470 LOCK_DOLLARZERO_MUTEX;
2471 #ifdef HAS_SETPROCTITLE
2472 /* The BSDs don't show the argv[] in ps(1) output, they
2473 * show a string from the process struct and provide
2474 * the setproctitle() routine to manipulate that. */
2476 s = SvPV_const(sv, len);
2477 # if __FreeBSD_version > 410001
2478 /* The leading "-" removes the "perl: " prefix,
2479 * but not the "(perl) suffix from the ps(1)
2480 * output, because that's what ps(1) shows if the
2481 * argv[] is modified. */
2482 setproctitle("-%s", s);
2483 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2484 /* This doesn't really work if you assume that
2485 * $0 = 'foobar'; will wipe out 'perl' from the $0
2486 * because in ps(1) output the result will be like
2487 * sprintf("perl: %s (perl)", s)
2488 * I guess this is a security feature:
2489 * one (a user process) cannot get rid of the original name.
2491 setproctitle("%s", s);
2495 #if defined(__hpux) && defined(PSTAT_SETCMD)
2498 s = SvPV_const(sv, len);
2499 un.pst_command = (char *)s;
2500 pstat(PSTAT_SETCMD, un, len, 0, 0);
2503 /* PL_origalen is set in perl_parse(). */
2504 s = SvPV_force(sv,len);
2505 if (len >= (STRLEN)PL_origalen-1) {
2506 /* Longer than original, will be truncated. We assume that
2507 * PL_origalen bytes are available. */
2508 Copy(s, PL_origargv[0], PL_origalen-1, char);
2511 /* Shorter than original, will be padded. */
2512 Copy(s, PL_origargv[0], len, char);
2513 PL_origargv[0][len] = 0;
2514 memset(PL_origargv[0] + len + 1,
2515 /* Is the space counterintuitive? Yes.
2516 * (You were expecting \0?)
2517 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2520 PL_origalen - len - 1);
2522 PL_origargv[0][PL_origalen-1] = 0;
2523 for (i = 1; i < PL_origargc; i++)
2525 UNLOCK_DOLLARZERO_MUTEX;
2533 Perl_whichsig(pTHX_ const char *sig)
2535 register char* const* sigv;
2537 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2538 if (strEQ(sig,*sigv))
2539 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2541 if (strEQ(sig,"CHLD"))
2545 if (strEQ(sig,"CLD"))
2552 Perl_sighandler(int sig)
2554 #ifdef PERL_GET_SIG_CONTEXT
2555 dTHXa(PERL_GET_SIG_CONTEXT);
2562 SV *sv = Nullsv, *tSv = PL_Sv;
2568 if (PL_savestack_ix + 15 <= PL_savestack_max)
2570 if (PL_markstack_ptr < PL_markstack_max - 2)
2572 if (PL_scopestack_ix < PL_scopestack_max - 3)
2575 if (!PL_psig_ptr[sig]) {
2576 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2581 /* Max number of items pushed there is 3*n or 4. We cannot fix
2582 infinity, so we fix 4 (in fact 5): */
2584 PL_savestack_ix += 5; /* Protect save in progress. */
2585 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2588 PL_markstack_ptr++; /* Protect mark. */
2590 PL_scopestack_ix += 1;
2591 /* sv_2cv is too complicated, try a simpler variant first: */
2592 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2593 || SvTYPE(cv) != SVt_PVCV)
2594 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2596 if (!cv || !CvROOT(cv)) {
2597 if (ckWARN(WARN_SIGNAL))
2598 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2599 PL_sig_name[sig], (gv ? GvENAME(gv)
2606 if(PL_psig_name[sig]) {
2607 sv = SvREFCNT_inc(PL_psig_name[sig]);
2609 #if !defined(PERL_IMPLICIT_CONTEXT)
2613 sv = sv_newmortal();
2614 sv_setpv(sv,PL_sig_name[sig]);
2617 PUSHSTACKi(PERLSI_SIGNAL);
2622 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2625 if (SvTRUE(ERRSV)) {
2627 #ifdef HAS_SIGPROCMASK
2628 /* Handler "died", for example to get out of a restart-able read().
2629 * Before we re-do that on its behalf re-enable the signal which was
2630 * blocked by the system when we entered.
2634 sigaddset(&set,sig);
2635 sigprocmask(SIG_UNBLOCK, &set, NULL);
2637 /* Not clear if this will work */
2638 (void)rsignal(sig, SIG_IGN);
2639 (void)rsignal(sig, PL_csighandlerp);
2641 #endif /* !PERL_MICRO */
2646 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2650 PL_scopestack_ix -= 1;
2653 PL_op = myop; /* Apparently not needed... */
2655 PL_Sv = tSv; /* Restore global temporaries. */
2662 restore_magic(pTHX_ const void *p)
2664 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2665 SV* sv = mgs->mgs_sv;
2670 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2672 #ifdef PERL_OLD_COPY_ON_WRITE
2673 /* While magic was saved (and off) sv_setsv may well have seen
2674 this SV as a prime candidate for COW. */
2676 sv_force_normal(sv);
2680 SvFLAGS(sv) |= mgs->mgs_flags;
2684 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2687 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2689 /* If we're still on top of the stack, pop us off. (That condition
2690 * will be satisfied if restore_magic was called explicitly, but *not*
2691 * if it's being called via leave_scope.)
2692 * The reason for doing this is that otherwise, things like sv_2cv()
2693 * may leave alloc gunk on the savestack, and some code
2694 * (e.g. sighandler) doesn't expect that...
2696 if (PL_savestack_ix == mgs->mgs_ss_ix)
2698 I32 popval = SSPOPINT;
2699 assert(popval == SAVEt_DESTRUCTOR_X);
2700 PL_savestack_ix -= 2;
2702 assert(popval == SAVEt_ALLOC);
2704 PL_savestack_ix -= popval;
2710 unwind_handler_stack(pTHX_ const void *p)
2713 const U32 flags = *(const U32*)p;
2716 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2717 /* cxstack_ix-- Not needed, die already unwound it. */
2718 #if !defined(PERL_IMPLICIT_CONTEXT)
2720 SvREFCNT_dec(PL_sig_sv);
2726 * c-indentation-style: bsd
2728 * indent-tabs-mode: t
2731 * ex: set ts=8 sts=4 sw=4 noet: