/* * Streamer.xs * * Code from Array::RefElem * Copyright (c) 1997-2000 Graham Barr . All rights reserved. * This program is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. * * Code From Scalar::Util * Copyright 2000 Gisle Aas. * This library is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. * A good chunk of the XS is morphed or taken directly from this module. * Thanks Gisle. * * alias_ref is from Lexical::Alias by Jeff Pinyan which * was borrowed/modified from Devel::LexAlias by Richard Clamp * * * Additional Code and Modifications * Copyright 2003 Yves Orton. * This library is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. * */ #ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #ifdef __cplusplus } #endif #ifndef PERL_VERSION # include # if !(defined(PERL_VERSION) || (PERL_SUBVERSION > 0 && defined(PATCHLEVEL))) # include # endif # define PERL_REVISION 5 # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION PERL_SUBVERSION #endif #if PERL_VERSION < 8 # define PERL_MAGIC_qr 'r' /* precompiled qr// regex */ # define BFD_Svs_SMG_OR_RMG SVs_RMG #elif ((PERL_VERSION==8) && (PERL_SUBVERSION >= 1) || (PERL_VERSION>8)) # define BFD_Svs_SMG_OR_RMG SVs_SMG # define MY_PLACEHOLDER PL_sv_placeholder #else # define BFD_Svs_SMG_OR_RMG SVs_RMG # define MY_PLACEHOLDER PL_sv_undef #endif #if (((PERL_VERSION == 9) && (PERL_SUBVERSION >= 4)) || (PERL_VERSION > 9)) # define NEW_REGEX_ENGINE 1 #endif #if (((PERL_VERSION == 8) && (PERL_SUBVERSION >= 1)) || (PERL_VERSION > 8)) #define MY_CAN_FIND_PLACEHOLDERS #define HAS_SV2OBJ #endif #ifdef SvWEAKREF # ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' # endif #define ADD_WEAK_REFCOUNT do { \ MAGIC *mg = NULL; \ if( SvMAGICAL(sv) \ && (mg = mg_find(sv, PERL_MAGIC_backref) ) \ ){ \ SV **svp = (SV**)mg->mg_obj; \ if (svp && *svp) { \ RETVAL += \ SvTYPE(*svp) == SVt_PVAV \ ? av_len((AV*)*svp)+1 \ : 1; \ } \ } \ } while (0) #else #define ADD_WEAK_REFCOUNT #endif #if PERL_VERSION < 7 /* Not in 5.6.1. */ # define SvUOK(sv) SvIOK_UV(sv) # ifdef cxinc # undef cxinc # endif # define cxinc() my_cxinc(aTHX) static I32 my_cxinc(pTHX) { cxstack_max = cxstack_max * 3 / 2; Renew(cxstack, cxstack_max + 1, struct context); /* XXX should fix CXINC macro */ return cxstack_ix + 1; } #endif #if PERL_VERSION < 6 # define NV double #endif #if PERL_VERSION < 8 # define MY_XS_AMAGIC #endif #if ((PERL_VERSION == 8) && (PERL_SUBVERSION <= 8)) # define MY_XS_AMAGIC #endif /* the following three subs are outright stolen from Data::Dumper ( Dumper.xs ) from the 5.6.1 distribution of Perl. Probably Gurusamy Sarathy's work. As is much of the code in _globname and globname */ /* does a string need to be protected? */ static I32 needs_q(register char *s) { TOP: if (s[0] == ':') { if (*++s) { if (*s++ != ':') return 1; } else return 1; } if (isIDFIRST(*s)) { while (*++s) if (!isALNUM(*s)) { if (*s == ':') goto TOP; else return 1; } } else return 1; return 0; } /* count the number of "'"s and "\"s in string */ static I32 num_q(register char *s, register STRLEN slen) { register I32 ret = 0; while (slen > 0) { if (*s == '\'' || *s == '\\') ++ret; ++s; --slen; } return ret; } /* returns number of chars added to escape "'"s and "\"s in s */ /* slen number of characters in s will be escaped */ /* destination must be long enough for additional chars */ static I32 esc_q(register char *d, register char *s, register STRLEN slen) { register I32 ret = 0; while (slen > 0) { switch (*s) { case '\'': case '\\': *d = '\\'; ++d; ++ret; default: *d = *s; ++d; ++s; --slen; break; } } return ret; } XS(XS_Data__Dump__Streamer_SvREADONLY); XS(XS_Data__Dump__Streamer_SvREADONLY) /* This is dangerous stuff. */ { dXSARGS; SV *sv = SvRV(ST(0)); if (items == 1) { if (SvREADONLY(sv)) XSRETURN_YES; else XSRETURN_NO; } else if (items == 2) { if (SvTRUE(ST(1))) { SvREADONLY_on(sv); XSRETURN_YES; } else { /* I hope you really know what you are doing. */ SvREADONLY_off(sv); XSRETURN_NO; } } XSRETURN_UNDEF; /* Can't happen. */ } XS(XS_Data__Dump__Streamer_SvREFCNT); XS(XS_Data__Dump__Streamer_SvREFCNT) /* This is dangerous stuff. */ { dXSARGS; SV *sv = SvRV(ST(0)); if (items == 1) XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ else if (items == 2) { /* I hope you really know what you are doing. */ SvREFCNT(sv) = SvIV(ST(1)); XSRETURN_IV(SvREFCNT(sv)); } XSRETURN_UNDEF; /* Can't happen. */ } /* this is from B is perl 5.9.2 */ typedef SV *B__SV; MODULE = B PACKAGE = B::SV #ifndef HAS_SV2OBJ #define object_2svref(sv) sv #define SVREF SV * SVREF object_2svref(sv) B::SV sv #endif MODULE = Data::Dump::Streamer PACKAGE = Data::Dump::Streamer void dualvar(num,str) SV * num SV * str PROTOTYPE: $$ CODE: { STRLEN len; char *ptr = SvPV(str,len); ST(0) = sv_newmortal(); (void)SvUPGRADE(ST(0),SVt_PVNV); sv_setpvn(ST(0),ptr,len); if(SvNOK(num) || SvPOK(num) || SvMAGICAL(num)) { SvNVX(ST(0)) = SvNV(num); SvNOK_on(ST(0)); } #ifdef SVf_IVisUV else if (SvUOK(num)) { SvUVX(ST(0)) = SvUV(num); SvIOK_on(ST(0)); SvIsUV_on(ST(0)); } #endif else { SvIVX(ST(0)) = SvIV(num); SvIOK_on(ST(0)); } if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str))) SvTAINTED_on(ST(0)); XSRETURN(1); } bool _could_be_dualvar(sv) SV * sv PROTOTYPE: $ CODE: { RETVAL = ((SvNIOK(sv)) && (SvPOK(sv))) ? 1 : 0; } OUTPUT: RETVAL int alias_av(avref, key, val) SV* avref I32 key SV* val PROTOTYPE: \@$$ PREINIT: AV* av; CODE: { if (!SvROK(avref) || SvTYPE(SvRV(avref)) != SVt_PVAV) croak("First argument to alias_av() must be an array reference"); av = (AV*)SvRV(avref); SvREFCNT_inc(val); if (!av_store(av, key, val)) { SvREFCNT_dec(val); RETVAL=0; } else { RETVAL=1; } } OUTPUT: RETVAL void push_alias(avref, val) SV* avref SV* val PROTOTYPE: \@$ PREINIT: AV* av; CODE: if (!SvROK(avref) || SvTYPE(SvRV(avref)) != SVt_PVAV) croak("First argument to push_alias() must be an array reference"); av = (AV*)SvRV(avref); SvREFCNT_inc(val); av_push(av, val); int alias_hv(hvref, key, val) SV* hvref SV* key SV* val PROTOTYPE: \%$$ PREINIT: HV* hv; CODE: { if (!SvROK(hvref) || SvTYPE(SvRV(hvref)) != SVt_PVHV) croak("First argument to alias_hv() must be a hash reference"); hv = (HV*)SvRV(hvref); SvREFCNT_inc(val); if (!hv_store_ent(hv, key, val, 0)) { SvREFCNT_dec(val); RETVAL=0; } else { RETVAL=1; } } OUTPUT: RETVAL char * blessed(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(!sv_isobject(sv)) { XSRETURN_UNDEF; } RETVAL = (char *)sv_reftype(SvRV(sv),TRUE); } OUTPUT: RETVAL UV refaddr(sv) SV * sv PROTOTYPE: $ CODE: { if(!SvROK(sv)) { RETVAL = 0; } else { RETVAL = PTR2UV(SvRV(sv)); } } OUTPUT: RETVAL void weaken(sv) SV *sv PROTOTYPE: $ CODE: #ifdef SvWEAKREF sv_rvweaken(sv); XSRETURN_YES; #else croak("weak references are not implemented in this release of perl"); #endif void isweak(sv) SV *sv PROTOTYPE: $ CODE: #ifdef SvWEAKREF ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv)); XSRETURN(1); #else XSRETURN_NO; #endif IV weak_refcount(sv) SV * sv PROTOTYPE: $ CODE: { RETVAL=0; ADD_WEAK_REFCOUNT; } OUTPUT: RETVAL IV sv_refcount(sv) SV * sv PROTOTYPE: $ CODE: { RETVAL = SvREFCNT(sv); ADD_WEAK_REFCOUNT; } OUTPUT: RETVAL IV refcount(sv) SV * sv PROTOTYPE: $ CODE: { if(!SvROK(sv)) { RETVAL=0; } else { sv = (SV*)SvRV(sv); RETVAL = SvREFCNT(sv); ADD_WEAK_REFCOUNT; } } OUTPUT: RETVAL bool is_numeric(sv) SV * sv PROTOTYPE: $ CODE: { RETVAL = (SvNIOK(sv)) ? 1 : 0; } OUTPUT: RETVAL int _make_ro(sv) SV *sv PROTOTYPE: $ CODE: RETVAL = SvREADONLY_on(sv); OUTPUT: RETVAL SV * make_ro(sv) SV *sv PROTOTYPE: $ CODE: SvREADONLY_on(sv); SvREFCNT_inc(sv); RETVAL=sv; OUTPUT: RETVAL int readonly_set(sv,set) SV *sv SV *set PROTOTYPE: $ CODE: if (SvTRUE(set)) { RETVAL = SvREADONLY_on(sv); } else { RETVAL = SvREADONLY_off(sv); } OUTPUT: RETVAL int readonly(sv) SV *sv PROTOTYPE: $ CODE: RETVAL = SvREADONLY(sv); OUTPUT: RETVAL int looks_like_number(sv) SV *sv PROTOTYPE: $ CODE: RETVAL = looks_like_number(sv); OUTPUT: RETVAL int alias_ref (dst,src) SV *dst SV *src CODE: { AV* padv = PL_comppad; int dt, st; int ok=0; I32 i; if (!SvROK(src) || !SvROK(dst)) croak("destination and source must be references"); dt = SvTYPE(SvRV(dst)); st = SvTYPE(SvRV(src)); if (!(dt < SVt_PVAV && st < SVt_PVAV || dt == st && dt <= SVt_PVHV)) croak("destination and source must be same type (%d != %d)",dt,st); for (i = 0; i <= av_len(padv); ++i) { SV** myvar_ptr = av_fetch(padv, i, 0); if (myvar_ptr) { if (SvRV(dst) == *myvar_ptr) { av_store(padv, i, SvRV(src)); SvREFCNT_inc(SvRV(src)); ok=1; } } } if (!ok) croak("Failed to created alias"); RETVAL = ok; } OUTPUT: RETVAL char * reftype(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(!SvROK(sv)) { XSRETURN_NO; } else { RETVAL = (char *)sv_reftype(SvRV(sv),FALSE); } } OUTPUT: RETVAL char * _globname(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(SvROK(sv)) { XSRETURN_NO; } else { U32 realtype; realtype = SvTYPE(sv); if (realtype == SVt_PVGV) { STRLEN i; RETVAL = SvPV(sv, i); } else { XSRETURN_NO; } } } OUTPUT: RETVAL SV * reftype_or_glob(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(SvROK(sv)) { RETVAL = newSVpv(sv_reftype(SvRV(sv),FALSE),0); } else { U32 realtype; realtype = SvTYPE(sv); if (realtype == SVt_PVGV) { char *c, *r; STRLEN i; /* SV *retval; */ RETVAL = newSVpvn("", 0); /* RETVAL = SvPV(sv, i); */ c = SvPV(sv, i); ++c; --i; /* just get the name */ if (i >= 6 && strncmp(c, "main::", 6) == 0) { c += 4; i -= 4; } if (needs_q(c)) { sv_grow(RETVAL, 6+2*i); r = SvPVX(RETVAL); r[0] = '*'; r[1] = '{'; r[2] = '\''; /* i have a feeling this will cause problems with utf8 glob names */ i += esc_q(r+3, c, i); i += 3; r[i++] = '\''; r[i++] = '}'; r[i] = '\0'; } else { sv_grow(RETVAL, i+2); r = SvPVX(RETVAL); r[0] = '*'; strcpy(r+1, c); i++; } SvCUR_set(RETVAL, i); /*sv_2mortal(RETVAL);*/ /*causes an error*/ } else { XSRETURN_NO; } } } OUTPUT: RETVAL SV * refaddr_or_glob(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(SvROK(sv)) { UV uv; uv = PTR2UV(SvRV(sv)); RETVAL = newSVuv(uv); } else { U32 realtype; realtype = SvTYPE(sv); if (realtype == SVt_PVGV) { char *c, *r; STRLEN i; /* SV *retval; */ RETVAL = newSVpvn("", 0); /* RETVAL = SvPV(sv, i); */ c = SvPV(sv, i); ++c; --i; /* just get the name */ if (i >= 6 && strncmp(c, "main::", 6) == 0) { c += 4; i -= 4; } if (needs_q(c)) { sv_grow(RETVAL, 6+2*i); r = SvPVX(RETVAL); r[0] = '*'; r[1] = '{'; r[2] = '\''; i += esc_q(r+3, c, i); i += 3; r[i++] = '\''; r[i++] = '}'; r[i] = '\0'; } else { sv_grow(RETVAL, i+2); r = SvPVX(RETVAL); r[0] = '*'; strcpy(r+1, c); i++; } SvCUR_set(RETVAL, i); /*sv_2mortal(RETVAL);*/ /*causes an error*/ } else { XSRETURN_NO; } } } OUTPUT: RETVAL SV * globname(sv) SV * sv PROTOTYPE: $ CODE: { if (SvMAGICAL(sv)) mg_get(sv); if(SvROK(sv)) { XSRETURN_NO; } else { U32 realtype; realtype = SvTYPE(sv); if (realtype == SVt_PVGV) { char *c, *r; STRLEN i; /* SV *retval; */ RETVAL = newSVpvn("", 0); /* RETVAL = SvPV(sv, i); */ c = SvPV(sv, i); ++c; --i; /* just get the name */ if (i >= 6 && strncmp(c, "main::", 6) == 0) { c += 4; i -= 4; } if (needs_q(c)) { sv_grow(RETVAL, 6+2*i); r = SvPVX(RETVAL); r[0] = '*'; r[1] = '{'; r[2] = '\''; i += esc_q(r+3, c, i); i += 3; r[i++] = '\''; r[i++] = '}'; r[i] = '\0'; } else { sv_grow(RETVAL, i+2); r = SvPVX(RETVAL); r[0] = '*'; strcpy(r+1, c); i++; } SvCUR_set(RETVAL, i); /*sv_2mortal(RETVAL);*/ /*causes an error*/ } else { XSRETURN_NO; } } } OUTPUT: RETVAL #ifdef MY_XS_AMAGIC void SvAMAGIC_off(sv) SV * sv PROTOTYPE: $ CODE: SvAMAGIC_off(sv); void SvAMAGIC_on(sv,klass) SV * sv SV * klass PROTOTYPE: $$ CODE: SvAMAGIC_off(sv); #endif #ifndef NEW_REGEX_ENGINE void regex(sv) SV * sv PROTOTYPE: $ PREINIT: STRLEN patlen; char reflags[6]; int left; PPCODE: { /* Checks if a reference is a regex or not. If the parameter is not a ref, or is not the result of a qr// then returns undef. Otherwise in list context it returns the pattern and the modifiers, in scalar context it returns the pattern just as it would if the qr// was blessed into the package Regexp and stringified normally. */ if (SvMAGICAL(sv)) { /* is this if needed??? Why?*/ mg_get(sv); } if(!SvROK(sv)) { /* bail if we dont have a ref. */ XSRETURN_UNDEF; } patlen=0; left=0; if (SvTHINKFIRST(sv)) { sv = (SV*)SvRV(sv); if (sv) { MAGIC *mg; if (SvTYPE(sv)==SVt_PVMG) { if ( ((SvFLAGS(sv) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|BFD_Svs_SMG_OR_RMG)) && (mg = mg_find(sv, PERL_MAGIC_qr))) { /* Housten, we have a regex! */ SV *pattern; regexp *re = (regexp *)mg->mg_obj; I32 gimme = GIMME_V; if ( gimme == G_ARRAY ) { /* we are in list/array context so stringify the modifiers that apply. We ignore "negative modifiers" in this scenario. Also we dont cache the modifiers. AFAICT there isnt anywhere for them to go. :-( */ char *fptr = "msix"; char ch; U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); while((ch = *fptr++)) { if(reganch & 1) { reflags[left++] = ch; } reganch >>= 1; } pattern = sv_2mortal(newSVpvn(re->precomp,re->prelen)); if (re->reganch & ROPT_UTF8) SvUTF8_on(pattern); /* return the pattern and the modifiers */ XPUSHs(pattern); XPUSHs(sv_2mortal(newSVpvn(reflags,left))); XSRETURN(2); } else { /* Non array/list context. So we build up the stringified form just as PL_sv_2pv does, and like it we also cache the result. The entire content of the if() is directly taken from PL_sv_2pv */ if (!mg->mg_ptr ) { char *fptr = "msix"; char ch; int right = 4; char need_newline = 0; U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); while((ch = *fptr++)) { if(reganch & 1) { reflags[left++] = ch; } else { reflags[right--] = ch; } reganch >>= 1; } if(left != 4) { reflags[left] = '-'; left = 5; } mg->mg_len = re->prelen + 4 + left; /* * If /x was used, we have to worry about a regex * ending with a comment later being embedded * within another regex. If so, we don't want this * regex's "commentization" to leak out to the * right part of the enclosing regex, we must cap * it with a newline. * * So, if /x was used, we scan backwards from the * end of the regex. If we find a '#' before we * find a newline, we need to add a newline * ourself. If we find a '\n' first (or if we * don't find '#' or '\n'), we don't need to add * anything. -jfriedl */ if (PMf_EXTENDED & re->reganch) { char *endptr = re->precomp + re->prelen; while (endptr >= re->precomp) { char c = *(endptr--); if (c == '\n') break; /* don't need another */ if (c == '#') { /* we end while in a comment, so we need a newline */ mg->mg_len++; /* save space for it */ need_newline = 1; /* note to add it */ break; } } } /**/ New(616, mg->mg_ptr, mg->mg_len + 1 + left, char); Copy("(?", mg->mg_ptr, 2, char); Copy(reflags, mg->mg_ptr+2, left, char); Copy(":", mg->mg_ptr+left+2, 1, char); Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); if (need_newline) mg->mg_ptr[mg->mg_len - 2] = '\n'; mg->mg_ptr[mg->mg_len - 1] = ')'; mg->mg_ptr[mg->mg_len] = 0; } /* return the pattern in (?msix:..) format */ pattern = sv_2mortal(newSVpvn(mg->mg_ptr,mg->mg_len)); if (re->reganch & ROPT_UTF8) SvUTF8_on(pattern); XPUSHs(pattern); XSRETURN(1); } } } } } /* 'twould appear it aint a regex, so return undef/empty list */ XSRETURN_UNDEF; } #endif #ifdef MY_CAN_FIND_PLACEHOLDERS void all_keys(hash,keys,placeholder) SV* hash SV* keys SV* placeholder PROTOTYPE: \%\@\@ PREINIT: AV* av_k; AV* av_p; HV* hv; SV *key; HE *he; CODE: if (!SvROK(hash) || SvTYPE(SvRV(hash)) != SVt_PVHV) croak("First argument to all_keys() must be an HASH reference"); if (!SvROK(keys) || SvTYPE(SvRV(keys)) != SVt_PVAV) croak("Second argument to all_keys() must be an ARRAY reference"); if (!SvROK(placeholder) || SvTYPE(SvRV(placeholder)) != SVt_PVAV) croak("Third argument to all_keys() must be an ARRAY reference"); hv = (HV*)SvRV(hash); av_k = (AV*)SvRV(keys); av_p = (AV*)SvRV(placeholder); av_clear(av_k); av_clear(av_p); (void)hv_iterinit(hv); while((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) { key=hv_iterkeysv(he); if (HeVAL(he) == &MY_PLACEHOLDER) { SvREFCNT_inc(key); av_push(av_p, key); } else { SvREFCNT_inc(key); av_push(av_k, key); } } void hidden_keys(hash) SV* hash PROTOTYPE: \% PREINIT: HV* hv; SV *key; HE *he; PPCODE: if (!SvROK(hash) || SvTYPE(SvRV(hash)) != SVt_PVHV) croak("First argument to hidden_keys() must be an HASH reference"); hv = (HV*)SvRV(hash); (void)hv_iterinit(hv); while((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) { key=hv_iterkeysv(he); if (HeVAL(he) == &MY_PLACEHOLDER) { XPUSHs( key ); } } void legal_keys(hash) SV* hash PROTOTYPE: \% PREINIT: HV* hv; SV *key; HE *he; PPCODE: if (!SvROK(hash) || SvTYPE(SvRV(hash)) != SVt_PVHV) croak("First argument to legal_keys() must be an HASH reference"); hv = (HV*)SvRV(hash); (void)hv_iterinit(hv); while((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) { key=hv_iterkeysv(he); XPUSHs( key ); } #endif BOOT: newXSproto("Data::Dump::Streamer::SvREADONLY_ref", XS_Data__Dump__Streamer_SvREADONLY, file,"$;$"); newXSproto("Data::Dump::Streamer::SvREFCNT_ref", XS_Data__Dump__Streamer_SvREFCNT, file,"$;$");