void _newiterator(rpmts ts, SV * sv_tagname, SV * sv_tagvalue, int keylen) {
rpmmi mi;
int tag = RPMDBI_PACKAGES;
void * value = NULL;
int i = 0;
dSP;
if (sv_tagname == NULL || !SvOK(sv_tagname)) {
tag = RPMDBI_PACKAGES; /* Assume search into installed packages */
} else {
tag = sv2dbquerytag(sv_tagname);
}
if (sv_tagvalue != NULL && SvOK(sv_tagvalue)) {
switch (tag) {
case RPMDBI_PACKAGES:
i = SvIV(sv_tagvalue);
value = &i;
keylen = sizeof(i);
break;
default:
value = (void *) SvPV_nolen(sv_tagvalue);
break;
}
}
mi = rpmtsInitIterator(ts, tag, value, keylen);
XPUSHs(sv_2mortal(sv_setref_pv(newSVpv("", 0), "RPM::PackageIterator", mi)));
PUTBACK;
return;
}
static RouteEntry *
route_sv2c(SV *h, RouteEntry *ref)
{
if (ref && h && SvROK(h)) {
HV *hv = (HV *)SvRV(h);
memset(ref, 0, sizeof(RouteEntry));
if (hv_exists(hv, "route_dst", 9)) {
SV **r = hv_fetch(hv, "route_dst", 9, 0);
if (SvOK(*r)) {
struct addr a;
if (addr_aton(SvPV(*r, PL_na), &a) == 0) {
memcpy(&(ref->route_dst), &a, sizeof(struct addr));
}
}
}
if (hv_exists(hv, "route_gw", 8)) {
SV **r = hv_fetch(hv, "route_gw", 8, 0);
if (SvOK(*r)) {
struct addr a;
if (addr_aton(SvPV(*r, PL_na), &a) == 0) {
memcpy(&(ref->route_gw), &a, sizeof(struct addr));
}
}
}
}
else {
ref = NULL;
}
return ref;
}
void
pack_intermediate_response_args(SV *dest, SV *name, SV *value) {
STRLEN offset = start_constructed(dest, ASN1_APPLICATION|ASN1_CONSTRUCTED, LDAP_OP_INTERMEDIATE_RESPONSE);
if (name && SvOK(name))
pack_raw_utf8(dest, ASN1_CONTEXT_SPECIFIC|ASN1_PRIMITIVE, 0, name);
if (value && SvOK(value))
pack_raw_utf8(dest, ASN1_CONTEXT_SPECIFIC|ASN1_PRIMITIVE, 1, value);
end_constructed(dest, offset);
}
static void perl_variable_to_json_internal( SV *input, json_writer_t *writer )
{
char *val;
int ival;
STRLEN len;
double number;
int type = -1;
if ( SvOK( input ) && SvROK( input ) ) {
type = SvTYPE( SvRV( input ) );
}
else if ( SvOK( input ) ) {
type = SvTYPE( input );
}
switch ( type ) {
case SVt_IV:
ival = SvIV( input );
json_writer_write_integer( writer, ival );
break;
case SVt_NV:
number = SvNV( input );
json_writer_write_number( writer, number );
break;
case SVt_PV:
val = SvPV( input, len );
json_writer_write_strn( writer, val, len );
break;
case SVt_PVNV:
if ( input == &PL_sv_yes ) {
json_writer_write_boolean( writer, TRUE );
}
else if ( input == &PL_sv_no ) {
json_writer_write_boolean( writer, FALSE );
}
break;
case SVt_PVAV:
perl_array_to_json( input, writer );
break;
case SVt_PVHV:
perl_hash_to_json( input, writer );
break;
default:
break;
}
}
SV*
Application_fonts( Handle self, char * name, char * encoding)
{
int count, i;
AV * glo = newAV();
PFont fmtx = apc_fonts( self, name[0] ? name : nil,
encoding[0] ? encoding : nil, &count);
for ( i = 0; i < count; i++) {
SV * sv = sv_Font2HV( &fmtx[ i]);
HV * profile = ( HV*) SvRV( sv);
if ( fmtx[i]. utf8_flags & FONT_UTF8_NAME) {
SV ** entry = hv_fetch(( HV*) SvRV( sv), "name", 4, 0);
if ( entry && SvOK( *entry))
SvUTF8_on( *entry);
}
if ( fmtx[i]. utf8_flags & FONT_UTF8_FAMILY) {
SV ** entry = hv_fetch(( HV*) SvRV( sv), "family", 6, 0);
if ( name && SvOK( *entry))
SvUTF8_on( *entry);
}
if ( fmtx[i]. utf8_flags & FONT_UTF8_ENCODING) {
SV ** entry = hv_fetch(( HV*) SvRV( sv), "encoding", 8, 0);
if ( name && SvOK( *entry))
SvUTF8_on( *entry);
}
if ( name[0] == 0 && encoding[0] == 0) {
/* Read specially-coded (const char*) encodings[] vector,
stored in fmtx[i].encoding. First pointer is filled with 0s,
except the last byte which is a counter. Such scheme
allows max 31 encodings per entry to be coded with sizeof(char*)==8.
The interface must be re-implemented, but this requires
either change in gencls syntax so arrays can be members of hashes,
or passing of a dynamic-allocated pointer vector here.
*/
char ** enc = (char**) fmtx[i].encoding;
unsigned char * shift = (unsigned char*) enc + sizeof(char *) - 1, j = *shift;
AV * loc = newAV();
pset_sv_noinc( encoding, newSVpv(( j > 0) ? *(++enc) : "", 0));
while ( j--) av_push( loc, newSVpv(*(enc++),0));
pset_sv_noinc( encodings, newRV_noinc(( SV*) loc));
}
pdelete( resolution);
pdelete( codepage);
av_push( glo, sv);
}
free( fmtx);
return newRV_noinc(( SV *) glo);
}
static int xsDecode(HV* hv, AV* av, SV* src, bool useIO) {
csv_t csv;
int result;
SetupCsv(&csv, hv);
if ((csv.useIO = useIO)) {
csv.tmp = NULL;
csv.size = 0;
} else {
STRLEN size;
csv.tmp = src;
csv.bptr = SvPV(src, size);
csv.size = size;
}
result = Decode(&csv, src, av);
if (result && csv.types) {
I32 i, len = av_len(av);
SV** svp;
for (i = 0; i <= len && i <= csv.types_len; i++) {
if ((svp = av_fetch(av, i, 0)) && *svp && SvOK(*svp)) {
switch (csv.types[i]) {
case CSV_XS_TYPE_IV:
sv_setiv(*svp, SvIV(*svp));
break;
case CSV_XS_TYPE_NV:
sv_setnv(*svp, SvIV(*svp));
break;
}
}
}
}
return result;
}
static int CsvGet(csv_t* csv, SV* src) {
if (!csv->useIO) {
return EOF;
}
{
int result;
dSP;
PUSHMARK(sp);
EXTEND(sp, 1);
PUSHs(src);
PUTBACK;
result = perl_call_method("getline", G_SCALAR);
SPAGAIN;
if (result) {
csv->tmp = POPs;
} else {
csv->tmp = NULL;
}
PUTBACK;
}
if (csv->tmp && SvOK(csv->tmp)) {
csv->bptr = SvPV(csv->tmp, csv->size);
csv->used = 0;
if (csv->size) {
return ((unsigned char) csv->bptr[csv->used++]);
}
}
return EOF;
}
long SvFlagsHash(SV * name, char * optname, HV * o)
{
int i;
int val=0;
if (!name || !SvOK(name))
return 0;
if (SvRV(name) && (SvTYPE(SvRV(name)) == SVt_PVAV)) {
AV * r = (AV*)SvRV(name);
for(i=0;i<=av_len(r);i++)
val |= SvOptsHash(*av_fetch(r, i, 0), optname, o);
} else if (SvRV(name) && (SvTYPE(SvRV(name)) == SVt_PVHV)) {
HV * r = (HV*)SvRV(name);
HE * h;
hv_iterinit(r);
while((h = hv_iternext(r))) {
I32 len;
char * key = hv_iterkey(h, &len);
SV ** f;
if (*key == '-') {
key++;
len--;
}
f = hv_fetch(o, key, len, 0);
if (f)
val |= SvIV(hv_iterval(o, h));
else
CroakOptsHash(optname, key, o);
}
} else
val |= SvOptsHash(name, optname, o);
return val;
}
static void
flush_pending_text(PSTATE* p_state, SV* self)
{
dTHX;
bool old_unbroken_text = p_state->unbroken_text;
SV* old_pend_text = p_state->pend_text;
bool old_is_cdata = p_state->is_cdata;
STRLEN old_offset = p_state->offset;
STRLEN old_line = p_state->line;
STRLEN old_column = p_state->column;
assert(p_state->pend_text && SvOK(p_state->pend_text));
p_state->unbroken_text = 0;
p_state->pend_text = 0;
p_state->is_cdata = p_state->pend_text_is_cdata;
p_state->offset = p_state->pend_text_offset;
p_state->line = p_state->pend_text_line;
p_state->column = p_state->pend_text_column;
report_event(p_state, E_TEXT,
SvPVX(old_pend_text), SvEND(old_pend_text),
SvUTF8(old_pend_text), 0, 0, self);
SvOK_off(old_pend_text);
p_state->unbroken_text = old_unbroken_text;
p_state->pend_text = old_pend_text;
p_state->is_cdata = old_is_cdata;
p_state->offset = old_offset;
p_state->line = old_line;
p_state->column = old_column;
}
KHARON_DECL int
encode_get_type(void *data)
{
SV *in = data;
D(fprintf(stderr, "get_type = %p\n", in));
if (!SvOK(in))
return STATE_UNDEF;
if (SvROK(in)) {
switch (SvTYPE(SvRV(in))) {
case SVt_PVAV: return STATE_LIST;
case SVt_PVHV: return STATE_MAP;
/* XXXrcd: memory leaks, likely... */
case SVt_IV: croak("Trying to encode SVt_IV");
case SVt_NV: croak("Trying to encode SVt_NV");
case SVt_PV: croak("Trying to encode SVt_PV");
// case SVt_RV: croak("Trying to encode SVt_RV");
case SVt_PVCV: croak("Trying to encode SVt_PVCV");
case SVt_PVGV: croak("Trying to encode SVt_PVGV");
case SVt_PVMG: croak("Trying to encode SVt_PVMG");
default:
croak("Encode error: bad data type");
}
}
return STATE_SCALAR;
}
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;
}
MP_INLINE SV *modperl_dir_config(pTHX_ request_rec *r, server_rec *s,
char *key, SV *sv_val)
{
SV *retval = &PL_sv_undef;
if (r && r->per_dir_config) {
MP_dDCFG;
retval = modperl_table_get_set(aTHX_ dcfg->configvars,
key, sv_val, FALSE);
}
if (!SvOK(retval)) {
if (s && s->module_config) {
MP_dSCFG(s);
SvREFCNT_dec(retval); /* in case above did newSV(0) */
retval = modperl_table_get_set(aTHX_ scfg->configvars,
key, sv_val, FALSE);
}
else {
retval = &PL_sv_undef;
}
}
return retval;
}
static amf0_data_t* _amf0_data(SV* sv) {
amf0_data_t* d;
if (NULL == sv || !SvOK(sv)) {
d = (amf0_data_t*)amf0_null_init();
}
else if (SvPOKp(sv)) {
STRLEN len;
char* c = SvPV(sv, len);
d = (amf0_data_t*)amf0_string_init_len(c, len);
}
else if (SvNOKp(sv)) {
d = (amf0_data_t*)amf0_number_init((double)SvNVX(sv));
}
else if (SvIOK_UV(sv)) {
d = (amf0_data_t*)amf0_number_init((double)SvUV(sv));
}
else if (SvIOKp(sv)) {
d = (amf0_data_t*)amf0_number_init((double)SvIV(sv));
}
else if (SvROK(sv)) {
d = _amf0_data_rv(SvRV(sv));
}
else {
Perl_croak(aTHX_ "Data::AMF::XS doesn't support SvTYPE: %d\n", SvTYPE(sv));
}
return d;
}
static HeapTuple
plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
{
TupleDesc td = attinmeta->tupdesc;
char **values;
SV *val;
char *key;
I32 klen;
HeapTuple tup;
values = (char **) palloc0(td->natts * sizeof(char *));
hv_iterinit(perlhash);
while ((val = hv_iternextsv(perlhash, &key, &klen)))
{
int attn = SPI_fnumber(td, key);
if (attn <= 0 || td->attrs[attn - 1]->attisdropped)
ereport(ERROR,
(errcode(ERRCODE_UNDEFINED_COLUMN),
errmsg("Perl hash contains nonexistent column \"%s\"",
key)));
if (SvOK(val) && SvTYPE(val) != SVt_NULL)
values[attn - 1] = SvPV(val, PL_na);
}
hv_iterinit(perlhash);
tup = BuildTupleFromCStrings(attinmeta, values);
pfree(values);
return tup;
}
static long sv_to_dimension(pTHX_ SV *sv, const char *member)
{
SV *warning;
const char *value = NULL;
assert(sv != NULL);
SvGETMAGIC(sv);
if (SvOK(sv) && !SvROK(sv))
{
if (looks_like_number(sv))
{
return SvIV(sv);
}
value = SvPV_nolen(sv);
}
warning = newSVpvn("", 0);
if (value) sv_catpvf(warning, " ('%s')", value);
if (member) sv_catpvf(warning, " in '%s'", member);
WARN((aTHX_ "Cannot use %s%s as dimension", identify_sv(sv), SvPV_nolen(warning)));
SvREFCNT_dec(warning);
return 0;
}
/*
this is used for autoload and shutdown callbacks
*/
static int
execute_perl (SV * function, char *args)
{
int count, ret_value = 1;
dSP;
ENTER;
SAVETMPS;
PUSHMARK (SP);
XPUSHs (sv_2mortal (newSVpv (args, 0)));
PUTBACK;
count = call_sv (function, G_EVAL | G_SCALAR);
SPAGAIN;
if (SvTRUE (ERRSV)) {
xchat_printf(ph, "Perl error: %s\n", SvPV_nolen (ERRSV));
if (!SvOK (POPs)) {} /* remove undef from the top of the stack */
} else if (count != 1) {
xchat_printf (ph, "Perl error: expected 1 value from %s, "
"got: %d\n", SvPV_nolen (function), count);
} else {
ret_value = POPi;
}
PUTBACK;
FREETMPS;
LEAVE;
return ret_value;
}
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;
}
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;
}
}
/*
*
* Verify that a Perl SV is a string and save it in FreeRadius
* Value Pair Format
*
*/
static int pairadd_sv(TALLOC_CTX *ctx, REQUEST *request, VALUE_PAIR **vps, char *key, SV *sv, FR_TOKEN op,
const char *hash_name, const char *list_name)
{
char *val;
VALUE_PAIR *vp;
if (SvOK(sv)) {
STRLEN len;
val = SvPV(sv, len);
vp = fr_pair_make(ctx, vps, key, NULL, op);
if (!vp) {
fail:
REDEBUG("Failed to create pair %s:%s %s %s", list_name, key,
fr_int2str(fr_tokens, op, "<INVALID>"), val);
return -1;
}
switch (vp->da->type) {
case PW_TYPE_STRING:
fr_pair_value_bstrncpy(vp, val, len);
break;
default:
if (fr_pair_value_from_str(vp, val, len) < 0) goto fail;
}
RDEBUG("&%s:%s %s $%s{'%s'} -> '%s'", list_name, key, fr_int2str(fr_tokens, op, "<INVALID>"),
hash_name, key, val);
return 0;
}
return -1;
}
void
ffi_pl_perl_to_complex_float(SV *sv, float *ptr)
{
if(sv_isobject(sv) && sv_derived_from(sv, "Math::Complex"))
{
ptr[0] = decompose(sv, 0);
ptr[1] = decompose(sv, 1);
}
else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)
{
AV *av = (AV*) SvRV(sv);
SV **real_sv, **imag_sv;
real_sv = av_fetch(av, 0, 0);
imag_sv = av_fetch(av, 1, 0);
ptr[0] = real_sv != NULL ? SvNV(*real_sv) : 0.0;
ptr[1]= imag_sv != NULL ? SvNV(*imag_sv) : 0.0;
}
else if(SvOK(sv))
{
ptr[0] = SvNV(sv);
ptr[1] = 0.0;
}
else
{
ptr[0] = 0.0;
ptr[1] = 0.0;
}
}
void
ffi_pl_complex_float_to_perl(SV *sv, float *ptr)
{
if(SvOK(sv) && sv_isobject(sv) && sv_derived_from(sv, "Math::Complex"))
{
/* the complex variable is a Math::Complex object */
set(sv, sv_2mortal(newSVnv(ptr[0])), 0);
set(sv, sv_2mortal(newSVnv(ptr[1])), 1);
}
else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV)
{
/* the compex variable is already an array */
AV *av = (AV*) SvRV(sv);
av_store(av, 0, newSVnv(ptr[0]));
av_store(av, 1, newSVnv(ptr[1]));
}
else
{
/* the complex variable is something else and an array needs to be created */
SV *values[2];
AV *av;
values[0] = newSVnv(ptr[0]);
values[1] = newSVnv(ptr[1]);
av = av_make(2, values);
sv_setsv(sv, newRV_noinc((SV*)av));
}
}
int
mop_get_code_info (SV *coderef, char **pkg, char **name)
{
if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) {
return 0;
}
coderef = SvRV(coderef);
/* sub is still being compiled */
if (!CvGV(coderef)) {
return 0;
}
/* I think this only gets triggered with a mangled coderef, but if
we hit it without the guard, we segfault. The slightly odd return
value strikes me as an improvement (mst)
*/
if ( isGV_with_GP(CvGV(coderef)) ) {
GV *gv = CvGV(coderef);
*pkg = HvNAME( GvSTASH(gv) ? GvSTASH(gv) : CvSTASH(coderef) );
*name = GvNAME( CvGV(coderef) );
} else {
*pkg = "__UNKNOWN__";
*name = "__ANON__";
}
return 1;
}
static void
call_async(plcb_OPCTX *ctx, AV *resobj)
{
SV *cv = ctx->u.callback;
dSP;
if (cv == NULL || SvOK(cv) == 0) {
warn("Context does not have a callback (%p)!", cv);
return;
}
if ((ctx->flags & PLCB_OPCTXf_IMPLICIT) == 0) {
if (ctx->nremaining && (ctx->flags & PLCB_OPCTXf_CALLEACH) == 0) {
return; /* Still have ops. Only call once they're all complete */
}
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc((SV*)resobj)));
PUTBACK;
call_sv(cv, G_DISCARD);
FREETMPS;
LEAVE;
if (ctx->nremaining == 0 && (ctx->flags & PLCB_OPCTXf_CALLDONE)) {
ENTER;
SAVETMPS;
PUSHMARK(SP);
call_sv(cv, G_DISCARD);
FREETMPS;
LEAVE;
}
}
static void SetupCsv(csv_t* csv, HV* self) {
SV** svp;
STRLEN len;
char* ptr;
csv->quoteChar = '"';
if ((svp = hv_fetch(self, "quote_char", 10, 0)) && *svp) {
if (!SvOK(*svp)) {
csv->quoteChar = '\0';
} else {
ptr = SvPV(*svp, len);
csv->quoteChar = len ? *ptr : '\0';
}
}
csv->escapeChar = '"';
if ((svp = hv_fetch(self, "escape_char", 11, 0)) && *svp) {
if (!SvOK(*svp)) {
csv->escapeChar = '\0';
} else {
ptr = SvPV(*svp, len);
csv->escapeChar = len ? *ptr : '\0';
}
}
csv->sepChar = ',';
if ((svp = hv_fetch(self, "sep_char", 8, 0)) && *svp && SvOK(*svp)) {
ptr = SvPV(*svp, len);
if (len) {
csv->sepChar = *ptr;
}
}
csv->types = NULL;
if ((svp = hv_fetch(self, "_types", 6, 0)) && *svp && SvOK(*svp)) {
STRLEN len;
csv->types = SvPV(*svp, len);
csv->types_len = len;
}
csv->binary = 0;
if ((svp = hv_fetch(self, "binary", 6, 0)) && *svp) {
csv->binary = SvTRUE(*svp);
}
csv->alwaysQuote = 0;
if ((svp = hv_fetch(self, "always_quote", 12, 0)) && *svp) {
csv->alwaysQuote = SvTRUE(*svp);
}
csv->self = self;
csv->used = 0;
}
HV *
Perl_newHV(pTHX)
{
HV * const hv = MUTABLE_HV(newSV_type(SVt_PVHV));
assert(!SvOK(hv));
return hv;
}
/* getcode関数 */
SV* xs_getcode(SV* sv_str)
{
int matches;
CodeCheck check[cc_tmpl_max];
if( sv_str==&PL_sv_undef )
{
return new_SV_UNDEF();
}
if( SvGMAGICAL(sv_str) )
{
mg_get(sv_str);
}
if( !SvOK(sv_str) )
{
return newSVsv(&PL_sv_undef);
}
matches = getcode_list(sv_str, check);
if( matches>0 )
{
int index = 0;
#if TEST && GC_DISP
fprintf(stderr,"<selected>\n");
fprintf(stderr," %d of 0..%d\n",index,matches-1);
fprintf(stderr," %s\n",charcodeToStr(check[index].code));
#endif
switch(check[index].code)
{
case cc_unknown: return new_CC_UNKNOWN();
case cc_ascii: return new_CC_ASCII();
case cc_sjis: return new_CC_SJIS();
case cc_eucjp: return new_CC_EUCJP();
case cc_jis: return new_CC_JIS();
case cc_jis_au: return new_CC_JIS_AU();
case cc_jis_jsky: return new_CC_JIS_JSKY();
case cc_utf8: return new_CC_UTF8();
case cc_utf16: return new_CC_UTF16();
case cc_utf32: return new_CC_UTF32();
case cc_utf32_be: return new_CC_UTF32_BE();
case cc_utf32_le: return new_CC_UTF32_LE();
case cc_sjis_jsky: return new_CC_SJIS_JSKY();
case cc_sjis_imode: return new_CC_SJIS_IMODE();
case cc_sjis_doti: return new_CC_SJIS_DOTI();
case cc_sjis_au: return new_CC_SJIS_AU();
default:
#ifdef TEST
return NULL;
#else
return new_CC_UNKNOWN();
#endif
}
}else
{
return new_CC_UNKNOWN();
}
}
static int
fd_cb (int fd, int flags, void *userdata)
{
HookData *data = (HookData *) userdata;
int retVal = 0;
int count = 0;
dSP;
ENTER;
SAVETMPS;
PUSHMARK (SP);
XPUSHs (data->userdata);
PUTBACK;
set_current_package (data->package);
count = call_sv (data->callback, G_EVAL);
set_current_package (&PL_sv_undef);
SPAGAIN;
if (SvTRUE (ERRSV)) {
hexchat_printf (ph, "Error in fd callback %s", SvPV_nolen (ERRSV));
if (!SvOK (POPs)) {} /* remove undef from the top of the stack */
retVal = HEXCHAT_EAT_ALL;
} else {
if (count != 1) {
hexchat_print (ph, "Fd handler should only return 1 value.");
retVal = HEXCHAT_EAT_NONE;
} else {
retVal = POPi;
if (retVal == 0) {
/* if 0 is returned, the fd is going to get unhooked */
PUSHMARK (SP);
XPUSHs (sv_2mortal (newSViv (PTR2IV (data->hook))));
PUTBACK;
call_pv ("Xchat::unhook", G_EVAL);
SPAGAIN;
SvREFCNT_dec (data->callback);
if (data->userdata) {
SvREFCNT_dec (data->userdata);
}
free (data);
}
}
}
PUTBACK;
FREETMPS;
LEAVE;
return retVal;
}
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;
}
static int
timer_cb (void *userdata)
{
HookData *data = (HookData *) userdata;
int retVal = 0;
int count = 0;
dSP;
ENTER;
SAVETMPS;
PUSHMARK (SP);
XPUSHs (data->userdata);
PUTBACK;
if (data->ctx) {
xchat_set_context (ph, data->ctx);
}
set_current_package (data->package);
count = call_sv (data->callback, G_EVAL);
set_current_package (&PL_sv_undef);
SPAGAIN;
if (SvTRUE (ERRSV)) {
xchat_printf (ph, "Error in timer callback %s", SvPV_nolen (ERRSV));
if (!SvOK (POPs)) {} /* remove undef from the top of the stack */
retVal = XCHAT_EAT_ALL;
} else {
if (count != 1) {
xchat_print (ph, "Timer handler should only return 1 value.");
retVal = XCHAT_EAT_NONE;
} else {
retVal = POPi;
if (retVal == 0) {
/* if 0 is return the timer is going to get unhooked */
PUSHMARK (SP);
XPUSHs (sv_2mortal (newSViv (PTR2IV (data->hook))));
XPUSHs (sv_mortalcopy (data->package));
PUTBACK;
call_pv ("Xchat::unhook", G_EVAL);
SPAGAIN;
}
}
}
PUTBACK;
FREETMPS;
LEAVE;
return retVal;
}
/* convert a hash to a string, with the format "key=val,key=val" */
char *
hash2str( HV* hash )
{
SV* val; /* temp for iterating over hash */
char* key; /* temp for iterating over hash */
I32 keylen; /* temp for iterating over hash */
int len = 0; /* length of final string, including EOS */
int n; /* number of elements in hash */
char* str; /* final string */
char* ptr; /* temp ptr */
/* iterate over hash, determining the length of the final string */
hv_iterinit(hash);
while( val = hv_iternextsv(hash, &key, &keylen) )
{
/* complain if the value is undefined or if it's a reference */
if ( !SvOK(val) || SvROK(val) )
croak( "hash entry for `%s' not a scalar", key );
n++;
len += keylen + SvCUR(val);
}
len += n /* '=' */
+ n-1 /* ',' */
+ 1; /* EOS */
/* now, fill in string */
New( 0, str, len, char );
ptr = str;
hv_iterinit(hash);
while( val = hv_iternextsv(hash, &key, &keylen) )
{
STRLEN cur;
char *pv;
strcpy(ptr, key);
ptr += keylen;
*ptr++ = '=';
pv = SvPV(val, cur);
strncpy(ptr, pv, cur);
ptr += cur;
*ptr++ = ',';
}
/* the EOS position now contains a ',', and ptr is one
past that. fix that */
*--ptr = '\0';
return str;
}
