view release on metacpan or  search on metacpan

xs/APR/Pool/APR__Pool.h  view on Meta::CPAN

        MP_APR_POOL_SV_TAKES_OWNERSHIP(sv, child_pool);

        MP_POOL_TRACE(MP_FUNC, "sub-pool p: 0x%lx, sv: 0x%lx, rv: 0x%lx",
                      (unsigned long)child_pool, sv, rv);

        if (parent_pool) {
            mpxs_add_pool_magic(rv, parent_pool_obj);
        }

        return rv;
    }
}

static MP_INLINE void mpxs_APR__Pool_clear(pTHX_ SV *obj)
{
    apr_pool_t *p = mp_xs_sv2_APR__Pool(obj);
    SV *sv = SvRV(obj);

    if (!MP_APR_POOL_SV_HAS_OWNERSHIP(sv)) {
        MP_POOL_TRACE(MP_FUNC, "parent pool (0x%lx) is a core pool",
                      (unsigned long)p);
        apr_pool_clear(p);
        return;
    }

    MP_POOL_TRACE(MP_FUNC,
                  "parent pool (0x%lx) is a custom pool, sv 0x%lx",
                  (unsigned long)p,
                  (unsigned long)sv);

    apr_pool_clear(p);

    /* apr_pool_clear runs & removes the cleanup, so we need to restore
     * it. Since clear triggers mpxs_apr_pool_cleanup call, our
     * object's guts get nuked too, so we need to restore them too */

    MP_APR_POOL_SV_TAKES_OWNERSHIP(sv, p);
}


typedef struct {
    SV *cv;
    SV *arg;
    apr_pool_t *p;
#ifdef USE_ITHREADS
    PerlInterpreter *perl;
    modperl_interp_t *interp;
#endif
} mpxs_cleanup_t;

/**
 * callback wrapper for Perl cleanup subroutines
 * @param data   internal storage
 */


static apr_status_t mpxs_cleanup_run(void *data)
{
    int count;
    mpxs_cleanup_t *cdata = (mpxs_cleanup_t *)data;
#ifdef USE_ITHREADS
    dTHXa(cdata->perl);
#endif
    dSP;

    ENTER;SAVETMPS;
    PUSHMARK(SP);
    if (cdata->arg) {
        XPUSHs(cdata->arg);
    }
    PUTBACK;

    save_gp(PL_errgv, 1);       /* local *@ */
    count = call_sv(cdata->cv, G_SCALAR|G_EVAL);

    SPAGAIN;

    if (count == 1) {
        (void)POPs; /* the return value is ignored */
    }

    if (SvTRUE(ERRSV)) {
        Perl_warn(aTHX_ "APR::Pool: cleanup died: %s", 
                  SvPV_nolen(ERRSV));
    }

    PUTBACK;
    FREETMPS;LEAVE;

    SvREFCNT_dec(cdata->cv);
    if (cdata->arg) {
        SvREFCNT_dec(cdata->arg);
    }

#ifdef USE_ITHREADS
    if (cdata->interp && modperl_opt_interp_unselect) {
        /* this will decrement the interp refcnt until
         * there are no more references, in which case
         * the interpreter will be putback into the mip
         */
        MP_TRACE_i(MP_FUNC, "calling interp_unselect(0x%lx)", cdata->interp);
        (void)modperl_opt_interp_unselect(cdata->interp);
    }
#endif

    /* the return value is ignored by apr_pool_destroy anyway */
    return APR_SUCCESS;
}

/**
 * register cleanups to run
 * @param p      pool with which to associate the cleanup
 * @param cv     subroutine reference to run
 * @param arg    optional argument to pass to the subroutine
 */
static MP_INLINE void mpxs_apr_pool_cleanup_register(pTHX_ apr_pool_t *p,
                                                     SV *cv, SV *arg)
{
    mpxs_cleanup_t *data =
        (mpxs_cleanup_t *)apr_pcalloc(p, sizeof(*data));

    data->cv = SvREFCNT_inc(cv);
    data->arg = arg ? SvREFCNT_inc(arg) : (SV *)NULL;
    data->p = p;
#ifdef USE_ITHREADS
    data->perl = aTHX;
    /* make sure interpreter is not putback into the mip
     * until this cleanup has run.
     */
    if (modperl_opt_thx_interp_get) {
        if ((data->interp = modperl_opt_thx_interp_get(data->perl))) {
            data->interp->refcnt++;
            MP_TRACE_i(MP_FUNC, "(0x%lx)->refcnt incremented to %ld",
                       data->interp, data->interp->refcnt);
        }
    }
#endif

    apr_pool_cleanup_register(p, data,
                              mpxs_cleanup_run,
                              apr_pool_cleanup_null);
}


static MP_INLINE SV *
mpxs_apr_pool_parent_get(pTHX_ apr_pool_t *child_pool)
{
    apr_pool_t *parent_pool = apr_pool_parent_get(child_pool);

    if (parent_pool) {
        return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool));
    }
    else {
        MP_POOL_TRACE(MP_FUNC, "pool (0x%lx) has no parents",
                      (unsigned long)child_pool);
        return &PL_sv_undef;
    }
}

/**
 * destroy a pool
 * @param obj    an APR::Pool object