3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
52 # include <sys/pstat.h>
55 Signal_t Perl_csighandler(int sig);
57 static void restore_magic(pTHX_ const void *p);
58 static void unwind_handler_stack(pTHX_ const void *p);
61 /* Missing protos on LynxOS */
62 void setruid(uid_t id);
63 void seteuid(uid_t id);
64 void setrgid(uid_t id);
65 void setegid(uid_t id);
69 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
77 /* MGS is typedef'ed to struct magic_state in perl.h */
80 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
83 assert(SvMAGICAL(sv));
84 #ifdef PERL_COPY_ON_WRITE
85 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
90 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
92 mgs = SSPTR(mgs_ix, MGS*);
94 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
95 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
99 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
103 =for apidoc mg_magical
105 Turns on the magical status of an SV. See C<sv_magic>.
111 Perl_mg_magical(pTHX_ SV *sv)
114 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
115 const MGVTBL* const vtbl = mg->mg_virtual;
117 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
121 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
130 Do magic after a value is retrieved from the SV. See C<sv_magic>.
136 Perl_mg_get(pTHX_ SV *sv)
138 const I32 mgs_ix = SSNEW(sizeof(MGS));
139 const bool was_temp = (bool)SvTEMP(sv);
141 MAGIC *newmg, *head, *cur, *mg;
142 /* guard against sv having being freed midway by holding a private
145 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
146 cause the SV's buffer to get stolen (and maybe other stuff).
149 sv_2mortal(SvREFCNT_inc(sv));
154 save_magic(mgs_ix, sv);
156 /* We must call svt_get(sv, mg) for each valid entry in the linked
157 list of magic. svt_get() may delete the current entry, add new
158 magic to the head of the list, or upgrade the SV. AMS 20010810 */
160 newmg = cur = head = mg = SvMAGIC(sv);
162 const MGVTBL * const vtbl = mg->mg_virtual;
164 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
165 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
167 /* guard against magic having been deleted - eg FETCH calling
172 /* Don't restore the flags for this entry if it was deleted. */
173 if (mg->mg_flags & MGf_GSKIP)
174 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
177 mg = mg->mg_moremagic;
180 /* Have we finished with the new entries we saw? Start again
181 where we left off (unless there are more new entries). */
189 /* Were any new entries added? */
190 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
197 restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
199 if (SvREFCNT(sv) == 1) {
200 /* We hold the last reference to this SV, which implies that the
201 SV was deleted as a side effect of the routines we called. */
210 Do magic after a value is assigned to the SV. See C<sv_magic>.
216 Perl_mg_set(pTHX_ SV *sv)
218 const I32 mgs_ix = SSNEW(sizeof(MGS));
222 save_magic(mgs_ix, sv);
224 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
225 const MGVTBL* vtbl = mg->mg_virtual;
226 nextmg = mg->mg_moremagic; /* it may delete itself */
227 if (mg->mg_flags & MGf_GSKIP) {
228 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
229 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
231 if (vtbl && vtbl->svt_set)
232 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
235 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
240 =for apidoc mg_length
242 Report on the SV's length. See C<sv_magic>.
248 Perl_mg_length(pTHX_ SV *sv)
253 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
254 const MGVTBL * const vtbl = mg->mg_virtual;
255 if (vtbl && vtbl->svt_len) {
256 const I32 mgs_ix = SSNEW(sizeof(MGS));
257 save_magic(mgs_ix, sv);
258 /* omit MGf_GSKIP -- not changed here */
259 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
260 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
266 U8 *s = (U8*)SvPV(sv, len);
267 len = Perl_utf8_length(aTHX_ s, s + len);
275 Perl_mg_size(pTHX_ SV *sv)
279 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
280 const MGVTBL* const vtbl = mg->mg_virtual;
281 if (vtbl && vtbl->svt_len) {
282 const I32 mgs_ix = SSNEW(sizeof(MGS));
284 save_magic(mgs_ix, sv);
285 /* omit MGf_GSKIP -- not changed here */
286 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
287 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
294 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
298 Perl_croak(aTHX_ "Size magic not implemented");
307 Clear something magical that the SV represents. See C<sv_magic>.
313 Perl_mg_clear(pTHX_ SV *sv)
315 const I32 mgs_ix = SSNEW(sizeof(MGS));
318 save_magic(mgs_ix, sv);
320 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
321 const MGVTBL* const vtbl = mg->mg_virtual;
322 /* omit GSKIP -- never set here */
324 if (vtbl && vtbl->svt_clear)
325 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
328 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
335 Finds the magic pointer for type matching the SV. See C<sv_magic>.
341 Perl_mg_find(pTHX_ const SV *sv, int type)
345 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
346 if (mg->mg_type == type)
356 Copies the magic from one SV to another. See C<sv_magic>.
362 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
366 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
367 const MGVTBL* const vtbl = mg->mg_virtual;
368 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
369 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
371 else if (isUPPER(mg->mg_type)) {
373 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
374 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
376 toLOWER(mg->mg_type), key, klen);
386 Free any magic storage used by the SV. See C<sv_magic>.
392 Perl_mg_free(pTHX_ SV *sv)
396 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
397 const MGVTBL* const vtbl = mg->mg_virtual;
398 moremagic = mg->mg_moremagic;
399 if (vtbl && vtbl->svt_free)
400 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
401 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
402 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
403 Safefree(mg->mg_ptr);
404 else if (mg->mg_len == HEf_SVKEY)
405 SvREFCNT_dec((SV*)mg->mg_ptr);
407 if (mg->mg_flags & MGf_REFCOUNTED)
408 SvREFCNT_dec(mg->mg_obj);
411 SvMAGIC_set(sv, NULL);
418 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
420 register const REGEXP *rx;
423 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
424 if (mg->mg_obj) /* @+ */
427 return rx->lastparen;
434 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
438 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
439 register const I32 paren = mg->mg_len;
444 if (paren <= (I32)rx->nparens &&
445 (s = rx->startp[paren]) != -1 &&
446 (t = rx->endp[paren]) != -1)
449 if (mg->mg_obj) /* @+ */
454 if (i > 0 && RX_MATCH_UTF8(rx)) {
455 char *b = rx->subbeg;
457 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
467 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
470 Perl_croak(aTHX_ PL_no_modify);
472 #ifndef HASATTRIBUTE_NORETURN
473 /* No __attribute__((noreturn)), so the compiler doesn't know that
474 * croak never returns. */
480 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
484 register const REGEXP *rx;
487 switch (*mg->mg_ptr) {
488 case '1': case '2': case '3': case '4':
489 case '5': case '6': case '7': case '8': case '9': case '&':
490 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
492 paren = atoi(mg->mg_ptr); /* $& is in [0] */
494 if (paren <= (I32)rx->nparens &&
495 (s1 = rx->startp[paren]) != -1 &&
496 (t1 = rx->endp[paren]) != -1)
500 if (i > 0 && RX_MATCH_UTF8(rx)) {
501 char *s = rx->subbeg + s1;
502 char *send = rx->subbeg + t1;
505 if (is_utf8_string((U8*)s, i))
506 i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
509 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
513 if (ckWARN(WARN_UNINITIALIZED))
518 if (ckWARN(WARN_UNINITIALIZED))
523 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
524 paren = rx->lastparen;
529 case '\016': /* ^N */
530 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
531 paren = rx->lastcloseparen;
537 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
538 if (rx->startp[0] != -1) {
549 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
550 if (rx->endp[0] != -1) {
551 i = rx->sublen - rx->endp[0];
562 if (!SvPOK(sv) && SvNIOK(sv)) {
572 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
576 register char *s = NULL;
580 switch (*mg->mg_ptr) {
581 case '\001': /* ^A */
582 sv_setsv(sv, PL_bodytarget);
584 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
585 if (*(mg->mg_ptr+1) == '\0') {
586 sv_setiv(sv, (IV)PL_minus_c);
588 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
589 sv_setiv(sv, (IV)STATUS_NATIVE);
593 case '\004': /* ^D */
594 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
596 case '\005': /* ^E */
597 if (*(mg->mg_ptr+1) == '\0') {
598 #ifdef MACOS_TRADITIONAL
602 sv_setnv(sv,(double)gMacPerl_OSErr);
603 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
608 # include <descrip.h>
609 # include <starlet.h>
611 $DESCRIPTOR(msgdsc,msg);
612 sv_setnv(sv,(NV) vaxc$errno);
613 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
614 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
620 if (!(_emx_env & 0x200)) { /* Under DOS */
621 sv_setnv(sv, (NV)errno);
622 sv_setpv(sv, errno ? Strerror(errno) : "");
624 if (errno != errno_isOS2) {
625 int tmp = _syserrno();
626 if (tmp) /* 2nd call to _syserrno() makes it 0 */
629 sv_setnv(sv, (NV)Perl_rc);
630 sv_setpv(sv, os2error(Perl_rc));
635 DWORD dwErr = GetLastError();
636 sv_setnv(sv, (NV)dwErr);
639 PerlProc_GetOSError(sv, dwErr);
642 sv_setpvn(sv, "", 0);
647 int saveerrno = errno;
648 sv_setnv(sv, (NV)errno);
649 sv_setpv(sv, errno ? Strerror(errno) : "");
656 SvNOK_on(sv); /* what a wonderful hack! */
658 else if (strEQ(mg->mg_ptr+1, "NCODING"))
659 sv_setsv(sv, PL_encoding);
661 case '\006': /* ^F */
662 sv_setiv(sv, (IV)PL_maxsysfd);
664 case '\010': /* ^H */
665 sv_setiv(sv, (IV)PL_hints);
667 case '\011': /* ^I */ /* NOT \t in EBCDIC */
669 sv_setpv(sv, PL_inplace);
671 sv_setsv(sv, &PL_sv_undef);
673 case '\017': /* ^O & ^OPEN */
674 if (*(mg->mg_ptr+1) == '\0') {
675 sv_setpv(sv, PL_osname);
678 else if (strEQ(mg->mg_ptr, "\017PEN")) {
679 if (!PL_compiling.cop_io)
680 sv_setsv(sv, &PL_sv_undef);
682 sv_setsv(sv, PL_compiling.cop_io);
686 case '\020': /* ^P */
687 sv_setiv(sv, (IV)PL_perldb);
689 case '\023': /* ^S */
690 if (*(mg->mg_ptr+1) == '\0') {
691 if (PL_lex_state != LEX_NOTPARSING)
694 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
699 case '\024': /* ^T */
700 if (*(mg->mg_ptr+1) == '\0') {
702 sv_setnv(sv, PL_basetime);
704 sv_setiv(sv, (IV)PL_basetime);
707 else if (strEQ(mg->mg_ptr, "\024AINT"))
708 sv_setiv(sv, PL_tainting
709 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
712 case '\025': /* $^UNICODE, $^UTF8LOCALE */
713 if (strEQ(mg->mg_ptr, "\025NICODE"))
714 sv_setuv(sv, (UV) PL_unicode);
715 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
716 sv_setuv(sv, (UV) PL_utf8locale);
718 case '\027': /* ^W & $^WARNING_BITS */
719 if (*(mg->mg_ptr+1) == '\0')
720 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
721 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
722 if (PL_compiling.cop_warnings == pWARN_NONE ||
723 PL_compiling.cop_warnings == pWARN_STD)
725 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
727 else if (PL_compiling.cop_warnings == pWARN_ALL) {
728 /* Get the bit mask for $warnings::Bits{all}, because
729 * it could have been extended by warnings::register */
731 HV *bits=get_hv("warnings::Bits", FALSE);
732 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
733 sv_setsv(sv, *bits_all);
736 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
740 sv_setsv(sv, PL_compiling.cop_warnings);
745 case '1': case '2': case '3': case '4':
746 case '5': case '6': case '7': case '8': case '9': case '&':
747 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
751 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
752 * XXX Does the new way break anything?
754 paren = atoi(mg->mg_ptr); /* $& is in [0] */
756 if (paren <= (I32)rx->nparens &&
757 (s1 = rx->startp[paren]) != -1 &&
758 (t1 = rx->endp[paren]) != -1)
768 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
773 if (RX_MATCH_TAINTED(rx)) {
774 MAGIC* mg = SvMAGIC(sv);
777 SvMAGIC_set(sv, mg->mg_moremagic);
779 if ((mgt = SvMAGIC(sv))) {
780 mg->mg_moremagic = mgt;
790 sv_setsv(sv,&PL_sv_undef);
793 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
794 paren = rx->lastparen;
798 sv_setsv(sv,&PL_sv_undef);
800 case '\016': /* ^N */
801 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
802 paren = rx->lastcloseparen;
806 sv_setsv(sv,&PL_sv_undef);
809 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
810 if ((s = rx->subbeg) && rx->startp[0] != -1) {
815 sv_setsv(sv,&PL_sv_undef);
818 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
819 if (rx->subbeg && rx->endp[0] != -1) {
820 s = rx->subbeg + rx->endp[0];
821 i = rx->sublen - rx->endp[0];
825 sv_setsv(sv,&PL_sv_undef);
829 if (GvIO(PL_last_in_gv)) {
830 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
836 sv_setiv(sv, (IV)STATUS_CURRENT);
837 #ifdef COMPLEX_STATUS
838 LvTARGOFF(sv) = PL_statusvalue;
839 LvTARGLEN(sv) = PL_statusvalue_vms;
844 if (GvIOp(PL_defoutgv))
845 s = IoTOP_NAME(GvIOp(PL_defoutgv));
849 sv_setpv(sv,GvENAME(PL_defoutgv));
854 if (GvIOp(PL_defoutgv))
855 s = IoFMT_NAME(GvIOp(PL_defoutgv));
857 s = GvENAME(PL_defoutgv);
862 if (GvIOp(PL_defoutgv))
863 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
866 if (GvIOp(PL_defoutgv))
867 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
870 if (GvIOp(PL_defoutgv))
871 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
879 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
882 if (GvIOp(PL_defoutgv))
883 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
889 sv_copypv(sv, PL_ors_sv);
892 sv_setpv(sv,PL_ofmt);
896 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
897 sv_setpv(sv, errno ? Strerror(errno) : "");
900 int saveerrno = errno;
901 sv_setnv(sv, (NV)errno);
903 if (errno == errno_isOS2 || errno == errno_isOS2_set)
904 sv_setpv(sv, os2error(Perl_rc));
907 sv_setpv(sv, errno ? Strerror(errno) : "");
911 SvNOK_on(sv); /* what a wonderful hack! */
914 sv_setiv(sv, (IV)PL_uid);
917 sv_setiv(sv, (IV)PL_euid);
920 sv_setiv(sv, (IV)PL_gid);
922 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
926 sv_setiv(sv, (IV)PL_egid);
928 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
933 Groups_t gary[NGROUPS];
934 I32 j = getgroups(NGROUPS,gary);
936 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
939 (void)SvIOK_on(sv); /* what a wonderful hack! */
941 #ifndef MACOS_TRADITIONAL
950 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
952 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
954 if (uf && uf->uf_val)
955 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
960 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
971 #ifdef DYNAMIC_ENV_FETCH
972 /* We just undefd an environment var. Is a replacement */
973 /* waiting in the wings? */
976 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
977 s = SvPV(*valp, len);
981 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
982 /* And you'll never guess what the dog had */
983 /* in its mouth... */
985 MgTAINTEDDIR_off(mg);
987 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
988 char pathbuf[256], eltbuf[256], *cp, *elt = s;
992 do { /* DCL$PATH may be a search list */
993 while (1) { /* as may dev portion of any element */
994 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
995 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
996 cando_by_name(S_IWUSR,0,elt) ) {
1001 if ((cp = strchr(elt, ':')) != Nullch)
1003 if (my_trnlnm(elt, eltbuf, j++))
1009 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1012 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1013 char *strend = s + len;
1015 while (s < strend) {
1019 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1020 s, strend, ':', &i);
1022 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1024 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1025 MgTAINTEDDIR_on(mg);
1031 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1037 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1041 my_setenv(MgPV(mg,n_a),Nullch);
1046 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1048 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1049 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1051 if (PL_localizing) {
1054 magic_clear_all_env(sv,mg);
1055 hv_iterinit((HV*)sv);
1056 while ((entry = hv_iternext((HV*)sv))) {
1058 my_setenv(hv_iterkey(entry, &keylen),
1059 SvPV(hv_iterval((HV*)sv, entry), n_a));
1067 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1071 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1072 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1074 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1077 # ifdef USE_ENVIRON_ARRAY
1078 # if defined(USE_ITHREADS)
1079 /* only the parent thread can clobber the process environment */
1080 if (PL_curinterp == aTHX)
1083 # ifndef PERL_USE_SAFE_PUTENV
1084 if (!PL_use_safe_putenv) {
1087 if (environ == PL_origenviron)
1088 environ = (char**)safesysmalloc(sizeof(char*));
1090 for (i = 0; environ[i]; i++)
1091 safesysfree(environ[i]);
1093 # endif /* PERL_USE_SAFE_PUTENV */
1095 environ[0] = Nullch;
1097 # endif /* USE_ENVIRON_ARRAY */
1098 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1099 #endif /* VMS || EPOC */
1100 #endif /* !PERL_MICRO */
1107 #ifdef HAS_SIGPROCMASK
1109 restore_sigmask(pTHX_ SV *save_sv)
1111 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1112 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1116 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1120 /* Are we fetching a signal entry? */
1121 i = whichsig(MgPV(mg,n_a));
1124 sv_setsv(sv,PL_psig_ptr[i]);
1126 Sighandler_t sigstate;
1127 sigstate = rsignal_state(i);
1128 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1129 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1131 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1132 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1134 /* cache state so we don't fetch it again */
1135 if(sigstate == SIG_IGN)
1136 sv_setpv(sv,"IGNORE");
1138 sv_setsv(sv,&PL_sv_undef);
1139 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1146 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1148 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1149 * refactoring might be in order.
1153 register const char *s = MgPV(mg,n_a);
1157 if (strEQ(s,"__DIE__"))
1159 else if (strEQ(s,"__WARN__"))
1162 Perl_croak(aTHX_ "No such hook: %s", s);
1166 SvREFCNT_dec(to_dec);
1171 /* Are we clearing a signal entry? */
1174 #ifdef HAS_SIGPROCMASK
1177 /* Avoid having the signal arrive at a bad time, if possible. */
1180 sigprocmask(SIG_BLOCK, &set, &save);
1182 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1183 SAVEFREESV(save_sv);
1184 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1187 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1188 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1190 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1191 PL_sig_defaulting[i] = 1;
1192 (void)rsignal(i, PL_csighandlerp);
1194 (void)rsignal(i, SIG_DFL);
1196 if(PL_psig_name[i]) {
1197 SvREFCNT_dec(PL_psig_name[i]);
1200 if(PL_psig_ptr[i]) {
1201 SV *to_dec=PL_psig_ptr[i];
1204 SvREFCNT_dec(to_dec);
1214 S_raise_signal(pTHX_ int sig)
1216 /* Set a flag to say this signal is pending */
1217 PL_psig_pend[sig]++;
1218 /* And one to say _a_ signal is pending */
1223 Perl_csighandler(int sig)
1225 #ifdef PERL_GET_SIG_CONTEXT
1226 dTHXa(PERL_GET_SIG_CONTEXT);
1230 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1231 (void) rsignal(sig, PL_csighandlerp);
1232 if (PL_sig_ignoring[sig]) return;
1234 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1235 if (PL_sig_defaulting[sig])
1236 #ifdef KILL_BY_SIGPRC
1237 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1242 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1243 /* Call the perl level handler now--
1244 * with risk we may be in malloc() etc. */
1245 (*PL_sighandlerp)(sig);
1247 S_raise_signal(aTHX_ sig);
1250 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1252 Perl_csighandler_init(void)
1255 if (PL_sig_handlers_initted) return;
1257 for (sig = 1; sig < SIG_SIZE; sig++) {
1258 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1260 PL_sig_defaulting[sig] = 1;
1261 (void) rsignal(sig, PL_csighandlerp);
1263 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1264 PL_sig_ignoring[sig] = 0;
1267 PL_sig_handlers_initted = 1;
1272 Perl_despatch_signals(pTHX)
1276 for (sig = 1; sig < SIG_SIZE; sig++) {
1277 if (PL_psig_pend[sig]) {
1278 PERL_BLOCKSIG_ADD(set, sig);
1279 PL_psig_pend[sig] = 0;
1280 PERL_BLOCKSIG_BLOCK(set);
1281 (*PL_sighandlerp)(sig);
1282 PERL_BLOCKSIG_UNBLOCK(set);
1288 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1293 /* Need to be careful with SvREFCNT_dec(), because that can have side
1294 * effects (due to closures). We must make sure that the new disposition
1295 * is in place before it is called.
1299 #ifdef HAS_SIGPROCMASK
1304 register const char *s = MgPV(mg,len);
1306 if (strEQ(s,"__DIE__"))
1308 else if (strEQ(s,"__WARN__"))
1311 Perl_croak(aTHX_ "No such hook: %s", s);
1319 i = whichsig(s); /* ...no, a brick */
1321 if (ckWARN(WARN_SIGNAL))
1322 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1325 #ifdef HAS_SIGPROCMASK
1326 /* Avoid having the signal arrive at a bad time, if possible. */
1329 sigprocmask(SIG_BLOCK, &set, &save);
1331 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1332 SAVEFREESV(save_sv);
1333 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1336 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1337 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1339 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1340 PL_sig_ignoring[i] = 0;
1342 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1343 PL_sig_defaulting[i] = 0;
1345 SvREFCNT_dec(PL_psig_name[i]);
1346 to_dec = PL_psig_ptr[i];
1347 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1348 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1349 PL_psig_name[i] = newSVpvn(s, len);
1350 SvREADONLY_on(PL_psig_name[i]);
1352 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1354 (void)rsignal(i, PL_csighandlerp);
1355 #ifdef HAS_SIGPROCMASK
1360 *svp = SvREFCNT_inc(sv);
1362 SvREFCNT_dec(to_dec);
1365 s = SvPV_force(sv,len);
1366 if (strEQ(s,"IGNORE")) {
1368 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1369 PL_sig_ignoring[i] = 1;
1370 (void)rsignal(i, PL_csighandlerp);
1372 (void)rsignal(i, SIG_IGN);
1376 else if (strEQ(s,"DEFAULT") || !*s) {
1378 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1380 PL_sig_defaulting[i] = 1;
1381 (void)rsignal(i, PL_csighandlerp);
1384 (void)rsignal(i, SIG_DFL);
1389 * We should warn if HINT_STRICT_REFS, but without
1390 * access to a known hint bit in a known OP, we can't
1391 * tell whether HINT_STRICT_REFS is in force or not.
1393 if (!strchr(s,':') && !strchr(s,'\''))
1394 sv_insert(sv, 0, 0, "main::", 6);
1396 (void)rsignal(i, PL_csighandlerp);
1398 *svp = SvREFCNT_inc(sv);
1400 #ifdef HAS_SIGPROCMASK
1405 SvREFCNT_dec(to_dec);
1408 #endif /* !PERL_MICRO */
1411 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1415 PL_sub_generation++;
1420 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1424 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1425 PL_amagic_generation++;
1431 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1433 HV * const hv = (HV*)LvTARG(sv);
1438 (void) hv_iterinit(hv);
1439 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1442 while (hv_iternext(hv))
1447 sv_setiv(sv, (IV)i);
1452 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1456 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1461 /* caller is responsible for stack switching/cleanup */
1463 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1469 PUSHs(SvTIED_obj(sv, mg));
1472 if (mg->mg_len >= 0)
1473 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1474 else if (mg->mg_len == HEf_SVKEY)
1475 PUSHs((SV*)mg->mg_ptr);
1477 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1478 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1486 return call_method(meth, flags);
1490 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1496 PUSHSTACKi(PERLSI_MAGIC);
1498 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1499 sv_setsv(sv, *PL_stack_sp--);
1509 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1512 mg->mg_flags |= MGf_GSKIP;
1513 magic_methpack(sv,mg,"FETCH");
1518 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1522 PUSHSTACKi(PERLSI_MAGIC);
1523 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1530 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1532 return magic_methpack(sv,mg,"DELETE");
1537 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1544 PUSHSTACKi(PERLSI_MAGIC);
1545 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1546 sv = *PL_stack_sp--;
1547 retval = (U32) SvIV(sv)-1;
1556 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1561 PUSHSTACKi(PERLSI_MAGIC);
1563 XPUSHs(SvTIED_obj(sv, mg));
1565 call_method("CLEAR", G_SCALAR|G_DISCARD);
1573 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1576 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1580 PUSHSTACKi(PERLSI_MAGIC);
1583 PUSHs(SvTIED_obj(sv, mg));
1588 if (call_method(meth, G_SCALAR))
1589 sv_setsv(key, *PL_stack_sp--);
1598 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1600 return magic_methpack(sv,mg,"EXISTS");
1604 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1607 SV *retval = &PL_sv_undef;
1608 SV *tied = SvTIED_obj((SV*)hv, mg);
1609 HV *pkg = SvSTASH((SV*)SvRV(tied));
1611 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1614 /* we are in an iteration so the hash cannot be empty */
1616 /* no xhv_eiter so now use FIRSTKEY */
1617 key = sv_newmortal();
1618 magic_nextpack((SV*)hv, mg, key);
1619 HvEITER(hv) = NULL; /* need to reset iterator */
1620 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1623 /* there is a SCALAR method that we can call */
1625 PUSHSTACKi(PERLSI_MAGIC);
1631 if (call_method("SCALAR", G_SCALAR))
1632 retval = *PL_stack_sp--;
1639 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1649 svp = av_fetch(GvAV(gv),
1650 atoi(MgPV(mg,n_a)), FALSE);
1651 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1652 /* set or clear breakpoint in the relevant control op */
1654 o->op_flags |= OPf_SPECIAL;
1656 o->op_flags &= ~OPf_SPECIAL;
1662 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1664 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1669 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1671 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1676 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1678 SV* lsv = LvTARG(sv);
1680 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1681 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1682 if (mg && mg->mg_len >= 0) {
1685 sv_pos_b2u(lsv, &i);
1686 sv_setiv(sv, i + PL_curcop->cop_arybase);
1695 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1697 SV* lsv = LvTARG(sv);
1704 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1705 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1709 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1710 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1712 else if (!SvOK(sv)) {
1716 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1718 pos = SvIV(sv) - PL_curcop->cop_arybase;
1721 ulen = sv_len_utf8(lsv);
1731 else if (pos > (SSize_t)len)
1736 sv_pos_u2b(lsv, &p, 0);
1741 mg->mg_flags &= ~MGf_MINMATCH;
1747 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1750 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1752 gv_efullname3(sv,((GV*)sv), "*");
1756 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1761 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1768 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1773 GvGP(sv) = gp_ref(GvGP(gv));
1778 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1781 SV * const lsv = LvTARG(sv);
1782 const char * const tmps = SvPV(lsv,len);
1783 I32 offs = LvTARGOFF(sv);
1784 I32 rem = LvTARGLEN(sv);
1788 sv_pos_u2b(lsv, &offs, &rem);
1789 if (offs > (I32)len)
1791 if (rem + offs > (I32)len)
1793 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1800 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1803 char *tmps = SvPV(sv, len);
1804 SV * const lsv = LvTARG(sv);
1805 I32 lvoff = LvTARGOFF(sv);
1806 I32 lvlen = LvTARGLEN(sv);
1810 sv_utf8_upgrade(lsv);
1811 sv_pos_u2b(lsv, &lvoff, &lvlen);
1812 sv_insert(lsv, lvoff, lvlen, tmps, len);
1813 LvTARGLEN(sv) = sv_len_utf8(sv);
1816 else if (lsv && SvUTF8(lsv)) {
1817 sv_pos_u2b(lsv, &lvoff, &lvlen);
1818 LvTARGLEN(sv) = len;
1819 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1820 sv_insert(lsv, lvoff, lvlen, tmps, len);
1824 sv_insert(lsv, lvoff, lvlen, tmps, len);
1825 LvTARGLEN(sv) = len;
1833 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1835 TAINT_IF((mg->mg_len & 1) ||
1836 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1841 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1844 if (PL_localizing) {
1845 if (PL_localizing == 1)
1850 else if (PL_tainted)
1858 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1860 SV * const lsv = LvTARG(sv);
1868 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1873 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1876 do_vecset(sv); /* XXX slurp this routine */
1881 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1884 if (LvTARGLEN(sv)) {
1886 SV *ahv = LvTARG(sv);
1887 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1892 AV* av = (AV*)LvTARG(sv);
1893 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1894 targ = AvARRAY(av)[LvTARGOFF(sv)];
1896 if (targ && targ != &PL_sv_undef) {
1897 /* somebody else defined it for us */
1898 SvREFCNT_dec(LvTARG(sv));
1899 LvTARG(sv) = SvREFCNT_inc(targ);
1901 SvREFCNT_dec(mg->mg_obj);
1902 mg->mg_obj = Nullsv;
1903 mg->mg_flags &= ~MGf_REFCOUNTED;
1908 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1913 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1919 sv_setsv(LvTARG(sv), sv);
1920 SvSETMAGIC(LvTARG(sv));
1926 Perl_vivify_defelem(pTHX_ SV *sv)
1931 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1934 SV *ahv = LvTARG(sv);
1935 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1938 if (!value || value == &PL_sv_undef)
1939 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
1942 AV* av = (AV*)LvTARG(sv);
1943 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1944 LvTARG(sv) = Nullsv; /* array can't be extended */
1946 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1947 if (!svp || (value = *svp) == &PL_sv_undef)
1948 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1951 (void)SvREFCNT_inc(value);
1952 SvREFCNT_dec(LvTARG(sv));
1955 SvREFCNT_dec(mg->mg_obj);
1956 mg->mg_obj = Nullsv;
1957 mg->mg_flags &= ~MGf_REFCOUNTED;
1961 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1963 AV *av = (AV*)mg->mg_obj;
1964 SV **svp = AvARRAY(av);
1965 I32 i = AvFILLp(av);
1970 if (!SvWEAKREF(svp[i]))
1971 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1972 /* XXX Should we check that it hasn't changed? */
1973 SvRV_set(svp[i], 0);
1975 SvWEAKREF_off(svp[i]);
1980 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1985 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1993 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1996 sv_unmagic(sv, PERL_MAGIC_bm);
2002 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2005 sv_unmagic(sv, PERL_MAGIC_fm);
2011 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2013 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2015 if (uf && uf->uf_set)
2016 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2021 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2024 sv_unmagic(sv, PERL_MAGIC_qr);
2029 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2031 regexp *re = (regexp *)mg->mg_obj;
2037 #ifdef USE_LOCALE_COLLATE
2039 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2042 * RenE<eacute> Descartes said "I think not."
2043 * and vanished with a faint plop.
2047 Safefree(mg->mg_ptr);
2053 #endif /* USE_LOCALE_COLLATE */
2055 /* Just clear the UTF-8 cache data. */
2057 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2060 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2062 mg->mg_len = -1; /* The mg_len holds the len cache. */
2067 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2069 register const char *s;
2072 switch (*mg->mg_ptr) {
2073 case '\001': /* ^A */
2074 sv_setsv(PL_bodytarget, sv);
2076 case '\003': /* ^C */
2077 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2080 case '\004': /* ^D */
2083 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2084 DEBUG_x(dump_all());
2086 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2089 case '\005': /* ^E */
2090 if (*(mg->mg_ptr+1) == '\0') {
2091 #ifdef MACOS_TRADITIONAL
2092 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2095 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2098 SetLastError( SvIV(sv) );
2101 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2103 /* will anyone ever use this? */
2104 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2110 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2112 SvREFCNT_dec(PL_encoding);
2113 if (SvOK(sv) || SvGMAGICAL(sv)) {
2114 PL_encoding = newSVsv(sv);
2117 PL_encoding = Nullsv;
2121 case '\006': /* ^F */
2122 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2124 case '\010': /* ^H */
2125 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2127 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2129 Safefree(PL_inplace);
2131 PL_inplace = savesvpv(sv);
2133 PL_inplace = Nullch;
2135 case '\017': /* ^O */
2136 if (*(mg->mg_ptr+1) == '\0') {
2138 Safefree(PL_osname);
2142 TAINT_PROPER("assigning to $^O");
2143 PL_osname = savesvpv(sv);
2146 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2147 if (!PL_compiling.cop_io)
2148 PL_compiling.cop_io = newSVsv(sv);
2150 sv_setsv(PL_compiling.cop_io,sv);
2153 case '\020': /* ^P */
2154 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2155 if (PL_perldb && !PL_DBsingle)
2158 case '\024': /* ^T */
2160 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2162 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2165 case '\027': /* ^W & $^WARNING_BITS */
2166 if (*(mg->mg_ptr+1) == '\0') {
2167 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2168 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2169 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2170 | (i ? G_WARN_ON : G_WARN_OFF) ;
2173 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2174 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2175 if (!SvPOK(sv) && PL_localizing) {
2176 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2177 PL_compiling.cop_warnings = pWARN_NONE;
2182 int accumulate = 0 ;
2183 int any_fatals = 0 ;
2184 const char * const ptr = (char*)SvPV(sv, len) ;
2185 for (i = 0 ; i < len ; ++i) {
2186 accumulate |= ptr[i] ;
2187 any_fatals |= (ptr[i] & 0xAA) ;
2190 PL_compiling.cop_warnings = pWARN_NONE;
2191 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2192 PL_compiling.cop_warnings = pWARN_ALL;
2193 PL_dowarn |= G_WARN_ONCE ;
2196 if (specialWARN(PL_compiling.cop_warnings))
2197 PL_compiling.cop_warnings = newSVsv(sv) ;
2199 sv_setsv(PL_compiling.cop_warnings, sv);
2200 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2201 PL_dowarn |= G_WARN_ONCE ;
2209 if (PL_localizing) {
2210 if (PL_localizing == 1)
2211 SAVESPTR(PL_last_in_gv);
2213 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2214 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2217 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2218 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2219 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2222 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2223 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2224 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2227 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2230 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2231 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2232 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2235 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2239 IO *io = GvIOp(PL_defoutgv);
2242 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2243 IoFLAGS(io) &= ~IOf_FLUSH;
2245 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2246 PerlIO *ofp = IoOFP(io);
2248 (void)PerlIO_flush(ofp);
2249 IoFLAGS(io) |= IOf_FLUSH;
2255 SvREFCNT_dec(PL_rs);
2256 PL_rs = newSVsv(sv);
2260 SvREFCNT_dec(PL_ors_sv);
2261 if (SvOK(sv) || SvGMAGICAL(sv)) {
2262 PL_ors_sv = newSVsv(sv);
2270 SvREFCNT_dec(PL_ofs_sv);
2271 if (SvOK(sv) || SvGMAGICAL(sv)) {
2272 PL_ofs_sv = newSVsv(sv);
2281 PL_ofmt = savesvpv(sv);
2284 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2287 #ifdef COMPLEX_STATUS
2288 if (PL_localizing == 2) {
2289 PL_statusvalue = LvTARGOFF(sv);
2290 PL_statusvalue_vms = LvTARGLEN(sv);
2294 #ifdef VMSISH_STATUS
2296 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2299 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2304 # define PERL_VMS_BANG vaxc$errno
2306 # define PERL_VMS_BANG 0
2308 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2309 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2313 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2314 if (PL_delaymagic) {
2315 PL_delaymagic |= DM_RUID;
2316 break; /* don't do magic till later */
2319 (void)setruid((Uid_t)PL_uid);
2322 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2324 #ifdef HAS_SETRESUID
2325 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2327 if (PL_uid == PL_euid) { /* special case $< = $> */
2329 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2330 if (PL_uid != 0 && PerlProc_getuid() == 0)
2331 (void)PerlProc_setuid(0);
2333 (void)PerlProc_setuid(PL_uid);
2335 PL_uid = PerlProc_getuid();
2336 Perl_croak(aTHX_ "setruid() not implemented");
2341 PL_uid = PerlProc_getuid();
2342 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2345 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2346 if (PL_delaymagic) {
2347 PL_delaymagic |= DM_EUID;
2348 break; /* don't do magic till later */
2351 (void)seteuid((Uid_t)PL_euid);
2354 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2356 #ifdef HAS_SETRESUID
2357 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2359 if (PL_euid == PL_uid) /* special case $> = $< */
2360 PerlProc_setuid(PL_euid);
2362 PL_euid = PerlProc_geteuid();
2363 Perl_croak(aTHX_ "seteuid() not implemented");
2368 PL_euid = PerlProc_geteuid();
2369 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2372 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2373 if (PL_delaymagic) {
2374 PL_delaymagic |= DM_RGID;
2375 break; /* don't do magic till later */
2378 (void)setrgid((Gid_t)PL_gid);
2381 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2383 #ifdef HAS_SETRESGID
2384 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2386 if (PL_gid == PL_egid) /* special case $( = $) */
2387 (void)PerlProc_setgid(PL_gid);
2389 PL_gid = PerlProc_getgid();
2390 Perl_croak(aTHX_ "setrgid() not implemented");
2395 PL_gid = PerlProc_getgid();
2396 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2399 #ifdef HAS_SETGROUPS
2401 const char *p = SvPV(sv, len);
2402 Groups_t gary[NGROUPS];
2407 for (i = 0; i < NGROUPS; ++i) {
2408 while (*p && !isSPACE(*p))
2417 (void)setgroups(i, gary);
2419 #else /* HAS_SETGROUPS */
2420 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2421 #endif /* HAS_SETGROUPS */
2422 if (PL_delaymagic) {
2423 PL_delaymagic |= DM_EGID;
2424 break; /* don't do magic till later */
2427 (void)setegid((Gid_t)PL_egid);
2430 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2432 #ifdef HAS_SETRESGID
2433 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2435 if (PL_egid == PL_gid) /* special case $) = $( */
2436 (void)PerlProc_setgid(PL_egid);
2438 PL_egid = PerlProc_getegid();
2439 Perl_croak(aTHX_ "setegid() not implemented");
2444 PL_egid = PerlProc_getegid();
2445 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2448 PL_chopset = SvPV_force(sv,len);
2450 #ifndef MACOS_TRADITIONAL
2452 LOCK_DOLLARZERO_MUTEX;
2453 #ifdef HAS_SETPROCTITLE
2454 /* The BSDs don't show the argv[] in ps(1) output, they
2455 * show a string from the process struct and provide
2456 * the setproctitle() routine to manipulate that. */
2459 # if __FreeBSD_version > 410001
2460 /* The leading "-" removes the "perl: " prefix,
2461 * but not the "(perl) suffix from the ps(1)
2462 * output, because that's what ps(1) shows if the
2463 * argv[] is modified. */
2464 setproctitle("-%s", s);
2465 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2466 /* This doesn't really work if you assume that
2467 * $0 = 'foobar'; will wipe out 'perl' from the $0
2468 * because in ps(1) output the result will be like
2469 * sprintf("perl: %s (perl)", s)
2470 * I guess this is a security feature:
2471 * one (a user process) cannot get rid of the original name.
2473 setproctitle("%s", s);
2477 #if defined(__hpux) && defined(PSTAT_SETCMD)
2481 un.pst_command = (char *)s;
2482 pstat(PSTAT_SETCMD, un, len, 0, 0);
2485 /* PL_origalen is set in perl_parse(). */
2486 s = SvPV_force(sv,len);
2487 if (len >= (STRLEN)PL_origalen-1) {
2488 /* Longer than original, will be truncated. We assume that
2489 * PL_origalen bytes are available. */
2490 Copy(s, PL_origargv[0], PL_origalen-1, char);
2493 /* Shorter than original, will be padded. */
2494 Copy(s, PL_origargv[0], len, char);
2495 PL_origargv[0][len] = 0;
2496 memset(PL_origargv[0] + len + 1,
2497 /* Is the space counterintuitive? Yes.
2498 * (You were expecting \0?)
2499 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2502 PL_origalen - len - 1);
2504 PL_origargv[0][PL_origalen-1] = 0;
2505 for (i = 1; i < PL_origargc; i++)
2507 UNLOCK_DOLLARZERO_MUTEX;
2515 Perl_whichsig(pTHX_ const char *sig)
2517 register char* const* sigv;
2519 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2520 if (strEQ(sig,*sigv))
2521 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2523 if (strEQ(sig,"CHLD"))
2527 if (strEQ(sig,"CLD"))
2534 Perl_sighandler(int sig)
2536 #ifdef PERL_GET_SIG_CONTEXT
2537 dTHXa(PERL_GET_SIG_CONTEXT);
2544 SV *sv = Nullsv, *tSv = PL_Sv;
2550 if (PL_savestack_ix + 15 <= PL_savestack_max)
2552 if (PL_markstack_ptr < PL_markstack_max - 2)
2554 if (PL_scopestack_ix < PL_scopestack_max - 3)
2557 if (!PL_psig_ptr[sig]) {
2558 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2563 /* Max number of items pushed there is 3*n or 4. We cannot fix
2564 infinity, so we fix 4 (in fact 5): */
2566 PL_savestack_ix += 5; /* Protect save in progress. */
2567 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2570 PL_markstack_ptr++; /* Protect mark. */
2572 PL_scopestack_ix += 1;
2573 /* sv_2cv is too complicated, try a simpler variant first: */
2574 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2575 || SvTYPE(cv) != SVt_PVCV)
2576 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2578 if (!cv || !CvROOT(cv)) {
2579 if (ckWARN(WARN_SIGNAL))
2580 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2581 PL_sig_name[sig], (gv ? GvENAME(gv)
2588 if(PL_psig_name[sig]) {
2589 sv = SvREFCNT_inc(PL_psig_name[sig]);
2591 #if !defined(PERL_IMPLICIT_CONTEXT)
2595 sv = sv_newmortal();
2596 sv_setpv(sv,PL_sig_name[sig]);
2599 PUSHSTACKi(PERLSI_SIGNAL);
2604 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2607 if (SvTRUE(ERRSV)) {
2609 #ifdef HAS_SIGPROCMASK
2610 /* Handler "died", for example to get out of a restart-able read().
2611 * Before we re-do that on its behalf re-enable the signal which was
2612 * blocked by the system when we entered.
2616 sigaddset(&set,sig);
2617 sigprocmask(SIG_UNBLOCK, &set, NULL);
2619 /* Not clear if this will work */
2620 (void)rsignal(sig, SIG_IGN);
2621 (void)rsignal(sig, PL_csighandlerp);
2623 #endif /* !PERL_MICRO */
2628 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2632 PL_scopestack_ix -= 1;
2635 PL_op = myop; /* Apparently not needed... */
2637 PL_Sv = tSv; /* Restore global temporaries. */
2644 restore_magic(pTHX_ const void *p)
2646 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2647 SV* sv = mgs->mgs_sv;
2652 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2654 #ifdef PERL_COPY_ON_WRITE
2655 /* While magic was saved (and off) sv_setsv may well have seen
2656 this SV as a prime candidate for COW. */
2658 sv_force_normal(sv);
2662 SvFLAGS(sv) |= mgs->mgs_flags;
2666 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2669 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2671 /* If we're still on top of the stack, pop us off. (That condition
2672 * will be satisfied if restore_magic was called explicitly, but *not*
2673 * if it's being called via leave_scope.)
2674 * The reason for doing this is that otherwise, things like sv_2cv()
2675 * may leave alloc gunk on the savestack, and some code
2676 * (e.g. sighandler) doesn't expect that...
2678 if (PL_savestack_ix == mgs->mgs_ss_ix)
2680 I32 popval = SSPOPINT;
2681 assert(popval == SAVEt_DESTRUCTOR_X);
2682 PL_savestack_ix -= 2;
2684 assert(popval == SAVEt_ALLOC);
2686 PL_savestack_ix -= popval;
2692 unwind_handler_stack(pTHX_ const void *p)
2695 const U32 flags = *(const U32*)p;
2698 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2699 /* cxstack_ix-- Not needed, die already unwound it. */
2700 #if !defined(PERL_IMPLICIT_CONTEXT)
2702 SvREFCNT_dec(PL_sig_sv);
2708 * c-indentation-style: bsd
2710 * indent-tabs-mode: t
2713 * ex: set ts=8 sts=4 sw=4 noet: