// Establish a connection using an SSL layer
void ssl_connect(mongo_link* link, SV *client) {
tcp_setup(link);
SV *ca_file_sv, *ca_path_sv;
char *ca_file, *ca_path;
if (link->master->socket){
// Register the error strings for libcrypto & libssl
SSL_load_error_strings();
// Register the available ciphers and digests
SSL_library_init();
// New context saying we are a client, and using SSL 2 or 3
link->ssl_context = SSL_CTX_new(SSLv23_client_method());
if(link->ssl_context == NULL){
ERR_print_errors_fp(stderr);
}
ca_file_sv = perl_mongo_call_method( client, "ssl_ca_file", 0, 0 );
ca_path_sv = perl_mongo_call_method( client, "ssl_ca_path", 0, 0 );
if ( SvPOK( ca_file_sv ) && SvPOK( ca_path_sv ) ) {
ca_file = SvPV_nolen( ca_file_sv );
ca_path = SvPV_nolen( ca_path_sv );
SSL_CTX_load_verify_locations( link->ssl_context, ca_file, ca_path );
}
// Create an SSL struct for the connection
link->ssl_handle = SSL_new(link->ssl_context);
if(link->ssl_handle == NULL){
ERR_print_errors_fp(stderr);
}
// Connect the SSL struct to our connection
if(!SSL_set_fd(link->ssl_handle, link->master->socket)){
ERR_print_errors_fp(stderr);
}
// Initiate SSL handshake
if(SSL_connect (link->ssl_handle) != 1){
ERR_print_errors_fp(stderr);
}
SSL_CTX_set_timeout(link->ssl_context, (long)link->timeout);
link->master->connected = 1;
}
}
inline int sv2int_str(SV *val, int_str *is,
unsigned short *flags, unsigned short strflag) {
char *s;
STRLEN len;
if (!SvOK(val)) {
LM_ERR("AVP:sv2int_str: Invalid value "
"(not a scalar).\n");
return 0;
}
if (SvIOK(val)) { /* numerical name */
is->n = SvIV(val);
*flags = 0;
return 1;
} else if (SvPOK(val)) {
s = SvPV(val, len);
is->s.len = len;
is->s.s = s;
(*flags) |= strflag;
return 1;
} else {
LM_ERR("AVP:sv2int_str: Invalid value "
"(neither string nor integer).\n");
return 0;
}
}
alpm_pkgreason_t
p2c_pkgreason(SV *sv)
{
STRLEN len;
char *rstr;
if(SvIOK(sv)){
switch(SvIV(sv)){
case 0: return ALPM_PKG_REASON_EXPLICIT;
case 1: return ALPM_PKG_REASON_DEPEND;
}
croak("integer reasons must be 0 or 1");
}else if(SvPOK(sv)){
rstr = SvPV(sv, len);
if(strncmp(rstr, "explicit", len) == 0){
return ALPM_PKG_REASON_EXPLICIT;
}else if(strncmp(rstr, "implicit", len) == 0
|| strncmp(rstr, "depend", len) == 0){
return ALPM_PKG_REASON_DEPEND;
}else{
croak("string reasons can only be explicit or implicit/depend");
}
}else{
croak("reasons can only be integers or strings");
}
}
void dump_value(pTHX_ SV* val, Buffer* buf)
{
if (!val) {
return;
}
if (SvIOK(val)) {
char str[50];
int len = sprintf(str, "%ld", (long) SvIV(val));
buffer_append(buf, str, len);
} else if (SvNOK(val)) {
char str[50];
int len = sprintf(str, "%lf", (double) SvNV(val));
buffer_append(buf, str, len);
} else if (SvPOK(val)) {
STRLEN len;
char* str = SvPV(val, len);
buffer_append(buf, "\"", 1);
buffer_append(buf, str, len);
buffer_append(buf, "\"", 1);
} else if (SvROK(val)) {
SV* rv = SvRV(val);
if (SvTYPE(rv) == SVt_PVAV) {
dump_array(aTHX_ (AV*) rv, buf);
} else if (SvTYPE(rv) == SVt_PVHV) {
dump_hash(aTHX_ (HV*) rv, buf);
}
}
}
static int sandwich_sapi_ub_write(const char *str, uint str_length TSRMLS_DC)
{
// FIXME - call out to Perl's selected fh
SV *oh;
sandwich_per_interp *interp = SG(server_context);
if(!interp || !interp->output_handler || interp->output_handler == &PL_sv_undef) {
fwrite(str, 1, str_length, stdout);
return str_length;
}
oh = interp->output_handler;
if (SvROK(oh) && (SvTYPE(SvRV(oh)) == SVt_PVCV)) {
dTHX;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpvn(str, str_length)));
PUTBACK;
call_sv(oh, G_VOID | G_EVAL);
FREETMPS;
LEAVE;
} else {
if(SvROK(oh) && !SvPOK(SvRV(oh))) {
sv_setpvn_mg(SvRV(oh), str, str_length);
} else {
sv_catpvn_mg(SvROK(oh)?SvRV(oh):oh, str, str_length);
}
}
return str_length;
}
static ngx_int_t
ngx_http_perl_sv2str(pTHX_ ngx_http_request_t *r, ngx_str_t *s, SV *sv)
{
u_char *p;
STRLEN len;
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PV) {
sv = SvRV(sv);
}
p = (u_char *) SvPV(sv, len);
s->len = len;
if (SvREADONLY(sv) && SvPOK(sv)) {
s->data = p;
ngx_log_debug2(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
"perl sv2str: %08XD \"%V\"", sv->sv_flags, s);
return NGX_OK;
}
s->data = ngx_pnalloc(r->pool, len);
if (s->data == NULL) {
return NGX_ERROR;
}
ngx_memcpy(s->data, p, len);
ngx_log_debug2(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
"perl sv2str: %08XD \"%V\"", sv->sv_flags, s);
return NGX_OK;
}
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
/* If called (normally) via open() then arg is ref to scalar we are
* using, otherwise arg (from binmode presumably) is either NULL
* or the _name_ of the scalar
*/
if (arg) {
if (SvROK(arg)) {
s->var = SvREFCNT_inc(SvRV(arg));
if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
(void)SvPV_nolen(s->var);
}
else {
s->var =
SvREFCNT_inc(perl_get_sv
(SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
}
}
else {
s->var = newSVpvn("", 0);
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
SvCUR(s->var) = 0;
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
s->posn = 0;
return code;
}
int
Tcl_GetBooleanFromObj (Tcl_Interp *interp, Tcl_Obj *obj, int *boolPtr)
{
dTHX;
SV *sv = ForceScalar(aTHX_ obj);
static char *yes[] = {"y", "yes", "true", "on", NULL};
static char *no[] = {"n", "no", "false", "off", NULL};
if (SvPOK(sv))
{
STRLEN na;
char *s = SvPV(sv, na);
char **p = yes;
while (*p)
{
if (!strcasecmp(s, *p++))
{
*boolPtr = 1;
return TCL_OK;
}
}
p = no;
while (*p)
{
if (!strcasecmp(s, *p++))
{
*boolPtr = 0;
return TCL_OK;
}
}
}
*boolPtr = SvTRUE(sv);
return TCL_OK;
}
SEXP
GetRScalar(SV *val)
{
dTHX;
SEXP ans = NULL_USER_OBJECT;
if(SvIOKp(val)) {
PROTECT(ans = NEW_INTEGER(1));
INTEGER_DATA(ans)[0] = SvIV(val);
UNPROTECT(1);
} else if(SvNOKp(val)) {
PROTECT(ans = NEW_NUMERIC(1));
NUMERIC_DATA(ans)[0] = SvNV(val);
UNPROTECT(1);
} else if(SvPOK(val)) {
PROTECT(ans = NEW_CHARACTER(1));
SET_STRING_ELT(ans, 0, COPY_TO_USER_STRING(SvPV(val, PL_na)));
UNPROTECT(1);
} else if(SvROK(val)) {
fprintf(stderr, "Not handling nested references in conversion from Perl to R at present. Suggestions for semantics welcome!\n");fflush(stderr);
} else if(SvTYPE(val) == SVt_PVMG) {
/*XXX get more info about the type of the magic object.
struct magic *mg = SvMAGIC(val);
*/
PROTECT(ans = createPerlReference(val));
UNPROTECT(1);
} else {
fprintf(stderr, "Cannot deal currently with Perl types %d\n", SvTYPE(val));fflush(stderr);
}
return(ans);
}
static GnmFuncHelp *
make_gnm_help (const char *name, int count, SV **SP)
{
GnmFuncHelp *help = NULL;
/* We assume that the description is a Perl array of the form
(key, text, key, text, ...). */
int n = count / 2, m = 0, k, type = GNM_FUNC_HELP_END;
GnmFuncHelp *helptmp = g_new0 (GnmFuncHelp, n + 1);
if (count % 2) POPs, count--;
for (k = n; k-- > 0; ) {
SV *sv = POPs;
if (SvPOK(sv)) {
STRLEN size;
gchar *tmp;
tmp = SvPV(sv, size);
helptmp[k].text = g_strndup (tmp, size);
} else {
helptmp[k].text = NULL;
}
sv = POPs;
if (SvIOK(sv)) type = SvIV(sv);
if (helptmp[k].text &&
type >= GNM_FUNC_HELP_NAME && GNM_FUNC_HELP_ODF) {
helptmp[k].type = type; m++;
} else {
helptmp[k].type = GNM_FUNC_HELP_END;
if (helptmp[k].text)
g_free ((char*)helptmp[k].text);
helptmp[k].text = NULL;
}
}
if (m == 0) {
/* No valid entries. */
g_free (helptmp);
} else {
/* Collect all valid entries in a new array. */
if (n == m) {
help = helptmp;
} else {
int i;
help = g_new (GnmFuncHelp, m+1);
for (i = 0, k = 0; k < n; k++)
if (helptmp[k].type != GNM_FUNC_HELP_END &&
helptmp[k].text)
help[i++] = helptmp[k];
g_free(helptmp);
}
help[m].type = GNM_FUNC_HELP_END;
help[m].text = NULL;
}
if (!help) /* Provide a reasonable default. */
help = default_gnm_help (name);
gnm_perl_loader_free_later (help);
for (n = 0; help[n].type != GNM_FUNC_HELP_END; n++)
gnm_perl_loader_free_later (help[n].text);
return help;
}
static void xs_getnameinfo(pTHX_ CV *cv)
{
dVAR;
dXSARGS;
SV *addr;
int flags;
char host[1024];
char serv[256];
char *sa; /* we'll cast to struct sockaddr * when necessary */
STRLEN addr_len;
int err;
if(items < 1 || items > 2)
croak_xs_usage(cv, "addr, flags=0");
SP -= items;
addr = ST(0);
if(items < 2)
flags = 0;
else
flags = SvIV(ST(1));
if(!SvPOK(addr))
croak("addr is not a string");
addr_len = SvCUR(addr);
/* We need to ensure the sockaddr is aligned, because a random SvPV might
* not be due to SvOOK */
Newx(sa, addr_len, char);
Copy(SvPV_nolen(addr), sa, addr_len, char);
#ifdef HAS_SOCKADDR_SA_LEN
((struct sockaddr *)sa)->sa_len = addr_len;
#endif
err = getnameinfo((struct sockaddr *)sa, addr_len,
host, sizeof(host),
serv, sizeof(serv),
flags);
Safefree(sa);
XPUSHs(err_to_SV(aTHX_ err));
if(err)
XSRETURN(1);
XPUSHs(sv_2mortal(newSVpv(host, 0)));
XPUSHs(sv_2mortal(newSVpv(serv, 0)));
XSRETURN(3);
}
char *
Perl_sv_pv(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_PV;
if (SvPOK(sv))
return SvPVX(sv);
return sv_2pv(sv, NULL);
}
int is_scalar_ref (SV* arg) { /* Utility to determine if ref to scalar */
SV* foo;
if (!SvROK(arg))
return 0;
foo = SvRV(arg);
if (SvPOK(foo))
return 1;
else
return 0;
}
char sv2idctype(const SV *sv)
{
if (SvIOK(sv)) return VT_LONG;
else if (SvNOK(sv)) return VT_FLOAT;
else if (SvPOK(sv)) return VT_STR;
else {
// otherwise, probably an object -> stringify
return VT_STR;
}
}
char *
Perl_sv_pvn_nomg(pTHX_ SV *sv, STRLEN *lp)
{
PERL_ARGS_ASSERT_SV_PVN_NOMG;
if (SvPOK(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
}
return sv_2pv_flags(sv, lp, 0);
}
char *
Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
{
PERL_ARGS_ASSERT_SV_PVN;
if (SvPOK(sv)) {
*lp = SvCUR(sv);
return SvPVX(sv);
}
return sv_2pv(sv, lp);
}
void
Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
{
register GP *gp;
bool doproto = SvTYPE(gv) > SVt_NULL;
char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
sv_upgrade((SV*)gv, SVt_PVGV);
if (SvLEN(gv)) {
if (proto) {
SvPVX(gv) = NULL;
SvLEN(gv) = 0;
SvPOK_off(gv);
} else
Safefree(SvPVX(gv));
}
Newz(602, gp, 1, GP);
GvGP(gv) = gp_ref(gp);
GvSV(gv) = NEWSV(72,0);
GvLINE(gv) = CopLINE(PL_curcop);
GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : "";
GvCVGEN(gv) = 0;
GvEGV(gv) = gv;
sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0);
GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
GvNAME(gv) = savepvn(name, len);
GvNAMELEN(gv) = len;
if (multi || doproto) /* doproto means it _was_ mentioned */
GvMULTI_on(gv);
if (doproto) { /* Replicate part of newSUB here. */
SvIOK_off(gv);
ENTER;
/* XXX unsafe for threads if eval_owner isn't held */
start_subparse(0,0); /* Create CV in compcv. */
GvCV(gv) = PL_compcv;
LEAVE;
PL_sub_generation++;
CvGV(GvCV(gv)) = gv;
CvFILE(GvCV(gv)) = CopFILE(PL_curcop);
CvSTASH(GvCV(gv)) = PL_curstash;
#ifdef USE_THREADS
CvOWNER(GvCV(gv)) = 0;
if (!CvMUTEXP(GvCV(gv))) {
New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(GvCV(gv)));
}
#endif /* USE_THREADS */
if (proto) {
sv_setpv((SV*)GvCV(gv), proto);
Safefree(proto);
}
}
}
SV *
sv_maybe_utf8(SV *sv)
{
#ifdef SvUTF8_on
if (SvPOK(sv))
{
if (has_highbit(SvPVX(sv),SvCUR(sv)))
SvUTF8_on(sv);
}
#endif
return sv;
}
static xmlNode *
pv_to_xmlnode(SV *value) {
unsigned int size;
char *string;
if (! SvPOK(value))
return NULL;
string = SvPV(value, size);
if (! string)
return NULL;
return lasso_string_fragment_to_xmlnode(string, size);
}
static int scalar2constant(SV * svconstant, const char * context, int * val) {
int rc = 0;
if (!svconstant || !SvOK(svconstant)) {
warn("Use of an undefined value");
return 0;
} else if (SvIOK(svconstant)) {
*val = SvIV(svconstant);
rc = 1;
} else if (SvPOK(svconstant)) {
rc = rpmconstantFindName((char *)context, (void *) SvPV_nolen(svconstant), val, 0);
} else {
}
return rc;
}
static int
verify_opset(pTHX_ SV *opset, int fatal)
{
const char *err = NULL;
dMY_CXT;
if (!SvOK(opset)) err = "undefined";
else if (!SvPOK(opset)) err = "wrong type";
else if (SvCUR(opset) != (STRLEN)opset_len) err = "wrong size";
if (err && fatal) {
croak("Invalid opset: %s", err);
}
return !err;
}
request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv)
{
SV *sv = (SV *)NULL;
MAGIC *mg;
if (SvROK(in)) {
SV *rv = (SV*)SvRV(in);
switch (SvTYPE(rv)) {
case SVt_PVMG:
sv = rv;
break;
case SVt_PVHV:
sv = modperl_hv_request_find(aTHX_ in, classname, cv);
break;
default:
Perl_croak(aTHX_ "panic: unsupported request_rec type %d",
(int)SvTYPE(rv));
}
}
/* might be Apache2::ServerRec::warn method */
if (!sv && !(classname && SvPOK(in) && !strEQ(classname, SvPVX(in)))) {
request_rec *r = NULL;
(void)modperl_tls_get_request_rec(&r);
if (!r) {
Perl_croak(aTHX_
"Apache2->%s called without setting Apache2->request!",
cv ? GvNAME(CvGV(cv)) : "unknown");
}
return r;
}
/* there could be pool magic attached to custom $r object, so make
* sure that mg->mg_ptr is set */
if ((mg = mg_find(sv, PERL_MAGIC_ext)) && mg->mg_ptr) {
return (request_rec *)mg->mg_ptr;
}
else {
if (classname && !sv_derived_from(in, classname)) {
/* XXX: find something faster than sv_derived_from */
return NULL;
}
return INT2PTR(request_rec *, SvIV(sv));
}
return NULL;
}
void
plcb_convert_storage(PLCB_t *object, AV *docav, plcb_DOCVAL *vspec)
{
SV *pv = SvROK(vspec->value) ? SvRV(vspec->value) : vspec->value;
uint32_t fmt = vspec->spec;
if (object->cv_customenc) {
vspec->need_free = 1;
vspec->value = custom_convert(docav, object->cv_customenc, vspec->value, &vspec->flags, CONVERT_OUT);
} else if (fmt == PLCB_CF_JSON) {
vspec->flags = PLCB_LF_JSON|PLCB_CF_JSON;
vspec->need_free = 1;
vspec->value = serialize_convert(object->cv_jsonenc, vspec->value, CONVERT_OUT);
} else if (fmt == PLCB_CF_STORABLE) {
vspec->flags = PLCB_CF_STORABLE | PLCB_LF_STORABLE;
vspec->need_free = 1;
vspec->value = serialize_convert(object->cv_serialize, vspec->value, CONVERT_OUT);
} else if (fmt == PLCB_CF_RAW) {
vspec->flags = PLCB_CF_RAW | PLCB_LF_RAW;
vspec->need_free = 0;
if (!SvPOK(pv)) {
die("Raw conversion requires string value!");
}
} else if (vspec->spec == PLCB_CF_UTF8) {
vspec->flags = PLCB_CF_UTF8 | PLCB_LF_UTF8;
vspec->need_free = 0;
sv_utf8_upgrade(pv);
} else {
die("Unrecognized flags used (0x%x) but no custom converted installed!", vspec->spec);
}
if (!vspec->need_free) {
/* Use input as-is */
vspec->value = pv;
}
/* Assume the resultant value is an SV */
if (SvTYPE(vspec->value) == SVt_PV) {
vspec->encoded = SvPVX(vspec->value);
vspec->len = SvCUR(vspec->value);
} else {
vspec->encoded = SvPV(vspec->value, vspec->len);
}
}
void parseApp(const char *func, const char *var, SV *arg, Autoref<App> &res)
{
if ( sv_isobject(arg) && (SvTYPE(SvRV(arg)) == SVt_PVMG) ) {
WrapApp *wa = (WrapApp *)SvIV((SV*)SvRV( arg ));
if (wa == 0 || wa->badMagic()) {
throw Exception::f("%s: %s has an incorrect magic for App", func, var);
}
res = wa->get();
} else if (SvPOK(arg)) {
STRLEN len;
char *s = SvPV(arg, len);
string appname(s, len);
res = App::find(appname); // will throw if can't find
} else {
throw Exception::f("%s: %s is not an App reference nor a string", func, var);
}
}
/*
* Load a YAML mapping into a Perl hash
*/
SV *
load_mapping(perl_yaml_loader_t *loader, char *tag)
{
SV *key_node;
SV *value_node;
HV *hash = newHV();
SV *hash_ref = (SV *)newRV_noinc((SV *)hash);
char *anchor = (char *)loader->event.data.mapping_start.anchor;
if (!tag)
tag = (char *)loader->event.data.mapping_start.tag;
/* Store the anchor label if any */
if (anchor)
hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(hash_ref), 0);
/* Get each key string and value node and put them in the hash */
while ((key_node = load_node(loader))) {
assert(SvPOK(key_node));
value_node = load_node(loader);
hv_store_ent(
hash, key_node, value_node, 0
);
}
/* Deal with possibly blessing the hash if the YAML tag has a class */
if (tag && strEQ(tag, TAG_PERL_PREFIX "hash"))
tag = NULL;
if (tag) {
char *class;
char *prefix = TAG_PERL_PREFIX "hash:";
if (*tag == '!') {
prefix = "!";
}
else if (strlen(tag) <= strlen(prefix) ||
! strnEQ(tag, prefix, strlen(prefix))
) croak(
loader_error_msg(loader, form("bad tag found for hash: '%s'", tag))
);
class = tag + strlen(prefix);
sv_bless(hash_ref, gv_stashpv(class, TRUE));
}
return hash_ref;
}
void
srl_path_set(pTHX_ srl_path_t *path, SV *src)
{
path->expr = NULL;
CLEAR_RESULTS(path);
CLEAR_ITERATOR(path);
if (sv_isobject(src) && sv_isa(src, "Sereal::Path::Iterator")) {
path->iter = INT2PTR(srl_iterator_ptr, SvIV((SV*) SvRV(src)));
path->i_own_iterator = 0;
} else if (SvPOK(src)) {
path->iter = srl_build_iterator_struct(aTHX_ NULL);
path->i_own_iterator = 1;
srl_iterator_set(aTHX_ path->iter, src);
} else {
croak("Sereal::Path: input should be either Sereal::Path::Iterator object or encoded Sereal document");
}
}
IV
PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
PerlIO_funcs * tab)
{
IV code;
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
/* If called (normally) via open() then arg is ref to scalar we are
* using, otherwise arg (from binmode presumably) is either NULL
* or the _name_ of the scalar
*/
if (arg) {
if (SvROK(arg)) {
if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
s->var = SvREFCNT_inc(SvRV(arg));
SvGETMAGIC(s->var);
if (!SvPOK(s->var) && SvOK(s->var))
(void)SvPV_nomg_const_nolen(s->var);
}
else {
s->var =
SvREFCNT_inc(perl_get_sv
(SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
}
}
else {
s->var = newSVpvn("", 0);
}
SvUPGRADE(s->var, SVt_PV);
code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
SvCUR_set(s->var, 0);
if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
s->posn = SvCUR(s->var);
else
s->posn = 0;
return code;
}
int sv2constant(SV * svconstant, const char * context) {
AV * avparam;
int val = 0;
SV **tmpsv;
int i;
if (svconstant == NULL) {
return 0;
} else if (!SvOK(svconstant)) {
return 0;
} else if (SvPOK(svconstant) || SvIOK(svconstant)) {
if (!scalar2constant(svconstant, context, &val))
warn("Unknow value '%s' in '%s'", SvPV_nolen(svconstant), context);
} else if (SvTYPE(SvRV(svconstant)) == SVt_PVAV) {
avparam = (AV*) SvRV(svconstant);
for (i = 0; i <= av_len(avparam); i++) {
tmpsv = av_fetch(avparam, i, 0);
if (!scalar2constant(*tmpsv, context, &val))
warn("Unknow value '%s' in '%s' from array", SvPV_nolen(*tmpsv), context);
}
} else {
}
return val;
}
/* converts a siglevel string or hashref into bitflags. */
alpm_siglevel_t
p2c_siglevel(SV *sig)
{
char *str;
STRLEN len;
alpm_siglevel_t ret;
HV *hv;
if(SvPOK(sig)){
str = SvPV(sig, len);
if(len == 7 && strncmp(str, "default", len) == 0){
return ALPM_SIG_USE_DEFAULT;
}else {
/* XXX: might not be null terminated? */
croak("Unrecognized global signature level string: %s", str);
}
}else if(SvROK(sig) && SvTYPE(SvRV(sig)) == SVt_PVHV){
hv = (HV*)SvRV(sig);
ret = fetch_trustmask(hv, "pkg");
ret |= fetch_trustmask(hv, "db") << OFFSET_DB;
return ret;
}
croak("A global signature level must be a string or hash reference");
}
PImage IPA__Morphology_BWTransform(PImage img,HV *profile)
{
dPROFILE;
const char *method="IPA::Morphology::BWTransform";
PImage oimg;
unsigned char *transtbl = nil;
if ( !img || !kind_of(( Handle) img, CImage))
croak("%s: not an image passed", "IPA::Morphology::BWTransform");
if (pexist(lookup)) {
SV *tblstr=pget_sv(lookup);
if (SvPOK(tblstr)) {
STRLEN tbllen;
transtbl=SvPV(tblstr,tbllen);
if (tbllen!=512) {
croak("%s: 'lookup' is %d bytes long, must be 512",method,tbllen);
}
}
else {
croak("%s : 'lookup' is not a string",method);
}
} else {
croak("%s : 'lookup' option missed",method);
}
switch (img->type) {
case imByte:
oimg=bw8bpp_transform(method,img,transtbl,1);
break;
default:
croak("%s: support for this type of images isn't realized yet",method);
}
return oimg;
}
