static void perl_vp_to_svpvn_element(REQUEST *request, AV *av, VALUE_PAIR const *vp,
int *i, const char *hash_name, const char *list_name)
{
size_t len;
SV *sv;
char buffer[1024];
switch (vp->da->type) {
case PW_TYPE_STRING:
RDEBUG("$%s{'%s'}[%i] = &%s:%s -> '%s'", hash_name, vp->da->name, *i,
list_name, vp->da->name, vp->vp_strvalue);
sv = newSVpvn(vp->vp_strvalue, vp->vp_length);
break;
default:
len = vp_prints_value(buffer, sizeof(buffer), vp, 0);
RDEBUG("$%s{'%s'}[%i] = &%s:%s -> '%s'", hash_name, vp->da->name, *i,
list_name, vp->da->name, buffer);
sv = newSVpvn(buffer, truncate_len(len, sizeof(buffer)));
break;
}
if (!sv) return;
SvTAINTED_on(sv);
av_push(av, sv);
(*i)++;
}
SV *modperl_table_get_set(pTHX_ apr_table_t *table, char *key,
SV *sv_val, int do_taint)
{
SV *retval = &PL_sv_undef;
if (table == NULL) {
/* do nothing */
}
else if (key == NULL) {
retval = modperl_hash_tie(aTHX_ "APR::Table",
(SV *)NULL, (void*)table);
}
else if (!sv_val) { /* no val was passed */
char *val;
if ((val = (char *)apr_table_get(table, key))) {
retval = newSVpv(val, 0);
}
else {
retval = newSV(0);
}
if (do_taint) {
SvTAINTED_on(retval);
}
}
else if (!SvOK(sv_val)) { /* val was passed in as undef */
apr_table_unset(table, key);
}
else {
apr_table_set(table, key, SvPV_nolen(sv_val));
}
return retval;
}
/* XXX: same as Perl_do_sprintf();
* but Perl_do_sprintf() is not part of the "public" api
*/
void modperl_perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
{
STRLEN patlen;
char *pat = SvPV(*sarg, patlen);
bool do_taint = FALSE;
sv_vsetpvfn(sv, pat, patlen, (va_list *)NULL, sarg + 1, len - 1, &do_taint);
SvSETMAGIC(sv);
if (do_taint) {
SvTAINTED_on(sv);
}
}
static
XS(epoc_getcwd) /* more or less stolen from win32.c */
{
dXSARGS;
/* Make the host for current directory */
char *buffer;
int buflen = 256;
char *ptr;
buffer = (char *) malloc( buflen);
if (buffer == NULL) {
XSRETURN_UNDEF;
}
while ((NULL == ( ptr = getcwd( buffer, buflen))) && (errno == ERANGE)) {
buflen *= 2;
if (NULL == realloc( buffer, buflen)) {
XSRETURN_UNDEF;
}
}
/*
* If ptr != Nullch
* then it worked, set PV valid,
* else return 'undef'
*/
if (ptr) {
SV *sv = sv_newmortal();
char *tptr;
for (tptr = ptr; *tptr != '\0'; tptr++) {
if (*tptr == '\\') {
*tptr = '/';
}
}
sv_setpv(sv, ptr);
free( buffer);
EXTEND(SP,1);
SvPOK_on(sv);
ST(0) = sv;
#ifndef INCOMPLETE_TAINTS
SvTAINTED_on(ST(0));
#endif
XSRETURN(1);
}
free( buffer);
XSRETURN_UNDEF;
}
MP_INLINE SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted)
{
SV *sv;
apr_status_t rc;
apr_size_t size;
apr_file_t *file;
size = r->finfo.size;
sv = newSV(size);
/* XXX: could have checked whether r->finfo.filehand is valid and
* save the apr_file_open call, but apache gives us no API to
* check whether filehand is valid. we can't test whether it's
* NULL or not, as it may contain garbagea
*/
rc = apr_file_open(&file, r->filename, APR_READ|APR_BINARY,
APR_OS_DEFAULT, r->pool);
SLURP_SUCCESS("opening");
rc = apr_file_read(file, SvPVX(sv), &size);
SLURP_SUCCESS("reading");
MP_TRACE_o(MP_FUNC, "read %d bytes from '%s'", size, r->filename);
if (r->finfo.size != size) {
SvREFCNT_dec(sv);
Perl_croak(aTHX_ "Error: read %d bytes, expected %d ('%s')",
size, (apr_size_t)r->finfo.size, r->filename);
}
rc = apr_file_close(file);
SLURP_SUCCESS("closing");
SvPVX(sv)[size] = '\0';
SvCUR_set(sv, size);
SvPOK_on(sv);
if (tainted) {
SvTAINTED_on(sv);
}
else {
SvTAINTED_off(sv);
}
return newRV_noinc(sv);
}
void
my_xsinit(pTHX)
{
dVAR;
static const char file[] = __FILE__;
#ifdef USE_CTRLX
GV *ctrlXgv;
SV *ctrlX;
#endif
#ifdef USE_SUBFILE
if (PL_preprocess)
croak("Can't use -P with pl2exe");
#endif
#ifdef NEED_INIT_WIN32CORE
init_Win32CORE(aTHX);
#endif
#ifdef USE_ZIP
pl2exe_boot_zip(aTHX);
#endif
#ifdef NEED_PREAMBLE
newXS("ExtUtils::PerlToExe::preamble",
XS_ExtUtils_PerlToExe_preamble,
file);
if (!PL_preambleav)
PL_preambleav = newAV();
av_push(PL_preambleav,
newSVpvs("BEGIN { ExtUtils::PerlToExe::preamble() }"));
#endif
#ifdef NEED_TAINT
TAINT;
TAINT_PROPER("appended " TAINT_TYPE);
TAINT_NOT;
#endif
#ifdef USE_CTRLX
ctrlXgv = gv_fetchpvs("\030", GV_NOTQUAL, SVt_PV);
ctrlX = GvSV(ctrlXgv);
/*
* We can't reopen PL_rsfp yet as it hasn't been set (the file is
* open, it's just in an auto variable in S_parse_body). However,
* it's easier to fixup the name here, before gv_fetch_file gets
* called on it.
*/
PL_origfilename = savepv(SvPV_nolen(ctrlX));
CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, PL_origfilename);
sv_setpv(ctrlX, CTRL_X);
SvTAINTED_on(ctrlX);
#endif
#ifdef USE_ZIP
pl2exe_load_zip(aTHX_ PL_origfilename);
#endif
real_xsinit(aTHX);
}
