<commit_before>#include "mod_perl.h"

#ifdef MP_IO_TIE_PERLIO

/***************************
 * The PerlIO Apache layer *
 ***************************/

/* PerlIO ":Apache" layer is used to use the Apache callbacks to read
 * from STDIN and write to STDOUT. The PerlIO API is documented in
 * perliol.pod */

typedef struct {
    struct _PerlIO base;
    request_rec *r;
} PerlIOApache;

/* _open just allocates the layer, _pushed does the real job of
 * filling the data in */
static PerlIO *
PerlIOApache_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n,
		  const char *mode, int fd, int imode, int perm,
		  PerlIO *f, int narg, SV **args)
{
    if (!f) {
        f = PerlIO_allocate(aTHX);
    }
    if ( (f = PerlIO_push(aTHX_ f, self, mode, args[0])) ) {
        PerlIOBase(f)->flags |= PERLIO_F_OPEN;
    }

    MP_TRACE_o(MP_FUNC, "mode %s", mode);

    return f;
}

/* this callback is used by pushed() and binmode() to add the layer */
static IV
PerlIOApache_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg,
		    PerlIO_funcs *tab)
{
    IV code;
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);

    if (arg) {
        st->r = modperl_sv2request_rec(aTHX_ arg);
        MP_TRACE_o(MP_FUNC, "stored request_rec obj: 0x%lx", st->r);
    }
    else {
        Perl_croak(aTHX_ "$r wasn't passed");
        /* XXX: try to get Apache->request? */
    }
    
    /* this method also sets the right flags according to the
     * 'mode' */
    code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
    
    return code;
}

static SV *
PerlIOApache_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
    SV *sv = newSV(0);

    if (!st->r) {
        Perl_croak(aTHX_ "an attempt to getarg from a stale io handle");
    }
    
    sv_setref_pv(sv, "Apache::RequestRec", (void*)(st->r));

    MP_TRACE_o(MP_FUNC, "retrieved request_rec obj: 0x%lx", st->r);
    
    return sv;
}

static IV
PerlIOApache_fileno(pTHX_ PerlIO *f)
{
    /* XXX: we could return STDIN => 0, STDOUT => 1, but that wouldn't
     * be correct, as the IO goes through the socket, may be we should
     * return the filedescriptor of the socket? 
     *
     * -1 in this case indicates that the layer cannot provide fileno
     */
    MP_TRACE_o(MP_FUNC, "did nothing");
    return -1;
}

static SSize_t
PerlIOApache_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
    request_rec *r = st->r;
    long total = 0;
    int rc;

    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
        PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
	return 0;
    }

    if (!r->read_length) {
        /* only do this once per-request */
        if ((rc = ap_setup_client_block(r, REQUEST_CHUNKED_ERROR)) != OK) {
            ap_log_error(APLOG_MARK, APLOG_ERR, 0, r->server,
                         "mod_perl: ap_setup_client_block failed: %d", rc);
            return -1;
        }
    }

    if (r->read_length || ap_should_client_block(r)) {
        total = ap_get_client_block(r, vbuf, count);

        MP_TRACE_o(MP_FUNC, "wanted %db, read %db [%s]",
                   count, total, (char *)vbuf);

        if (total < 0) {
            /*
             * XXX: as stated in ap_get_client_block, the real
             * error gets lots, so we only know that there was one
             */
            ap_log_error(APLOG_MARK, APLOG_ERR, 0, r->server,
                         "mod_perl: $r->read failed to read");
        }
    }

    return total;
}

static SSize_t
PerlIOApache_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
    modperl_config_req_t *rcfg = modperl_config_req_get(st->r);
    apr_size_t bytes = 0;
    apr_status_t rv;

    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
	return 0;
    }
    
    MP_CHECK_WBUCKET_INIT("print");

    MP_TRACE_o(MP_FUNC, "%d bytes [%s]", count, (char *)vbuf);
        
    rv = modperl_wbucket_write(aTHX_ rcfg->wbucket, vbuf, &count);
    if (rv != APR_SUCCESS) {
        Perl_croak(aTHX_ modperl_apr_strerror(rv)); 
    }
    bytes += count;
    
    return (SSize_t) bytes;
}

static IV
PerlIOApache_flush(pTHX_ PerlIO *f)
{
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
    modperl_config_req_t *rcfg;

    if (!st->r) {
        Perl_warn(aTHX_ "an attempt to flush a stale IO handle");
        return -1;
    }

    /* no flush on readonly io handle */
    if (! (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) ) {
        return -1;
    }

    rcfg = modperl_config_req_get(st->r);

    MP_CHECK_WBUCKET_INIT("flush");

    MP_TRACE_o(MP_FUNC, "%d bytes [%s]", rcfg->wbucket->outcnt,
               apr_pstrmemdup(rcfg->wbucket->pool, rcfg->wbucket->outbuf,
                              rcfg->wbucket->outcnt));

    MP_FAILURE_CROAK(modperl_wbucket_flush(rcfg->wbucket, FALSE));

    return 0;
}

/* 5.8.0 doesn't export PerlIOBase_noop_fail, so we duplicate it here */
static IV PerlIOApache_noop_fail(pTHX_ PerlIO *f)
{
    return -1;
}

static IV
PerlIOApache_close(pTHX_ PerlIO *f)
{
    IV code = PerlIOBase_close(aTHX_ f);
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);

    MP_TRACE_o(MP_FUNC, "done with request_rec obj: 0x%lx", st->r);
    /* prevent possible bugs where a stale r will be attempted to be
     * reused (e.g. dupped filehandle) */
    st->r = NULL;

    return code;
}

static IV
PerlIOApache_popped(pTHX_ PerlIO *f)
{
    /* XXX: just temp for tracing */
    MP_TRACE_o(MP_FUNC, "done");<commit_msg>To improve the usability of the IO tracing dump only the first few dozens of characters in the string being written, read or flushed PR: Obtained from: Submitted by: Reviewed by:<commit_after>#include "mod_perl.h"

#ifdef MP_IO_TIE_PERLIO

/***************************
 * The PerlIO Apache layer *
 ***************************/

/* PerlIO ":Apache" layer is used to use the Apache callbacks to read
 * from STDIN and write to STDOUT. The PerlIO API is documented in
 * perliol.pod */

typedef struct {
    struct _PerlIO base;
    request_rec *r;
} PerlIOApache;

/* not too long so it won't wrap when posted in email */
#define IO_DUMP_LENGTH 35
/* dumping hundreds of lines in the trace, makes it hard to read. Get
 * a string chunk of IO_DUMP_LENGTH or less */
#define IO_DUMP_FIRST_CHUNK(p, str, count)       \
    count < IO_DUMP_LENGTH                       \
        ? (char *)str                            \
        : (char *)apr_psprintf(p, "%s...",       \
                               apr_pstrmemdup(p, str, IO_DUMP_LENGTH))

/* _open just allocates the layer, _pushed does the real job of
 * filling the data in */
static PerlIO *
PerlIOApache_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n,
		  const char *mode, int fd, int imode, int perm,
		  PerlIO *f, int narg, SV **args)
{
    if (!f) {
        f = PerlIO_allocate(aTHX);
    }
    if ( (f = PerlIO_push(aTHX_ f, self, mode, args[0])) ) {
        PerlIOBase(f)->flags |= PERLIO_F_OPEN;
    }

    MP_TRACE_o(MP_FUNC, "mode %s", mode);

    return f;
}

/* this callback is used by pushed() and binmode() to add the layer */
static IV
PerlIOApache_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg,
		    PerlIO_funcs *tab)
{
    IV code;
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);

    if (arg) {
        st->r = modperl_sv2request_rec(aTHX_ arg);
        MP_TRACE_o(MP_FUNC, "stored request_rec obj: 0x%lx", st->r);
    }
    else {
        Perl_croak(aTHX_ "$r wasn't passed");
        /* XXX: try to get Apache->request? */
    }
    
    /* this method also sets the right flags according to the
     * 'mode' */
    code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
    
    return code;
}

static SV *
PerlIOApache_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
{
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
    SV *sv = newSV(0);

    if (!st->r) {
        Perl_croak(aTHX_ "an attempt to getarg from a stale io handle");
    }
    
    sv_setref_pv(sv, "Apache::RequestRec", (void*)(st->r));

    MP_TRACE_o(MP_FUNC, "retrieved request_rec obj: 0x%lx", st->r);
    
    return sv;
}

static IV
PerlIOApache_fileno(pTHX_ PerlIO *f)
{
    /* XXX: we could return STDIN => 0, STDOUT => 1, but that wouldn't
     * be correct, as the IO goes through the socket, may be we should
     * return the filedescriptor of the socket? 
     *
     * -1 in this case indicates that the layer cannot provide fileno
     */
    MP_TRACE_o(MP_FUNC, "did nothing");
    return -1;
}

static SSize_t
PerlIOApache_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
    request_rec *r = st->r;
    long total = 0;
    int rc;

    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) ||
        PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
	return 0;
    }

    if (!r->read_length) {
        /* only do this once per-request */
        if ((rc = ap_setup_client_block(r, REQUEST_CHUNKED_ERROR)) != OK) {
            ap_log_error(APLOG_MARK, APLOG_ERR, 0, r->server,
                         "mod_perl: ap_setup_client_block failed: %d", rc);
            return -1;
        }
    }

    if (r->read_length || ap_should_client_block(r)) {
        total = ap_get_client_block(r, vbuf, count);

        MP_TRACE_o(MP_FUNC, "wanted %db, read %db [%s]",
                   count, total,
                   IO_DUMP_FIRST_CHUNK(r->pool, vbuf, total));

        if (total < 0) {
            /*
             * XXX: as stated in ap_get_client_block, the real
             * error gets lots, so we only know that there was one
             */
            ap_log_error(APLOG_MARK, APLOG_ERR, 0, r->server,
                         "mod_perl: $r->read failed to read");
        }
    }

    return total;
}

static SSize_t
PerlIOApache_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
    modperl_config_req_t *rcfg = modperl_config_req_get(st->r);
    apr_size_t bytes = 0;
    apr_status_t rv;

    if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) {
	return 0;
    }
    
    MP_CHECK_WBUCKET_INIT("print");

    MP_TRACE_o(MP_FUNC, "%4db [%s]", count,
               IO_DUMP_FIRST_CHUNK(rcfg->wbucket->pool, vbuf, count));
        
    rv = modperl_wbucket_write(aTHX_ rcfg->wbucket, vbuf, &count);
    if (rv != APR_SUCCESS) {
        Perl_croak(aTHX_ modperl_apr_strerror(rv)); 
    }
    bytes += count;
    
    return (SSize_t) bytes;
}

static IV
PerlIOApache_flush(pTHX_ PerlIO *f)
{
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);
    modperl_config_req_t *rcfg;

    if (!st->r) {
        Perl_warn(aTHX_ "an attempt to flush a stale IO handle");
        return -1;
    }

    /* no flush on readonly io handle */
    if (! (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) ) {
        return -1;
    }

    rcfg = modperl_config_req_get(st->r);

    MP_CHECK_WBUCKET_INIT("flush");

    MP_TRACE_o(MP_FUNC, "%4db [%s]", rcfg->wbucket->outcnt,
               IO_DUMP_FIRST_CHUNK(rcfg->wbucket->pool,
                                   apr_pstrmemdup(rcfg->wbucket->pool,
                                                  rcfg->wbucket->outbuf,
                                                  rcfg->wbucket->outcnt),
                                   rcfg->wbucket->outcnt));

    MP_FAILURE_CROAK(modperl_wbucket_flush(rcfg->wbucket, FALSE));

    return 0;
}

/* 5.8.0 doesn't export PerlIOBase_noop_fail, so we duplicate it here */
static IV PerlIOApache_noop_fail(pTHX_ PerlIO *f)
{
    return -1;
}

static IV
PerlIOApache_close(pTHX_ PerlIO *f)
{
    IV code = PerlIOBase_close(aTHX_ f);
    PerlIOApache *st = PerlIOSelf(f, PerlIOApache);

    MP_TRACE_o(MP_FUNC, "done with request_rec obj: 0x%lx", st->r);
    /* prevent possible bugs where a stale r will be attempted to be
     * reused (e.g. dupped filehandle) */
    st->r = NULL;

    return code;
}

static IV
PerlIOApache_popped(pTHX_ PerlIO *f)
{
    /* XXX: just temp for tracing */
    MP_TRACE_o(MP_FUNC, "done");
{'fraction_non_alphanumeric': 0.12522806435561454, 'fraction_numerical': 0.0044783546193398575, 'mean_word_length': 2.546764705882353, 'pattern_counts': {'":': 2, '<': 6, '<?xml version=': 0, '>': 78, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 6, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1868211', 'n_tokens_mistral': 4642, 'n_tokens_neox': 4428, 'n_words': 1135}