File Coverage

lib/Data/Dump/Streamer.xs

Criterion	Covered	Total	%
statement	124	225	55.1
branch	118	304	38.8
condition			n/a
subroutine			n/a
pod			n/a
total	242	529	45.7

/*
 * 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,"$;$");