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 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 char *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)) {
568 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
572 register char *s = NULL;
576 switch (*mg->mg_ptr) {
577 case '\001': /* ^A */
578 sv_setsv(sv, PL_bodytarget);
580 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
581 if (*(mg->mg_ptr+1) == '\0') {
582 sv_setiv(sv, (IV)PL_minus_c);
584 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
585 sv_setiv(sv, (IV)STATUS_NATIVE);
589 case '\004': /* ^D */
590 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
592 case '\005': /* ^E */
593 if (*(mg->mg_ptr+1) == '\0') {
594 #ifdef MACOS_TRADITIONAL
598 sv_setnv(sv,(double)gMacPerl_OSErr);
599 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
604 # include <descrip.h>
605 # include <starlet.h>
607 $DESCRIPTOR(msgdsc,msg);
608 sv_setnv(sv,(NV) vaxc$errno);
609 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
610 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
616 if (!(_emx_env & 0x200)) { /* Under DOS */
617 sv_setnv(sv, (NV)errno);
618 sv_setpv(sv, errno ? Strerror(errno) : "");
620 if (errno != errno_isOS2) {
621 int tmp = _syserrno();
622 if (tmp) /* 2nd call to _syserrno() makes it 0 */
625 sv_setnv(sv, (NV)Perl_rc);
626 sv_setpv(sv, os2error(Perl_rc));
631 DWORD dwErr = GetLastError();
632 sv_setnv(sv, (NV)dwErr);
635 PerlProc_GetOSError(sv, dwErr);
638 sv_setpvn(sv, "", 0);
643 int saveerrno = errno;
644 sv_setnv(sv, (NV)errno);
645 sv_setpv(sv, errno ? Strerror(errno) : "");
652 SvNOK_on(sv); /* what a wonderful hack! */
654 else if (strEQ(mg->mg_ptr+1, "NCODING"))
655 sv_setsv(sv, PL_encoding);
657 case '\006': /* ^F */
658 sv_setiv(sv, (IV)PL_maxsysfd);
660 case '\010': /* ^H */
661 sv_setiv(sv, (IV)PL_hints);
663 case '\011': /* ^I */ /* NOT \t in EBCDIC */
665 sv_setpv(sv, PL_inplace);
667 sv_setsv(sv, &PL_sv_undef);
669 case '\017': /* ^O & ^OPEN */
670 if (*(mg->mg_ptr+1) == '\0') {
671 sv_setpv(sv, PL_osname);
674 else if (strEQ(mg->mg_ptr, "\017PEN")) {
675 if (!PL_compiling.cop_io)
676 sv_setsv(sv, &PL_sv_undef);
678 sv_setsv(sv, PL_compiling.cop_io);
682 case '\020': /* ^P */
683 sv_setiv(sv, (IV)PL_perldb);
685 case '\023': /* ^S */
686 if (*(mg->mg_ptr+1) == '\0') {
687 if (PL_lex_state != LEX_NOTPARSING)
690 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
695 case '\024': /* ^T */
696 if (*(mg->mg_ptr+1) == '\0') {
698 sv_setnv(sv, PL_basetime);
700 sv_setiv(sv, (IV)PL_basetime);
703 else if (strEQ(mg->mg_ptr, "\024AINT"))
704 sv_setiv(sv, PL_tainting
705 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
708 case '\025': /* $^UNICODE, $^UTF8LOCALE */
709 if (strEQ(mg->mg_ptr, "\025NICODE"))
710 sv_setuv(sv, (UV) PL_unicode);
711 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
712 sv_setuv(sv, (UV) PL_utf8locale);
714 case '\027': /* ^W & $^WARNING_BITS */
715 if (*(mg->mg_ptr+1) == '\0')
716 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
717 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
718 if (PL_compiling.cop_warnings == pWARN_NONE ||
719 PL_compiling.cop_warnings == pWARN_STD)
721 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
723 else if (PL_compiling.cop_warnings == pWARN_ALL) {
724 /* Get the bit mask for $warnings::Bits{all}, because
725 * it could have been extended by warnings::register */
727 HV *bits=get_hv("warnings::Bits", FALSE);
728 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
729 sv_setsv(sv, *bits_all);
732 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
736 sv_setsv(sv, PL_compiling.cop_warnings);
741 case '1': case '2': case '3': case '4':
742 case '5': case '6': case '7': case '8': case '9': case '&':
743 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
747 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
748 * XXX Does the new way break anything?
750 paren = atoi(mg->mg_ptr); /* $& is in [0] */
752 if (paren <= (I32)rx->nparens &&
753 (s1 = rx->startp[paren]) != -1 &&
754 (t1 = rx->endp[paren]) != -1)
764 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
769 if (RX_MATCH_TAINTED(rx)) {
770 MAGIC* mg = SvMAGIC(sv);
773 SvMAGIC_set(sv, mg->mg_moremagic);
775 if ((mgt = SvMAGIC(sv))) {
776 mg->mg_moremagic = mgt;
786 sv_setsv(sv,&PL_sv_undef);
789 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
790 paren = rx->lastparen;
794 sv_setsv(sv,&PL_sv_undef);
796 case '\016': /* ^N */
797 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
798 paren = rx->lastcloseparen;
802 sv_setsv(sv,&PL_sv_undef);
805 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
806 if ((s = rx->subbeg) && rx->startp[0] != -1) {
811 sv_setsv(sv,&PL_sv_undef);
814 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
815 if (rx->subbeg && rx->endp[0] != -1) {
816 s = rx->subbeg + rx->endp[0];
817 i = rx->sublen - rx->endp[0];
821 sv_setsv(sv,&PL_sv_undef);
824 if (GvIO(PL_last_in_gv)) {
825 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
830 sv_setiv(sv, (IV)STATUS_CURRENT);
831 #ifdef COMPLEX_STATUS
832 LvTARGOFF(sv) = PL_statusvalue;
833 LvTARGLEN(sv) = PL_statusvalue_vms;
838 if (GvIOp(PL_defoutgv))
839 s = IoTOP_NAME(GvIOp(PL_defoutgv));
843 sv_setpv(sv,GvENAME(PL_defoutgv));
848 if (GvIOp(PL_defoutgv))
849 s = IoFMT_NAME(GvIOp(PL_defoutgv));
851 s = GvENAME(PL_defoutgv);
855 if (GvIOp(PL_defoutgv))
856 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
859 if (GvIOp(PL_defoutgv))
860 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
863 if (GvIOp(PL_defoutgv))
864 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
871 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
874 if (GvIOp(PL_defoutgv))
875 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
881 sv_copypv(sv, PL_ors_sv);
884 sv_setpv(sv,PL_ofmt);
888 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
889 sv_setpv(sv, errno ? Strerror(errno) : "");
892 int saveerrno = errno;
893 sv_setnv(sv, (NV)errno);
895 if (errno == errno_isOS2 || errno == errno_isOS2_set)
896 sv_setpv(sv, os2error(Perl_rc));
899 sv_setpv(sv, errno ? Strerror(errno) : "");
903 SvNOK_on(sv); /* what a wonderful hack! */
906 sv_setiv(sv, (IV)PL_uid);
909 sv_setiv(sv, (IV)PL_euid);
912 sv_setiv(sv, (IV)PL_gid);
914 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
918 sv_setiv(sv, (IV)PL_egid);
920 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
925 Groups_t gary[NGROUPS];
926 I32 j = getgroups(NGROUPS,gary);
928 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
931 (void)SvIOK_on(sv); /* what a wonderful hack! */
933 #ifndef MACOS_TRADITIONAL
942 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
944 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
946 if (uf && uf->uf_val)
947 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
952 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
960 ptr = MgPV_const(mg,klen);
963 #ifdef DYNAMIC_ENV_FETCH
964 /* We just undefd an environment var. Is a replacement */
965 /* waiting in the wings? */
968 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
969 s = SvPV(*valp, len);
973 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
974 /* And you'll never guess what the dog had */
975 /* in its mouth... */
977 MgTAINTEDDIR_off(mg);
979 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
980 char pathbuf[256], eltbuf[256], *cp, *elt = s;
984 do { /* DCL$PATH may be a search list */
985 while (1) { /* as may dev portion of any element */
986 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
987 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
988 cando_by_name(S_IWUSR,0,elt) ) {
993 if ((cp = strchr(elt, ':')) != Nullch)
995 if (my_trnlnm(elt, eltbuf, j++))
1001 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1004 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1005 char *strend = s + len;
1007 while (s < strend) {
1011 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1012 s, strend, ':', &i);
1014 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1016 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1017 MgTAINTEDDIR_on(mg);
1023 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1029 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1033 my_setenv(MgPV(mg,n_a),Nullch);
1038 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1040 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1041 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1043 if (PL_localizing) {
1046 magic_clear_all_env(sv,mg);
1047 hv_iterinit((HV*)sv);
1048 while ((entry = hv_iternext((HV*)sv))) {
1050 my_setenv(hv_iterkey(entry, &keylen),
1051 SvPV(hv_iterval((HV*)sv, entry), n_a));
1059 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1063 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1064 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1066 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1069 # ifdef USE_ENVIRON_ARRAY
1070 # if defined(USE_ITHREADS)
1071 /* only the parent thread can clobber the process environment */
1072 if (PL_curinterp == aTHX)
1075 # ifndef PERL_USE_SAFE_PUTENV
1076 if (!PL_use_safe_putenv) {
1079 if (environ == PL_origenviron)
1080 environ = (char**)safesysmalloc(sizeof(char*));
1082 for (i = 0; environ[i]; i++)
1083 safesysfree(environ[i]);
1085 # endif /* PERL_USE_SAFE_PUTENV */
1087 environ[0] = Nullch;
1089 # endif /* USE_ENVIRON_ARRAY */
1090 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1091 #endif /* VMS || EPOC */
1092 #endif /* !PERL_MICRO */
1099 #ifdef HAS_SIGPROCMASK
1101 restore_sigmask(pTHX_ SV *save_sv)
1103 sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1104 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1108 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1112 /* Are we fetching a signal entry? */
1113 i = whichsig(MgPV(mg,n_a));
1116 sv_setsv(sv,PL_psig_ptr[i]);
1118 Sighandler_t sigstate;
1119 sigstate = rsignal_state(i);
1120 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1121 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1123 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1124 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1126 /* cache state so we don't fetch it again */
1127 if(sigstate == SIG_IGN)
1128 sv_setpv(sv,"IGNORE");
1130 sv_setsv(sv,&PL_sv_undef);
1131 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1138 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1140 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1141 * refactoring might be in order.
1145 register const char *s = MgPV(mg,n_a);
1149 if (strEQ(s,"__DIE__"))
1151 else if (strEQ(s,"__WARN__"))
1154 Perl_croak(aTHX_ "No such hook: %s", s);
1158 SvREFCNT_dec(to_dec);
1163 /* Are we clearing a signal entry? */
1166 #ifdef HAS_SIGPROCMASK
1169 /* Avoid having the signal arrive at a bad time, if possible. */
1172 sigprocmask(SIG_BLOCK, &set, &save);
1174 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1175 SAVEFREESV(save_sv);
1176 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1179 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1180 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1182 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1183 PL_sig_defaulting[i] = 1;
1184 (void)rsignal(i, PL_csighandlerp);
1186 (void)rsignal(i, SIG_DFL);
1188 if(PL_psig_name[i]) {
1189 SvREFCNT_dec(PL_psig_name[i]);
1192 if(PL_psig_ptr[i]) {
1193 SV *to_dec=PL_psig_ptr[i];
1196 SvREFCNT_dec(to_dec);
1206 S_raise_signal(pTHX_ int sig)
1208 /* Set a flag to say this signal is pending */
1209 PL_psig_pend[sig]++;
1210 /* And one to say _a_ signal is pending */
1215 Perl_csighandler(int sig)
1217 #ifdef PERL_GET_SIG_CONTEXT
1218 dTHXa(PERL_GET_SIG_CONTEXT);
1222 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1223 (void) rsignal(sig, PL_csighandlerp);
1224 if (PL_sig_ignoring[sig]) return;
1226 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1227 if (PL_sig_defaulting[sig])
1228 #ifdef KILL_BY_SIGPRC
1229 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1234 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1235 /* Call the perl level handler now--
1236 * with risk we may be in malloc() etc. */
1237 (*PL_sighandlerp)(sig);
1239 S_raise_signal(aTHX_ sig);
1242 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1244 Perl_csighandler_init(void)
1247 if (PL_sig_handlers_initted) return;
1249 for (sig = 1; sig < SIG_SIZE; sig++) {
1250 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1252 PL_sig_defaulting[sig] = 1;
1253 (void) rsignal(sig, PL_csighandlerp);
1255 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1256 PL_sig_ignoring[sig] = 0;
1259 PL_sig_handlers_initted = 1;
1264 Perl_despatch_signals(pTHX)
1268 for (sig = 1; sig < SIG_SIZE; sig++) {
1269 if (PL_psig_pend[sig]) {
1270 PERL_BLOCKSIG_ADD(set, sig);
1271 PL_psig_pend[sig] = 0;
1272 PERL_BLOCKSIG_BLOCK(set);
1273 (*PL_sighandlerp)(sig);
1274 PERL_BLOCKSIG_UNBLOCK(set);
1280 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1285 /* Need to be careful with SvREFCNT_dec(), because that can have side
1286 * effects (due to closures). We must make sure that the new disposition
1287 * is in place before it is called.
1291 #ifdef HAS_SIGPROCMASK
1296 register const char *s = MgPV(mg,len);
1298 if (strEQ(s,"__DIE__"))
1300 else if (strEQ(s,"__WARN__"))
1303 Perl_croak(aTHX_ "No such hook: %s", s);
1311 i = whichsig(s); /* ...no, a brick */
1313 if (ckWARN(WARN_SIGNAL))
1314 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1317 #ifdef HAS_SIGPROCMASK
1318 /* Avoid having the signal arrive at a bad time, if possible. */
1321 sigprocmask(SIG_BLOCK, &set, &save);
1323 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1324 SAVEFREESV(save_sv);
1325 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1328 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1329 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1331 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1332 PL_sig_ignoring[i] = 0;
1334 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1335 PL_sig_defaulting[i] = 0;
1337 SvREFCNT_dec(PL_psig_name[i]);
1338 to_dec = PL_psig_ptr[i];
1339 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1340 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1341 PL_psig_name[i] = newSVpvn(s, len);
1342 SvREADONLY_on(PL_psig_name[i]);
1344 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1346 (void)rsignal(i, PL_csighandlerp);
1347 #ifdef HAS_SIGPROCMASK
1352 *svp = SvREFCNT_inc(sv);
1354 SvREFCNT_dec(to_dec);
1357 s = SvPV_force(sv,len);
1358 if (strEQ(s,"IGNORE")) {
1360 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1361 PL_sig_ignoring[i] = 1;
1362 (void)rsignal(i, PL_csighandlerp);
1364 (void)rsignal(i, SIG_IGN);
1368 else if (strEQ(s,"DEFAULT") || !*s) {
1370 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1372 PL_sig_defaulting[i] = 1;
1373 (void)rsignal(i, PL_csighandlerp);
1376 (void)rsignal(i, SIG_DFL);
1381 * We should warn if HINT_STRICT_REFS, but without
1382 * access to a known hint bit in a known OP, we can't
1383 * tell whether HINT_STRICT_REFS is in force or not.
1385 if (!strchr(s,':') && !strchr(s,'\''))
1386 sv_insert(sv, 0, 0, "main::", 6);
1388 (void)rsignal(i, PL_csighandlerp);
1390 *svp = SvREFCNT_inc(sv);
1392 #ifdef HAS_SIGPROCMASK
1397 SvREFCNT_dec(to_dec);
1400 #endif /* !PERL_MICRO */
1403 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1407 PL_sub_generation++;
1412 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1416 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1417 PL_amagic_generation++;
1423 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1425 HV * const hv = (HV*)LvTARG(sv);
1430 (void) hv_iterinit(hv);
1431 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1434 while (hv_iternext(hv))
1439 sv_setiv(sv, (IV)i);
1444 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1448 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1453 /* caller is responsible for stack switching/cleanup */
1455 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1461 PUSHs(SvTIED_obj(sv, mg));
1464 if (mg->mg_len >= 0)
1465 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1466 else if (mg->mg_len == HEf_SVKEY)
1467 PUSHs((SV*)mg->mg_ptr);
1469 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1470 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1478 return call_method(meth, flags);
1482 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1488 PUSHSTACKi(PERLSI_MAGIC);
1490 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1491 sv_setsv(sv, *PL_stack_sp--);
1501 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1504 mg->mg_flags |= MGf_GSKIP;
1505 magic_methpack(sv,mg,"FETCH");
1510 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1514 PUSHSTACKi(PERLSI_MAGIC);
1515 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1522 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1524 return magic_methpack(sv,mg,"DELETE");
1529 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1536 PUSHSTACKi(PERLSI_MAGIC);
1537 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1538 sv = *PL_stack_sp--;
1539 retval = (U32) SvIV(sv)-1;
1548 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1553 PUSHSTACKi(PERLSI_MAGIC);
1555 XPUSHs(SvTIED_obj(sv, mg));
1557 call_method("CLEAR", G_SCALAR|G_DISCARD);
1565 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1568 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1572 PUSHSTACKi(PERLSI_MAGIC);
1575 PUSHs(SvTIED_obj(sv, mg));
1580 if (call_method(meth, G_SCALAR))
1581 sv_setsv(key, *PL_stack_sp--);
1590 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1592 return magic_methpack(sv,mg,"EXISTS");
1596 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1599 SV *retval = &PL_sv_undef;
1600 SV *tied = SvTIED_obj((SV*)hv, mg);
1601 HV *pkg = SvSTASH((SV*)SvRV(tied));
1603 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1605 if (HvEITER_get(hv))
1606 /* we are in an iteration so the hash cannot be empty */
1608 /* no xhv_eiter so now use FIRSTKEY */
1609 key = sv_newmortal();
1610 magic_nextpack((SV*)hv, mg, key);
1611 HvEITER_set(hv, NULL); /* need to reset iterator */
1612 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1615 /* there is a SCALAR method that we can call */
1617 PUSHSTACKi(PERLSI_MAGIC);
1623 if (call_method("SCALAR", G_SCALAR))
1624 retval = *PL_stack_sp--;
1631 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1641 svp = av_fetch(GvAV(gv),
1642 atoi(MgPV(mg,n_a)), FALSE);
1643 if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1644 /* set or clear breakpoint in the relevant control op */
1646 o->op_flags |= OPf_SPECIAL;
1648 o->op_flags &= ~OPf_SPECIAL;
1654 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1656 sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1661 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1663 av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1668 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1670 SV* lsv = LvTARG(sv);
1672 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1673 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1674 if (mg && mg->mg_len >= 0) {
1677 sv_pos_b2u(lsv, &i);
1678 sv_setiv(sv, i + PL_curcop->cop_arybase);
1687 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1689 SV* lsv = LvTARG(sv);
1696 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1697 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1701 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1702 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1704 else if (!SvOK(sv)) {
1708 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1710 pos = SvIV(sv) - PL_curcop->cop_arybase;
1713 ulen = sv_len_utf8(lsv);
1723 else if (pos > (SSize_t)len)
1728 sv_pos_u2b(lsv, &p, 0);
1733 mg->mg_flags &= ~MGf_MINMATCH;
1739 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1742 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1744 gv_efullname3(sv,((GV*)sv), "*");
1748 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1753 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1760 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1765 GvGP(sv) = gp_ref(GvGP(gv));
1770 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1773 SV * const lsv = LvTARG(sv);
1774 const char * const tmps = SvPV(lsv,len);
1775 I32 offs = LvTARGOFF(sv);
1776 I32 rem = LvTARGLEN(sv);
1780 sv_pos_u2b(lsv, &offs, &rem);
1781 if (offs > (I32)len)
1783 if (rem + offs > (I32)len)
1785 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1792 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1795 char *tmps = SvPV(sv, len);
1796 SV * const lsv = LvTARG(sv);
1797 I32 lvoff = LvTARGOFF(sv);
1798 I32 lvlen = LvTARGLEN(sv);
1802 sv_utf8_upgrade(lsv);
1803 sv_pos_u2b(lsv, &lvoff, &lvlen);
1804 sv_insert(lsv, lvoff, lvlen, tmps, len);
1805 LvTARGLEN(sv) = sv_len_utf8(sv);
1808 else if (lsv && SvUTF8(lsv)) {
1809 sv_pos_u2b(lsv, &lvoff, &lvlen);
1810 LvTARGLEN(sv) = len;
1811 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1812 sv_insert(lsv, lvoff, lvlen, tmps, len);
1816 sv_insert(lsv, lvoff, lvlen, tmps, len);
1817 LvTARGLEN(sv) = len;
1825 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1827 TAINT_IF((mg->mg_len & 1) ||
1828 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1833 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1836 if (PL_localizing) {
1837 if (PL_localizing == 1)
1842 else if (PL_tainted)
1850 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1852 SV * const lsv = LvTARG(sv);
1860 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1865 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1868 do_vecset(sv); /* XXX slurp this routine */
1873 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1876 if (LvTARGLEN(sv)) {
1878 SV *ahv = LvTARG(sv);
1879 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1884 AV* av = (AV*)LvTARG(sv);
1885 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1886 targ = AvARRAY(av)[LvTARGOFF(sv)];
1888 if (targ && targ != &PL_sv_undef) {
1889 /* somebody else defined it for us */
1890 SvREFCNT_dec(LvTARG(sv));
1891 LvTARG(sv) = SvREFCNT_inc(targ);
1893 SvREFCNT_dec(mg->mg_obj);
1894 mg->mg_obj = Nullsv;
1895 mg->mg_flags &= ~MGf_REFCOUNTED;
1900 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1905 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1911 sv_setsv(LvTARG(sv), sv);
1912 SvSETMAGIC(LvTARG(sv));
1918 Perl_vivify_defelem(pTHX_ SV *sv)
1923 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1926 SV *ahv = LvTARG(sv);
1927 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1930 if (!value || value == &PL_sv_undef)
1931 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
1934 AV* av = (AV*)LvTARG(sv);
1935 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1936 LvTARG(sv) = Nullsv; /* array can't be extended */
1938 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1939 if (!svp || (value = *svp) == &PL_sv_undef)
1940 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1943 (void)SvREFCNT_inc(value);
1944 SvREFCNT_dec(LvTARG(sv));
1947 SvREFCNT_dec(mg->mg_obj);
1948 mg->mg_obj = Nullsv;
1949 mg->mg_flags &= ~MGf_REFCOUNTED;
1953 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1955 AV *av = (AV*)mg->mg_obj;
1956 SV **svp = AvARRAY(av);
1957 I32 i = AvFILLp(av);
1962 if (!SvWEAKREF(svp[i]))
1963 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1964 /* XXX Should we check that it hasn't changed? */
1965 SvRV_set(svp[i], 0);
1967 SvWEAKREF_off(svp[i]);
1972 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1977 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1985 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1988 sv_unmagic(sv, PERL_MAGIC_bm);
1994 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
1997 sv_unmagic(sv, PERL_MAGIC_fm);
2003 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2005 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2007 if (uf && uf->uf_set)
2008 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2013 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2016 sv_unmagic(sv, PERL_MAGIC_qr);
2021 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2023 regexp *re = (regexp *)mg->mg_obj;
2029 #ifdef USE_LOCALE_COLLATE
2031 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2034 * RenE<eacute> Descartes said "I think not."
2035 * and vanished with a faint plop.
2039 Safefree(mg->mg_ptr);
2045 #endif /* USE_LOCALE_COLLATE */
2047 /* Just clear the UTF-8 cache data. */
2049 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2052 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2054 mg->mg_len = -1; /* The mg_len holds the len cache. */
2059 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2061 register const char *s;
2064 switch (*mg->mg_ptr) {
2065 case '\001': /* ^A */
2066 sv_setsv(PL_bodytarget, sv);
2068 case '\003': /* ^C */
2069 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2072 case '\004': /* ^D */
2075 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2076 DEBUG_x(dump_all());
2078 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2081 case '\005': /* ^E */
2082 if (*(mg->mg_ptr+1) == '\0') {
2083 #ifdef MACOS_TRADITIONAL
2084 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2087 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2090 SetLastError( SvIV(sv) );
2093 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2095 /* will anyone ever use this? */
2096 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2102 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2104 SvREFCNT_dec(PL_encoding);
2105 if (SvOK(sv) || SvGMAGICAL(sv)) {
2106 PL_encoding = newSVsv(sv);
2109 PL_encoding = Nullsv;
2113 case '\006': /* ^F */
2114 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2116 case '\010': /* ^H */
2117 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2119 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2121 Safefree(PL_inplace);
2123 PL_inplace = savesvpv(sv);
2125 PL_inplace = Nullch;
2127 case '\017': /* ^O */
2128 if (*(mg->mg_ptr+1) == '\0') {
2130 Safefree(PL_osname);
2134 TAINT_PROPER("assigning to $^O");
2135 PL_osname = savesvpv(sv);
2138 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2139 if (!PL_compiling.cop_io)
2140 PL_compiling.cop_io = newSVsv(sv);
2142 sv_setsv(PL_compiling.cop_io,sv);
2145 case '\020': /* ^P */
2146 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2147 if (PL_perldb && !PL_DBsingle)
2150 case '\024': /* ^T */
2152 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2154 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2157 case '\027': /* ^W & $^WARNING_BITS */
2158 if (*(mg->mg_ptr+1) == '\0') {
2159 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2160 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2161 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2162 | (i ? G_WARN_ON : G_WARN_OFF) ;
2165 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2166 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2167 if (!SvPOK(sv) && PL_localizing) {
2168 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2169 PL_compiling.cop_warnings = pWARN_NONE;
2174 int accumulate = 0 ;
2175 int any_fatals = 0 ;
2176 const char * const ptr = (char*)SvPV(sv, len) ;
2177 for (i = 0 ; i < len ; ++i) {
2178 accumulate |= ptr[i] ;
2179 any_fatals |= (ptr[i] & 0xAA) ;
2182 PL_compiling.cop_warnings = pWARN_NONE;
2183 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2184 PL_compiling.cop_warnings = pWARN_ALL;
2185 PL_dowarn |= G_WARN_ONCE ;
2188 if (specialWARN(PL_compiling.cop_warnings))
2189 PL_compiling.cop_warnings = newSVsv(sv) ;
2191 sv_setsv(PL_compiling.cop_warnings, sv);
2192 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2193 PL_dowarn |= G_WARN_ONCE ;
2201 if (PL_localizing) {
2202 if (PL_localizing == 1)
2203 SAVESPTR(PL_last_in_gv);
2205 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2206 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2209 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2210 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2211 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2214 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2215 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2216 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2219 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2222 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2223 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2224 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2227 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2231 IO *io = GvIOp(PL_defoutgv);
2234 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2235 IoFLAGS(io) &= ~IOf_FLUSH;
2237 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2238 PerlIO *ofp = IoOFP(io);
2240 (void)PerlIO_flush(ofp);
2241 IoFLAGS(io) |= IOf_FLUSH;
2247 SvREFCNT_dec(PL_rs);
2248 PL_rs = newSVsv(sv);
2252 SvREFCNT_dec(PL_ors_sv);
2253 if (SvOK(sv) || SvGMAGICAL(sv)) {
2254 PL_ors_sv = newSVsv(sv);
2262 SvREFCNT_dec(PL_ofs_sv);
2263 if (SvOK(sv) || SvGMAGICAL(sv)) {
2264 PL_ofs_sv = newSVsv(sv);
2273 PL_ofmt = savesvpv(sv);
2276 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2279 #ifdef COMPLEX_STATUS
2280 if (PL_localizing == 2) {
2281 PL_statusvalue = LvTARGOFF(sv);
2282 PL_statusvalue_vms = LvTARGLEN(sv);
2286 #ifdef VMSISH_STATUS
2288 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2291 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2296 # define PERL_VMS_BANG vaxc$errno
2298 # define PERL_VMS_BANG 0
2300 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2301 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2305 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2306 if (PL_delaymagic) {
2307 PL_delaymagic |= DM_RUID;
2308 break; /* don't do magic till later */
2311 (void)setruid((Uid_t)PL_uid);
2314 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2316 #ifdef HAS_SETRESUID
2317 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2319 if (PL_uid == PL_euid) { /* special case $< = $> */
2321 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2322 if (PL_uid != 0 && PerlProc_getuid() == 0)
2323 (void)PerlProc_setuid(0);
2325 (void)PerlProc_setuid(PL_uid);
2327 PL_uid = PerlProc_getuid();
2328 Perl_croak(aTHX_ "setruid() not implemented");
2333 PL_uid = PerlProc_getuid();
2334 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2337 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2338 if (PL_delaymagic) {
2339 PL_delaymagic |= DM_EUID;
2340 break; /* don't do magic till later */
2343 (void)seteuid((Uid_t)PL_euid);
2346 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2348 #ifdef HAS_SETRESUID
2349 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2351 if (PL_euid == PL_uid) /* special case $> = $< */
2352 PerlProc_setuid(PL_euid);
2354 PL_euid = PerlProc_geteuid();
2355 Perl_croak(aTHX_ "seteuid() not implemented");
2360 PL_euid = PerlProc_geteuid();
2361 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2364 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2365 if (PL_delaymagic) {
2366 PL_delaymagic |= DM_RGID;
2367 break; /* don't do magic till later */
2370 (void)setrgid((Gid_t)PL_gid);
2373 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2375 #ifdef HAS_SETRESGID
2376 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2378 if (PL_gid == PL_egid) /* special case $( = $) */
2379 (void)PerlProc_setgid(PL_gid);
2381 PL_gid = PerlProc_getgid();
2382 Perl_croak(aTHX_ "setrgid() not implemented");
2387 PL_gid = PerlProc_getgid();
2388 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2391 #ifdef HAS_SETGROUPS
2393 const char *p = SvPV(sv, len);
2394 Groups_t gary[NGROUPS];
2399 for (i = 0; i < NGROUPS; ++i) {
2400 while (*p && !isSPACE(*p))
2409 (void)setgroups(i, gary);
2411 #else /* HAS_SETGROUPS */
2412 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2413 #endif /* HAS_SETGROUPS */
2414 if (PL_delaymagic) {
2415 PL_delaymagic |= DM_EGID;
2416 break; /* don't do magic till later */
2419 (void)setegid((Gid_t)PL_egid);
2422 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2424 #ifdef HAS_SETRESGID
2425 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2427 if (PL_egid == PL_gid) /* special case $) = $( */
2428 (void)PerlProc_setgid(PL_egid);
2430 PL_egid = PerlProc_getegid();
2431 Perl_croak(aTHX_ "setegid() not implemented");
2436 PL_egid = PerlProc_getegid();
2437 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2440 PL_chopset = SvPV_force(sv,len);
2442 #ifndef MACOS_TRADITIONAL
2444 LOCK_DOLLARZERO_MUTEX;
2445 #ifdef HAS_SETPROCTITLE
2446 /* The BSDs don't show the argv[] in ps(1) output, they
2447 * show a string from the process struct and provide
2448 * the setproctitle() routine to manipulate that. */
2451 # if __FreeBSD_version > 410001
2452 /* The leading "-" removes the "perl: " prefix,
2453 * but not the "(perl) suffix from the ps(1)
2454 * output, because that's what ps(1) shows if the
2455 * argv[] is modified. */
2456 setproctitle("-%s", s);
2457 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2458 /* This doesn't really work if you assume that
2459 * $0 = 'foobar'; will wipe out 'perl' from the $0
2460 * because in ps(1) output the result will be like
2461 * sprintf("perl: %s (perl)", s)
2462 * I guess this is a security feature:
2463 * one (a user process) cannot get rid of the original name.
2465 setproctitle("%s", s);
2469 #if defined(__hpux) && defined(PSTAT_SETCMD)
2473 un.pst_command = (char *)s;
2474 pstat(PSTAT_SETCMD, un, len, 0, 0);
2477 /* PL_origalen is set in perl_parse(). */
2478 s = SvPV_force(sv,len);
2479 if (len >= (STRLEN)PL_origalen-1) {
2480 /* Longer than original, will be truncated. We assume that
2481 * PL_origalen bytes are available. */
2482 Copy(s, PL_origargv[0], PL_origalen-1, char);
2485 /* Shorter than original, will be padded. */
2486 Copy(s, PL_origargv[0], len, char);
2487 PL_origargv[0][len] = 0;
2488 memset(PL_origargv[0] + len + 1,
2489 /* Is the space counterintuitive? Yes.
2490 * (You were expecting \0?)
2491 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2494 PL_origalen - len - 1);
2496 PL_origargv[0][PL_origalen-1] = 0;
2497 for (i = 1; i < PL_origargc; i++)
2499 UNLOCK_DOLLARZERO_MUTEX;
2507 Perl_whichsig(pTHX_ const char *sig)
2509 register char* const* sigv;
2511 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2512 if (strEQ(sig,*sigv))
2513 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2515 if (strEQ(sig,"CHLD"))
2519 if (strEQ(sig,"CLD"))
2526 Perl_sighandler(int sig)
2528 #ifdef PERL_GET_SIG_CONTEXT
2529 dTHXa(PERL_GET_SIG_CONTEXT);
2536 SV *sv = Nullsv, *tSv = PL_Sv;
2542 if (PL_savestack_ix + 15 <= PL_savestack_max)
2544 if (PL_markstack_ptr < PL_markstack_max - 2)
2546 if (PL_scopestack_ix < PL_scopestack_max - 3)
2549 if (!PL_psig_ptr[sig]) {
2550 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2555 /* Max number of items pushed there is 3*n or 4. We cannot fix
2556 infinity, so we fix 4 (in fact 5): */
2558 PL_savestack_ix += 5; /* Protect save in progress. */
2559 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2562 PL_markstack_ptr++; /* Protect mark. */
2564 PL_scopestack_ix += 1;
2565 /* sv_2cv is too complicated, try a simpler variant first: */
2566 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2567 || SvTYPE(cv) != SVt_PVCV)
2568 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2570 if (!cv || !CvROOT(cv)) {
2571 if (ckWARN(WARN_SIGNAL))
2572 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2573 PL_sig_name[sig], (gv ? GvENAME(gv)
2580 if(PL_psig_name[sig]) {
2581 sv = SvREFCNT_inc(PL_psig_name[sig]);
2583 #if !defined(PERL_IMPLICIT_CONTEXT)
2587 sv = sv_newmortal();
2588 sv_setpv(sv,PL_sig_name[sig]);
2591 PUSHSTACKi(PERLSI_SIGNAL);
2596 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2599 if (SvTRUE(ERRSV)) {
2601 #ifdef HAS_SIGPROCMASK
2602 /* Handler "died", for example to get out of a restart-able read().
2603 * Before we re-do that on its behalf re-enable the signal which was
2604 * blocked by the system when we entered.
2608 sigaddset(&set,sig);
2609 sigprocmask(SIG_UNBLOCK, &set, NULL);
2611 /* Not clear if this will work */
2612 (void)rsignal(sig, SIG_IGN);
2613 (void)rsignal(sig, PL_csighandlerp);
2615 #endif /* !PERL_MICRO */
2620 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2624 PL_scopestack_ix -= 1;
2627 PL_op = myop; /* Apparently not needed... */
2629 PL_Sv = tSv; /* Restore global temporaries. */
2636 restore_magic(pTHX_ const void *p)
2638 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2639 SV* sv = mgs->mgs_sv;
2644 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2646 #ifdef PERL_COPY_ON_WRITE
2647 /* While magic was saved (and off) sv_setsv may well have seen
2648 this SV as a prime candidate for COW. */
2650 sv_force_normal(sv);
2654 SvFLAGS(sv) |= mgs->mgs_flags;
2658 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2661 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2663 /* If we're still on top of the stack, pop us off. (That condition
2664 * will be satisfied if restore_magic was called explicitly, but *not*
2665 * if it's being called via leave_scope.)
2666 * The reason for doing this is that otherwise, things like sv_2cv()
2667 * may leave alloc gunk on the savestack, and some code
2668 * (e.g. sighandler) doesn't expect that...
2670 if (PL_savestack_ix == mgs->mgs_ss_ix)
2672 I32 popval = SSPOPINT;
2673 assert(popval == SAVEt_DESTRUCTOR_X);
2674 PL_savestack_ix -= 2;
2676 assert(popval == SAVEt_ALLOC);
2678 PL_savestack_ix -= popval;
2684 unwind_handler_stack(pTHX_ const void *p)
2687 const U32 flags = *(const U32*)p;
2690 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2691 /* cxstack_ix-- Not needed, die already unwound it. */
2692 #if !defined(PERL_IMPLICIT_CONTEXT)
2694 SvREFCNT_dec(PL_sig_sv);
2700 * c-indentation-style: bsd
2702 * indent-tabs-mode: t
2705 * ex: set ts=8 sts=4 sw=4 noet: