/* maxlen 0 = read one text line */
I32
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
{
filter_t funcp;
SV *datasv = NULL;
if (!PL_rsfp_filters)
return -1;
if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
/* Provide a default input filter to make life easy. */
/* Note that we append to the line. This is handy. */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: from rsfp\n", idx));
if (maxlen) {
/* Want a block */
int len ;
const int old_len = SvCUR(buf_sv);
/* ensure buf_sv is large enough */
SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
if (PerlIO_error(PL_rsfp))
return -1; /* error */
else
return 0 ; /* end of file */
}
SvCUR_set(buf_sv, old_len + len) ;
} else {
/* Want a line */
if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
if (PerlIO_error(PL_rsfp))
return -1; /* error */
else
return 0 ; /* end of file */
}
}
return SvCUR(buf_sv);
}
/* Skip this filter slot if filter has been deleted */
if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: skipped (filter deleted)\n",
idx));
return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
}
/* Get function pointer hidden within datasv */
funcp = DPTR2FPTR(filter_t, IoANY(datasv));
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: via function %p (%s)\n",
idx, datasv, SvPV_nolen_const(datasv)));
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
/* Return: <0:error, =0:eof, >0:not eof */
return (*funcp)(aTHX_ idx, buf_sv, maxlen);
}
void
Perl_taint_proper(pTHX_ const char *f, const char *const s)
{
#if defined(HAS_SETEUID) && defined(DEBUGGING)
dVAR;
PERL_ARGS_ASSERT_TAINT_PROPER;
# if Uid_t_size == 1
{
const UV uid = PL_uid;
const UV euid = PL_euid;
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"UVuf" %"UVuf"\n",
s, PL_tainted, uid, euid));
}
# else
{
const IV uid = PL_uid;
const IV euid = PL_euid;
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"IVdf" %"IVdf"\n",
s, PL_tainted, uid, euid));
}
# endif
#endif
if (PL_tainted) {
const char *ug;
if (!f)
f = PL_no_security;
if (PL_euid != PL_uid)
ug = " while running setuid";
else if (PL_egid != PL_gid)
ug = " while running setgid";
else if (PL_taint_warn)
ug = " while running with -t switch";
else
ug = " while running with -T switch";
if (PL_unsafe || PL_taint_warn) {
if(ckWARN_d(WARN_TAINT))
Perl_warner(aTHX_ packWARN(WARN_TAINT), f, s, ug);
}
else {
Perl_croak(aTHX_ f, s, ug);
}
}
}
void
Perl_taint_proper(pTHX_ const char *f, const char *const s)
{
#if defined(HAS_SETEUID) && defined(DEBUGGING)
PERL_ARGS_ASSERT_TAINT_PROPER;
{
const Uid_t uid = PerlProc_getuid();
const Uid_t euid = PerlProc_geteuid();
#if Uid_t_sign == 1 /* uid_t is unsigned. */
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"UVuf" %"UVuf"\n",
s, TAINT_get, (UV)uid, (UV)euid));
#else /* uid_t is signed (Uid_t_sign == -1), or don't know. */
DEBUG_u(PerlIO_printf(Perl_debug_log,
"%s %d %"IVdf" %"IVdf"\n",
s, TAINT_get, (IV)uid, (IV)euid));
#endif
}
#endif
if (TAINT_get) {
const char *ug;
if (!f)
f = PL_no_security;
if (PerlProc_getuid() != PerlProc_geteuid())
ug = " while running setuid";
else if (PerlProc_getgid() != PerlProc_getegid())
ug = " while running setgid";
else if (TAINT_WARN_get)
ug = " while running with -t switch";
else
ug = " while running with -T switch";
/* XXX because taint_proper adds extra format args, we can't
* get the caller to check properly; o we just silence the warning
* and hope the callers aren't naughty */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
if (PL_unsafe || TAINT_WARN_get) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_TAINT), f, s, ug);
}
else {
Perl_croak(aTHX_ f, s, ug);
}
GCC_DIAG_RESTORE;
}
}
STATIC void
S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max,
I32 mark_min, I32 mark_max)
{
#ifdef DEBUGGING
dVAR;
I32 i = stack_max - 30;
const I32 *markscan = PL_markstack + mark_min;
PERL_ARGS_ASSERT_DEB_STACK_N;
if (i < stack_min)
i = stack_min;
while (++markscan <= PL_markstack + mark_max)
if (*markscan >= i)
break;
if (i > stack_min)
PerlIO_printf(Perl_debug_log, "... ");
if (stack_base[0] != &PL_sv_undef || stack_max < 0)
PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
do {
++i;
if (markscan <= PL_markstack + mark_max && *markscan < i) {
do {
++markscan;
PerlIO_putc(Perl_debug_log, '*');
}
while (markscan <= PL_markstack + mark_max && *markscan < i);
PerlIO_printf(Perl_debug_log, " ");
}
if (i > stack_max)
break;
PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
}
while (1);
PerlIO_printf(Perl_debug_log, "\n");
#else
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(stack_base);
PERL_UNUSED_ARG(stack_min);
PERL_UNUSED_ARG(stack_max);
PERL_UNUSED_ARG(mark_min);
PERL_UNUSED_ARG(mark_max);
#endif /* DEBUGGING */
}
static int
fmm_mime_magic(PerlFMM *state, char *file, char **mime_type)
{
PerlIO *fhandle;
SV *err;
int ret;
if ((ret = fmm_fsmagic(state, file, mime_type)) == 0) {
return 0;
}
if (ret == -1) {
return -1;
}
fhandle = PerlIO_open(file, "r");
if (!fhandle) {
err = newSVpvf(
"Failed to open file %s: %s", file, strerror(errno));
FMM_SET_ERROR(state, err);
return -1;
}
if ((ret = fmm_fhmagic(state, fhandle, mime_type)) == 0) {
#ifdef FMM_DEBUG
PerlIO_printf(PerlIO_stderr(), "[fmm_mime_magic]: fmm_fhmagic returns 0\n");
#endif
PerlIO_close(fhandle);
return 0;
}
PerlIO_close(fhandle);
return fmm_ext_magic(state, file, mime_type);
}
int
Perl_runops_debug(pTHX)
{
#ifdef DEBUGGING
if (!PL_op) {
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN");
return 0;
}
do {
PERL_ASYNC_CHECK();
if (PL_debug) {
if (PL_watchaddr != 0 && *PL_watchaddr != PL_watchok)
PerlIO_printf(Perl_debug_log,
"WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
PTR2UV(*PL_watchaddr));
DEBUG_s(debstack());
DEBUG_t(debop(PL_op));
DEBUG_P(debprof(PL_op));
}
} while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
TAINT_NOT;
return 0;
#else
return runops_standard();
#endif /* DEBUGGING */
}
static void
dl_generic_private_init(pTHX) /* called by dl_*.xs dl_private_init() */
{
char *perl_dl_nonlazy;
MY_CXT_INIT;
MY_CXT.x_dl_last_error = newSVpvn("", 0);
dl_nonlazy = 0;
#ifdef DL_LOADONCEONLY
dl_loaded_files = Nullhv;
#endif
#ifdef DEBUGGING
{
SV *sv = get_sv("DynaLoader::dl_debug", 0);
dl_debug = sv ? SvIV(sv) : 0;
}
#endif
if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL )
dl_nonlazy = atoi(perl_dl_nonlazy);
if (dl_nonlazy)
DLDEBUG(1,PerlIO_printf(Perl_debug_log, "DynaLoader bind mode is 'non-lazy'\n"));
#ifdef DL_LOADONCEONLY
if (!dl_loaded_files)
dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */
#endif
#ifdef DL_UNLOAD_ALL_AT_EXIT
call_atexit(&dl_unload_all_files, (void*)0);
#endif
}
/* SaveError() takes printf style args and saves the result in LastError */
static void
SaveError(pTHXo_ char* pat, ...)
{
va_list args;
SV *msv;
char *message;
STRLEN len;
/* This code is based on croak/warn, see mess() in util.c */
va_start(args, pat);
msv = vmess(pat, &args);
va_end(args);
message = SvPV(msv,len);
len++; /* include terminating null char */
/* Allocate some memory for the error message */
if (LastError)
LastError = (char*)saferealloc(LastError, len) ;
else
LastError = (char *) safemalloc(len) ;
/* Copy message into LastError (including terminating null char) */
strncpy(LastError, message, len) ;
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",LastError));
}
I32
Perl_debstackptrs(pTHX)
{
#ifdef DEBUGGING
dVAR;
PerlIO_printf(Perl_debug_log,
"%8"UVxf" %8"UVxf" %8"IVdf" %8"IVdf" %8"IVdf"\n",
PTR2UV(PL_curstack), PTR2UV(PL_stack_base),
(IV)*PL_markstack_ptr, (IV)(PL_stack_sp-PL_stack_base),
(IV)(PL_stack_max-PL_stack_base));
PerlIO_printf(Perl_debug_log,
"%8"UVxf" %8"UVxf" %8"UVuf" %8"UVuf" %8"UVuf"\n",
PTR2UV(PL_mainstack), PTR2UV(AvARRAY(PL_curstack)),
PTR2UV(PL_mainstack), PTR2UV(AvFILLp(PL_curstack)),
PTR2UV(AvMAX(PL_curstack)));
#endif /* DEBUGGING */
return 0;
}
void
buffer_dump(Buffer *buffer, uint32_t size)
{
unsigned char *data = buffer->buf;
unsigned char c;
int i = 1;
int n;
char bytestr[4] = {0};
char hexstr[ 16*3 + 5] = {0};
char charstr[16*1 + 5] = {0};
if (!size) {
size = buffer->end - buffer->offset;
}
for (n = buffer->offset; n < buffer->offset + size; n++) {
c = data[n];
/* store hex str (for left side) */
snprintf(bytestr, sizeof(bytestr), "%02x ", c);
strncat(hexstr, bytestr, sizeof(hexstr)-strlen(hexstr)-1);
/* store char str (for right side) */
if (isalnum(c) == 0) {
c = '.';
}
snprintf(bytestr, sizeof(bytestr), "%c", c);
strncat(charstr, bytestr, sizeof(charstr)-strlen(charstr)-1);
if (i % 16 == 0) {
/* line completed */
PerlIO_printf(PerlIO_stderr(), "%-50.50s %s\n", hexstr, charstr);
hexstr[0] = 0;
charstr[0] = 0;
}
i++;
}
if (strlen(hexstr) > 0) {
/* print rest of buffer if not empty */
PerlIO_printf(PerlIO_stderr(), "%-50.50s %s\n", hexstr, charstr);
}
}
/* Perform mime magic on a buffer */
static int
fmm_bufmagic(PerlFMM *state, unsigned char **buffer, char **mime_type)
{
if (fmm_softmagic(state, buffer, HOWMANY, mime_type) == 0) {
#ifdef FMM_DEBUG
PerlIO_printf(PerlIO_stderr(), "[fmm_bufmagic]: fmm_softmagic returns 0\n");
#endif
return 0;
}
if (fmm_ascmagic(*buffer, HOWMANY, mime_type) == 0) {
#ifdef FMM_DEBUG
PerlIO_printf(PerlIO_stderr(), "[fmm_bufmagic]: fmm_ascmagic returns 0\n");
#endif
return 0;
}
return 1;
}
void
Perl_watch(pTHX_ char **addr)
{
#ifdef DEBUGGING
PL_watchaddr = addr;
PL_watchok = *addr;
PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n",
PTR2UV(PL_watchaddr), PTR2UV(PL_watchok));
#endif /* DEBUGGING */
}
void
buffer_free(Buffer *buffer)
{
if (buffer->alloc > 0) {
#ifdef XS_DEBUG
PerlIO_printf(PerlIO_stderr(), "Buffer high water mark: %d\n", buffer->alloc);
#endif
memset(buffer->buf, 0, buffer->alloc);
buffer->alloc = 0;
Safefree(buffer->buf);
}
}
void
Perl_vdeb(pTHX_ const char *pat, va_list *args)
{
#ifdef DEBUGGING
const char* const file = PL_curcop ? OutCopFILE(PL_curcop) : "<null>";
const char* const display_file = file ? file : "<free>";
const long line = PL_curcop ? (long)CopLINE(PL_curcop) : 0;
PERL_ARGS_ASSERT_VDEB;
if (DEBUG_v_TEST)
PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t",
(long)PerlProc_getpid(), display_file, line);
else
PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line);
(void) PerlIO_vprintf(Perl_debug_log, pat, *args);
#else
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(pat);
PERL_UNUSED_ARG(args);
#endif /* DEBUGGING */
}
void
Perl_debprofdump(pTHX)
{
#ifdef DEBUGGING
unsigned i;
if (!PL_profiledata)
return;
for (i = 0; i < MAXO; i++) {
if (PL_profiledata[i])
PerlIO_printf(Perl_debug_log,
"%5lu %s\n", (unsigned long)PL_profiledata[i],
PL_op_name[i]);
}
#endif /* DEBUGGING */
}
void
buffer_init(Buffer *buffer, uint32_t len)
{
if (!len) len = BUFFER_ALLOCSZ;
buffer->alloc = 0;
New(0, buffer->buf, (int)len, u_char);
buffer->alloc = len;
buffer->offset = 0;
buffer->end = 0;
#ifdef XS_DEBUG
PerlIO_printf(PerlIO_stderr(), "Buffer allocated with %d bytes\n", len);
#endif
}
static void
fmm_append_mime(PerlFMM *state, char **buf, union VALUETYPE *p, fmmagic *m)
{
char *pp;
unsigned long v;
char *time_str;
SV *err;
#ifdef FMM_DEBUG
PerlIO_printf(PerlIO_stderr(), "fmm_append_mime: buf = %s\n", buf);
#endif
switch (m->type) {
case BYTE:
v = p->b;
break;
case SHORT:
case BESHORT:
case LESHORT:
v = p->h;
break;
case STRING:
if (m->reln == '=') {
fmm_append_buf(state, buf, m->desc, m->value.s );
} else {
fmm_append_buf(state, buf, m->desc, p->s);
}
return;
case DATE:
case BEDATE:
case LEDATE:
Newz(1234, time_str, CTIME_LEN, char);
strftime(time_str, CTIME_LEN, CTIME_FMT,
localtime((const time_t *) &p->l));
pp = time_str;
fmm_append_buf(state, buf, m->desc, pp);
Safefree(time_str);
return;
default:
err = newSVpvf(
"fmm_append_mime: invalud m->type (%d) in fmm_append_mime().\n", m->type);
FMM_SET_ERROR(state, err);
return;
}
v = fmm_signextend(state, m, v) & m->mask;
fmm_append_buf(state, buf, m->desc, (unsigned long) v);
}
I32
Perl_debstack(pTHX)
{
#ifndef SKIP_DEBUGGING
if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
return 0;
PerlIO_printf(Perl_debug_log, " => ");
deb_stack_n(PL_stack_base,
0,
PL_stack_sp - PL_stack_base,
PL_curstackinfo->si_markoff,
PL_markstack_ptr - PL_markstack);
#endif /* SKIP_DEBUGGING */
return 0;
}
void *
buffer_append_space(Buffer *buffer, uint32_t len)
{
uint32_t newlen;
void *p;
if (len > BUFFER_MAX_CHUNK)
croak("buffer_append_space: len %u too large (max %u)", len, BUFFER_MAX_CHUNK);
/* If the buffer is empty, start using it from the beginning. */
if (buffer->offset == buffer->end) {
buffer->offset = 0;
buffer->end = 0;
}
restart:
/* If there is enough space to store all data, store it now. */
if (buffer->end + len <= buffer->alloc) {
p = buffer->buf + buffer->end;
buffer->end += len;
return p;
}
/* Compact data back to the start of the buffer if necessary */
if (buffer_compact(buffer))
goto restart;
/* Increase the size of the buffer and retry. */
if (buffer->alloc + len < 4096)
newlen = (buffer->alloc + len) * 2;
else
newlen = buffer->alloc + len + 4096;
if (newlen > BUFFER_MAX_LEN)
croak("buffer_append_space: alloc %u too large (max %u)",
newlen, BUFFER_MAX_LEN);
#ifdef XS_DEBUG
PerlIO_printf(PerlIO_stderr(), "Buffer extended to %d\n", newlen);
#endif
Renew(buffer->buf, (int)newlen, u_char);
buffer->alloc = newlen;
goto restart;
/* NOTREACHED */
}
void
mop_method_destroy(mop_method *method)
{
if (mop_component_state_has_refs((mop_component *) method))
return;
mop_component_state_destroy((mop_component *) method );
if (method->associated_metaclass != NULL)
return;
PerlIO_printf(PerlIO_stderr(), " DESTROY mop_method %p\n", method);
SvREFCNT_dec(method->body);
Safefree(method->package_name);
Safefree(method->name);
Safefree(method);
}
static int
buffer_compact(Buffer *buffer)
{
/*
* If the buffer is at least BUFFER_COMPACT_PERCENT empty, move the
* data to the beginning.
*/
if (buffer->offset * 1.0 / buffer->alloc >= BUFFER_COMPACT_PERCENT ) {
#ifdef XS_DEBUG
PerlIO_printf(PerlIO_stderr(), "Buffer compacting (%d -> %d)\n", buffer->offset + buffer_len(buffer), buffer_len(buffer));
#endif
Move(buffer->buf + buffer->offset, buffer->buf, (int)(buffer->end - buffer->offset), u_char);
buffer->end -= buffer->offset;
buffer->offset = 0;
return (1);
}
return (0);
}
/* SaveError() takes printf style args and saves the result in dl_last_error */
static void
SaveError(pTHX_ char* pat, ...)
{
dMY_CXT;
va_list args;
SV *msv;
char *message;
STRLEN len;
/* This code is based on croak/warn, see mess() in util.c */
va_start(args, pat);
msv = vmess(pat, &args);
va_end(args);
message = SvPV(msv,len);
len++; /* include terminating null char */
/* Copy message into dl_last_error (including terminating null char) */
sv_setpvn(MY_CXT.x_dl_last_error, message, len) ;
DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",dl_last_error));
}
/* Will refuse to append anything after MAXMIMESTRING into dst*/
static void
fmm_append_buf(PerlFMM *state, char **dst, char *str, ...)
{
va_list ap;
char buf[MAXMIMESTRING];
SV *err;
strcpy( buf, str );
va_start(ap, str);
vsnprintf(buf, sizeof(buf), str, ap);
va_end(ap);
if (strlen(buf) + 1 > MAXMIMESTRING - strlen(*dst)) {
err = newSVpv("detected truncation in fmm_append_buf. refusing to append", 0);
FMM_SET_ERROR(state, err);
return;
}
#ifdef FMM_DEBUG
PerlIO_printf(PerlIO_stderr(), "dst = %s, buf = %s\n", *dst, buf);
#endif
strncat(*dst, buf, strlen(buf));
}
int
runops() {
if (!op) {
warn("NULL OP IN RUN");
return 0;
}
SAVEI32(runlevel);
runlevel++;
do {
if (debug) {
if (watchaddr != 0 && *watchaddr != watchok)
PerlIO_printf(Perl_debug_log, "WARNING: %lx changed from %lx to %lx\n",
(long)watchaddr, (long)watchok, (long)*watchaddr);
DEBUG_s(debstack());
DEBUG_t(debop(op));
DEBUG_P(debprof(op));
}
} while ( op = (*op->op_ppaddr)() );
TAINT_NOT;
return 0;
}
I32
Perl_debop(pTHX_ OP *o)
{
#ifdef DEBUGGING
SV *sv;
SV **svp;
STRLEN n_a;
Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]);
switch (o->op_type) {
case OP_CONST:
PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv));
break;
case OP_GVSV:
case OP_GV:
if (cGVOPo_gv) {
sv = NEWSV(0,0);
gv_fullname3(sv, cGVOPo_gv, Nullch);
PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a));
SvREFCNT_dec(sv);
}
else
PerlIO_printf(Perl_debug_log, "(NULL)");
break;
case OP_PADSV:
case OP_PADAV:
case OP_PADHV:
/* print the lexical's name */
svp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
if (svp)
PerlIO_printf(Perl_debug_log, "(%s)", SvPV(*svp,n_a));
else
PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ);
break;
default:
break;
}
PerlIO_printf(Perl_debug_log, "\n");
#endif /* DEBUGGING */
return 0;
}
wvpinfo *
_wavpack_parse(PerlIO *infile, char *file, HV *info, uint8_t seeking)
{
int err = 0;
int done = 0;
u_char *bptr;
wvpinfo *wvp;
Newz(0, wvp, sizeof(wvpinfo), wvpinfo);
Newz(0, wvp->buf, sizeof(Buffer), Buffer);
Newz(0, wvp->header, sizeof(WavpackHeader), WavpackHeader);
wvp->infile = infile;
wvp->file = file;
wvp->info = info;
wvp->file_offset = 0;
wvp->audio_offset = 0;
wvp->seeking = seeking ? 1 : 0;
buffer_init(wvp->buf, WAVPACK_BLOCK_SIZE);
wvp->file_size = _file_size(infile);
my_hv_store( info, "file_size", newSVuv(wvp->file_size) );
// Loop through each wvpk block until we find a good one
while (!done) {
if ( !_check_buf(infile, wvp->buf, 32, WAVPACK_BLOCK_SIZE) ) {
err = -1;
goto out;
}
bptr = buffer_ptr(wvp->buf);
// If first byte is 'R', assume old version
if ( bptr[0] == 'R' ) {
if ( !_wavpack_parse_old(wvp) ) {
err = -1;
goto out;
}
break;
}
// May need to read past some junk before wvpk header
while ( bptr[0] != 'w' || bptr[1] != 'v' || bptr[2] != 'p' || bptr[3] != 'k' ) {
buffer_consume(wvp->buf, 1);
wvp->audio_offset++;
if ( !buffer_len(wvp->buf) ) {
if ( !_check_buf(infile, wvp->buf, 32, WAVPACK_BLOCK_SIZE) ) {
PerlIO_printf(PerlIO_stderr(), "Unable to find a valid WavPack block in file: %s\n", file);
err = -1;
goto out;
}
}
bptr = buffer_ptr(wvp->buf);
}
if ( _wavpack_parse_block(wvp) ) {
done = 1;
}
}
my_hv_store( info, "audio_offset", newSVuv(wvp->audio_offset) );
my_hv_store( info, "audio_size", newSVuv(wvp->file_size - wvp->audio_offset) );
out:
buffer_free(wvp->buf);
Safefree(wvp->buf);
Safefree(wvp->header);
return wvp;
}
/*
* Initialize locale awareness.
*/
int
Perl_init_i18nl10n(pTHX_ int printwarn)
{
int ok = 1;
/* returns
* 1 = set ok or not applicable,
* 0 = fallback to C locale,
* -1 = fallback to C locale failed
*/
#if defined(USE_LOCALE)
#ifdef USE_LOCALE_CTYPE
char *curctype = NULL;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
char *curcoll = NULL;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
char *curnum = NULL;
#endif /* USE_LOCALE_NUMERIC */
#ifdef __GLIBC__
char *language = PerlEnv_getenv("LANGUAGE");
#endif
char *lc_all = PerlEnv_getenv("LC_ALL");
char *lang = PerlEnv_getenv("LANG");
bool setlocale_failure = FALSE;
#ifdef LOCALE_ENVIRON_REQUIRED
/*
* Ultrix setlocale(..., "") fails if there are no environment
* variables from which to get a locale name.
*/
bool done = FALSE;
#ifdef LC_ALL
if (lang) {
if (setlocale(LC_ALL, ""))
done = TRUE;
else
setlocale_failure = TRUE;
}
if (!setlocale_failure) {
#ifdef USE_LOCALE_CTYPE
if (! (curctype =
setlocale(LC_CTYPE,
(!done && (lang || PerlEnv_getenv("LC_CTYPE")))
? "" : Nullch)))
setlocale_failure = TRUE;
else
curctype = savepv(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! (curcoll =
setlocale(LC_COLLATE,
(!done && (lang || PerlEnv_getenv("LC_COLLATE")))
? "" : Nullch)))
setlocale_failure = TRUE;
else
curcoll = savepv(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! (curnum =
setlocale(LC_NUMERIC,
(!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
? "" : Nullch)))
setlocale_failure = TRUE;
else
curnum = savepv(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
#endif /* LC_ALL */
#endif /* !LOCALE_ENVIRON_REQUIRED */
#ifdef LC_ALL
if (! setlocale(LC_ALL, ""))
setlocale_failure = TRUE;
#endif /* LC_ALL */
if (!setlocale_failure) {
#ifdef USE_LOCALE_CTYPE
if (! (curctype = setlocale(LC_CTYPE, "")))
setlocale_failure = TRUE;
else
curctype = savepv(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! (curcoll = setlocale(LC_COLLATE, "")))
setlocale_failure = TRUE;
else
curcoll = savepv(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! (curnum = setlocale(LC_NUMERIC, "")))
setlocale_failure = TRUE;
else
curnum = savepv(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
if (setlocale_failure) {
char *p;
bool locwarn = (printwarn > 1 ||
(printwarn &&
(!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
if (locwarn) {
#ifdef LC_ALL
PerlIO_printf(Perl_error_log,
"perl: warning: Setting locale failed.\n");
#else /* !LC_ALL */
PerlIO_printf(Perl_error_log,
"perl: warning: Setting locale failed for the categories:\n\t");
#ifdef USE_LOCALE_CTYPE
if (! curctype)
PerlIO_printf(Perl_error_log, "LC_CTYPE ");
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
if (! curcoll)
PerlIO_printf(Perl_error_log, "LC_COLLATE ");
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
if (! curnum)
PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
#endif /* USE_LOCALE_NUMERIC */
PerlIO_printf(Perl_error_log, "\n");
#endif /* LC_ALL */
PerlIO_printf(Perl_error_log,
"perl: warning: Please check that your locale settings:\n");
#ifdef __GLIBC__
PerlIO_printf(Perl_error_log,
"\tLANGUAGE = %c%s%c,\n",
language ? '"' : '(',
language ? language : "unset",
language ? '"' : ')');
#endif
PerlIO_printf(Perl_error_log,
"\tLC_ALL = %c%s%c,\n",
lc_all ? '"' : '(',
lc_all ? lc_all : "unset",
lc_all ? '"' : ')');
#if defined(USE_ENVIRON_ARRAY)
{
char **e;
for (e = environ; *e; e++) {
if (strnEQ(*e, "LC_", 3)
&& strnNE(*e, "LC_ALL=", 7)
&& (p = strchr(*e, '=')))
PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
(int)(p - *e), *e, p + 1);
}
}
#else
PerlIO_printf(Perl_error_log,
"\t(possibly more locale environment variables)\n");
#endif
PerlIO_printf(Perl_error_log,
"\tLANG = %c%s%c\n",
lang ? '"' : '(',
lang ? lang : "unset",
lang ? '"' : ')');
PerlIO_printf(Perl_error_log,
" are supported and installed on your system.\n");
}
#ifdef LC_ALL
if (setlocale(LC_ALL, "C")) {
if (locwarn)
PerlIO_printf(Perl_error_log,
"perl: warning: Falling back to the standard locale (\"C\").\n");
ok = 0;
}
else {
if (locwarn)
PerlIO_printf(Perl_error_log,
"perl: warning: Failed to fall back to the standard locale (\"C\").\n");
ok = -1;
}
#else /* ! LC_ALL */
if (0
#ifdef USE_LOCALE_CTYPE
|| !(curctype || setlocale(LC_CTYPE, "C"))
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
|| !(curcoll || setlocale(LC_COLLATE, "C"))
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
|| !(curnum || setlocale(LC_NUMERIC, "C"))
#endif /* USE_LOCALE_NUMERIC */
)
{
if (locwarn)
PerlIO_printf(Perl_error_log,
"perl: warning: Cannot fall back to the standard locale (\"C\").\n");
ok = -1;
}
#endif /* ! LC_ALL */
#ifdef USE_LOCALE_CTYPE
curctype = savepv(setlocale(LC_CTYPE, Nullch));
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
curcoll = savepv(setlocale(LC_COLLATE, Nullch));
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
curnum = savepv(setlocale(LC_NUMERIC, Nullch));
#endif /* USE_LOCALE_NUMERIC */
}
else {
#ifdef USE_LOCALE_CTYPE
new_ctype(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
new_collate(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
new_numeric(curnum);
#endif /* USE_LOCALE_NUMERIC */
}
#endif /* USE_LOCALE */
#ifdef USE_PERLIO
{
/* Set PL_utf8locale to TRUE if using PerlIO _and_
any of the following are true:
- nl_langinfo(CODESET) contains /^utf-?8/i
- $ENV{LC_ALL} contains /^utf-?8/i
- $ENV{LC_CTYPE} contains /^utf-?8/i
- $ENV{LANG} contains /^utf-?8/i
The LC_ALL, LC_CTYPE, LANG obey the usual override
hierarchy of locale environment variables. (LANGUAGE
affects only LC_MESSAGES only under glibc.) (If present,
it overrides LC_MESSAGES for GNU gettext, and it also
can have more than one locale, separated by spaces,
in case you need to know.)
If PL_utf8locale and PL_unicode (set by -C or by $ENV{PERL_UNICODE})
are true, perl.c:S_parse_body() will turn on the PerlIO :utf8 layer
on STDIN, STDOUT, STDERR, _and_ the default open discipline.
*/
bool utf8locale = FALSE;
char *codeset = NULL;
#if defined(HAS_NL_LANGINFO) && defined(CODESET)
codeset = nl_langinfo(CODESET);
#endif
if (codeset)
utf8locale = (ibcmp(codeset, "UTF-8", 5) == 0 ||
ibcmp(codeset, "UTF8", 4) == 0);
#if defined(USE_LOCALE)
else { /* nl_langinfo(CODESET) is supposed to correctly
* interpret the locale environment variables,
* but just in case it fails, let's do this manually. */
if (lang)
utf8locale = (ibcmp(lang, "UTF-8", 5) == 0 ||
ibcmp(lang, "UTF8", 4) == 0);
#ifdef USE_LOCALE_CTYPE
if (curctype)
utf8locale = (ibcmp(curctype, "UTF-8", 5) == 0 ||
ibcmp(curctype, "UTF8", 4) == 0);
#endif
if (lc_all)
utf8locale = (ibcmp(lc_all, "UTF-8", 5) == 0 ||
ibcmp(lc_all, "UTF8", 4) == 0);
}
#endif /* USE_LOCALE */
if (utf8locale)
PL_utf8locale = TRUE;
}
/* Set PL_unicode to $ENV{PERL_UNICODE} if using PerlIO.
This is an alternative to using the -C command line switch
(the -C if present will override this). */
{
char *p = PerlEnv_getenv("PERL_UNICODE");
PL_unicode = p ? parse_unicode_opts(&p) : 0;
}
#endif
#ifdef USE_LOCALE_CTYPE
Safefree(curctype);
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
Safefree(curcoll);
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
Safefree(curnum);
#endif /* USE_LOCALE_NUMERIC */
return ok;
}
int
_wavpack_parse_old(wvpinfo *wvp)
{
int ret = 1;
char chunk_id[5];
uint32_t chunk_size;
WavpackHeader3 wphdr;
WaveHeader3 wavhdr;
unsigned char *bptr;
uint32_t total_samples;
uint32_t song_length_ms;
Zero(&wavhdr, sizeof(wavhdr), char);
Zero(&wphdr, sizeof(wphdr), char);
DEBUG_TRACE("Parsing old WavPack version\n");
// Verify RIFF header
if ( strncmp( (char *)buffer_ptr(wvp->buf), "RIFF", 4 ) ) {
PerlIO_printf(PerlIO_stderr(), "Invalid WavPack file: missing RIFF header: %s\n", wvp->file);
ret = 0;
goto out;
}
buffer_consume(wvp->buf, 4);
chunk_size = buffer_get_int_le(wvp->buf);
// Check format
if ( strncmp( (char *)buffer_ptr(wvp->buf), "WAVE", 4 ) ) {
PerlIO_printf(PerlIO_stderr(), "Invalid WavPack file: missing WAVE header: %s\n", wvp->file);
ret = 0;
goto out;
}
buffer_consume(wvp->buf, 4);
wvp->file_offset += 12;
// Verify we have at least 8 bytes
if ( !_check_buf(wvp->infile, wvp->buf, 8, WAVPACK_BLOCK_SIZE) ) {
ret = 0;
goto out;
}
// loop through all chunks, read fmt, and break at data
while ( buffer_len(wvp->buf) >= 8 ) {
strncpy( chunk_id, (char *)buffer_ptr(wvp->buf), 4 );
chunk_id[4] = '\0';
buffer_consume(wvp->buf, 4);
chunk_size = buffer_get_int_le(wvp->buf);
wvp->file_offset += 8;
// Adjust for padding
if ( chunk_size % 2 ) {
chunk_size++;
}
DEBUG_TRACE(" %s size %d\n", chunk_id, chunk_size);
if ( !strcmp( chunk_id, "data" ) ) {
break;
}
wvp->file_offset += chunk_size;
if ( !strcmp( chunk_id, "fmt " ) ) {
if ( !_check_buf(wvp->infile, wvp->buf, chunk_size, WAV_BLOCK_SIZE) ) {
ret = 0;
goto out;
}
if (chunk_size < sizeof(wavhdr)) {
ret = 0;
goto out;
}
// Read wav header
wavhdr.FormatTag = buffer_get_short_le(wvp->buf);
wavhdr.NumChannels = buffer_get_short_le(wvp->buf);
wavhdr.SampleRate = buffer_get_int_le(wvp->buf);
wavhdr.BytesPerSecond = buffer_get_int_le(wvp->buf);
wavhdr.BlockAlign = buffer_get_short_le(wvp->buf);
wavhdr.BitsPerSample = buffer_get_short_le(wvp->buf);
// Skip rest of fmt chunk if necessary
if (chunk_size > 16) {
_wavpack_skip(wvp, chunk_size - 16);
}
}
else {
// Skip it
_wavpack_skip(wvp, chunk_size);
}
// Verify we have at least 8 bytes
if ( !_check_buf(wvp->infile, wvp->buf, 8, WAVPACK_BLOCK_SIZE) ) {
ret = 0;
goto out;
}
}
// Verify wav header, this code comes from unpack3.c
if (
wavhdr.FormatTag != 1 || !wavhdr.NumChannels || wavhdr.NumChannels > 2 ||
!wavhdr.SampleRate || wavhdr.BitsPerSample < 16 || wavhdr.BitsPerSample > 24 ||
wavhdr.BlockAlign / wavhdr.NumChannels > 3 || wavhdr.BlockAlign % wavhdr.NumChannels ||
wavhdr.BlockAlign / wavhdr.NumChannels < (wavhdr.BitsPerSample + 7) / 8
) {
ret = 0;
goto out;
}
// chunk_size here is the size of the data chunk
total_samples = chunk_size / wavhdr.NumChannels / ((wavhdr.BitsPerSample > 16) ? 3 : 2);
// read WavpackHeader3 (differs for each version)
bptr = buffer_ptr(wvp->buf);
if ( bptr[0] != 'w' || bptr[1] != 'v' || bptr[2] != 'p' || bptr[3] != 'k' ) {
PerlIO_printf(PerlIO_stderr(), "Invalid WavPack file: missing wvpk header: %s\n", wvp->file);
ret = 0;
goto out;
}
buffer_consume(wvp->buf, 4);
wphdr.ckSize = buffer_get_int_le(wvp->buf);
wphdr.version = buffer_get_short_le(wvp->buf);
if (wphdr.version >= 2) {
wphdr.bits = buffer_get_short_le(wvp->buf);
}
if (wphdr.version == 3) {
wphdr.flags = buffer_get_short_le(wvp->buf);
wphdr.shift = buffer_get_short_le(wvp->buf);
wphdr.total_samples = buffer_get_int_le(wvp->buf);
total_samples = wphdr.total_samples;
}
DEBUG_TRACE("wvpk header @ %llu:\n", wvp->file_offset);
DEBUG_TRACE(" size: %u\n", wphdr.ckSize);
DEBUG_TRACE(" version: %d\n", wphdr.version);
DEBUG_TRACE(" bits: 0x%x\n", wphdr.bits);
DEBUG_TRACE(" flags: 0x%x\n", wphdr.flags);
DEBUG_TRACE(" shift: 0x%x\n", wphdr.shift);
DEBUG_TRACE(" total_samples: %d\n", wphdr.total_samples);
my_hv_store( wvp->info, "encoder_version", newSVuv(wphdr.version) );
my_hv_store( wvp->info, "bits_per_sample", newSVuv(wavhdr.BitsPerSample) );
my_hv_store( wvp->info, "channels", newSVuv(wavhdr.NumChannels) );
my_hv_store( wvp->info, "samplerate", newSVuv(wavhdr.SampleRate) );
my_hv_store( wvp->info, "total_samples", newSVuv(total_samples) );
song_length_ms = ((total_samples * 1.0) / wavhdr.SampleRate) * 1000;
my_hv_store( wvp->info, "song_length_ms", newSVuv(song_length_ms) );
my_hv_store( wvp->info, "bitrate", newSVuv( _bitrate(wvp->file_size - wvp->audio_offset, song_length_ms) ) );
out:
return ret;
}
SV *
DeadCode(pTHX)
{
#ifdef PURIFY
return Nullsv;
#else
SV* sva;
SV* sv;
SV* ret = newRV_noinc((SV*)newAV());
register SV* svend;
int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) == SVt_PVCV) {
CV *cv = (CV*)sv;
AV* padlist = CvPADLIST(cv), *argav;
SV** svp;
SV** pad;
int i = 0, j, levelm, totm = 0, levelref, totref = 0;
int levels, tots = 0, levela, tota = 0, levelas, totas = 0;
int dumpit = 0;
if (CvXSUB(sv)) {
continue; /* XSUB */
}
if (!CvGV(sv)) {
continue; /* file-level scope. */
}
if (!CvROOT(cv)) {
/* PerlIO_printf(Perl_debug_log, " no root?!\n"); */
continue; /* autoloading stub. */
}
do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv));
if (CvDEPTH(cv)) {
PerlIO_printf(Perl_debug_log, " busy\n");
continue;
}
svp = AvARRAY(padlist);
while (++i <= AvFILL(padlist)) { /* Depth. */
SV **args;
pad = AvARRAY((AV*)svp[i]);
argav = (AV*)pad[0];
if (!argav || (SV*)argav == &PL_sv_undef) {
PerlIO_printf(Perl_debug_log, " closure-template\n");
continue;
}
args = AvARRAY(argav);
levelm = levels = levelref = levelas = 0;
levela = sizeof(SV*) * (AvMAX(argav) + 1);
if (AvREAL(argav)) {
for (j = 0; j < AvFILL(argav); j++) {
if (SvROK(args[j])) {
PerlIO_printf(Perl_debug_log, " ref in args!\n");
levelref++;
}
/* else if (SvPOK(args[j]) && SvPVX(args[j])) { */
else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) {
levelas += SvLEN(args[j])/SvREFCNT(args[j]);
}
}
}
for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */
if (SvROK(pad[j])) {
levelref++;
do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
dumpit = 1;
}
/* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */
else if (SvTYPE(pad[j]) >= SVt_PVAV) {
if (!SvPADMY(pad[j])) {
levelref++;
do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
dumpit = 1;
}
}
else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) {
levels++;
levelm += SvLEN(pad[j])/SvREFCNT(pad[j]);
/* Dump(pad[j],4); */
}
}
PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n",
i, levelref, levelm, levels, levela, levelas);
totm += levelm;
tota += levela;
totas += levelas;
tots += levels;
totref += levelref;
if (dumpit)
do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
}
if (AvFILL(padlist) > 1) {
PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n",
totref, totm, tots, tota, totas);
}
tref += totref;
tm += totm;
ts += tots;
ta += tota;
tas += totas;
}
}
}
PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
return ret;
#endif /* !PURIFY */
}
void
Perl_deb_stack_all(pTHX)
{
#ifdef DEBUGGING
dVAR;
I32 si_ix;
const PERL_SI *si;
/* rewind to start of chain */
si = PL_curstackinfo;
while (si->si_prev)
si = si->si_prev;
si_ix=0;
for (;;)
{
const size_t si_name_ix = si->si_type+1; /* -1 is a valid index */
const char * const si_name = (si_name_ix >= sizeof(si_names)) ? "????" : si_names[si_name_ix];
I32 ix;
PerlIO_printf(Perl_debug_log, "STACK %"IVdf": %s\n",
(IV)si_ix, si_name);
for (ix=0; ix<=si->si_cxix; ix++) {
const PERL_CONTEXT * const cx = &(si->si_cxstack[ix]);
PerlIO_printf(Perl_debug_log,
" CX %"IVdf": %-6s => ",
(IV)ix, PL_block_type[CxTYPE(cx)]
);
/* substitution contexts don't save stack pointers etc) */
if (CxTYPE(cx) == CXt_SUBST)
PerlIO_printf(Perl_debug_log, "\n");
else {
/* Find the current context's stack range by searching
* forward for any higher contexts using this stack; failing
* that, it will be equal to the size of the stack for old
* stacks, or PL_stack_sp for the current stack
*/
I32 i, stack_min, stack_max, mark_min, mark_max;
const PERL_CONTEXT *cx_n = NULL;
const PERL_SI *si_n;
/* there's a separate stack per SI, so only search
* this one */
for (i=ix+1; i<=si->si_cxix; i++) {
if (CxTYPE(cx) == CXt_SUBST)
continue;
cx_n = &(si->si_cxstack[i]);
break;
}
stack_min = cx->blk_oldsp;
if (cx_n) {
stack_max = cx_n->blk_oldsp;
}
else if (si == PL_curstackinfo) {
stack_max = PL_stack_sp - AvARRAY(si->si_stack);
}
else {
stack_max = AvFILLp(si->si_stack);
}
/* for the other stack types, there's only one stack
* shared between all SIs */
si_n = si;
i = ix;
cx_n = NULL;
for (;;) {
i++;
if (i > si_n->si_cxix) {
if (si_n == PL_curstackinfo)
break;
else {
si_n = si_n->si_next;
i = 0;
}
}
if (CxTYPE(&(si_n->si_cxstack[i])) == CXt_SUBST)
continue;
cx_n = &(si_n->si_cxstack[i]);
break;
}
mark_min = cx->blk_oldmarksp;
if (cx_n) {
mark_max = cx_n->blk_oldmarksp;
}
else {
mark_max = PL_markstack_ptr - PL_markstack;
}
deb_stack_n(AvARRAY(si->si_stack),
stack_min, stack_max, mark_min, mark_max);
if (CxTYPE(cx) == CXt_EVAL || CxTYPE(cx) == CXt_SUB
|| CxTYPE(cx) == CXt_FORMAT)
{
const OP * const retop = cx->blk_sub.retop;
PerlIO_printf(Perl_debug_log, " retop=%s\n",
retop ? OP_NAME(retop) : "(null)"
);
}
}
} /* next context */
if (si == PL_curstackinfo)
break;
si = si->si_next;
si_ix++;
if (!si)
break; /* shouldn't happen, but just in case.. */
} /* next stackinfo */
PerlIO_printf(Perl_debug_log, "\n");
#else
PERL_UNUSED_CONTEXT;
#endif /* DEBUGGING */
}
