/* mg.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, * 2000, 2001, 2002, 2003, 2004, 2005 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * */ /* * "Sam sat on the ground and put his head in his hands. 'I wish I had never * come here, and I don't want to see no more magic,' he said, and fell silent." */ /* =head1 Magical Functions "Magic" is special data attached to SV structures in order to give them "magical" properties. When any Perl code tries to read from, or assign to, an SV marked as magical, it calls the 'get' or 'set' function associated with that SV's magic. A get is called prior to reading an SV, in order to give it a chance to update its internal value (get on $. writes the line number of the last read filehandle into to the SV's IV slot), while set is called after an SV has been written to, in order to allow it to make use of its changed value (set on $/ copies the SV's new value to the PL_rs global variable). Magic is implemented as a linked list of MAGIC structures attached to the SV. Each MAGIC struct holds the type of the magic, a pointer to an array of functions that implement the get(), set(), length() etc functions, plus space for some flags and pointers. For example, a tied variable has a MAGIC structure that contains a pointer to the object associated with the tie. */ #include "EXTERN.h" #define PERL_IN_MG_C #include "perl.h" #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) # ifndef NGROUPS # define NGROUPS 32 # endif # ifdef I_GRP # include # endif #endif #ifdef __hpux # include #endif Signal_t Perl_csighandler(int sig); #ifdef __Lynx__ /* Missing protos on LynxOS */ void setruid(uid_t id); void seteuid(uid_t id); void setrgid(uid_t id); void setegid(uid_t id); #endif /* * Use the "DESTRUCTOR" scope cleanup to reinstate magic. */ struct magic_state { SV* mgs_sv; U32 mgs_flags; I32 mgs_ss_ix; }; /* MGS is typedef'ed to struct magic_state in perl.h */ STATIC void S_save_magic(pTHX_ I32 mgs_ix, SV *sv) 17620145 { 17620145 MGS* mgs; 17620145 assert(SvMAGICAL(sv)); #ifdef PERL_OLD_COPY_ON_WRITE /* Turning READONLY off for a copy-on-write scalar is a bad idea. */ if (SvIsCOW(sv)) sv_force_normal(sv); #endif 17620145 SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix)); 17620145 mgs = SSPTR(mgs_ix, MGS*); 17620145 mgs->mgs_sv = sv; 17620145 mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); 17620145 mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ 17620145 SvMAGICAL_off(sv); 17620145 SvREADONLY_off(sv); 17620145 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT; } /* =for apidoc mg_magical Turns on the magical status of an SV. See C. =cut */ void Perl_mg_magical(pTHX_ SV *sv) 11067776 { 11067776 const MAGIC* mg; 22246477 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 11178701 const MGVTBL* const vtbl = mg->mg_virtual; 11178701 if (vtbl) { 11147340 if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) 5377901 SvGMAGICAL_on(sv); 11147340 if (vtbl->svt_set) 6803382 SvSMAGICAL_on(sv); 11147340 if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear) 4958457 SvRMAGICAL_on(sv); } } } /* =for apidoc mg_get Do magic after a value is retrieved from the SV. See C. =cut */ int Perl_mg_get(pTHX_ SV *sv) 10635393 { 10635393 const I32 mgs_ix = SSNEW(sizeof(MGS)); 10635393 const bool was_temp = (bool)SvTEMP(sv); 10635393 int have_new = 0; 10635393 MAGIC *newmg, *head, *cur, *mg; /* guard against sv having being freed midway by holding a private reference. */ /* sv_2mortal has this side effect of turning on the TEMP flag, which can cause the SV's buffer to get stolen (and maybe other stuff). So restore it. */ 10635393 sv_2mortal(SvREFCNT_inc(sv)); 10635393 if (!was_temp) { 10635393 SvTEMP_off(sv); } 10635393 save_magic(mgs_ix, sv); /* We must call svt_get(sv, mg) for each valid entry in the linked list of magic. svt_get() may delete the current entry, add new magic to the head of the list, or upgrade the SV. AMS 20010810 */ 10635393 newmg = cur = head = mg = SvMAGIC(sv); 21281687 while (mg) { 10646309 const MGVTBL * const vtbl = mg->mg_virtual; 10646309 if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { 10635910 CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg); /* guard against magic having been deleted - eg FETCH calling * untie */ 10635900 if (!SvMAGIC(sv)) 5 break; /* Don't restore the flags for this entry if it was deleted. */ 10635895 if (mg->mg_flags & MGf_GSKIP) 115214 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0; } 10646294 mg = mg->mg_moremagic; 10646294 if (have_new) { /* Have we finished with the new entries we saw? Start again where we left off (unless there are more new entries). */ 3 if (mg == head) { 3 have_new = 0; 3 mg = cur; 3 head = newmg; } } /* Were any new entries added? */ 10646294 if (!have_new && (newmg = SvMAGIC(sv)) != head) { 3 have_new = 1; 3 cur = mg; 3 mg = newmg; } } 10635383 restore_magic(INT2PTR(void *, (IV)mgs_ix)); 10635383 if (SvREFCNT(sv) == 1) { /* We hold the last reference to this SV, which implies that the SV was deleted as a side effect of the routines we called. */ 1 SvOK_off(sv); } 10635383 return 0; } /* =for apidoc mg_set Do magic after a value is assigned to the SV. See C. =cut */ int Perl_mg_set(pTHX_ SV *sv) 6818369 { 6818369 const I32 mgs_ix = SSNEW(sizeof(MGS)); 6818369 MAGIC* mg; 6818369 MAGIC* nextmg; 6818369 save_magic(mgs_ix, sv); 13075198 for (mg = SvMAGIC(sv); mg; mg = nextmg) { 6256846 const MGVTBL* vtbl = mg->mg_virtual; 6256846 nextmg = mg->mg_moremagic; /* it may delete itself */ 6256846 if (mg->mg_flags & MGf_GSKIP) { 40 mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ 40 (SSPTR(mgs_ix, MGS*))->mgs_flags = 0; } 6256846 if (vtbl && vtbl->svt_set) 6256830 CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg); } 6818352 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 6818352 return 0; } /* =for apidoc mg_length Report on the SV's length. See C. =cut */ U32 Perl_mg_length(pTHX_ SV *sv) 9846 { 9846 MAGIC* mg; 9846 STRLEN len; 9856 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 9846 const MGVTBL * const vtbl = mg->mg_virtual; 9846 if (vtbl && vtbl->svt_len) { 9836 const I32 mgs_ix = SSNEW(sizeof(MGS)); 9836 save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ 9836 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); 9836 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 9836 return len; } } 10 if (DO_UTF8(sv)) { 1 const U8 *s = (U8*)SvPV_const(sv, len); 1 len = Perl_utf8_length(aTHX_ s, s + len); } else 9 (void)SvPV_const(sv, len); 10 return len; } I32 Perl_mg_size(pTHX_ SV *sv) 713638 { 713638 MAGIC* mg; 1427018 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 713764 const MGVTBL* const vtbl = mg->mg_virtual; 713764 if (vtbl && vtbl->svt_len) { 384 const I32 mgs_ix = SSNEW(sizeof(MGS)); 384 I32 len; 384 save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ 384 len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); 384 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 384 return len; } } 713254 switch(SvTYPE(sv)) { case SVt_PVAV: 713254 return AvFILLp((AV *) sv); /* Fallback to non-tied array */ case SVt_PVHV: /* FIXME */ default: ###### Perl_croak(aTHX_ "Size magic not implemented"); 713638 break; } 713638 return 0; } /* =for apidoc mg_clear Clear something magical that the SV represents. See C. =cut */ int Perl_mg_clear(pTHX_ SV *sv) 156163 { 156163 const I32 mgs_ix = SSNEW(sizeof(MGS)); 156163 MAGIC* mg; 156163 save_magic(mgs_ix, sv); 175623 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 19464 const MGVTBL* const vtbl = mg->mg_virtual; /* omit GSKIP -- never set here */ 19464 if (vtbl && vtbl->svt_clear) 14021 CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg); } 156159 restore_magic(INT2PTR(void*, (IV)mgs_ix)); 156159 return 0; } /* =for apidoc mg_find Finds the magic pointer for type matching the SV. See C. =cut */ MAGIC* Perl_mg_find(pTHX_ const SV *sv, int type) 69226344 { 69226344 if (sv) { 69224331 MAGIC *mg; 134640296 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 86004774 if (mg->mg_type == type) 20588809 return mg; } } 48637535 return 0; } /* =for apidoc mg_copy Copies the magic from one SV to another. See C. =cut */ int Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) 475343 { 475343 int count = 0; 475343 MAGIC* mg; 951114 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 475771 const MGVTBL* const vtbl = mg->mg_virtual; 475771 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){ ###### count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen); } 475771 else if (isUPPER(mg->mg_type)) { 475343 sv_magic(nsv, mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) : (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj) ? sv : mg->mg_obj, toLOWER(mg->mg_type), key, klen); 475343 count++; } } 475343 return count; } /* =for apidoc mg_localize Copy some of the magic from an existing SV to new localized version of that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg taint, pos). =cut */ void Perl_mg_localize(pTHX_ SV *sv, SV *nsv) 237502 { 237502 MAGIC *mg; 480380 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 242878 const MGVTBL* const vtbl = mg->mg_virtual; 242878 switch (mg->mg_type) { /* value magic types: don't copy */ case PERL_MAGIC_bm: case PERL_MAGIC_fm: case PERL_MAGIC_regex_global: case PERL_MAGIC_nkeys: #ifdef USE_LOCALE_COLLATE case PERL_MAGIC_collxfrm: #endif case PERL_MAGIC_qr: case PERL_MAGIC_taint: case PERL_MAGIC_vec: case PERL_MAGIC_vstring: case PERL_MAGIC_utf8: case PERL_MAGIC_substr: case PERL_MAGIC_defelem: case PERL_MAGIC_arylen: case PERL_MAGIC_pos: case PERL_MAGIC_backref: case PERL_MAGIC_arylen_p: case PERL_MAGIC_rhash: case PERL_MAGIC_symtab: 229745 continue; } 229745 if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) { /* XXX calling the copy method is probably not correct. DAPM */ ###### (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, mg->mg_ptr, mg->mg_len); } else { 229745 sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl, mg->mg_ptr, mg->mg_len); } /* container types should remain read-only across localization */ 229745 SvFLAGS(nsv) |= SvREADONLY(sv); } 237502 if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { 229745 SvFLAGS(nsv) |= SvMAGICAL(sv); 229745 PL_localizing = 1; 229745 SvSETMAGIC(nsv); 229745 PL_localizing = 0; } } /* =for apidoc mg_free Free any magic storage used by the SV. See C. =cut */ int Perl_mg_free(pTHX_ SV *sv) 6816818 { 6816818 MAGIC* mg; 6816818 MAGIC* moremagic; 13670909 for (mg = SvMAGIC(sv); mg; mg = moremagic) { 6854091 const MGVTBL* const vtbl = mg->mg_virtual; 6854091 moremagic = mg->mg_moremagic; 6854091 if (vtbl && vtbl->svt_free) 183865 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); 6854091 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { 824206 if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8) 682926 Safefree(mg->mg_ptr); 141280 else if (mg->mg_len == HEf_SVKEY) 141280 SvREFCNT_dec((SV*)mg->mg_ptr); } 6854091 if (mg->mg_flags & MGf_REFCOUNTED) 281471 SvREFCNT_dec(mg->mg_obj); 6854091 Safefree(mg); } 6816818 SvMAGIC_set(sv, NULL); 6816818 return 0; } #include U32 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) 40 { 40 register const REGEXP *rx; 40 PERL_UNUSED_ARG(sv); 40 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 38 if (mg->mg_obj) /* @+ */ 18 return rx->nparens; else /* @- */ 20 return rx->lastparen; } 2 return (U32)-1; } int Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) 1888 { 1888 register REGEXP *rx; 1888 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 1888 register const I32 paren = mg->mg_len; 1888 register I32 s; 1888 register I32 t; 1888 if (paren < 0) ###### return 0; 1888 if (paren <= (I32)rx->nparens && (s = rx->startp[paren]) != -1 && (t = rx->endp[paren]) != -1) { 1852 register I32 i; 1852 if (mg->mg_obj) /* @+ */ 629 i = t; else /* @- */ 1223 i = s; 1852 if (i > 0 && RX_MATCH_UTF8(rx)) { ###### const char * const b = rx->subbeg; ###### if (b) ###### i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i)); } 1852 sv_setiv(sv, i); } } 1888 return 0; } int Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) 2 { 2 PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg); 2 Perl_croak(aTHX_ PL_no_modify); NORETURN_FUNCTION_END; } U32 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) 9836 { 9836 register I32 paren; 9836 register I32 i; 9836 register const REGEXP *rx; 9836 I32 s1, t1; 9836 switch (*mg->mg_ptr) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': 9832 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 9831 paren = atoi(mg->mg_ptr); /* $& is in [0] */ getparen: 9831 if (paren <= (I32)rx->nparens && (s1 = rx->startp[paren]) != -1 && (t1 = rx->endp[paren]) != -1) { 9830 i = t1 - s1; getlen: 9832 if (i > 0 && RX_MATCH_UTF8(rx)) { 7 const char * const s = rx->subbeg + s1; 7 const U8 *ep; 7 STRLEN el; 7 i = t1 - s1; 7 if (is_utf8_string_loclen((U8*)s, i, &ep, &el)) 7 i = el; } 9832 if (i < 0) ###### Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i); 9832 return i; } else { 1 if (ckWARN(WARN_UNINITIALIZED)) 1 report_uninit(sv); } } else { 1 if (ckWARN(WARN_UNINITIALIZED)) 1 report_uninit(sv); } 2 return 0; case '+': ###### if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { ###### paren = rx->lastparen; ###### if (paren) ###### goto getparen; } ###### return 0; case '\016': /* ^N */ ###### if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { ###### paren = rx->lastcloseparen; ###### if (paren) ###### goto getparen; } ###### return 0; case '`': 1 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 1 if (rx->startp[0] != -1) { 1 i = rx->startp[0]; 1 if (i > 0) { 1 s1 = 0; 1 t1 = i; 1 goto getlen; } } } ###### return 0; case '\'': 1 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 1 if (rx->endp[0] != -1) { 1 i = rx->sublen - rx->endp[0]; 1 if (i > 0) { 1 s1 = rx->endp[0]; 1 t1 = rx->sublen; 1 goto getlen; } } } ###### return 0; } 2 magic_get(sv,mg); 2 if (!SvPOK(sv) && SvNIOK(sv)) { ###### sv_2pv(sv, 0); } 2 if (SvPOK(sv)) 2 return SvCUR(sv); ###### return 0; } #define SvRTRIM(sv) STMT_START { \ STRLEN len = SvCUR(sv); \ while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \ --len; \ SvCUR_set(sv, len); \ } STMT_END int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 4591256 { dVAR; 4591256 register I32 paren; 4591256 register char *s = NULL; 4591256 register I32 i; 4591256 register REGEXP *rx; 4591256 switch (*mg->mg_ptr) { case '\001': /* ^A */ 85 sv_setsv(sv, PL_bodytarget); 85 break; case '\003': /* ^C, ^CHILD_ERROR_NATIVE */ 15873 if (*(mg->mg_ptr+1) == '\0') { 15870 sv_setiv(sv, (IV)PL_minus_c); } 3 else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) { 3 sv_setiv(sv, (IV)STATUS_NATIVE); } 3 break; case '\004': /* ^D */ 71769 sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); 71769 break; case '\005': /* ^E */ 159 if (*(mg->mg_ptr+1) == '\0') { #ifdef MACOS_TRADITIONAL { char msg[256]; sv_setnv(sv,(double)gMacPerl_OSErr); sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); } #else #ifdef VMS { # include # include char msg[255]; $DESCRIPTOR(msgdsc,msg); sv_setnv(sv,(NV) vaxc$errno); if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1) sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length); else sv_setpvn(sv,"",0); } #else #ifdef OS2 if (!(_emx_env & 0x200)) { /* Under DOS */ sv_setnv(sv, (NV)errno); sv_setpv(sv, errno ? Strerror(errno) : ""); } else { if (errno != errno_isOS2) { int tmp = _syserrno(); if (tmp) /* 2nd call to _syserrno() makes it 0 */ Perl_rc = tmp; } sv_setnv(sv, (NV)Perl_rc); sv_setpv(sv, os2error(Perl_rc)); } #else #ifdef WIN32 { DWORD dwErr = GetLastError(); sv_setnv(sv, (NV)dwErr); if (dwErr) { PerlProc_GetOSError(sv, dwErr); } else sv_setpvn(sv, "", 0); SetLastError(dwErr); } #else { 2 const int saveerrno = errno; 2 sv_setnv(sv, (NV)errno); 2 sv_setpv(sv, errno ? Strerror(errno) : ""); 2 errno = saveerrno; } #endif #endif #endif #endif 2 SvRTRIM(sv); 2 SvNOK_on(sv); /* what a wonderful hack! */ } 157 else if (strEQ(mg->mg_ptr+1, "NCODING")) 157 sv_setsv(sv, PL_encoding); 157 break; case '\006': /* ^F */ 25 sv_setiv(sv, (IV)PL_maxsysfd); 25 break; case '\010': /* ^H */ 54747 sv_setiv(sv, (IV)PL_hints); 54747 break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ 13 if (PL_inplace) 9 sv_setpv(sv, PL_inplace); else 4 sv_setsv(sv, &PL_sv_undef); 4 break; case '\017': /* ^O & ^OPEN */ 66009 if (*(mg->mg_ptr+1) == '\0') { 65991 sv_setpv(sv, PL_osname); 65991 SvTAINTED_off(sv); } 18 else if (strEQ(mg->mg_ptr, "\017PEN")) { 18 if (!PL_compiling.cop_io) 11 sv_setsv(sv, &PL_sv_undef); else { 7 sv_setsv(sv, PL_compiling.cop_io); } } 7 break; case '\020': /* ^P */ 419 sv_setiv(sv, (IV)PL_perldb); 419 break; case '\023': /* ^S */ 14 if (*(mg->mg_ptr+1) == '\0') { 14 if (PL_lex_state != LEX_NOTPARSING) 1 SvOK_off(sv); 13 else if (PL_in_eval) 6 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); else 7 sv_setiv(sv, 0); } 7 break; case '\024': /* ^T */ 970 if (*(mg->mg_ptr+1) == '\0') { #ifdef BIG_TIME sv_setnv(sv, PL_basetime); #else 335 sv_setiv(sv, (IV)PL_basetime); #endif } 635 else if (strEQ(mg->mg_ptr, "\024AINT")) 635 sv_setiv(sv, PL_tainting ? (PL_taint_warn || PL_unsafe ? -1 : 1) : 0); 635 break; case '\025': /* $^UNICODE, $^UTF8LOCALE */ 31 if (strEQ(mg->mg_ptr, "\025NICODE")) 30 sv_setuv(sv, (UV) PL_unicode); 1 else if (strEQ(mg->mg_ptr, "\025TF8LOCALE")) 1 sv_setuv(sv, (UV) PL_utf8locale); 1 break; case '\027': /* ^W & $^WARNING_BITS */ 31882 if (*(mg->mg_ptr+1) == '\0') 21911 sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); 9971 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { 9971 if (PL_compiling.cop_warnings == pWARN_NONE || PL_compiling.cop_warnings == pWARN_STD) { 5412 sv_setpvn(sv, WARN_NONEstring, WARNsize) ; } 4559 else if (PL_compiling.cop_warnings == pWARN_ALL) { /* Get the bit mask for $warnings::Bits{all}, because * it could have been extended by warnings::register */ 3574 SV **bits_all; 3574 HV *bits=get_hv("warnings::Bits", FALSE); 3574 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { 3574 sv_setsv(sv, *bits_all); } else { ###### sv_setpvn(sv, WARN_ALLstring, WARNsize) ; } } else { 985 sv_setsv(sv, PL_compiling.cop_warnings); } 9971 SvPOK_only(sv); } 9971 break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': 4086838 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 4086545 I32 s1, t1; /* * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj)); * XXX Does the new way break anything? */ 4086545 paren = atoi(mg->mg_ptr); /* $& is in [0] */ getparen: 4087347 if (paren <= (I32)rx->nparens && (s1 = rx->startp[paren]) != -1 && (t1 = rx->endp[paren]) != -1) { 3398332 i = t1 - s1; 3398332 s = rx->subbeg + s1; 3398332 if (!rx->subbeg) ###### break; getrx: 3398419 if (i >= 0) { 3398419 sv_setpvn(sv, s, i); 3398419 if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i)) 76907 SvUTF8_on(sv); else 3321512 SvUTF8_off(sv); 3398419 if (PL_tainting) { 965 if (RX_MATCH_TAINTED(rx)) { 53 MAGIC* mg = SvMAGIC(sv); 53 MAGIC* mgt; 53 PL_tainted = 1; 53 SvMAGIC_set(sv, mg->mg_moremagic); 53 SvTAINT(sv); 53 if ((mgt = SvMAGIC(sv))) { 53 mg->mg_moremagic = mgt; 53 SvMAGIC_set(sv, mg); } } else 912 SvTAINTED_off(sv); } 912 break; } } } 689308 sv_setsv(sv,&PL_sv_undef); 689308 break; case '+': 776 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 776 paren = rx->lastparen; 776 if (paren) 776 goto getparen; } ###### sv_setsv(sv,&PL_sv_undef); ###### break; case '\016': /* ^N */ 27 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 27 paren = rx->lastcloseparen; 27 if (paren) 26 goto getparen; } 1 sv_setsv(sv,&PL_sv_undef); 1 break; case '`': 55 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 55 if ((s = rx->subbeg) && rx->startp[0] != -1) { 55 i = rx->startp[0]; 55 goto getrx; } } ###### sv_setsv(sv,&PL_sv_undef); ###### break; case '\'': 32 if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 32 if (rx->subbeg && rx->endp[0] != -1) { 32 s = rx->subbeg + rx->endp[0]; 32 i = rx->sublen - rx->endp[0]; 32 goto getrx; } } ###### sv_setsv(sv,&PL_sv_undef); ###### break; case '.': 93335 if (GvIO(PL_last_in_gv)) { 93318 sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); } 93318 break; case '?': { 6555 sv_setiv(sv, (IV)STATUS_CURRENT); #ifdef COMPLEX_STATUS LvTARGOFF(sv) = PL_statusvalue; LvTARGLEN(sv) = PL_statusvalue_vms; #endif } 6555 break; case '^': 2 if (GvIOp(PL_defoutgv)) 2 s = IoTOP_NAME(GvIOp(PL_defoutgv)); 2 if (s) 1 sv_setpv(sv,s); else { 1 sv_setpv(sv,GvENAME(PL_defoutgv)); 1 sv_catpv(sv,"_TOP"); } 1 break; case '~': 6 if (GvIOp(PL_defoutgv)) 6 s = IoFMT_NAME(GvIOp(PL_defoutgv)); 6 if (!s) 3 s = GvENAME(PL_defoutgv); 6 sv_setpv(sv,s); 6 break; case '=': 6 if (GvIOp(PL_defoutgv)) 6 sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); 6 break; case '-': 11 if (GvIOp(PL_defoutgv)) 11 sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); 11 break; case '%': 7 if (GvIOp(PL_defoutgv)) 7 sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); 7 break; case ':': ###### break; case '/': ###### break; case '[': ###### WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase)); ###### break; case '|': 169 if (GvIOp(PL_defoutgv)) 169 sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); 169 break; case ',': 60624 break; case '\\': 60624 if (PL_ors_sv) 132 sv_copypv(sv, PL_ors_sv); 132 break; case '!': #ifdef VMS sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); sv_setpv(sv, errno ? Strerror(errno) : ""); #else { 41949 const int saveerrno = errno; 41949 sv_setnv(sv, (NV)errno); #ifdef OS2 if (errno == errno_isOS2 || errno == errno_isOS2_set) sv_setpv(sv, os2error(Perl_rc)); else #endif 41949 sv_setpv(sv, errno ? Strerror(errno) : ""); 41949 errno = saveerrno; } #endif 41949 SvRTRIM(sv); 41949 SvNOK_on(sv); /* what a wonderful hack! */ 41949 break; case '<': 21 sv_setiv(sv, (IV)PL_uid); 21 break; case '>': 44 sv_setiv(sv, (IV)PL_euid); 44 break; case '(': 4 sv_setiv(sv, (IV)PL_gid); #ifdef HAS_GETGROUPS 4 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid); #endif 4 goto add_groups; case ')': 5 sv_setiv(sv, (IV)PL_egid); #ifdef HAS_GETGROUPS 5 Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid); #endif add_groups: #ifdef HAS_GETGROUPS { 9 Groups_t gary[NGROUPS]; 9 I32 j = getgroups(NGROUPS,gary); 27 while (--j >= 0) 18 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]); } #endif 9 (void)SvIOK_on(sv); /* what a wonderful hack! */ break; #ifndef MACOS_TRADITIONAL case '0': 4591256 break; #endif } 4591256 return 0; } int Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) ###### { ###### struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; ###### if (uf && uf->uf_val) ###### (*uf->uf_val)(aTHX_ uf->uf_index, sv); ###### return 0; } int Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) 218436 { dVAR; 218436 const char *s; 218436 const char *ptr; 218436 STRLEN len, klen; 218436 s = SvPV_const(sv,len); 218436 ptr = MgPV_const(mg,klen); 218436 my_setenv(ptr, s); #ifdef DYNAMIC_ENV_FETCH /* We just undefd an environment var. Is a replacement */ /* waiting in the wings? */ if (!len) { SV **valp; if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE))) s = SvPV_const(*valp, len); } #endif #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS) /* And you'll never guess what the dog had */ /* in its mouth... */ 218436 if (PL_tainting) { 2195 MgTAINTEDDIR_off(mg); #ifdef VMS if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) { char pathbuf[256], eltbuf[256], *cp, *elt = s; Stat_t sbuf; int i = 0, j = 0; do { /* DCL$PATH may be a search list */ while (1) { /* as may dev portion of any element */ if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { if ( *(cp+1) == '.' || *(cp+1) == '-' || cando_by_name(S_IWUSR,0,elt) ) { MgTAINTEDDIR_on(mg); return 0; } } if ((cp = strchr(elt, ':')) != Nullch) *cp = '\0'; if (my_trnlnm(elt, eltbuf, j++)) elt = eltbuf; else break; } j = 0; } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); } #endif /* VMS */ 2195 if (s && klen == 4 && strEQ(ptr,"PATH")) { 63 const char * const strend = s + len; 543 while (s < strend) { 482 char tmpbuf[256]; 482 Stat_t st; 482 I32 i; 482 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, strend, ':', &i); 482 s++; 482 if (i >= sizeof tmpbuf /* too long -- assume the worst */ || *tmpbuf != '/' || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) { 2 MgTAINTEDDIR_on(mg); 2 return 0; } } } } #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */ 218434 return 0; } int Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) 187 { 187 PERL_UNUSED_ARG(sv); 187 my_setenv(MgPV_nolen_const(mg),Nullch); 187 return 0; } int Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) 36 { #if defined(VMS) || defined(EPOC) || defined(SYMBIAN) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else 36 if (PL_localizing) { 36 HE* entry; 36 magic_clear_all_env(sv,mg); 36 hv_iterinit((HV*)sv); 872 while ((entry = hv_iternext((HV*)sv))) { 836 I32 keylen; 836 my_setenv(hv_iterkey(entry, &keylen), SvPV_nolen_const(hv_iterval((HV*)sv, entry))); } } #endif 36 return 0; } int Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) 56 { dVAR; #ifndef PERL_MICRO #if defined(VMS) || defined(EPOC) || defined(SYMBIAN) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else # if defined(PERL_IMPLICIT_SYS) || defined(WIN32) PerlEnv_clearenv(); # else # ifdef USE_ENVIRON_ARRAY # if defined(USE_ITHREADS) /* only the parent thread can clobber the process environment */ if (PL_curinterp == aTHX) # endif { # ifndef PERL_USE_SAFE_PUTENV 56 if (!PL_use_safe_putenv) { 56 I32 i; 56 if (environ == PL_origenviron) ###### environ = (char**)safesysmalloc(sizeof(char*)); else 1778 for (i = 0; environ[i]; i++) 1722 safesysfree(environ[i]); } # endif /* PERL_USE_SAFE_PUTENV */ 56 environ[0] = Nullch; } # endif /* USE_ENVIRON_ARRAY */ # endif /* PERL_IMPLICIT_SYS || WIN32 */ #endif /* VMS || EPOC */ #endif /* !PERL_MICRO */ 56 PERL_UNUSED_ARG(sv); 56 PERL_UNUSED_ARG(mg); 56 return 0; } #ifndef PERL_MICRO #ifdef HAS_SIGPROCMASK static void restore_sigmask(pTHX_ SV *save_sv) 1483 { 1483 const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv ); 1483 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0); } #endif int Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) 22076 { /* Are we fetching a signal entry? */ 22076 const I32 i = whichsig(MgPV_nolen_const(mg)); 22076 if (i > 0) { 531 if(PL_psig_ptr[i]) 520 sv_setsv(sv,PL_psig_ptr[i]); else { 11 Sighandler_t sigstate; 11 sigstate = rsignal_state(i); #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL; #endif /* cache state so we don't fetch it again */ 11 if(sigstate == SIG_IGN) 2 sv_setpv(sv,"IGNORE"); else 9 sv_setsv(sv,&PL_sv_undef); 11 PL_psig_ptr[i] = SvREFCNT_inc(sv); 11 SvTEMP_off(sv); } } 22076 return 0; } int Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) 1 { /* XXX Some of this code was copied from Perl_magic_setsig. A little * refactoring might be in order. */ dVAR; 1 register const char * const s = MgPV_nolen_const(mg); 1 PERL_UNUSED_ARG(sv); 1 if (*s == '_') { 1 SV** svp = 0; 1 if (strEQ(s,"__DIE__")) ###### svp = &PL_diehook; 1 else if (strEQ(s,"__WARN__")) 1 svp = &PL_warnhook; else ###### Perl_croak(aTHX_ "No such hook: %s", s); 1 if (svp && *svp) { 1 SV * const to_dec = *svp; 1 *svp = 0; 1 SvREFCNT_dec(to_dec); } } else { /* Are we clearing a signal entry? */ ###### const I32 i = whichsig(s); ###### if (i > 0) { #ifdef HAS_SIGPROCMASK ###### sigset_t set, save; ###### SV* save_sv; /* Avoid having the signal arrive at a bad time, if possible. */ ###### sigemptyset(&set); ###### sigaddset(&set,i); ###### sigprocmask(SIG_BLOCK, &set, &save); ###### ENTER; ###### save_sv = newSVpv((char *)(&save), sizeof(sigset_t)); ###### SAVEFREESV(save_sv); ###### SAVEDESTRUCTOR_X(restore_sigmask, save_sv); #endif ###### PERL_ASYNC_CHECK(); #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) if (!PL_sig_handlers_initted) Perl_csighandler_init(); #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 1; (void)rsignal(i, PL_csighandlerp); #else ###### (void)rsignal(i, SIG_DFL); #endif ###### if(PL_psig_name[i]) { ###### SvREFCNT_dec(PL_psig_name[i]); ###### PL_psig_name[i]=0; } ###### if(PL_psig_ptr[i]) { ###### SV *to_dec=PL_psig_ptr[i]; ###### PL_psig_ptr[i]=0; ###### LEAVE; ###### SvREFCNT_dec(to_dec); } else ###### LEAVE; } } 1 return 0; } static void S_raise_signal(pTHX_ int sig) 22 { /* Set a flag to say this signal is pending */ 22 PL_psig_pend[sig]++; /* And one to say _a_ signal is pending */ 22 PL_sig_pending = 1; } Signal_t Perl_csighandler(int sig) 22 { #ifdef PERL_GET_SIG_CONTEXT dTHXa(PERL_GET_SIG_CONTEXT); #else dTHX; #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS (void) rsignal(sig, PL_csighandlerp); if (PL_sig_ignoring[sig]) return; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS if (PL_sig_defaulting[sig]) #ifdef KILL_BY_SIGPRC exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG); #else exit(1); #endif #endif 22 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) /* Call the perl level handler now-- * with risk we may be in malloc() etc. */ ###### (*PL_sighandlerp)(sig); else 22 S_raise_signal(aTHX_ sig); } #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) void Perl_csighandler_init(void) { int sig; if (PL_sig_handlers_initted) return; for (sig = 1; sig < SIG_SIZE; sig++) { #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS dTHX; PL_sig_defaulting[sig] = 1; (void) rsignal(sig, PL_csighandlerp); #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[sig] = 0; #endif } PL_sig_handlers_initted = 1; } #endif void Perl_despatch_signals(pTHX) 22 { 22 int sig; 22 PL_sig_pending = 0; 1231 for (sig = 1; sig < SIG_SIZE; sig++) { 1214 if (PL_psig_pend[sig]) { 22 PERL_BLOCKSIG_ADD(set, sig); 22 PL_psig_pend[sig] = 0; 22 PERL_BLOCKSIG_BLOCK(set); 22 (*PL_sighandlerp)(sig); 17 PERL_BLOCKSIG_UNBLOCK(set); } } } int Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) 53763 { dVAR; 53763 I32 i; 53763 SV** svp = 0; /* Need to be careful with SvREFCNT_dec(), because that can have side * effects (due to closures). We must make sure that the new disposition * is in place before it is called. */ 53763 SV* to_dec = 0; 53763 STRLEN len; #ifdef HAS_SIGPROCMASK 53763 sigset_t set, save; 53763 SV* save_sv; #endif 53763 register const char *s = MgPV_const(mg,len); 53763 if (*s == '_') { 52267 if (strEQ(s,"__DIE__")) 6619 svp = &PL_diehook; 45648 else if (strEQ(s,"__WARN__")) 45648 svp = &PL_warnhook; else ###### Perl_croak(aTHX_ "No such hook: %s", s); 52267 i = 0; 52267 if (*svp) { 17854 to_dec = *svp; 17854 *svp = 0; } } else { 1496 i = whichsig(s); /* ...no, a brick */ 1496 if (i <= 0) { 13 if (ckWARN(WARN_SIGNAL)) 1 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); 13 return 0; } #ifdef HAS_SIGPROCMASK /* Avoid having the signal arrive at a bad time, if possible. */ 1483 sigemptyset(&set); 1483 sigaddset(&set,i); 1483 sigprocmask(SIG_BLOCK, &set, &save); 1483 ENTER; 1483 save_sv = newSVpv((char *)(&save), sizeof(sigset_t)); 1483 SAVEFREESV(save_sv); 1483 SAVEDESTRUCTOR_X(restore_sigmask, save_sv); #endif 1483 PERL_ASYNC_CHECK(); #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) if (!PL_sig_handlers_initted) Perl_csighandler_init(); #endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[i] = 0; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 0; #endif 1483 SvREFCNT_dec(PL_psig_name[i]); 1483 to_dec = PL_psig_ptr[i]; 1483 PL_psig_ptr[i] = SvREFCNT_inc(sv); 1483 SvTEMP_off(sv); /* Make sure it doesn't go away on us */ 1483 PL_psig_name[i] = newSVpvn(s, len); 1483 SvREADONLY_on(PL_psig_name[i]); } 53750 if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { 18904 if (i) { 660 (void)rsignal(i, PL_csighandlerp); #ifdef HAS_SIGPROCMASK 660 LEAVE; #endif } else 18244 *svp = SvREFCNT_inc(sv); 18904 if(to_dec) 1356 SvREFCNT_dec(to_dec); 18904 return 0; } 34846 s = SvPV_force(sv,len); 34846 if (strEQ(s,"IGNORE")) { 43 if (i) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[i] = 1; (void)rsignal(i, PL_csighandlerp); #else 43 (void)rsignal(i, SIG_IGN); #endif } } 34803 else if (strEQ(s,"DEFAULT") || !*s) { 34783 if (i) #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS { PL_sig_defaulting[i] = 1; (void)rsignal(i, PL_csighandlerp); } #else 763 (void)rsignal(i, SIG_DFL); #endif } else { /* * We should warn if HINT_STRICT_REFS, but without * access to a known hint bit in a known OP, we can't * tell whether HINT_STRICT_REFS is in force or not. */ 20 if (!strchr(s,':') && !strchr(s,'\'')) 15 sv_insert(sv, 0, 0, "main::", 6); 20 if (i) 17 (void)rsignal(i, PL_csighandlerp); else 3 *svp = SvREFCNT_inc(sv); } #ifdef HAS_SIGPROCMASK 34846 if(i) 823 LEAVE; #endif 34846 if(to_dec) 17949 SvREFCNT_dec(to_dec); 34846 return 0; } #endif /* !PERL_MICRO */ int Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) 43463 { 43463 PERL_UNUSED_ARG(sv); 43463 PERL_UNUSED_ARG(mg); 43463 PL_sub_generation++; 43463 return 0; } int Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg) 1079 { 1079 PERL_UNUSED_ARG(sv); 1079 PERL_UNUSED_ARG(mg); /* HV_badAMAGIC_on(Sv_STASH(sv)); */ 1079 PL_amagic_generation++; 1079 return 0; } int Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) 12 { 12 HV * const hv = (HV*)LvTARG(sv); 12 I32 i = 0; 12 PERL_UNUSED_ARG(mg); 12 if (hv) { 12 (void) hv_iterinit(hv); 12 if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) 12 i = HvKEYS(hv); else { ###### while (hv_iternext(hv)) ###### i++; } } 12 sv_setiv(sv, (IV)i); 12 return 0; } int Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) 4 { 4 PERL_UNUSED_ARG(mg); 4 if (LvTARG(sv)) { 4 hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); } 4 return 0; } /* caller is responsible for stack switching/cleanup */ STATIC int S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val) 120645 { 120645 dSP; 120645 PUSHMARK(SP); 120645 EXTEND(SP, n); 120645 PUSHs(SvTIED_obj(sv, mg)); 120645 if (n > 1) { 120645 if (mg->mg_ptr) { 117483 if (mg->mg_len >= 0) 24 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len))); 117459 else if (mg->mg_len == HEf_SVKEY) 117459 PUSHs((SV*)mg->mg_ptr); } 3162 else if (mg->mg_type == PERL_MAGIC_tiedelem) { 2479 PUSHs(sv_2mortal(newSViv(mg->mg_len))); } } 120645 if (n > 2) { 2753 PUSHs(val); } 120645 PUTBACK; 120645 return call_method(meth, flags); } STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth) 117548 { 117548 dVAR; dSP; 117548 ENTER; 117548 SAVETMPS; 117548 PUSHSTACKi(PERLSI_MAGIC); 117548 if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) { 117535 sv_setsv(sv, *PL_stack_sp--); } 117535 POPSTACK; 117535 FREETMPS; 117535 LEAVE; 117535 return 0; } int Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) 117113 { 117113 if (mg->mg_ptr) 115216 mg->mg_flags |= MGf_GSKIP; 117113 magic_methpack(sv,mg,"FETCH"); 117103 return 0; } int Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) 2753 { 2753 dVAR; dSP; 2753 ENTER; 2753 PUSHSTACKi(PERLSI_MAGIC); 2753 magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); 2741 POPSTACK; 2741 LEAVE; 2741 return 0; } int Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) 94 { 94 return magic_methpack(sv,mg,"DELETE"); } U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) 344 { 344 dVAR; dSP; 344 U32 retval = 0; 344 ENTER; 344 SAVETMPS; 344 PUSHSTACKi(PERLSI_MAGIC); 344 if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { 344 sv = *PL_stack_sp--; 344 retval = (U32) SvIV(sv)-1; } 344 POPSTACK; 344 FREETMPS; 344 LEAVE; 344 return retval; } int Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) 133 { 133 dVAR; dSP; 133 ENTER; 133 PUSHSTACKi(PERLSI_MAGIC); 133 PUSHMARK(SP); 133 XPUSHs(SvTIED_obj(sv, mg)); 133 PUTBACK; 133 call_method("CLEAR", G_SCALAR|G_DISCARD); 132 POPSTACK; 132 LEAVE; 132 return 0; } int Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) 107962 { 107962 dVAR; dSP; 107962 const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; 107962 ENTER; 107962 SAVETMPS; 107962 PUSHSTACKi(PERLSI_MAGIC); 107962 PUSHMARK(SP); 107962 EXTEND(SP, 2); 107962 PUSHs(SvTIED_obj(sv, mg)); 107962 if (SvOK(key)) 107098 PUSHs(key); 107962 PUTBACK; 107962 if (call_method(meth, G_SCALAR)) 107962 sv_setsv(key, *PL_stack_sp--); 107962 POPSTACK; 107962 FREETMPS; 107962 LEAVE; 107962 return 0; } int Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg) 341 { 341 return magic_methpack(sv,mg,"EXISTS"); } SV * Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) 7 { 7 dVAR; dSP; 7 SV *retval = &PL_sv_undef; 7 SV * const tied = SvTIED_obj((SV*)hv, mg); 7 HV * const pkg = SvSTASH((SV*)SvRV(tied)); 7 if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) { 5 SV *key; 5 if (HvEITER_get(hv)) /* we are in an iteration so the hash cannot be empty */ 1 return &PL_sv_yes; /* no xhv_eiter so now use FIRSTKEY */ 4 key = sv_newmortal(); 4 magic_nextpack((SV*)hv, mg, key); 4 HvEITER_set(hv, NULL); /* need to reset iterator */ 4 return SvOK(key) ? &PL_sv_yes : &PL_sv_no; } /* there is a SCALAR method that we can call */ 2 ENTER; 2 PUSHSTACKi(PERLSI_MAGIC); 2 PUSHMARK(SP); 2 EXTEND(SP, 1); 2 PUSHs(tied); 2 PUTBACK; 2 if (call_method("SCALAR", G_SCALAR)) 2 retval = *PL_stack_sp--; 2 POPSTACK; 2 LEAVE; 2 return retval; } int Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) ###### { ###### GV * const gv = PL_DBline; ###### const I32 i = SvTRUE(sv); ###### SV ** const svp = av_fetch(GvAV(gv), ###### atoi(MgPV_nolen_const(mg)), FALSE); ###### if (svp && SvIOKp(*svp)) { ###### OP * const o = INT2PTR(OP*,SvIVX(*svp)); ###### if (o) { /* set or clear breakpoint in the relevant control op */ ###### if (i) ###### o->op_flags |= OPf_SPECIAL; else ###### o->op_flags &= ~OPf_SPECIAL; } } ###### return 0; } int Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) 387095 { 387095 const AV * const obj = (AV*)mg->mg_obj; 387095 if (obj) { 387089 sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase); } else { 6 SvOK_off(sv); } 387095 return 0; } int Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) 430 { 430 AV * const obj = (AV*)mg->mg_obj; 430 if (obj) { 422 av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase); } else { 8 if (ckWARN(WARN_MISC)) 4 Perl_warner(aTHX_ packWARN(WARN_MISC), "Attempt to set length of freed array"); } 429 return 0; } int Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) 18296 { 18296 PERL_UNUSED_ARG(sv); /* during global destruction, mg_obj may already have been freed */ 18296 if (PL_in_clean_all) 1355 return 0; 16941 mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen); 16941 if (mg) { /* arylen scalar holds a pointer back to the array, but doesn't own a reference. Hence the we (the array) are about to go away with it still pointing at us. Clear its pointer, else it would be pointing at free memory. See the comment in sv_magic about reference loops, and why it can't own a reference to us. */ 14928 mg->mg_obj = 0; } 16941 return 0; } int Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) 48138 { 48138 SV* const lsv = LvTARG(sv); 48138 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { 48134 mg = mg_find(lsv, PERL_MAGIC_regex_global); 48134 if (mg && mg->mg_len >= 0) { 48108 I32 i = mg->mg_len; 48108 if (DO_UTF8(lsv)) ###### sv_pos_b2u(lsv, &i); 48108 sv_setiv(sv, i + PL_curcop->cop_arybase); 48108 return 0; } } 30 SvOK_off(sv); 30 return 0; } int Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) 178420 { 178420 SV* const lsv = LvTARG(sv); 178420 SSize_t pos; 178420 STRLEN len; 178420 STRLEN ulen = 0; 178420 mg = 0; 178420 if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) 139963 mg = mg_find(lsv, PERL_MAGIC_regex_global); 178420 if (!mg) { 38464 if (!SvOK(sv)) 151 return 0; 38313 sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); 38313 mg = mg_find(lsv, PERL_MAGIC_regex_global); } 139956 else if (!SvOK(sv)) { 25 mg->mg_len = -1; 25 return 0; } 178244 len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv); 178244 pos = SvIV(sv) - PL_curcop->cop_arybase; 178244 if (DO_UTF8(lsv)) { 41 ulen = sv_len_utf8(lsv); 41 if (ulen) 41 len = ulen; } 178244 if (pos < 0) { ###### pos += len; ###### if (pos < 0) ###### pos = 0; } 178244 else if (pos > (SSize_t)len) 1 pos = len; 178244 if (ulen) { 41 I32 p = pos; 41 sv_pos_u2b(lsv, &p, 0); 41 pos = p; } 178244 mg->mg_len = pos; 178244 mg->mg_flags &= ~MGf_MINMATCH; 178244 return 0; } int Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg) 442 { 442 PERL_UNUSED_ARG(mg); 442 if (SvFAKE(sv)) { /* FAKE globs can get coerced */ 390 SvFAKE_off(sv); 390 gv_efullname3(sv,((GV*)sv), "*"); 390 SvFAKE_on(sv); } else 52 gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */ 442 return 0; } int Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg) 132136 { 132136 GV* gv; 132136 PERL_UNUSED_ARG(mg); 132136 if (!SvOK(sv)) 132117 return 0; 19 gv = gv_fetchsv(sv,TRUE, SVt_PVGV); 19 if (sv == (SV*)gv) ###### return 0; 19 if (GvGP(sv)) 19 gp_free((GV*)sv); 19 GvGP(sv) = gp_ref(GvGP(gv)); 19 return 0; } int Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) 6068 { 6068 STRLEN len; 6068 SV * const lsv = LvTARG(sv); 6068 const char * const tmps = SvPV_const(lsv,len); 6068 I32 offs = LvTARGOFF(sv); 6068 I32 rem = LvTARGLEN(sv); 6068 PERL_UNUSED_ARG(mg); 6068 if (SvUTF8(lsv)) 3314 sv_pos_u2b(lsv, &offs, &rem); 6068 if (offs > (I32)len) ###### offs = len; 6068 if (rem + offs > (I32)len) ###### rem = len - offs; 6068 sv_setpvn(sv, tmps + offs, (STRLEN)rem); 6068 if (SvUTF8(lsv)) 3314 SvUTF8_on(sv); 6068 return 0; } int Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) 16797 { 16797 STRLEN len; 16797 const char *tmps = SvPV_const(sv, len); 16797 SV * const lsv = LvTARG(sv); 16797 I32 lvoff = LvTARGOFF(sv); 16797 I32 lvlen = LvTARGLEN(sv); 16797 PERL_UNUSED_ARG(mg); 16797 if (DO_UTF8(sv)) { 293 sv_utf8_upgrade(lsv); 293 sv_pos_u2b(lsv, &lvoff, &lvlen); 293 sv_insert(lsv, lvoff, lvlen, tmps, len); 293 LvTARGLEN(sv) = sv_len_utf8(sv); 293 SvUTF8_on(lsv); } 16504 else if (lsv && SvUTF8(lsv)) { 883 sv_pos_u2b(lsv, &lvoff, &lvlen); 883 LvTARGLEN(sv) = len; 883 tmps = (char*)bytes_to_utf8((U8*)tmps, &len); 883 sv_insert(lsv, lvoff, lvlen, tmps, len); 883 Safefree(tmps); } else { 15621 sv_insert(lsv, lvoff, lvlen, tmps, len); 15621 LvTARGLEN(sv) = len; } 16797 return 0; } int Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) 5456972 { 5456972 PERL_UNUSED_ARG(sv); 5456972 TAINT_IF(mg->mg_len & 1); 5456972 return 0; } int Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) 2733505 { 2733505 PERL_UNUSED_ARG(sv); 2733505 if (PL_tainted) 2713706 mg->mg_len |= 1; else 19799 mg->mg_len &= ~1; 2733505 return 0; } int Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) 2591 { 2591 SV * const lsv = LvTARG(sv); 2591 PERL_UNUSED_ARG(mg); 2591 if (!lsv) { ###### SvOK_off(sv); ###### return 0; } 2591 sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); 2591 return 0; } int Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) 1937936 { 1937936 PERL_UNUSED_ARG(mg); 1937936 do_vecset(sv); /* XXX slurp this routine */ 1937935 return 0; } int Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) 2261 { 2261 SV *targ = Nullsv; 2261 if (LvTARGLEN(sv)) { 2261 if (mg->mg_obj) { 2245 SV * const ahv = LvTARG(sv); 2245 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0); 2245 if (he) ###### targ = HeVAL(he); } else { 16 AV* const av = (AV*)LvTARG(sv); 16 if ((I32)LvTARGOFF(sv) <= AvFILL(av)) 11 targ = AvARRAY(av)[LvTARGOFF(sv)]; } 2261 if (targ && targ != &PL_sv_undef) { /* somebody else defined it for us */ ###### SvREFCNT_dec(LvTARG(sv)); ###### LvTARG(sv) = SvREFCNT_inc(targ); ###### LvTARGLEN(sv) = 0; ###### SvREFCNT_dec(mg->mg_obj); ###### mg->mg_obj = Nullsv; ###### mg->mg_flags &= ~MGf_REFCOUNTED; } } else ###### targ = LvTARG(sv); 2261 sv_setsv(sv, targ ? targ : &PL_sv_undef); 2261 return 0; } int Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) 4 { 4 PERL_UNUSED_ARG(mg); 4 if (LvTARGLEN(sv)) 4 vivify_defelem(sv); 4 if (LvTARG(sv)) { 4 sv_setsv(LvTARG(sv), sv); 4 SvSETMAGIC(LvTARG(sv)); } 4 return 0; } void Perl_vivify_defelem(pTHX_ SV *sv) 7 { 7 MAGIC *mg; 7 SV *value = Nullsv; 7 if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem))) ###### return; 7 if (mg->mg_obj) { 1 SV * const ahv = LvTARG(sv); 1 HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0); 1 if (he) 1 value = HeVAL(he); 1 if (!value || value == &PL_sv_undef) ###### Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj); } else { 6 AV* const av = (AV*)LvTARG(sv); 6 if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av)) ###### LvTARG(sv) = Nullsv; /* array can't be extended */ else { 6 SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE); 6 if (!svp || (value = *svp) == &PL_sv_undef) ###### Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv)); } } 7 (void)SvREFCNT_inc(value); 7 SvREFCNT_dec(LvTARG(sv)); 7 LvTARG(sv) = value; 7 LvTARGLEN(sv) = 0; 7 SvREFCNT_dec(mg->mg_obj); 7 mg->mg_obj = Nullsv; 7 mg->mg_flags &= ~MGf_REFCOUNTED; } int Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) 123580 { 123580 AV *const av = (AV*)mg->mg_obj; 123580 SV **svp = AvARRAY(av); 123580 PERL_UNUSED_ARG(sv); 123580 if (svp) { 123580 SV *const *const last = svp + AvFILLp(av); 613480 while (svp <= last) { 489900 if (*svp) { 489900 SV *const referrer = *svp; 489900 if (SvWEAKREF(referrer)) { /* XXX Should we check that it hasn't changed? */ 19 SvRV_set(referrer, 0); 19 SvOK_off(referrer); 19 SvWEAKREF_off(referrer); 489881 } else if (SvTYPE(referrer) == SVt_PVGV || SvTYPE(referrer) == SVt_PVLV) { /* You lookin' at me? */ 489881 assert(GvSTASH(referrer)); 489881 assert(GvSTASH(referrer) == (HV*)sv); 489881 GvSTASH(referrer) = 0; } else { ###### Perl_croak(aTHX_ "panic: magic_killbackrefs (flags=%"UVxf")", SvFLAGS(referrer)); } 489900 *svp = Nullsv; } 489900 svp++; } } 123580 SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */ 123580 return 0; } int Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) 340158 { 340158 mg->mg_len = -1; 340158 SvSCREAM_off(sv); 340158 return 0; } int Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg) ###### { ###### PERL_UNUSED_ARG(mg); ###### sv_unmagic(sv, PERL_MAGIC_bm); ###### SvVALID_off(sv); ###### return 0; } int Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg) ###### { ###### PERL_UNUSED_ARG(mg); ###### sv_unmagic(sv, PERL_MAGIC_fm); ###### SvCOMPILED_off(sv); ###### return 0; } int Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) ###### { ###### const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; ###### if (uf && uf->uf_set) ###### (*uf->uf_set)(aTHX_ uf->uf_index, sv); ###### return 0; } int Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) 6 { 6 PERL_UNUSED_ARG(mg); 6 sv_unmagic(sv, PERL_MAGIC_qr); 6 return 0; } int Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg) 31490 { 31490 regexp * const re = (regexp *)mg->mg_obj; 31490 PERL_UNUSED_ARG(sv); 31490 ReREFCNT_dec(re); 31490 return 0; } #ifdef USE_LOCALE_COLLATE int Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) 5011 { /* * RenE Descartes said "I think not." * and vanished with a faint plop. */ 5011 PERL_UNUSED_ARG(sv); 5011 if (mg->mg_ptr) { 4513 Safefree(mg->mg_ptr); 4513 mg->mg_ptr = NULL; 4513 mg->mg_len = -1; } 5011 return 0; } #endif /* USE_LOCALE_COLLATE */ /* Just clear the UTF-8 cache data. */ int Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg) 81255 { 81255 PERL_UNUSED_ARG(sv); 81255 Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */ 81255 mg->mg_ptr = 0; 81255 mg->mg_len = -1; /* The mg_len holds the len cache. */ 81255 return 0; } int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 526064 { 526064 register const char *s; 526064 I32 i; 526064 STRLEN len; 526064 switch (*mg->mg_ptr) { case '\001': /* ^A */ 114 sv_setsv(PL_bodytarget, sv); 114 break; case '\003': /* ^C */ 313 PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 313 break; case '\004': /* ^D */ #ifdef DEBUGGING ###### s = SvPV_nolen_const(sv); ###### PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; ###### DEBUG_x(dump_all()); #else PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG; #endif ###### break; case '\005': /* ^E */ 316 if (*(mg->mg_ptr+1) == '\0') { #ifdef MACOS_TRADITIONAL gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); #else # ifdef VMS set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); # else # ifdef WIN32 SetLastError( SvIV(sv) ); # else # ifdef OS2 os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); # else /* will anyone ever use this? */ 2 SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4); # endif # endif # endif #endif } 314 else if (strEQ(mg->mg_ptr+1, "NCODING")) { 314 if (PL_encoding) 104 SvREFCNT_dec(PL_encoding); 314 if (SvOK(sv) || SvGMAGICAL(sv)) { 117 PL_encoding = newSVsv(sv); } else { 197 PL_encoding = Nullsv; } } 197 break; case '\006': /* ^F */ 72 PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 72 break; case '\010': /* ^H */ 27394 PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 27394 break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ 17 Safefree(PL_inplace); 17 PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch; case '\017': /* ^O */ 30 if (*(mg->mg_ptr+1) == '\0') { 18 Safefree(PL_osname); 18 PL_osname = Nullch; 18 if (SvOK(sv)) { 8 TAINT_PROPER("assigning to $^O"); 7 PL_osname = savesvpv(sv); } } 12 else if (strEQ(mg->mg_ptr, "\017PEN")) { 12 if (!PL_compiling.cop_io) 10 PL_compiling.cop_io = newSVsv(sv); else 2 sv_setsv(PL_compiling.cop_io,sv); } 2 break; case '\020': /* ^P */ 6 PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 6 if (PL_perldb && !PL_DBsingle) 1 init_debugger(); 1 break; case '\024': /* ^T */ #ifdef BIG_TIME PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); #else ###### PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); #endif ###### break; case '\027': /* ^W & $^WARNING_BITS */ 69000 if (*(mg->mg_ptr+1) == '\0') { 64017 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 64001 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 64001 PL_dowarn = (PL_dowarn & ~G_WARN_ON) | (i ? G_WARN_ON : G_WARN_OFF) ; } } 4983 else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { 4983 if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { 4917 if (!SvPOK(sv) && PL_localizing) { ###### sv_setpvn(sv, WARN_NONEstring, WARNsize); ###### PL_compiling.cop_warnings = pWARN_NONE; ###### break; } { 4917 STRLEN len, i; 4917 int accumulate = 0 ; 4917 int any_fatals = 0 ; 4917 const char * const ptr = SvPV_const(sv, len) ; 64377 for (i = 0 ; i < len ; ++i) { 59460 accumulate |= ptr[i] ; 59460 any_fatals |= (ptr[i] & 0xAA) ; } 4917 if (!accumulate) 1102 PL_compiling.cop_warnings = pWARN_NONE; 3815 else if (isWARN_on(sv, WARN_ALL) && !any_fatals) { 3060 PL_compiling.cop_warnings = pWARN_ALL; 3060 PL_dowarn |= G_WARN_ONCE ; } else { 755 if (specialWARN(PL_compiling.cop_warnings)) 726 PL_compiling.cop_warnings = newSVsv(sv) ; else 29 sv_setsv(PL_compiling.cop_warnings, sv); 755 if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) 235 PL_dowarn |= G_WARN_ONCE ; } } } } 235 break; case '.': 1192 if (PL_localizing) { 804 if (PL_localizing == 1) 402 SAVESPTR(PL_last_in_gv); } 388 else if (SvOK(sv) && GvIO(PL_last_in_gv)) 386 IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); 386 break; case '^': 22 Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); 22 s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); 22 IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO); 22 break; case '~': 38 Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); 38 s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); 38 IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO); 38 break; case '=': 4 IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 4 break; case '-': 2 IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 2 if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) ###### IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; ###### break; case '%': ###### IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); ###### break; case '|': { 4990 IO * const io = GvIOp(PL_defoutgv); 4990 if(!io) ###### break; 4990 if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0) 86 IoFLAGS(io) &= ~IOf_FLUSH; else { 4904 if (!(IoFLAGS(io) & IOf_FLUSH)) { 4668 PerlIO *ofp = IoOFP(io); 4668 if (ofp) 4610 (void)PerlIO_flush(ofp); 4668 IoFLAGS(io) |= IOf_FLUSH; } } } 4668 break; case '/': 16048 SvREFCNT_dec(PL_rs); 16048 PL_rs = newSVsv(sv); 16048 break; case '\\': 151591 if (PL_ors_sv) 15394 SvREFCNT_dec(PL_ors_sv); 151591 if (SvOK(sv) || SvGMAGICAL(sv)) { 15403 PL_ors_sv = newSVsv(sv); } else { 136188 PL_ors_sv = Nullsv; } 136188 break; case ',': 105831 if (PL_ofs_sv) 15486 SvREFCNT_dec(PL_ofs_sv); 105831 if (SvOK(sv) || SvGMAGICAL(sv)) { 15490 PL_ofs_sv = newSVsv(sv); } else { 90341 PL_ofs_sv = Nullsv; } 90341 break; case '[': ###### PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); ###### break; case '?': #ifdef COMPLEX_STATUS if (PL_localizing == 2) { PL_statusvalue = LvTARGOFF(sv); PL_statusvalue_vms = LvTARGLEN(sv); } else #endif #ifdef VMSISH_STATUS if (VMSISH_STATUS) STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv))); else #endif 327 STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); 327 break; case '!': { #ifdef VMS # define PERL_VMS_BANG vaxc$errno #else # define PERL_VMS_BANG 0 #endif SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, 83452 (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); } 83452 break; case '<': ###### PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); ###### if (PL_delaymagic) { ###### PL_delaymagic |= DM_RUID; ###### break; /* don't do magic till later */ } #ifdef HAS_SETRUID (void)setruid((Uid_t)PL_uid); #else #ifdef HAS_SETREUID ###### (void)setreuid((Uid_t)PL_uid, (Uid_t)-1); #else #ifdef HAS_SETRESUID (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1); #else if (PL_uid == PL_euid) { /* special case $< = $> */ #ifdef PERL_DARWIN /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ if (PL_uid != 0 && PerlProc_getuid() == 0) (void)PerlProc_setuid(0); #endif (void)PerlProc_setuid(PL_uid); } else { PL_uid = PerlProc_getuid(); Perl_croak(aTHX_ "setruid() not implemented"); } #endif #endif #endif ###### PL_uid = PerlProc_getuid(); ###### PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); ###### break; case '>': 4 PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); 4 if (PL_delaymagic) { ###### PL_delaymagic |= DM_EUID; ###### break; /* don't do magic till later */ } #ifdef HAS_SETEUID 4 (void)seteuid((Uid_t)PL_euid); #else #ifdef HAS_SETREUID (void)setreuid((Uid_t)-1, (Uid_t)PL_euid); #else #ifdef HAS_SETRESUID (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1); #else if (PL_euid == PL_uid) /* special case $> = $< */ PerlProc_setuid(PL_euid); else { PL_euid = PerlProc_geteuid(); Perl_croak(aTHX_ "seteuid() not implemented"); } #endif #endif #endif 4 PL_euid = PerlProc_geteuid(); 4 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); 4 break; case '(': ###### PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); ###### if (PL_delaymagic) { ###### PL_delaymagic |= DM_RGID; ###### break; /* don't do magic till later */ } #ifdef HAS_SETRGID (void)setrgid((Gid_t)PL_gid); #else #ifdef HAS_SETREGID ###### (void)setregid((Gid_t)PL_gid, (Gid_t)-1); #else #ifdef HAS_SETRESGID (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1); #else if (PL_gid == PL_egid) /* special case $( = $) */ (void)PerlProc_setgid(PL_gid); else { PL_gid = PerlProc_getgid(); Perl_croak(aTHX_ "setrgid() not implemented"); } #endif #endif #endif ###### PL_gid = PerlProc_getgid(); ###### PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); ###### break; case ')': #ifdef HAS_SETGROUPS { ###### const char *p = SvPV_const(sv, len); ###### Groups_t gary[NGROUPS]; ###### while (isSPACE(*p)) ###### ++p; ###### PL_egid = Atol(p); ###### for (i = 0; i < NGROUPS; ++i) { ###### while (*p && !isSPACE(*p)) ###### ++p; ###### while (isSPACE(*p)) ###### ++p; ###### if (!*p) ###### break; ###### gary[i] = Atol(p); } ###### if (i) ###### (void)setgroups(i, gary); } #else /* HAS_SETGROUPS */ PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); #endif /* HAS_SETGROUPS */ ###### if (PL_delaymagic) { ###### PL_delaymagic |= DM_EGID; ###### break; /* don't do magic till later */ } #ifdef HAS_SETEGID ###### (void)setegid((Gid_t)PL_egid); #else #ifdef HAS_SETREGID (void)setregid((Gid_t)-1, (Gid_t)PL_egid); #else #ifdef HAS_SETRESGID (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1); #else if (PL_egid == PL_gid) /* special case $) = $( */ (void)PerlProc_setgid(PL_egid); else { PL_egid = PerlProc_getegid(); Perl_croak(aTHX_ "setegid() not implemented"); } #endif #endif #endif ###### PL_egid = PerlProc_getegid(); ###### PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); ###### break; case ':': 30 PL_chopset = SvPV_force(sv,len); 30 break; #ifndef MACOS_TRADITIONAL case '0': LOCK_DOLLARZERO_MUTEX; #ifdef HAS_SETPROCTITLE /* The BSDs don't show the argv[] in ps(1) output, they * show a string from the process struct and provide * the setproctitle() routine to manipulate that. */ { s = SvPV_const(sv, len); # if __FreeBSD_version > 410001 /* The leading "-" removes the "perl: " prefix, * but not the "(perl) suffix from the ps(1) * output, because that's what ps(1) shows if the * argv[] is modified. */ setproctitle("-%s", s); # else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ /* This doesn't really work if you assume that * $0 = 'foobar'; will wipe out 'perl' from the $0 * because in ps(1) output the result will be like * sprintf("perl: %s (perl)", s) * I guess this is a security feature: * one (a user process) cannot get rid of the original name. * --jhi */ setproctitle("%s", s); # endif } #endif #if defined(__hpux) && defined(PSTAT_SETCMD) { union pstun un; s = SvPV_const(sv, len); un.pst_command = (char *)s; pstat(PSTAT_SETCMD, un, len, 0, 0); } #endif /* PL_origalen is set in perl_parse(). */ 89 s = SvPV_force(sv,len); 89 if (len >= (STRLEN)PL_origalen-1) { /* Longer than original, will be truncated. We assume that * PL_origalen bytes are available. */ ###### Copy(s, PL_origargv[0], PL_origalen-1, char); } else { /* Shorter than original, will be padded. */ 89 Copy(s, PL_origargv[0], len, char); 89 PL_origargv[0][len] = 0; 89 memset(PL_origargv[0] + len + 1, /* Is the space counterintuitive? Yes. * (You were expecting \0?) * Does it work? Seems to. (In Linux 2.4.20 at least.) * --jhi */ (int)' ', PL_origalen - len - 1); } 89 PL_origargv[0][PL_origalen-1] = 0; 432 for (i = 1; i < PL_origargc; i++) 343 PL_origargv[i] = 0; UNLOCK_DOLLARZERO_MUTEX; 526063 break; #endif } 526063 return 0; } I32 Perl_whichsig(pTHX_ const char *sig) 23590 { 23590 register char* const* sigv; 1538226 for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) 1516666 if (strEQ(sig,*sigv)) 2030 return PL_sig_num[sigv - (char* const*)PL_sig_name]; #ifdef SIGCLD 21560 if (strEQ(sig,"CHLD")) ###### return SIGCLD; #endif #ifdef SIGCHLD 21560 if (strEQ(sig,"CLD")) ###### return SIGCHLD; #endif 21560 return -1; } Signal_t Perl_sighandler(int sig) 27 { #ifdef PERL_GET_SIG_CONTEXT dTHXa(PERL_GET_SIG_CONTEXT); #else dTHX; #endif 27 dSP; 27 GV *gv = Nullgv; 27 SV *sv = Nullsv; 27 SV * const tSv = PL_Sv; 27 CV *cv = Nullcv; 27 OP *myop = PL_op; 27 U32 flags = 0; 27 XPV * const tXpv = PL_Xpv; 27 if (PL_savestack_ix + 15 <= PL_savestack_max) 27 flags |= 1; 27 if (PL_markstack_ptr < PL_markstack_max - 2) 27 flags |= 4; 27 if (PL_scopestack_ix < PL_scopestack_max - 3) 27 flags |= 16; 27 if (!PL_psig_ptr[sig]) { ###### PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", PL_sig_name[sig]); ###### exit(sig); } /* Max number of items pushed there is 3*n or 4. We cannot fix infinity, so we fix 4 (in fact 5): */ 27 if (flags & 1) { 27 PL_savestack_ix += 5; /* Protect save in progress. */ 27 SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags); } 27 if (flags & 4) 27 PL_markstack_ptr++; /* Protect mark. */ 27 if (flags & 16) 27 PL_scopestack_ix += 1; /* sv_2cv is too complicated, try a simpler variant first: */ 27 if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) || SvTYPE(cv) != SVt_PVCV) { 9 HV *st; 9 cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE); } 27 if (!cv || !CvROOT(cv)) { 2 if (ckWARN(WARN_SIGNAL)) 1 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n", PL_sig_name[sig], (gv ? GvENAME(gv) : ((cv && CvGV(cv)) ? GvENAME(CvGV(cv)) : "__ANON__"))); 1 goto cleanup; } 25 if(PL_psig_name[sig]) { 25 sv = SvREFCNT_inc(PL_psig_name[sig]); 25 flags |= 64; #if !defined(PERL_IMPLICIT_CONTEXT) 25 PL_sig_sv = sv; #endif } else { ###### sv = sv_newmortal(); ###### sv_setpv(sv,PL_sig_name[sig]); } 25 PUSHSTACKi(PERLSI_SIGNAL); 25 PUSHMARK(SP); 25 PUSHs(sv); 25 PUTBACK; 25 call_sv((SV*)cv, G_DISCARD|G_EVAL); 24 POPSTACK; 24 if (SvTRUE(ERRSV)) { #ifndef PERL_MICRO #ifdef HAS_SIGPROCMASK /* Handler "died", for example to get out of a restart-able read(). * Before we re-do that on its behalf re-enable the signal which was * blocked by the system when we entered. */ 4 sigset_t set; 4 sigemptyset(&set); 4 sigaddset(&set,sig); 4 sigprocmask(SIG_UNBLOCK, &set, NULL); #else /* Not clear if this will work */ (void)rsignal(sig, SIG_IGN); (void)rsignal(sig, PL_csighandlerp); #endif #endif /* !PERL_MICRO */ 4 DieNull; } cleanup: 22 if (flags & 1) 22 PL_savestack_ix -= 8; /* Unprotect save in progress. */ 22 if (flags & 4) 22 PL_markstack_ptr--; 22 if (flags & 16) 22 PL_scopestack_ix -= 1; 22 if (flags & 64) 20 SvREFCNT_dec(sv); 22 PL_op = myop; /* Apparently not needed... */ 22 PL_Sv = tSv; /* Restore global temporaries. */ 22 PL_Xpv = tXpv; return; } static void S_restore_magic(pTHX_ const void *p) 17620547 { 17620547 MGS* const mgs = SSPTR(PTR2IV(p), MGS*); 17620547 SV* const sv = mgs->mgs_sv; 17620547 if (!sv) 402 return; 17620145 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { #ifdef PERL_OLD_COPY_ON_WRITE /* While magic was saved (and off) sv_setsv may well have seen this SV as a prime candidate for COW. */ if (SvIsCOW(sv)) sv_force_normal(sv); #endif 16878804 if (mgs->mgs_flags) 16763550 SvFLAGS(sv) |= mgs->mgs_flags; else 115254 mg_magical(sv); 16878804 if (SvGMAGICAL(sv)) 16111895 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); } 17620145 mgs->mgs_sv = NULL; /* mark the MGS structure as restored */ /* If we're still on top of the stack, pop us off. (That condition * will be satisfied if restore_magic was called explicitly, but *not* * if it's being called via leave_scope.) * The reason for doing this is that otherwise, things like sv_2cv() * may leave alloc gunk on the savestack, and some code * (e.g. sighandler) doesn't expect that... */ 17620145 if (PL_savestack_ix == mgs->mgs_ss_ix) { 17619712 I32 popval = SSPOPINT; 17619712 assert(popval == SAVEt_DESTRUCTOR_X); 17619712 PL_savestack_ix -= 2; 17619712 popval = SSPOPINT; 17619712 assert(popval == SAVEt_ALLOC); 17619712 popval = SSPOPINT; 17619712 PL_savestack_ix -= popval; } } static void S_unwind_handler_stack(pTHX_ const void *p) 5 { dVAR; 5 const U32 flags = *(const U32*)p; 5 if (flags & 1) 5 PL_savestack_ix -= 5; /* Unprotect save in progress. */ /* cxstack_ix-- Not needed, die already unwound it. */ #if !defined(PERL_IMPLICIT_CONTEXT) 5 if (flags & 64) 5 SvREFCNT_dec(PL_sig_sv); #endif } /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 * indent-tabs-mode: t * End: * * ex: set ts=8 sts=4 sw=4 noet: */