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);
884 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
885 sv_setpv(sv, errno ? Strerror(errno) : "");
888 int saveerrno = errno;
889 sv_setnv(sv, (NV)errno);
891 if (errno == errno_isOS2 || errno == errno_isOS2_set)
892 sv_setpv(sv, os2error(Perl_rc));
895 sv_setpv(sv, errno ? Strerror(errno) : "");
899 SvNOK_on(sv); /* what a wonderful hack! */
902 sv_setiv(sv, (IV)PL_uid);
905 sv_setiv(sv, (IV)PL_euid);
908 sv_setiv(sv, (IV)PL_gid);
910 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
914 sv_setiv(sv, (IV)PL_egid);
916 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
921 Groups_t gary[NGROUPS];
922 I32 j = getgroups(NGROUPS,gary);
924 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
927 (void)SvIOK_on(sv); /* what a wonderful hack! */
929 #ifndef MACOS_TRADITIONAL
938 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
940 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
942 if (uf && uf->uf_val)
943 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
948 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
955 s = SvPV_const(sv,len);
956 ptr = MgPV_const(mg,klen);
959 #ifdef DYNAMIC_ENV_FETCH
960 /* We just undefd an environment var. Is a replacement */
961 /* waiting in the wings? */
964 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
965 s = SvPV_const(*valp, len);
969 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
970 /* And you'll never guess what the dog had */
971 /* in its mouth... */
973 MgTAINTEDDIR_off(mg);
975 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
976 char pathbuf[256], eltbuf[256], *cp, *elt = s;
980 do { /* DCL$PATH may be a search list */
981 while (1) { /* as may dev portion of any element */
982 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
983 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
984 cando_by_name(S_IWUSR,0,elt) ) {
989 if ((cp = strchr(elt, ':')) != Nullch)
991 if (my_trnlnm(elt, eltbuf, j++))
997 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1000 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1001 const char *strend = s + len;
1003 while (s < strend) {
1007 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1008 s, strend, ':', &i);
1010 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1012 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1013 MgTAINTEDDIR_on(mg);
1019 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1025 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1028 my_setenv(MgPV_nolen_const(mg),Nullch);
1033 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1035 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1036 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1038 if (PL_localizing) {
1040 magic_clear_all_env(sv,mg);
1041 hv_iterinit((HV*)sv);
1042 while ((entry = hv_iternext((HV*)sv))) {
1044 my_setenv(hv_iterkey(entry, &keylen),
1045 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1053 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1057 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1058 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1060 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1063 # ifdef USE_ENVIRON_ARRAY
1064 # if defined(USE_ITHREADS)
1065 /* only the parent thread can clobber the process environment */
1066 if (PL_curinterp == aTHX)
1069 # ifndef PERL_USE_SAFE_PUTENV
1070 if (!PL_use_safe_putenv) {
1073 if (environ == PL_origenviron)
1074 environ = (char**)safesysmalloc(sizeof(char*));
1076 for (i = 0; environ[i]; i++)
1077 safesysfree(environ[i]);
1079 # endif /* PERL_USE_SAFE_PUTENV */
1081 environ[0] = Nullch;
1083 # endif /* USE_ENVIRON_ARRAY */
1084 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1085 #endif /* VMS || EPOC */
1086 #endif /* !PERL_MICRO */
1093 #ifdef HAS_SIGPROCMASK
1095 restore_sigmask(pTHX_ SV *save_sv)
1097 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1098 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1102 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1105 /* Are we fetching a signal entry? */
1106 i = whichsig(MgPV_nolen_const(mg));
1109 sv_setsv(sv,PL_psig_ptr[i]);
1111 Sighandler_t sigstate;
1112 sigstate = rsignal_state(i);
1113 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1114 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1116 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1117 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1119 /* cache state so we don't fetch it again */
1120 if(sigstate == SIG_IGN)
1121 sv_setpv(sv,"IGNORE");
1123 sv_setsv(sv,&PL_sv_undef);
1124 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1131 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1133 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1134 * refactoring might be in order.
1137 register const char *s = MgPV_nolen_const(mg);
1141 if (strEQ(s,"__DIE__"))
1143 else if (strEQ(s,"__WARN__"))
1146 Perl_croak(aTHX_ "No such hook: %s", s);
1150 SvREFCNT_dec(to_dec);
1155 /* Are we clearing a signal entry? */
1158 #ifdef HAS_SIGPROCMASK
1161 /* Avoid having the signal arrive at a bad time, if possible. */
1164 sigprocmask(SIG_BLOCK, &set, &save);
1166 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1167 SAVEFREESV(save_sv);
1168 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1171 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1172 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1174 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1175 PL_sig_defaulting[i] = 1;
1176 (void)rsignal(i, PL_csighandlerp);
1178 (void)rsignal(i, SIG_DFL);
1180 if(PL_psig_name[i]) {
1181 SvREFCNT_dec(PL_psig_name[i]);
1184 if(PL_psig_ptr[i]) {
1185 SV *to_dec=PL_psig_ptr[i];
1188 SvREFCNT_dec(to_dec);
1198 S_raise_signal(pTHX_ int sig)
1200 /* Set a flag to say this signal is pending */
1201 PL_psig_pend[sig]++;
1202 /* And one to say _a_ signal is pending */
1207 Perl_csighandler(int sig)
1209 #ifdef PERL_GET_SIG_CONTEXT
1210 dTHXa(PERL_GET_SIG_CONTEXT);
1214 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1215 (void) rsignal(sig, PL_csighandlerp);
1216 if (PL_sig_ignoring[sig]) return;
1218 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1219 if (PL_sig_defaulting[sig])
1220 #ifdef KILL_BY_SIGPRC
1221 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1226 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1227 /* Call the perl level handler now--
1228 * with risk we may be in malloc() etc. */
1229 (*PL_sighandlerp)(sig);
1231 S_raise_signal(aTHX_ sig);
1234 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1236 Perl_csighandler_init(void)
1239 if (PL_sig_handlers_initted) return;
1241 for (sig = 1; sig < SIG_SIZE; sig++) {
1242 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1244 PL_sig_defaulting[sig] = 1;
1245 (void) rsignal(sig, PL_csighandlerp);
1247 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1248 PL_sig_ignoring[sig] = 0;
1251 PL_sig_handlers_initted = 1;
1256 Perl_despatch_signals(pTHX)
1260 for (sig = 1; sig < SIG_SIZE; sig++) {
1261 if (PL_psig_pend[sig]) {
1262 PERL_BLOCKSIG_ADD(set, sig);
1263 PL_psig_pend[sig] = 0;
1264 PERL_BLOCKSIG_BLOCK(set);
1265 (*PL_sighandlerp)(sig);
1266 PERL_BLOCKSIG_UNBLOCK(set);
1272 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1277 /* Need to be careful with SvREFCNT_dec(), because that can have side
1278 * effects (due to closures). We must make sure that the new disposition
1279 * is in place before it is called.
1283 #ifdef HAS_SIGPROCMASK
1288 register const char *s = MgPV_const(mg,len);
1290 if (strEQ(s,"__DIE__"))
1292 else if (strEQ(s,"__WARN__"))
1295 Perl_croak(aTHX_ "No such hook: %s", s);
1303 i = whichsig(s); /* ...no, a brick */
1305 if (ckWARN(WARN_SIGNAL))
1306 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1309 #ifdef HAS_SIGPROCMASK
1310 /* Avoid having the signal arrive at a bad time, if possible. */
1313 sigprocmask(SIG_BLOCK, &set, &save);
1315 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1316 SAVEFREESV(save_sv);
1317 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1320 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1321 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1323 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1324 PL_sig_ignoring[i] = 0;
1326 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1327 PL_sig_defaulting[i] = 0;
1329 SvREFCNT_dec(PL_psig_name[i]);
1330 to_dec = PL_psig_ptr[i];
1331 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1332 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1333 PL_psig_name[i] = newSVpvn(s, len);
1334 SvREADONLY_on(PL_psig_name[i]);
1336 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1338 (void)rsignal(i, PL_csighandlerp);
1339 #ifdef HAS_SIGPROCMASK
1344 *svp = SvREFCNT_inc(sv);
1346 SvREFCNT_dec(to_dec);
1349 s = SvPV_force(sv,len);
1350 if (strEQ(s,"IGNORE")) {
1352 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1353 PL_sig_ignoring[i] = 1;
1354 (void)rsignal(i, PL_csighandlerp);
1356 (void)rsignal(i, SIG_IGN);
1360 else if (strEQ(s,"DEFAULT") || !*s) {
1362 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1364 PL_sig_defaulting[i] = 1;
1365 (void)rsignal(i, PL_csighandlerp);
1368 (void)rsignal(i, SIG_DFL);
1373 * We should warn if HINT_STRICT_REFS, but without
1374 * access to a known hint bit in a known OP, we can't
1375 * tell whether HINT_STRICT_REFS is in force or not.
1377 if (!strchr(s,':') && !strchr(s,'\''))
1378 sv_insert(sv, 0, 0, "main::", 6);
1380 (void)rsignal(i, PL_csighandlerp);
1382 *svp = SvREFCNT_inc(sv);
1384 #ifdef HAS_SIGPROCMASK
1389 SvREFCNT_dec(to_dec);
1392 #endif /* !PERL_MICRO */
1395 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1399 PL_sub_generation++;
1404 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1408 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1409 PL_amagic_generation++;
1415 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1417 HV * const hv = (HV*)LvTARG(sv);
1422 (void) hv_iterinit(hv);
1423 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1426 while (hv_iternext(hv))
1431 sv_setiv(sv, (IV)i);
1436 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1440 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1445 /* caller is responsible for stack switching/cleanup */
1447 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1453 PUSHs(SvTIED_obj(sv, mg));
1456 if (mg->mg_len >= 0)
1457 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1458 else if (mg->mg_len == HEf_SVKEY)
1459 PUSHs((SV*)mg->mg_ptr);
1461 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1462 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1470 return call_method(meth, flags);
1474 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1480 PUSHSTACKi(PERLSI_MAGIC);
1482 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1483 sv_setsv(sv, *PL_stack_sp--);
1493 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1496 mg->mg_flags |= MGf_GSKIP;
1497 magic_methpack(sv,mg,"FETCH");
1502 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1506 PUSHSTACKi(PERLSI_MAGIC);
1507 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1514 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1516 return magic_methpack(sv,mg,"DELETE");
1521 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1528 PUSHSTACKi(PERLSI_MAGIC);
1529 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1530 sv = *PL_stack_sp--;
1531 retval = (U32) SvIV(sv)-1;
1540 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1545 PUSHSTACKi(PERLSI_MAGIC);
1547 XPUSHs(SvTIED_obj(sv, mg));
1549 call_method("CLEAR", G_SCALAR|G_DISCARD);
1557 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1560 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1564 PUSHSTACKi(PERLSI_MAGIC);
1567 PUSHs(SvTIED_obj(sv, mg));
1572 if (call_method(meth, G_SCALAR))
1573 sv_setsv(key, *PL_stack_sp--);
1582 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1584 return magic_methpack(sv,mg,"EXISTS");
1588 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1591 SV *retval = &PL_sv_undef;
1592 SV *tied = SvTIED_obj((SV*)hv, mg);
1593 HV *pkg = SvSTASH((SV*)SvRV(tied));
1595 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1597 if (HvEITER_get(hv))
1598 /* we are in an iteration so the hash cannot be empty */
1600 /* no xhv_eiter so now use FIRSTKEY */
1601 key = sv_newmortal();
1602 magic_nextpack((SV*)hv, mg, key);
1603 HvEITER_set(hv, NULL); /* need to reset iterator */
1604 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1607 /* there is a SCALAR method that we can call */
1609 PUSHSTACKi(PERLSI_MAGIC);
1615 if (call_method("SCALAR", G_SCALAR))
1616 retval = *PL_stack_sp--;
1623 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1632 svp = av_fetch(GvAV(gv),
1633 atoi(MgPV_nolen_const(mg)), FALSE);
1634 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1635 /* set or clear breakpoint in the relevant control op */
1637 o->op_flags |= OPf_SPECIAL;
1639 o->op_flags &= ~OPf_SPECIAL;
1645 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1647 AV *obj = (AV*)mg->mg_obj;
1649 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1657 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1659 AV *obj = (AV*)mg->mg_obj;
1661 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1663 if (ckWARN(WARN_MISC))
1664 Perl_warner(aTHX_ packWARN(WARN_MISC),
1665 "Attempt to set length of freed array");
1671 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1673 PERL_UNUSED_ARG(sv);
1674 /* during global destruction, mg_obj may already have been freed */
1675 if (PL_in_clean_all)
1678 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1681 /* arylen scalar holds a pointer back to the array, but doesn't own a
1682 reference. Hence the we (the array) are about to go away with it
1683 still pointing at us. Clear its pointer, else it would be pointing
1684 at free memory. See the comment in sv_magic about reference loops,
1685 and why it can't own a reference to us. */
1692 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1694 SV* lsv = LvTARG(sv);
1696 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1697 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1698 if (mg && mg->mg_len >= 0) {
1701 sv_pos_b2u(lsv, &i);
1702 sv_setiv(sv, i + PL_curcop->cop_arybase);
1711 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1713 SV* lsv = LvTARG(sv);
1720 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1721 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1725 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1726 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1728 else if (!SvOK(sv)) {
1732 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1734 pos = SvIV(sv) - PL_curcop->cop_arybase;
1737 ulen = sv_len_utf8(lsv);
1747 else if (pos > (SSize_t)len)
1752 sv_pos_u2b(lsv, &p, 0);
1757 mg->mg_flags &= ~MGf_MINMATCH;
1763 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1766 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1768 gv_efullname3(sv,((GV*)sv), "*");
1772 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1777 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1784 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1789 GvGP(sv) = gp_ref(GvGP(gv));
1794 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1797 SV * const lsv = LvTARG(sv);
1798 const char * const tmps = SvPV_const(lsv,len);
1799 I32 offs = LvTARGOFF(sv);
1800 I32 rem = LvTARGLEN(sv);
1804 sv_pos_u2b(lsv, &offs, &rem);
1805 if (offs > (I32)len)
1807 if (rem + offs > (I32)len)
1809 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1816 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1819 const char *tmps = SvPV_const(sv, len);
1820 SV * const lsv = LvTARG(sv);
1821 I32 lvoff = LvTARGOFF(sv);
1822 I32 lvlen = LvTARGLEN(sv);
1826 sv_utf8_upgrade(lsv);
1827 sv_pos_u2b(lsv, &lvoff, &lvlen);
1828 sv_insert(lsv, lvoff, lvlen, tmps, len);
1829 LvTARGLEN(sv) = sv_len_utf8(sv);
1832 else if (lsv && SvUTF8(lsv)) {
1833 sv_pos_u2b(lsv, &lvoff, &lvlen);
1834 LvTARGLEN(sv) = len;
1835 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1836 sv_insert(lsv, lvoff, lvlen, tmps, len);
1840 sv_insert(lsv, lvoff, lvlen, tmps, len);
1841 LvTARGLEN(sv) = len;
1849 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1851 TAINT_IF((mg->mg_len & 1) ||
1852 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1857 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1860 if (PL_localizing) {
1861 if (PL_localizing == 1)
1866 else if (PL_tainted)
1874 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1876 SV * const lsv = LvTARG(sv);
1884 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1889 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1892 do_vecset(sv); /* XXX slurp this routine */
1897 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1900 if (LvTARGLEN(sv)) {
1902 SV *ahv = LvTARG(sv);
1903 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1908 AV* av = (AV*)LvTARG(sv);
1909 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1910 targ = AvARRAY(av)[LvTARGOFF(sv)];
1912 if (targ && targ != &PL_sv_undef) {
1913 /* somebody else defined it for us */
1914 SvREFCNT_dec(LvTARG(sv));
1915 LvTARG(sv) = SvREFCNT_inc(targ);
1917 SvREFCNT_dec(mg->mg_obj);
1918 mg->mg_obj = Nullsv;
1919 mg->mg_flags &= ~MGf_REFCOUNTED;
1924 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1929 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1935 sv_setsv(LvTARG(sv), sv);
1936 SvSETMAGIC(LvTARG(sv));
1942 Perl_vivify_defelem(pTHX_ SV *sv)
1947 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1950 SV *ahv = LvTARG(sv);
1951 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1954 if (!value || value == &PL_sv_undef)
1955 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
1958 AV* av = (AV*)LvTARG(sv);
1959 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1960 LvTARG(sv) = Nullsv; /* array can't be extended */
1962 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1963 if (!svp || (value = *svp) == &PL_sv_undef)
1964 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1967 (void)SvREFCNT_inc(value);
1968 SvREFCNT_dec(LvTARG(sv));
1971 SvREFCNT_dec(mg->mg_obj);
1972 mg->mg_obj = Nullsv;
1973 mg->mg_flags &= ~MGf_REFCOUNTED;
1977 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1979 AV *av = (AV*)mg->mg_obj;
1980 SV **svp = AvARRAY(av);
1981 I32 i = AvFILLp(av);
1986 if (!SvWEAKREF(svp[i]))
1987 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1988 /* XXX Should we check that it hasn't changed? */
1989 SvRV_set(svp[i], 0);
1991 SvWEAKREF_off(svp[i]);
1996 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2001 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2009 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2012 sv_unmagic(sv, PERL_MAGIC_bm);
2018 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2021 sv_unmagic(sv, PERL_MAGIC_fm);
2027 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2029 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2031 if (uf && uf->uf_set)
2032 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2037 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2040 sv_unmagic(sv, PERL_MAGIC_qr);
2045 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2047 regexp *re = (regexp *)mg->mg_obj;
2053 #ifdef USE_LOCALE_COLLATE
2055 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2058 * RenE<eacute> Descartes said "I think not."
2059 * and vanished with a faint plop.
2063 Safefree(mg->mg_ptr);
2069 #endif /* USE_LOCALE_COLLATE */
2071 /* Just clear the UTF-8 cache data. */
2073 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2076 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2078 mg->mg_len = -1; /* The mg_len holds the len cache. */
2083 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2085 register const char *s;
2088 switch (*mg->mg_ptr) {
2089 case '\001': /* ^A */
2090 sv_setsv(PL_bodytarget, sv);
2092 case '\003': /* ^C */
2093 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2096 case '\004': /* ^D */
2098 s = SvPV_nolen_const(sv);
2099 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2100 DEBUG_x(dump_all());
2102 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2105 case '\005': /* ^E */
2106 if (*(mg->mg_ptr+1) == '\0') {
2107 #ifdef MACOS_TRADITIONAL
2108 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2111 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2114 SetLastError( SvIV(sv) );
2117 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2119 /* will anyone ever use this? */
2120 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2126 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2128 SvREFCNT_dec(PL_encoding);
2129 if (SvOK(sv) || SvGMAGICAL(sv)) {
2130 PL_encoding = newSVsv(sv);
2133 PL_encoding = Nullsv;
2137 case '\006': /* ^F */
2138 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2140 case '\010': /* ^H */
2141 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2143 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2145 Safefree(PL_inplace);
2147 PL_inplace = savesvpv(sv);
2149 PL_inplace = Nullch;
2151 case '\017': /* ^O */
2152 if (*(mg->mg_ptr+1) == '\0') {
2154 Safefree(PL_osname);
2158 TAINT_PROPER("assigning to $^O");
2159 PL_osname = savesvpv(sv);
2162 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2163 if (!PL_compiling.cop_io)
2164 PL_compiling.cop_io = newSVsv(sv);
2166 sv_setsv(PL_compiling.cop_io,sv);
2169 case '\020': /* ^P */
2170 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2171 if (PL_perldb && !PL_DBsingle)
2174 case '\024': /* ^T */
2176 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2178 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2181 case '\027': /* ^W & $^WARNING_BITS */
2182 if (*(mg->mg_ptr+1) == '\0') {
2183 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2184 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2185 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2186 | (i ? G_WARN_ON : G_WARN_OFF) ;
2189 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2190 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2191 if (!SvPOK(sv) && PL_localizing) {
2192 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2193 PL_compiling.cop_warnings = pWARN_NONE;
2198 int accumulate = 0 ;
2199 int any_fatals = 0 ;
2200 const char * const ptr = SvPV_const(sv, len) ;
2201 for (i = 0 ; i < len ; ++i) {
2202 accumulate |= ptr[i] ;
2203 any_fatals |= (ptr[i] & 0xAA) ;
2206 PL_compiling.cop_warnings = pWARN_NONE;
2207 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2208 PL_compiling.cop_warnings = pWARN_ALL;
2209 PL_dowarn |= G_WARN_ONCE ;
2212 if (specialWARN(PL_compiling.cop_warnings))
2213 PL_compiling.cop_warnings = newSVsv(sv) ;
2215 sv_setsv(PL_compiling.cop_warnings, sv);
2216 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2217 PL_dowarn |= G_WARN_ONCE ;
2225 if (PL_localizing) {
2226 if (PL_localizing == 1)
2227 SAVESPTR(PL_last_in_gv);
2229 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2230 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2233 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2234 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2235 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2238 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2239 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2240 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2243 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2246 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2247 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2248 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2251 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2255 IO *io = GvIOp(PL_defoutgv);
2258 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2259 IoFLAGS(io) &= ~IOf_FLUSH;
2261 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2262 PerlIO *ofp = IoOFP(io);
2264 (void)PerlIO_flush(ofp);
2265 IoFLAGS(io) |= IOf_FLUSH;
2271 SvREFCNT_dec(PL_rs);
2272 PL_rs = newSVsv(sv);
2276 SvREFCNT_dec(PL_ors_sv);
2277 if (SvOK(sv) || SvGMAGICAL(sv)) {
2278 PL_ors_sv = newSVsv(sv);
2286 SvREFCNT_dec(PL_ofs_sv);
2287 if (SvOK(sv) || SvGMAGICAL(sv)) {
2288 PL_ofs_sv = newSVsv(sv);
2295 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2298 #ifdef COMPLEX_STATUS
2299 if (PL_localizing == 2) {
2300 PL_statusvalue = LvTARGOFF(sv);
2301 PL_statusvalue_vms = LvTARGLEN(sv);
2305 #ifdef VMSISH_STATUS
2307 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2310 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2315 # define PERL_VMS_BANG vaxc$errno
2317 # define PERL_VMS_BANG 0
2319 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2320 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2324 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2325 if (PL_delaymagic) {
2326 PL_delaymagic |= DM_RUID;
2327 break; /* don't do magic till later */
2330 (void)setruid((Uid_t)PL_uid);
2333 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2335 #ifdef HAS_SETRESUID
2336 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2338 if (PL_uid == PL_euid) { /* special case $< = $> */
2340 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2341 if (PL_uid != 0 && PerlProc_getuid() == 0)
2342 (void)PerlProc_setuid(0);
2344 (void)PerlProc_setuid(PL_uid);
2346 PL_uid = PerlProc_getuid();
2347 Perl_croak(aTHX_ "setruid() not implemented");
2352 PL_uid = PerlProc_getuid();
2353 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2356 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2357 if (PL_delaymagic) {
2358 PL_delaymagic |= DM_EUID;
2359 break; /* don't do magic till later */
2362 (void)seteuid((Uid_t)PL_euid);
2365 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2367 #ifdef HAS_SETRESUID
2368 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2370 if (PL_euid == PL_uid) /* special case $> = $< */
2371 PerlProc_setuid(PL_euid);
2373 PL_euid = PerlProc_geteuid();
2374 Perl_croak(aTHX_ "seteuid() not implemented");
2379 PL_euid = PerlProc_geteuid();
2380 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2383 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2384 if (PL_delaymagic) {
2385 PL_delaymagic |= DM_RGID;
2386 break; /* don't do magic till later */
2389 (void)setrgid((Gid_t)PL_gid);
2392 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2394 #ifdef HAS_SETRESGID
2395 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2397 if (PL_gid == PL_egid) /* special case $( = $) */
2398 (void)PerlProc_setgid(PL_gid);
2400 PL_gid = PerlProc_getgid();
2401 Perl_croak(aTHX_ "setrgid() not implemented");
2406 PL_gid = PerlProc_getgid();
2407 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2410 #ifdef HAS_SETGROUPS
2412 const char *p = SvPV_const(sv, len);
2413 Groups_t gary[NGROUPS];
2418 for (i = 0; i < NGROUPS; ++i) {
2419 while (*p && !isSPACE(*p))
2428 (void)setgroups(i, gary);
2430 #else /* HAS_SETGROUPS */
2431 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2432 #endif /* HAS_SETGROUPS */
2433 if (PL_delaymagic) {
2434 PL_delaymagic |= DM_EGID;
2435 break; /* don't do magic till later */
2438 (void)setegid((Gid_t)PL_egid);
2441 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2443 #ifdef HAS_SETRESGID
2444 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2446 if (PL_egid == PL_gid) /* special case $) = $( */
2447 (void)PerlProc_setgid(PL_egid);
2449 PL_egid = PerlProc_getegid();
2450 Perl_croak(aTHX_ "setegid() not implemented");
2455 PL_egid = PerlProc_getegid();
2456 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2459 PL_chopset = SvPV_force(sv,len);
2461 #ifndef MACOS_TRADITIONAL
2463 LOCK_DOLLARZERO_MUTEX;
2464 #ifdef HAS_SETPROCTITLE
2465 /* The BSDs don't show the argv[] in ps(1) output, they
2466 * show a string from the process struct and provide
2467 * the setproctitle() routine to manipulate that. */
2469 s = SvPV_const(sv, len);
2470 # if __FreeBSD_version > 410001
2471 /* The leading "-" removes the "perl: " prefix,
2472 * but not the "(perl) suffix from the ps(1)
2473 * output, because that's what ps(1) shows if the
2474 * argv[] is modified. */
2475 setproctitle("-%s", s);
2476 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2477 /* This doesn't really work if you assume that
2478 * $0 = 'foobar'; will wipe out 'perl' from the $0
2479 * because in ps(1) output the result will be like
2480 * sprintf("perl: %s (perl)", s)
2481 * I guess this is a security feature:
2482 * one (a user process) cannot get rid of the original name.
2484 setproctitle("%s", s);
2488 #if defined(__hpux) && defined(PSTAT_SETCMD)
2491 s = SvPV_const(sv, len);
2492 un.pst_command = (char *)s;
2493 pstat(PSTAT_SETCMD, un, len, 0, 0);
2496 /* PL_origalen is set in perl_parse(). */
2497 s = SvPV_force(sv,len);
2498 if (len >= (STRLEN)PL_origalen-1) {
2499 /* Longer than original, will be truncated. We assume that
2500 * PL_origalen bytes are available. */
2501 Copy(s, PL_origargv[0], PL_origalen-1, char);
2504 /* Shorter than original, will be padded. */
2505 Copy(s, PL_origargv[0], len, char);
2506 PL_origargv[0][len] = 0;
2507 memset(PL_origargv[0] + len + 1,
2508 /* Is the space counterintuitive? Yes.
2509 * (You were expecting \0?)
2510 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2513 PL_origalen - len - 1);
2515 PL_origargv[0][PL_origalen-1] = 0;
2516 for (i = 1; i < PL_origargc; i++)
2518 UNLOCK_DOLLARZERO_MUTEX;
2526 Perl_whichsig(pTHX_ const char *sig)
2528 register char* const* sigv;
2530 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2531 if (strEQ(sig,*sigv))
2532 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2534 if (strEQ(sig,"CHLD"))
2538 if (strEQ(sig,"CLD"))
2545 Perl_sighandler(int sig)
2547 #ifdef PERL_GET_SIG_CONTEXT
2548 dTHXa(PERL_GET_SIG_CONTEXT);
2555 SV *sv = Nullsv, *tSv = PL_Sv;
2561 if (PL_savestack_ix + 15 <= PL_savestack_max)
2563 if (PL_markstack_ptr < PL_markstack_max - 2)
2565 if (PL_scopestack_ix < PL_scopestack_max - 3)
2568 if (!PL_psig_ptr[sig]) {
2569 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2574 /* Max number of items pushed there is 3*n or 4. We cannot fix
2575 infinity, so we fix 4 (in fact 5): */
2577 PL_savestack_ix += 5; /* Protect save in progress. */
2578 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2581 PL_markstack_ptr++; /* Protect mark. */
2583 PL_scopestack_ix += 1;
2584 /* sv_2cv is too complicated, try a simpler variant first: */
2585 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2586 || SvTYPE(cv) != SVt_PVCV)
2587 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2589 if (!cv || !CvROOT(cv)) {
2590 if (ckWARN(WARN_SIGNAL))
2591 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2592 PL_sig_name[sig], (gv ? GvENAME(gv)
2599 if(PL_psig_name[sig]) {
2600 sv = SvREFCNT_inc(PL_psig_name[sig]);
2602 #if !defined(PERL_IMPLICIT_CONTEXT)
2606 sv = sv_newmortal();
2607 sv_setpv(sv,PL_sig_name[sig]);
2610 PUSHSTACKi(PERLSI_SIGNAL);
2615 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2618 if (SvTRUE(ERRSV)) {
2620 #ifdef HAS_SIGPROCMASK
2621 /* Handler "died", for example to get out of a restart-able read().
2622 * Before we re-do that on its behalf re-enable the signal which was
2623 * blocked by the system when we entered.
2627 sigaddset(&set,sig);
2628 sigprocmask(SIG_UNBLOCK, &set, NULL);
2630 /* Not clear if this will work */
2631 (void)rsignal(sig, SIG_IGN);
2632 (void)rsignal(sig, PL_csighandlerp);
2634 #endif /* !PERL_MICRO */
2639 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2643 PL_scopestack_ix -= 1;
2646 PL_op = myop; /* Apparently not needed... */
2648 PL_Sv = tSv; /* Restore global temporaries. */
2655 restore_magic(pTHX_ const void *p)
2657 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2658 SV* sv = mgs->mgs_sv;
2663 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2665 #ifdef PERL_OLD_COPY_ON_WRITE
2666 /* While magic was saved (and off) sv_setsv may well have seen
2667 this SV as a prime candidate for COW. */
2669 sv_force_normal(sv);
2673 SvFLAGS(sv) |= mgs->mgs_flags;
2677 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2680 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2682 /* If we're still on top of the stack, pop us off. (That condition
2683 * will be satisfied if restore_magic was called explicitly, but *not*
2684 * if it's being called via leave_scope.)
2685 * The reason for doing this is that otherwise, things like sv_2cv()
2686 * may leave alloc gunk on the savestack, and some code
2687 * (e.g. sighandler) doesn't expect that...
2689 if (PL_savestack_ix == mgs->mgs_ss_ix)
2691 I32 popval = SSPOPINT;
2692 assert(popval == SAVEt_DESTRUCTOR_X);
2693 PL_savestack_ix -= 2;
2695 assert(popval == SAVEt_ALLOC);
2697 PL_savestack_ix -= popval;
2703 unwind_handler_stack(pTHX_ const void *p)
2706 const U32 flags = *(const U32*)p;
2709 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2710 /* cxstack_ix-- Not needed, die already unwound it. */
2711 #if !defined(PERL_IMPLICIT_CONTEXT)
2713 SvREFCNT_dec(PL_sig_sv);
2719 * c-indentation-style: bsd
2721 * indent-tabs-mode: t
2724 * ex: set ts=8 sts=4 sw=4 noet: