/* mg.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
STATIC void
S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
{
- dTHR;
MGS* mgs;
assert(SvMAGICAL(sv));
int
Perl_mg_get(pTHX_ SV *sv)
{
- dTHR;
I32 mgs_ix;
MAGIC* mg;
MAGIC** mgp;
int
Perl_mg_set(pTHX_ SV *sv)
{
- dTHR;
I32 mgs_ix;
MAGIC* mg;
MAGIC* nextmg;
Perl_mg_find(pTHX_ SV *sv, int type)
{
MAGIC* mg;
+ if (!sv)
+ return 0;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
if (mg->mg_type == type)
return mg;
moremagic = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != 'g')
+ if (mg->mg_ptr && mg->mg_type != 'g') {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
+ }
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
return 0;
}
+
#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
#endif
U32
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register REGEXP *rx;
if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
int
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register I32 paren;
register I32 s;
register I32 i;
i = t;
else /* @- */
i = s;
+
+ if (i > 0 && DO_UTF8(PL_reg_sv)) {
+ char *b = rx->subbeg;
+ i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
+ }
sv_setiv(sv,i);
}
}
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
Perl_croak(aTHX_ PL_no_modify);
/* NOT REACHED */
return 0;
U32
Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register I32 paren;
register I32 i;
register REGEXP *rx;
case '5': case '6': case '7': case '8': case '9': case '&':
if (PL_curpm && (rx = PL_curpm->op_pmregexp)) {
- paren = atoi(mg->mg_ptr);
+ paren = atoi(mg->mg_ptr); /* $& is in [0] */
getparen:
if (paren <= rx->nparens &&
(s1 = rx->startp[paren]) != -1 &&
{
i = t1 - s1;
getlen:
- if (i > 0 && (PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) {
- char *s = rx->subbeg + s1;
+ if (i > 0 && DO_UTF8(PL_reg_sv)) {
+ char *s = rx->subbeg + s1;
char *send = rx->subbeg + t1;
- i = 0;
- while (s < send) {
- s += UTF8SKIP(s);
- i++;
- }
+
+ i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
}
- if (i >= 0)
- return i;
+ if (i < 0)
+ Perl_croak(aTHX_ "panic: magic_len: %d", i);
+ return i;
}
}
return 0;
}
}
return 0;
- case ',':
- return (STRLEN)PL_ofslen;
- case '\\':
- return (STRLEN)PL_orslen;
}
magic_get(sv,mg);
if (!SvPOK(sv) && SvNIOK(sv)) {
int
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register I32 paren;
register char *s;
register I32 i;
break;
case '\023': /* ^S */
{
- dTHR;
if (PL_lex_state != LEX_NOTPARSING)
(void)SvOK_off(sv);
else if (PL_in_eval)
* Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
* XXX Does the new way break anything?
*/
- paren = atoi(mg->mg_ptr);
+ paren = atoi(mg->mg_ptr); /* $& is in [0] */
getparen:
if (paren <= rx->nparens &&
(s1 = rx->startp[paren]) != -1 &&
PL_tainted = FALSE;
}
sv_setpvn(sv, s, i);
- if ((PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE)
+ if (DO_UTF8(PL_reg_sv))
SvUTF8_on(sv);
else
SvUTF8_off(sv);
sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
break;
case ',':
- sv_setpvn(sv,PL_ofs,PL_ofslen);
break;
case '\\':
- sv_setpvn(sv,PL_ors,PL_orslen);
break;
case '#':
sv_setpv(sv,PL_ofmt);
#if defined(VMS)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
#else
- dTHR;
if (PL_localizing) {
HE* entry;
STRLEN n_a;
}
FreeEnvironmentStrings(envv);
# else
+#ifdef USE_ENVIRON_ARRAY
# ifndef PERL_USE_SAFE_PUTENV
I32 i;
environ[0] = Nullch;
+#endif /* USE_ENVIRON_ARRAY */
# endif /* WIN32 */
# endif /* PERL_IMPLICIT_SYS */
#endif /* VMS */
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register char *s;
I32 i;
SV** svp;
int
Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
OP *o;
I32 i;
GV* gv;
int
Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
return 0;
}
int
Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
return 0;
}
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
mg = mg_find(lsv, 'g');
if (mg && mg->mg_len >= 0) {
- dTHR;
I32 i = mg->mg_len;
if (DO_UTF8(lsv))
sv_pos_b2u(lsv, &i);
SSize_t pos;
STRLEN len;
STRLEN ulen = 0;
- dTHR;
mg = 0;
{
STRLEN len;
char *tmps = SvPV(sv,len);
- sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+ if (DO_UTF8(sv)) {
+ sv_utf8_upgrade(LvTARG(sv));
+ sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+ SvUTF8_on(LvTARG(sv));
+ }
+ else
+ sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+
return 0;
}
int
Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
TAINT_IF((mg->mg_len & 1) ||
((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
return 0;
int
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
if (PL_localizing) {
if (PL_localizing == 1)
mg->mg_len <<= 1;
targ = AvARRAY(av)[LvTARGOFF(sv)];
}
if (targ && targ != &PL_sv_undef) {
- dTHR; /* just for SvREFCNT_dec */
/* somebody else defined it for us */
SvREFCNT_dec(LvTARG(sv));
LvTARG(sv) = SvREFCNT_inc(targ);
void
Perl_vivify_defelem(pTHX_ SV *sv)
{
- dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/
MAGIC *mg;
SV *value = Nullsv;
int
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
register char *s;
I32 i;
STRLEN len;
PL_rs = SvREFCNT_inc(PL_nrs);
break;
case '\\':
- if (PL_ors)
- Safefree(PL_ors);
+ if (PL_ors_sv)
+ SvREFCNT_dec(PL_ors_sv);
if (SvOK(sv) || SvGMAGICAL(sv)) {
- s = SvPV(sv,PL_orslen);
- PL_ors = savepvn(s,PL_orslen);
+ PL_ors_sv = newSVsv(sv);
}
else {
- PL_ors = Nullch;
- PL_orslen = 0;
+ PL_ors_sv = Nullsv;
}
break;
case ',':
- if (PL_ofs)
- Safefree(PL_ofs);
- PL_ofs = savepv(SvPV(sv, PL_ofslen));
+ if (PL_ofs_sv)
+ SvREFCNT_dec(PL_ofs_sv);
+ if (SvOK(sv) || SvGMAGICAL(sv)) {
+ PL_ofs_sv = newSVsv(sv);
+ }
+ else {
+ PL_ofs_sv = Nullsv;
+ }
break;
case '#':
if (PL_ofmt)
int
Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
{
- dTHR;
DEBUG_S(PerlIO_printf(Perl_debug_log,
"0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
PTR2UV(thr), PTR2UV(sv));)
static void
restore_magic(pTHXo_ void *p)
{
- dTHR;
MGS* mgs = SSPTR(PTR2IV(p), MGS*);
SV* sv = mgs->mgs_sv;
static void
unwind_handler_stack(pTHXo_ void *p)
{
- dTHR;
U32 flags = *(U32*)p;
if (flags & 1)