3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Sam sat on the ground and put his head in his hands. 'I wish I had never
13 * come here, and I don't want to see no more magic,' he said, and fell silent."
17 =head1 Magical Functions
19 "Magic" is special data attached to SV structures in order to give them
20 "magical" properties. When any Perl code tries to read from, or assign to,
21 an SV marked as magical, it calls the 'get' or 'set' function associated
22 with that SV's magic. A get is called prior to reading an SV, in order to
23 give it a chance to update its internal value (get on $. writes the line
24 number of the last read filehandle into to the SV's IV slot), while
25 set is called after an SV has been written to, in order to allow it to make
26 use of its changed value (set on $/ copies the SV's new value to the
27 PL_rs global variable).
29 Magic is implemented as a linked list of MAGIC structures attached to the
30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
31 of functions that implement the get(), set(), length() etc functions,
32 plus space for some flags and pointers. For example, a tied variable has
33 a MAGIC structure that contains a pointer to the object associated with the
42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
52 # include <sys/pstat.h>
55 Signal_t Perl_csighandler(int sig);
57 static void restore_magic(pTHX_ const void *p);
58 static void unwind_handler_stack(pTHX_ const void *p);
61 /* Missing protos on LynxOS */
62 void setruid(uid_t id);
63 void seteuid(uid_t id);
64 void setrgid(uid_t id);
65 void setegid(uid_t id);
69 * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
77 /* MGS is typedef'ed to struct magic_state in perl.h */
80 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
83 assert(SvMAGICAL(sv));
84 #ifdef PERL_OLD_COPY_ON_WRITE
85 /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
90 SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
92 mgs = SSPTR(mgs_ix, MGS*);
94 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
95 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
99 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
103 =for apidoc mg_magical
105 Turns on the magical status of an SV. See C<sv_magic>.
111 Perl_mg_magical(pTHX_ SV *sv)
114 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
115 const MGVTBL* const vtbl = mg->mg_virtual;
117 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
121 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
130 Do magic after a value is retrieved from the SV. See C<sv_magic>.
136 Perl_mg_get(pTHX_ SV *sv)
138 const I32 mgs_ix = SSNEW(sizeof(MGS));
139 const bool was_temp = (bool)SvTEMP(sv);
141 MAGIC *newmg, *head, *cur, *mg;
142 /* guard against sv having being freed midway by holding a private
145 /* sv_2mortal has this side effect of turning on the TEMP flag, which can
146 cause the SV's buffer to get stolen (and maybe other stuff).
149 sv_2mortal(SvREFCNT_inc(sv));
154 save_magic(mgs_ix, sv);
156 /* We must call svt_get(sv, mg) for each valid entry in the linked
157 list of magic. svt_get() may delete the current entry, add new
158 magic to the head of the list, or upgrade the SV. AMS 20010810 */
160 newmg = cur = head = mg = SvMAGIC(sv);
162 const MGVTBL * const vtbl = mg->mg_virtual;
164 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
165 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
167 /* guard against magic having been deleted - eg FETCH calling
172 /* Don't restore the flags for this entry if it was deleted. */
173 if (mg->mg_flags & MGf_GSKIP)
174 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
177 mg = mg->mg_moremagic;
180 /* Have we finished with the new entries we saw? Start again
181 where we left off (unless there are more new entries). */
189 /* Were any new entries added? */
190 if (!have_new && (newmg = SvMAGIC(sv)) != head) {
197 restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
199 if (SvREFCNT(sv) == 1) {
200 /* We hold the last reference to this SV, which implies that the
201 SV was deleted as a side effect of the routines we called. */
210 Do magic after a value is assigned to the SV. See C<sv_magic>.
216 Perl_mg_set(pTHX_ SV *sv)
218 const I32 mgs_ix = SSNEW(sizeof(MGS));
222 save_magic(mgs_ix, sv);
224 for (mg = SvMAGIC(sv); mg; mg = nextmg) {
225 const MGVTBL* vtbl = mg->mg_virtual;
226 nextmg = mg->mg_moremagic; /* it may delete itself */
227 if (mg->mg_flags & MGf_GSKIP) {
228 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
229 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
231 if (vtbl && vtbl->svt_set)
232 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
235 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
240 =for apidoc mg_length
242 Report on the SV's length. See C<sv_magic>.
248 Perl_mg_length(pTHX_ SV *sv)
253 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
254 const MGVTBL * const vtbl = mg->mg_virtual;
255 if (vtbl && vtbl->svt_len) {
256 const I32 mgs_ix = SSNEW(sizeof(MGS));
257 save_magic(mgs_ix, sv);
258 /* omit MGf_GSKIP -- not changed here */
259 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
260 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
266 const U8 *s = (U8*)SvPV_const(sv, len);
267 len = Perl_utf8_length(aTHX_ s, s + len);
270 (void)SvPV_const(sv, len);
275 Perl_mg_size(pTHX_ SV *sv)
279 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
280 const MGVTBL* const vtbl = mg->mg_virtual;
281 if (vtbl && vtbl->svt_len) {
282 const I32 mgs_ix = SSNEW(sizeof(MGS));
284 save_magic(mgs_ix, sv);
285 /* omit MGf_GSKIP -- not changed here */
286 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
287 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
294 return AvFILLp((AV *) sv); /* Fallback to non-tied array */
298 Perl_croak(aTHX_ "Size magic not implemented");
307 Clear something magical that the SV represents. See C<sv_magic>.
313 Perl_mg_clear(pTHX_ SV *sv)
315 const I32 mgs_ix = SSNEW(sizeof(MGS));
318 save_magic(mgs_ix, sv);
320 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
321 const MGVTBL* const vtbl = mg->mg_virtual;
322 /* omit GSKIP -- never set here */
324 if (vtbl && vtbl->svt_clear)
325 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
328 restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
335 Finds the magic pointer for type matching the SV. See C<sv_magic>.
341 Perl_mg_find(pTHX_ const SV *sv, int type)
345 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
346 if (mg->mg_type == type)
356 Copies the magic from one SV to another. See C<sv_magic>.
362 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
366 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
367 const MGVTBL* const vtbl = mg->mg_virtual;
368 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
369 count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
371 else if (isUPPER(mg->mg_type)) {
373 mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
374 (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
376 toLOWER(mg->mg_type), key, klen);
386 Free any magic storage used by the SV. See C<sv_magic>.
392 Perl_mg_free(pTHX_ SV *sv)
396 for (mg = SvMAGIC(sv); mg; mg = moremagic) {
397 const MGVTBL* const vtbl = mg->mg_virtual;
398 moremagic = mg->mg_moremagic;
399 if (vtbl && vtbl->svt_free)
400 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
401 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
402 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
403 Safefree(mg->mg_ptr);
404 else if (mg->mg_len == HEf_SVKEY)
405 SvREFCNT_dec((SV*)mg->mg_ptr);
407 if (mg->mg_flags & MGf_REFCOUNTED)
408 SvREFCNT_dec(mg->mg_obj);
411 SvMAGIC_set(sv, NULL);
418 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
420 register const REGEXP *rx;
423 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
424 if (mg->mg_obj) /* @+ */
427 return rx->lastparen;
434 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
438 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
439 register const I32 paren = mg->mg_len;
444 if (paren <= (I32)rx->nparens &&
445 (s = rx->startp[paren]) != -1 &&
446 (t = rx->endp[paren]) != -1)
449 if (mg->mg_obj) /* @+ */
454 if (i > 0 && RX_MATCH_UTF8(rx)) {
455 char *b = rx->subbeg;
457 i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
467 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
470 Perl_croak(aTHX_ PL_no_modify);
471 NORETURN_FUNCTION_END;
475 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
479 register const REGEXP *rx;
482 switch (*mg->mg_ptr) {
483 case '1': case '2': case '3': case '4':
484 case '5': case '6': case '7': case '8': case '9': case '&':
485 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
487 paren = atoi(mg->mg_ptr); /* $& is in [0] */
489 if (paren <= (I32)rx->nparens &&
490 (s1 = rx->startp[paren]) != -1 &&
491 (t1 = rx->endp[paren]) != -1)
495 if (i > 0 && RX_MATCH_UTF8(rx)) {
496 const char * const s = rx->subbeg + s1;
501 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
505 Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
509 if (ckWARN(WARN_UNINITIALIZED))
514 if (ckWARN(WARN_UNINITIALIZED))
519 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
520 paren = rx->lastparen;
525 case '\016': /* ^N */
526 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
527 paren = rx->lastcloseparen;
533 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
534 if (rx->startp[0] != -1) {
545 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
546 if (rx->endp[0] != -1) {
547 i = rx->sublen - rx->endp[0];
558 if (!SvPOK(sv) && SvNIOK(sv)) {
566 #define SvRTRIM(sv) STMT_START { \
567 STRLEN len = SvCUR(sv); \
568 while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
570 SvCUR_set(sv, len); \
574 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
578 register char *s = NULL;
582 switch (*mg->mg_ptr) {
583 case '\001': /* ^A */
584 sv_setsv(sv, PL_bodytarget);
586 case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
587 if (*(mg->mg_ptr+1) == '\0') {
588 sv_setiv(sv, (IV)PL_minus_c);
590 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
591 sv_setiv(sv, (IV)STATUS_NATIVE);
595 case '\004': /* ^D */
596 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
598 case '\005': /* ^E */
599 if (*(mg->mg_ptr+1) == '\0') {
600 #ifdef MACOS_TRADITIONAL
604 sv_setnv(sv,(double)gMacPerl_OSErr);
605 sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
610 # include <descrip.h>
611 # include <starlet.h>
613 $DESCRIPTOR(msgdsc,msg);
614 sv_setnv(sv,(NV) vaxc$errno);
615 if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
616 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
622 if (!(_emx_env & 0x200)) { /* Under DOS */
623 sv_setnv(sv, (NV)errno);
624 sv_setpv(sv, errno ? Strerror(errno) : "");
626 if (errno != errno_isOS2) {
627 int tmp = _syserrno();
628 if (tmp) /* 2nd call to _syserrno() makes it 0 */
631 sv_setnv(sv, (NV)Perl_rc);
632 sv_setpv(sv, os2error(Perl_rc));
637 DWORD dwErr = GetLastError();
638 sv_setnv(sv, (NV)dwErr);
641 PerlProc_GetOSError(sv, dwErr);
644 sv_setpvn(sv, "", 0);
649 int saveerrno = errno;
650 sv_setnv(sv, (NV)errno);
651 sv_setpv(sv, errno ? Strerror(errno) : "");
659 SvNOK_on(sv); /* what a wonderful hack! */
661 else if (strEQ(mg->mg_ptr+1, "NCODING"))
662 sv_setsv(sv, PL_encoding);
664 case '\006': /* ^F */
665 sv_setiv(sv, (IV)PL_maxsysfd);
667 case '\010': /* ^H */
668 sv_setiv(sv, (IV)PL_hints);
670 case '\011': /* ^I */ /* NOT \t in EBCDIC */
672 sv_setpv(sv, PL_inplace);
674 sv_setsv(sv, &PL_sv_undef);
676 case '\017': /* ^O & ^OPEN */
677 if (*(mg->mg_ptr+1) == '\0') {
678 sv_setpv(sv, PL_osname);
681 else if (strEQ(mg->mg_ptr, "\017PEN")) {
682 if (!PL_compiling.cop_io)
683 sv_setsv(sv, &PL_sv_undef);
685 sv_setsv(sv, PL_compiling.cop_io);
689 case '\020': /* ^P */
690 sv_setiv(sv, (IV)PL_perldb);
692 case '\023': /* ^S */
693 if (*(mg->mg_ptr+1) == '\0') {
694 if (PL_lex_state != LEX_NOTPARSING)
697 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
702 case '\024': /* ^T */
703 if (*(mg->mg_ptr+1) == '\0') {
705 sv_setnv(sv, PL_basetime);
707 sv_setiv(sv, (IV)PL_basetime);
710 else if (strEQ(mg->mg_ptr, "\024AINT"))
711 sv_setiv(sv, PL_tainting
712 ? (PL_taint_warn || PL_unsafe ? -1 : 1)
715 case '\025': /* $^UNICODE, $^UTF8LOCALE */
716 if (strEQ(mg->mg_ptr, "\025NICODE"))
717 sv_setuv(sv, (UV) PL_unicode);
718 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
719 sv_setuv(sv, (UV) PL_utf8locale);
721 case '\027': /* ^W & $^WARNING_BITS */
722 if (*(mg->mg_ptr+1) == '\0')
723 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
724 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
725 if (PL_compiling.cop_warnings == pWARN_NONE ||
726 PL_compiling.cop_warnings == pWARN_STD)
728 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
730 else if (PL_compiling.cop_warnings == pWARN_ALL) {
731 /* Get the bit mask for $warnings::Bits{all}, because
732 * it could have been extended by warnings::register */
734 HV *bits=get_hv("warnings::Bits", FALSE);
735 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
736 sv_setsv(sv, *bits_all);
739 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
743 sv_setsv(sv, PL_compiling.cop_warnings);
748 case '1': case '2': case '3': case '4':
749 case '5': case '6': case '7': case '8': case '9': case '&':
750 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
754 * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
755 * XXX Does the new way break anything?
757 paren = atoi(mg->mg_ptr); /* $& is in [0] */
759 if (paren <= (I32)rx->nparens &&
760 (s1 = rx->startp[paren]) != -1 &&
761 (t1 = rx->endp[paren]) != -1)
771 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
776 if (RX_MATCH_TAINTED(rx)) {
777 MAGIC* mg = SvMAGIC(sv);
780 SvMAGIC_set(sv, mg->mg_moremagic);
782 if ((mgt = SvMAGIC(sv))) {
783 mg->mg_moremagic = mgt;
793 sv_setsv(sv,&PL_sv_undef);
796 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
797 paren = rx->lastparen;
801 sv_setsv(sv,&PL_sv_undef);
803 case '\016': /* ^N */
804 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
805 paren = rx->lastcloseparen;
809 sv_setsv(sv,&PL_sv_undef);
812 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
813 if ((s = rx->subbeg) && rx->startp[0] != -1) {
818 sv_setsv(sv,&PL_sv_undef);
821 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
822 if (rx->subbeg && rx->endp[0] != -1) {
823 s = rx->subbeg + rx->endp[0];
824 i = rx->sublen - rx->endp[0];
828 sv_setsv(sv,&PL_sv_undef);
831 if (GvIO(PL_last_in_gv)) {
832 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
837 sv_setiv(sv, (IV)STATUS_CURRENT);
838 #ifdef COMPLEX_STATUS
839 LvTARGOFF(sv) = PL_statusvalue;
840 LvTARGLEN(sv) = PL_statusvalue_vms;
845 if (GvIOp(PL_defoutgv))
846 s = IoTOP_NAME(GvIOp(PL_defoutgv));
850 sv_setpv(sv,GvENAME(PL_defoutgv));
855 if (GvIOp(PL_defoutgv))
856 s = IoFMT_NAME(GvIOp(PL_defoutgv));
858 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)));
878 WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
881 if (GvIOp(PL_defoutgv))
882 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
888 sv_copypv(sv, PL_ors_sv);
892 sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
893 sv_setpv(sv, errno ? Strerror(errno) : "");
896 int saveerrno = errno;
897 sv_setnv(sv, (NV)errno);
899 if (errno == errno_isOS2 || errno == errno_isOS2_set)
900 sv_setpv(sv, os2error(Perl_rc));
903 sv_setpv(sv, errno ? Strerror(errno) : "");
908 SvNOK_on(sv); /* what a wonderful hack! */
911 sv_setiv(sv, (IV)PL_uid);
914 sv_setiv(sv, (IV)PL_euid);
917 sv_setiv(sv, (IV)PL_gid);
919 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
923 sv_setiv(sv, (IV)PL_egid);
925 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
930 Groups_t gary[NGROUPS];
931 I32 j = getgroups(NGROUPS,gary);
933 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
936 (void)SvIOK_on(sv); /* what a wonderful hack! */
938 #ifndef MACOS_TRADITIONAL
947 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
949 struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
951 if (uf && uf->uf_val)
952 (*uf->uf_val)(aTHX_ uf->uf_index, sv);
957 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
964 s = SvPV_const(sv,len);
965 ptr = MgPV_const(mg,klen);
968 #ifdef DYNAMIC_ENV_FETCH
969 /* We just undefd an environment var. Is a replacement */
970 /* waiting in the wings? */
973 if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
974 s = SvPV_const(*valp, len);
978 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
979 /* And you'll never guess what the dog had */
980 /* in its mouth... */
982 MgTAINTEDDIR_off(mg);
984 if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
985 char pathbuf[256], eltbuf[256], *cp, *elt = s;
989 do { /* DCL$PATH may be a search list */
990 while (1) { /* as may dev portion of any element */
991 if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
992 if ( *(cp+1) == '.' || *(cp+1) == '-' ||
993 cando_by_name(S_IWUSR,0,elt) ) {
998 if ((cp = strchr(elt, ':')) != Nullch)
1000 if (my_trnlnm(elt, eltbuf, j++))
1006 } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1009 if (s && klen == 4 && strEQ(ptr,"PATH")) {
1010 const char *strend = s + len;
1012 while (s < strend) {
1016 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1017 s, strend, ':', &i);
1019 if (i >= sizeof tmpbuf /* too long -- assume the worst */
1021 || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1022 MgTAINTEDDIR_on(mg);
1028 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1034 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1037 my_setenv(MgPV_nolen_const(mg),Nullch);
1042 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1044 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1045 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1047 if (PL_localizing) {
1049 magic_clear_all_env(sv,mg);
1050 hv_iterinit((HV*)sv);
1051 while ((entry = hv_iternext((HV*)sv))) {
1053 my_setenv(hv_iterkey(entry, &keylen),
1054 SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1062 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1066 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1067 Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1069 # if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1072 # ifdef USE_ENVIRON_ARRAY
1073 # if defined(USE_ITHREADS)
1074 /* only the parent thread can clobber the process environment */
1075 if (PL_curinterp == aTHX)
1078 # ifndef PERL_USE_SAFE_PUTENV
1079 if (!PL_use_safe_putenv) {
1082 if (environ == PL_origenviron)
1083 environ = (char**)safesysmalloc(sizeof(char*));
1085 for (i = 0; environ[i]; i++)
1086 safesysfree(environ[i]);
1088 # endif /* PERL_USE_SAFE_PUTENV */
1090 environ[0] = Nullch;
1092 # endif /* USE_ENVIRON_ARRAY */
1093 # endif /* PERL_IMPLICIT_SYS || WIN32 */
1094 #endif /* VMS || EPOC */
1095 #endif /* !PERL_MICRO */
1102 #ifdef HAS_SIGPROCMASK
1104 restore_sigmask(pTHX_ SV *save_sv)
1106 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1107 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1111 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1114 /* Are we fetching a signal entry? */
1115 i = whichsig(MgPV_nolen_const(mg));
1118 sv_setsv(sv,PL_psig_ptr[i]);
1120 Sighandler_t sigstate;
1121 sigstate = rsignal_state(i);
1122 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1123 if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1125 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1126 if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1128 /* cache state so we don't fetch it again */
1129 if(sigstate == SIG_IGN)
1130 sv_setpv(sv,"IGNORE");
1132 sv_setsv(sv,&PL_sv_undef);
1133 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1140 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1142 /* XXX Some of this code was copied from Perl_magic_setsig. A little
1143 * refactoring might be in order.
1146 register const char *s = MgPV_nolen_const(mg);
1150 if (strEQ(s,"__DIE__"))
1152 else if (strEQ(s,"__WARN__"))
1155 Perl_croak(aTHX_ "No such hook: %s", s);
1159 SvREFCNT_dec(to_dec);
1164 /* Are we clearing a signal entry? */
1167 #ifdef HAS_SIGPROCMASK
1170 /* Avoid having the signal arrive at a bad time, if possible. */
1173 sigprocmask(SIG_BLOCK, &set, &save);
1175 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1176 SAVEFREESV(save_sv);
1177 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1180 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1181 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1183 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1184 PL_sig_defaulting[i] = 1;
1185 (void)rsignal(i, PL_csighandlerp);
1187 (void)rsignal(i, SIG_DFL);
1189 if(PL_psig_name[i]) {
1190 SvREFCNT_dec(PL_psig_name[i]);
1193 if(PL_psig_ptr[i]) {
1194 SV *to_dec=PL_psig_ptr[i];
1197 SvREFCNT_dec(to_dec);
1207 S_raise_signal(pTHX_ int sig)
1209 /* Set a flag to say this signal is pending */
1210 PL_psig_pend[sig]++;
1211 /* And one to say _a_ signal is pending */
1216 Perl_csighandler(int sig)
1218 #ifdef PERL_GET_SIG_CONTEXT
1219 dTHXa(PERL_GET_SIG_CONTEXT);
1223 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1224 (void) rsignal(sig, PL_csighandlerp);
1225 if (PL_sig_ignoring[sig]) return;
1227 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1228 if (PL_sig_defaulting[sig])
1229 #ifdef KILL_BY_SIGPRC
1230 exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1235 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1236 /* Call the perl level handler now--
1237 * with risk we may be in malloc() etc. */
1238 (*PL_sighandlerp)(sig);
1240 S_raise_signal(aTHX_ sig);
1243 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1245 Perl_csighandler_init(void)
1248 if (PL_sig_handlers_initted) return;
1250 for (sig = 1; sig < SIG_SIZE; sig++) {
1251 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1253 PL_sig_defaulting[sig] = 1;
1254 (void) rsignal(sig, PL_csighandlerp);
1256 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1257 PL_sig_ignoring[sig] = 0;
1260 PL_sig_handlers_initted = 1;
1265 Perl_despatch_signals(pTHX)
1269 for (sig = 1; sig < SIG_SIZE; sig++) {
1270 if (PL_psig_pend[sig]) {
1271 PERL_BLOCKSIG_ADD(set, sig);
1272 PL_psig_pend[sig] = 0;
1273 PERL_BLOCKSIG_BLOCK(set);
1274 (*PL_sighandlerp)(sig);
1275 PERL_BLOCKSIG_UNBLOCK(set);
1281 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1286 /* Need to be careful with SvREFCNT_dec(), because that can have side
1287 * effects (due to closures). We must make sure that the new disposition
1288 * is in place before it is called.
1292 #ifdef HAS_SIGPROCMASK
1297 register const char *s = MgPV_const(mg,len);
1299 if (strEQ(s,"__DIE__"))
1301 else if (strEQ(s,"__WARN__"))
1304 Perl_croak(aTHX_ "No such hook: %s", s);
1312 i = whichsig(s); /* ...no, a brick */
1314 if (ckWARN(WARN_SIGNAL))
1315 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1318 #ifdef HAS_SIGPROCMASK
1319 /* Avoid having the signal arrive at a bad time, if possible. */
1322 sigprocmask(SIG_BLOCK, &set, &save);
1324 save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1325 SAVEFREESV(save_sv);
1326 SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1329 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1330 if (!PL_sig_handlers_initted) Perl_csighandler_init();
1332 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1333 PL_sig_ignoring[i] = 0;
1335 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1336 PL_sig_defaulting[i] = 0;
1338 SvREFCNT_dec(PL_psig_name[i]);
1339 to_dec = PL_psig_ptr[i];
1340 PL_psig_ptr[i] = SvREFCNT_inc(sv);
1341 SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1342 PL_psig_name[i] = newSVpvn(s, len);
1343 SvREADONLY_on(PL_psig_name[i]);
1345 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1347 (void)rsignal(i, PL_csighandlerp);
1348 #ifdef HAS_SIGPROCMASK
1353 *svp = SvREFCNT_inc(sv);
1355 SvREFCNT_dec(to_dec);
1358 s = SvPV_force(sv,len);
1359 if (strEQ(s,"IGNORE")) {
1361 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1362 PL_sig_ignoring[i] = 1;
1363 (void)rsignal(i, PL_csighandlerp);
1365 (void)rsignal(i, SIG_IGN);
1369 else if (strEQ(s,"DEFAULT") || !*s) {
1371 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1373 PL_sig_defaulting[i] = 1;
1374 (void)rsignal(i, PL_csighandlerp);
1377 (void)rsignal(i, SIG_DFL);
1382 * We should warn if HINT_STRICT_REFS, but without
1383 * access to a known hint bit in a known OP, we can't
1384 * tell whether HINT_STRICT_REFS is in force or not.
1386 if (!strchr(s,':') && !strchr(s,'\''))
1387 sv_insert(sv, 0, 0, "main::", 6);
1389 (void)rsignal(i, PL_csighandlerp);
1391 *svp = SvREFCNT_inc(sv);
1393 #ifdef HAS_SIGPROCMASK
1398 SvREFCNT_dec(to_dec);
1401 #endif /* !PERL_MICRO */
1404 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1408 PL_sub_generation++;
1413 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1417 /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1418 PL_amagic_generation++;
1424 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1426 HV * const hv = (HV*)LvTARG(sv);
1431 (void) hv_iterinit(hv);
1432 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1435 while (hv_iternext(hv))
1440 sv_setiv(sv, (IV)i);
1445 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1449 hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1454 /* caller is responsible for stack switching/cleanup */
1456 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1462 PUSHs(SvTIED_obj(sv, mg));
1465 if (mg->mg_len >= 0)
1466 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1467 else if (mg->mg_len == HEf_SVKEY)
1468 PUSHs((SV*)mg->mg_ptr);
1470 else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1471 PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1479 return call_method(meth, flags);
1483 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1489 PUSHSTACKi(PERLSI_MAGIC);
1491 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1492 sv_setsv(sv, *PL_stack_sp--);
1502 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1505 mg->mg_flags |= MGf_GSKIP;
1506 magic_methpack(sv,mg,"FETCH");
1511 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1515 PUSHSTACKi(PERLSI_MAGIC);
1516 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1523 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1525 return magic_methpack(sv,mg,"DELETE");
1530 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1537 PUSHSTACKi(PERLSI_MAGIC);
1538 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1539 sv = *PL_stack_sp--;
1540 retval = (U32) SvIV(sv)-1;
1549 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1554 PUSHSTACKi(PERLSI_MAGIC);
1556 XPUSHs(SvTIED_obj(sv, mg));
1558 call_method("CLEAR", G_SCALAR|G_DISCARD);
1566 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1569 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1573 PUSHSTACKi(PERLSI_MAGIC);
1576 PUSHs(SvTIED_obj(sv, mg));
1581 if (call_method(meth, G_SCALAR))
1582 sv_setsv(key, *PL_stack_sp--);
1591 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1593 return magic_methpack(sv,mg,"EXISTS");
1597 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1600 SV *retval = &PL_sv_undef;
1601 SV *tied = SvTIED_obj((SV*)hv, mg);
1602 HV *pkg = SvSTASH((SV*)SvRV(tied));
1604 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1606 if (HvEITER_get(hv))
1607 /* we are in an iteration so the hash cannot be empty */
1609 /* no xhv_eiter so now use FIRSTKEY */
1610 key = sv_newmortal();
1611 magic_nextpack((SV*)hv, mg, key);
1612 HvEITER_set(hv, NULL); /* need to reset iterator */
1613 return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1616 /* there is a SCALAR method that we can call */
1618 PUSHSTACKi(PERLSI_MAGIC);
1624 if (call_method("SCALAR", G_SCALAR))
1625 retval = *PL_stack_sp--;
1632 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1641 svp = av_fetch(GvAV(gv),
1642 atoi(MgPV_nolen_const(mg)), 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 AV *obj = (AV*)mg->mg_obj;
1658 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1666 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1668 AV *obj = (AV*)mg->mg_obj;
1670 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1672 if (ckWARN(WARN_MISC))
1673 Perl_warner(aTHX_ packWARN(WARN_MISC),
1674 "Attempt to set length of freed array");
1680 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1682 PERL_UNUSED_ARG(sv);
1683 /* during global destruction, mg_obj may already have been freed */
1684 if (PL_in_clean_all)
1687 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1690 /* arylen scalar holds a pointer back to the array, but doesn't own a
1691 reference. Hence the we (the array) are about to go away with it
1692 still pointing at us. Clear its pointer, else it would be pointing
1693 at free memory. See the comment in sv_magic about reference loops,
1694 and why it can't own a reference to us. */
1701 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1703 SV* lsv = LvTARG(sv);
1705 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1706 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1707 if (mg && mg->mg_len >= 0) {
1710 sv_pos_b2u(lsv, &i);
1711 sv_setiv(sv, i + PL_curcop->cop_arybase);
1720 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1722 SV* lsv = LvTARG(sv);
1729 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1730 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1734 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1735 mg = mg_find(lsv, PERL_MAGIC_regex_global);
1737 else if (!SvOK(sv)) {
1741 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1743 pos = SvIV(sv) - PL_curcop->cop_arybase;
1746 ulen = sv_len_utf8(lsv);
1756 else if (pos > (SSize_t)len)
1761 sv_pos_u2b(lsv, &p, 0);
1766 mg->mg_flags &= ~MGf_MINMATCH;
1772 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1775 if (SvFAKE(sv)) { /* FAKE globs can get coerced */
1777 gv_efullname3(sv,((GV*)sv), "*");
1781 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
1786 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1793 gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1798 GvGP(sv) = gp_ref(GvGP(gv));
1803 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1806 SV * const lsv = LvTARG(sv);
1807 const char * const tmps = SvPV_const(lsv,len);
1808 I32 offs = LvTARGOFF(sv);
1809 I32 rem = LvTARGLEN(sv);
1813 sv_pos_u2b(lsv, &offs, &rem);
1814 if (offs > (I32)len)
1816 if (rem + offs > (I32)len)
1818 sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1825 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1828 const char *tmps = SvPV_const(sv, len);
1829 SV * const lsv = LvTARG(sv);
1830 I32 lvoff = LvTARGOFF(sv);
1831 I32 lvlen = LvTARGLEN(sv);
1835 sv_utf8_upgrade(lsv);
1836 sv_pos_u2b(lsv, &lvoff, &lvlen);
1837 sv_insert(lsv, lvoff, lvlen, tmps, len);
1838 LvTARGLEN(sv) = sv_len_utf8(sv);
1841 else if (lsv && SvUTF8(lsv)) {
1842 sv_pos_u2b(lsv, &lvoff, &lvlen);
1843 LvTARGLEN(sv) = len;
1844 tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1845 sv_insert(lsv, lvoff, lvlen, tmps, len);
1849 sv_insert(lsv, lvoff, lvlen, tmps, len);
1850 LvTARGLEN(sv) = len;
1858 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1860 TAINT_IF((mg->mg_len & 1) ||
1861 ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
1866 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1869 if (PL_localizing) {
1870 if (PL_localizing == 1)
1875 else if (PL_tainted)
1883 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1885 SV * const lsv = LvTARG(sv);
1893 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1898 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1901 do_vecset(sv); /* XXX slurp this routine */
1906 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1909 if (LvTARGLEN(sv)) {
1911 SV *ahv = LvTARG(sv);
1912 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1917 AV* av = (AV*)LvTARG(sv);
1918 if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1919 targ = AvARRAY(av)[LvTARGOFF(sv)];
1921 if (targ && targ != &PL_sv_undef) {
1922 /* somebody else defined it for us */
1923 SvREFCNT_dec(LvTARG(sv));
1924 LvTARG(sv) = SvREFCNT_inc(targ);
1926 SvREFCNT_dec(mg->mg_obj);
1927 mg->mg_obj = Nullsv;
1928 mg->mg_flags &= ~MGf_REFCOUNTED;
1933 sv_setsv(sv, targ ? targ : &PL_sv_undef);
1938 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1944 sv_setsv(LvTARG(sv), sv);
1945 SvSETMAGIC(LvTARG(sv));
1951 Perl_vivify_defelem(pTHX_ SV *sv)
1956 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1959 SV *ahv = LvTARG(sv);
1960 HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1963 if (!value || value == &PL_sv_undef)
1964 Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
1967 AV* av = (AV*)LvTARG(sv);
1968 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1969 LvTARG(sv) = Nullsv; /* array can't be extended */
1971 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1972 if (!svp || (value = *svp) == &PL_sv_undef)
1973 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1976 (void)SvREFCNT_inc(value);
1977 SvREFCNT_dec(LvTARG(sv));
1980 SvREFCNT_dec(mg->mg_obj);
1981 mg->mg_obj = Nullsv;
1982 mg->mg_flags &= ~MGf_REFCOUNTED;
1986 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1988 AV *av = (AV*)mg->mg_obj;
1989 SV **svp = AvARRAY(av);
1990 I32 i = AvFILLp(av);
1995 if (!SvWEAKREF(svp[i]))
1996 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1997 /* XXX Should we check that it hasn't changed? */
1998 SvRV_set(svp[i], 0);
2000 SvWEAKREF_off(svp[i]);
2005 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2010 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2018 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2021 sv_unmagic(sv, PERL_MAGIC_bm);
2027 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2030 sv_unmagic(sv, PERL_MAGIC_fm);
2036 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2038 const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2040 if (uf && uf->uf_set)
2041 (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2046 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2049 sv_unmagic(sv, PERL_MAGIC_qr);
2054 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2056 regexp *re = (regexp *)mg->mg_obj;
2062 #ifdef USE_LOCALE_COLLATE
2064 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2067 * RenE<eacute> Descartes said "I think not."
2068 * and vanished with a faint plop.
2072 Safefree(mg->mg_ptr);
2078 #endif /* USE_LOCALE_COLLATE */
2080 /* Just clear the UTF-8 cache data. */
2082 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2085 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
2087 mg->mg_len = -1; /* The mg_len holds the len cache. */
2092 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2094 register const char *s;
2097 switch (*mg->mg_ptr) {
2098 case '\001': /* ^A */
2099 sv_setsv(PL_bodytarget, sv);
2101 case '\003': /* ^C */
2102 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2105 case '\004': /* ^D */
2107 s = SvPV_nolen_const(sv);
2108 PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2109 DEBUG_x(dump_all());
2111 PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2114 case '\005': /* ^E */
2115 if (*(mg->mg_ptr+1) == '\0') {
2116 #ifdef MACOS_TRADITIONAL
2117 gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2120 set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2123 SetLastError( SvIV(sv) );
2126 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2128 /* will anyone ever use this? */
2129 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2135 else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2137 SvREFCNT_dec(PL_encoding);
2138 if (SvOK(sv) || SvGMAGICAL(sv)) {
2139 PL_encoding = newSVsv(sv);
2142 PL_encoding = Nullsv;
2146 case '\006': /* ^F */
2147 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2149 case '\010': /* ^H */
2150 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2152 case '\011': /* ^I */ /* NOT \t in EBCDIC */
2154 Safefree(PL_inplace);
2156 PL_inplace = savesvpv(sv);
2158 PL_inplace = Nullch;
2160 case '\017': /* ^O */
2161 if (*(mg->mg_ptr+1) == '\0') {
2163 Safefree(PL_osname);
2167 TAINT_PROPER("assigning to $^O");
2168 PL_osname = savesvpv(sv);
2171 else if (strEQ(mg->mg_ptr, "\017PEN")) {
2172 if (!PL_compiling.cop_io)
2173 PL_compiling.cop_io = newSVsv(sv);
2175 sv_setsv(PL_compiling.cop_io,sv);
2178 case '\020': /* ^P */
2179 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2180 if (PL_perldb && !PL_DBsingle)
2183 case '\024': /* ^T */
2185 PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2187 PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2190 case '\027': /* ^W & $^WARNING_BITS */
2191 if (*(mg->mg_ptr+1) == '\0') {
2192 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2193 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2194 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2195 | (i ? G_WARN_ON : G_WARN_OFF) ;
2198 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2199 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2200 if (!SvPOK(sv) && PL_localizing) {
2201 sv_setpvn(sv, WARN_NONEstring, WARNsize);
2202 PL_compiling.cop_warnings = pWARN_NONE;
2207 int accumulate = 0 ;
2208 int any_fatals = 0 ;
2209 const char * const ptr = SvPV_const(sv, len) ;
2210 for (i = 0 ; i < len ; ++i) {
2211 accumulate |= ptr[i] ;
2212 any_fatals |= (ptr[i] & 0xAA) ;
2215 PL_compiling.cop_warnings = pWARN_NONE;
2216 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2217 PL_compiling.cop_warnings = pWARN_ALL;
2218 PL_dowarn |= G_WARN_ONCE ;
2221 if (specialWARN(PL_compiling.cop_warnings))
2222 PL_compiling.cop_warnings = newSVsv(sv) ;
2224 sv_setsv(PL_compiling.cop_warnings, sv);
2225 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2226 PL_dowarn |= G_WARN_ONCE ;
2234 if (PL_localizing) {
2235 if (PL_localizing == 1)
2236 SAVESPTR(PL_last_in_gv);
2238 else if (SvOK(sv) && GvIO(PL_last_in_gv))
2239 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2242 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2243 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2244 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2247 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2248 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2249 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2252 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2255 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2256 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2257 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2260 IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2264 IO *io = GvIOp(PL_defoutgv);
2267 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2268 IoFLAGS(io) &= ~IOf_FLUSH;
2270 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2271 PerlIO *ofp = IoOFP(io);
2273 (void)PerlIO_flush(ofp);
2274 IoFLAGS(io) |= IOf_FLUSH;
2280 SvREFCNT_dec(PL_rs);
2281 PL_rs = newSVsv(sv);
2285 SvREFCNT_dec(PL_ors_sv);
2286 if (SvOK(sv) || SvGMAGICAL(sv)) {
2287 PL_ors_sv = newSVsv(sv);
2295 SvREFCNT_dec(PL_ofs_sv);
2296 if (SvOK(sv) || SvGMAGICAL(sv)) {
2297 PL_ofs_sv = newSVsv(sv);
2304 PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2307 #ifdef COMPLEX_STATUS
2308 if (PL_localizing == 2) {
2309 PL_statusvalue = LvTARGOFF(sv);
2310 PL_statusvalue_vms = LvTARGLEN(sv);
2314 #ifdef VMSISH_STATUS
2316 STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2319 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2324 # define PERL_VMS_BANG vaxc$errno
2326 # define PERL_VMS_BANG 0
2328 SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2329 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2333 PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2334 if (PL_delaymagic) {
2335 PL_delaymagic |= DM_RUID;
2336 break; /* don't do magic till later */
2339 (void)setruid((Uid_t)PL_uid);
2342 (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2344 #ifdef HAS_SETRESUID
2345 (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2347 if (PL_uid == PL_euid) { /* special case $< = $> */
2349 /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2350 if (PL_uid != 0 && PerlProc_getuid() == 0)
2351 (void)PerlProc_setuid(0);
2353 (void)PerlProc_setuid(PL_uid);
2355 PL_uid = PerlProc_getuid();
2356 Perl_croak(aTHX_ "setruid() not implemented");
2361 PL_uid = PerlProc_getuid();
2362 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2365 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2366 if (PL_delaymagic) {
2367 PL_delaymagic |= DM_EUID;
2368 break; /* don't do magic till later */
2371 (void)seteuid((Uid_t)PL_euid);
2374 (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2376 #ifdef HAS_SETRESUID
2377 (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2379 if (PL_euid == PL_uid) /* special case $> = $< */
2380 PerlProc_setuid(PL_euid);
2382 PL_euid = PerlProc_geteuid();
2383 Perl_croak(aTHX_ "seteuid() not implemented");
2388 PL_euid = PerlProc_geteuid();
2389 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2392 PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2393 if (PL_delaymagic) {
2394 PL_delaymagic |= DM_RGID;
2395 break; /* don't do magic till later */
2398 (void)setrgid((Gid_t)PL_gid);
2401 (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2403 #ifdef HAS_SETRESGID
2404 (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2406 if (PL_gid == PL_egid) /* special case $( = $) */
2407 (void)PerlProc_setgid(PL_gid);
2409 PL_gid = PerlProc_getgid();
2410 Perl_croak(aTHX_ "setrgid() not implemented");
2415 PL_gid = PerlProc_getgid();
2416 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2419 #ifdef HAS_SETGROUPS
2421 const char *p = SvPV_const(sv, len);
2422 Groups_t gary[NGROUPS];
2427 for (i = 0; i < NGROUPS; ++i) {
2428 while (*p && !isSPACE(*p))
2437 (void)setgroups(i, gary);
2439 #else /* HAS_SETGROUPS */
2440 PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2441 #endif /* HAS_SETGROUPS */
2442 if (PL_delaymagic) {
2443 PL_delaymagic |= DM_EGID;
2444 break; /* don't do magic till later */
2447 (void)setegid((Gid_t)PL_egid);
2450 (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2452 #ifdef HAS_SETRESGID
2453 (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2455 if (PL_egid == PL_gid) /* special case $) = $( */
2456 (void)PerlProc_setgid(PL_egid);
2458 PL_egid = PerlProc_getegid();
2459 Perl_croak(aTHX_ "setegid() not implemented");
2464 PL_egid = PerlProc_getegid();
2465 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2468 PL_chopset = SvPV_force(sv,len);
2470 #ifndef MACOS_TRADITIONAL
2472 LOCK_DOLLARZERO_MUTEX;
2473 #ifdef HAS_SETPROCTITLE
2474 /* The BSDs don't show the argv[] in ps(1) output, they
2475 * show a string from the process struct and provide
2476 * the setproctitle() routine to manipulate that. */
2478 s = SvPV_const(sv, len);
2479 # if __FreeBSD_version > 410001
2480 /* The leading "-" removes the "perl: " prefix,
2481 * but not the "(perl) suffix from the ps(1)
2482 * output, because that's what ps(1) shows if the
2483 * argv[] is modified. */
2484 setproctitle("-%s", s);
2485 # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2486 /* This doesn't really work if you assume that
2487 * $0 = 'foobar'; will wipe out 'perl' from the $0
2488 * because in ps(1) output the result will be like
2489 * sprintf("perl: %s (perl)", s)
2490 * I guess this is a security feature:
2491 * one (a user process) cannot get rid of the original name.
2493 setproctitle("%s", s);
2497 #if defined(__hpux) && defined(PSTAT_SETCMD)
2500 s = SvPV_const(sv, len);
2501 un.pst_command = (char *)s;
2502 pstat(PSTAT_SETCMD, un, len, 0, 0);
2505 /* PL_origalen is set in perl_parse(). */
2506 s = SvPV_force(sv,len);
2507 if (len >= (STRLEN)PL_origalen-1) {
2508 /* Longer than original, will be truncated. We assume that
2509 * PL_origalen bytes are available. */
2510 Copy(s, PL_origargv[0], PL_origalen-1, char);
2513 /* Shorter than original, will be padded. */
2514 Copy(s, PL_origargv[0], len, char);
2515 PL_origargv[0][len] = 0;
2516 memset(PL_origargv[0] + len + 1,
2517 /* Is the space counterintuitive? Yes.
2518 * (You were expecting \0?)
2519 * Does it work? Seems to. (In Linux 2.4.20 at least.)
2522 PL_origalen - len - 1);
2524 PL_origargv[0][PL_origalen-1] = 0;
2525 for (i = 1; i < PL_origargc; i++)
2527 UNLOCK_DOLLARZERO_MUTEX;
2535 Perl_whichsig(pTHX_ const char *sig)
2537 register char* const* sigv;
2539 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2540 if (strEQ(sig,*sigv))
2541 return PL_sig_num[sigv - (char* const*)PL_sig_name];
2543 if (strEQ(sig,"CHLD"))
2547 if (strEQ(sig,"CLD"))
2554 Perl_sighandler(int sig)
2556 #ifdef PERL_GET_SIG_CONTEXT
2557 dTHXa(PERL_GET_SIG_CONTEXT);
2564 SV *sv = Nullsv, *tSv = PL_Sv;
2570 if (PL_savestack_ix + 15 <= PL_savestack_max)
2572 if (PL_markstack_ptr < PL_markstack_max - 2)
2574 if (PL_scopestack_ix < PL_scopestack_max - 3)
2577 if (!PL_psig_ptr[sig]) {
2578 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2583 /* Max number of items pushed there is 3*n or 4. We cannot fix
2584 infinity, so we fix 4 (in fact 5): */
2586 PL_savestack_ix += 5; /* Protect save in progress. */
2587 SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2590 PL_markstack_ptr++; /* Protect mark. */
2592 PL_scopestack_ix += 1;
2593 /* sv_2cv is too complicated, try a simpler variant first: */
2594 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2595 || SvTYPE(cv) != SVt_PVCV)
2596 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2598 if (!cv || !CvROOT(cv)) {
2599 if (ckWARN(WARN_SIGNAL))
2600 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2601 PL_sig_name[sig], (gv ? GvENAME(gv)
2608 if(PL_psig_name[sig]) {
2609 sv = SvREFCNT_inc(PL_psig_name[sig]);
2611 #if !defined(PERL_IMPLICIT_CONTEXT)
2615 sv = sv_newmortal();
2616 sv_setpv(sv,PL_sig_name[sig]);
2619 PUSHSTACKi(PERLSI_SIGNAL);
2624 call_sv((SV*)cv, G_DISCARD|G_EVAL);
2627 if (SvTRUE(ERRSV)) {
2629 #ifdef HAS_SIGPROCMASK
2630 /* Handler "died", for example to get out of a restart-able read().
2631 * Before we re-do that on its behalf re-enable the signal which was
2632 * blocked by the system when we entered.
2636 sigaddset(&set,sig);
2637 sigprocmask(SIG_UNBLOCK, &set, NULL);
2639 /* Not clear if this will work */
2640 (void)rsignal(sig, SIG_IGN);
2641 (void)rsignal(sig, PL_csighandlerp);
2643 #endif /* !PERL_MICRO */
2648 PL_savestack_ix -= 8; /* Unprotect save in progress. */
2652 PL_scopestack_ix -= 1;
2655 PL_op = myop; /* Apparently not needed... */
2657 PL_Sv = tSv; /* Restore global temporaries. */
2664 restore_magic(pTHX_ const void *p)
2666 MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2667 SV* sv = mgs->mgs_sv;
2672 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2674 #ifdef PERL_OLD_COPY_ON_WRITE
2675 /* While magic was saved (and off) sv_setsv may well have seen
2676 this SV as a prime candidate for COW. */
2678 sv_force_normal(sv);
2682 SvFLAGS(sv) |= mgs->mgs_flags;
2686 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2689 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
2691 /* If we're still on top of the stack, pop us off. (That condition
2692 * will be satisfied if restore_magic was called explicitly, but *not*
2693 * if it's being called via leave_scope.)
2694 * The reason for doing this is that otherwise, things like sv_2cv()
2695 * may leave alloc gunk on the savestack, and some code
2696 * (e.g. sighandler) doesn't expect that...
2698 if (PL_savestack_ix == mgs->mgs_ss_ix)
2700 I32 popval = SSPOPINT;
2701 assert(popval == SAVEt_DESTRUCTOR_X);
2702 PL_savestack_ix -= 2;
2704 assert(popval == SAVEt_ALLOC);
2706 PL_savestack_ix -= popval;
2712 unwind_handler_stack(pTHX_ const void *p)
2715 const U32 flags = *(const U32*)p;
2718 PL_savestack_ix -= 5; /* Unprotect save in progress. */
2719 /* cxstack_ix-- Not needed, die already unwound it. */
2720 #if !defined(PERL_IMPLICIT_CONTEXT)
2722 SvREFCNT_dec(PL_sig_sv);
2728 * c-indentation-style: bsd
2730 * indent-tabs-mode: t
2733 * ex: set ts=8 sts=4 sw=4 noet: