void
scan_search_entry_response(const char** src, const char* max, HV *out) {
SV *dn, *key;
STRLEN len;
dn = newSV(0);
hv_stores(out, "dn", dn);
scan_string_utf8(src, max, dn);
scan_sequence(src, max, &len);
if (len != max - *src)
croak("scan_search_entry_response: packet too short");
key = sv_newmortal();
while (*src < max) {
const char *attribute_max;
AV *values;
scan_sequence(src, max, &len);
attribute_max = *src + len;
scan_string_utf8(src, max, key);
values = newAV();
hv_store_ent(out, key, newRV_noinc((SV*)values), 0);
scan_set(src, max, &len);
if (attribute_max != *src + len)
croak("bad packet");
while (*src < attribute_max) {
SV *v = newSV(0);
av_push(values, v);
scan_string_utf8(src, attribute_max, v);
}
}
}
/*----------------------------------------------------------------------------
try_match__()
The pattern matching function which includes loading perl interpreter and
trying the perl pattern matching.
arguments:
input: char* string, -- input text
char* pattern -- match pattern
output:if no match found, return FAILURE (0).
----------------------------------------------------------------------------*/
int try_match__( void )
{
SV *text; /* the storage for the string in embedded Perl */
SV *string_buff; /* the storage for the string in embedded Perl */
int was_match; /* number of the matches */
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
char *string = ptoc_string(CTXTc 1),
*pattern = ptoc_string(CTXTc 2);
/* first load the perl interpreter, if unloaded */
if (perlObjectStatus == UNLOADED) load_perl__();
text = newSV(0);
string_buff = newSV(0);
sv_setpv(text, string); /* store the string in the SV */
was_match = match(text, pattern );
global_pattern_mode = is_global_pattern(pattern);
SvREFCNT_dec(string_buff);
SvREFCNT_dec(text);
return(was_match);
}
void
__getdns_callback(Net__GetDNS__XS__Context * context,
getdns_callback_type_t callback_type, Net__GetDNS__XS__Dict * response,
void * userarg, getdns_transaction_t transaction_id)
{
dSP;
struct __callback * cb;
if (!userarg) return;
cb = (struct __callback *)userarg;
if (!cb->callbackfn) return;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(sv_setref_pv(newSV(0), "Net::GetDNS::XS::ContextPtr", (void *)context)));
XPUSHs(sv_2mortal(newSVuv(callback_type)));
XPUSHs(sv_2mortal(sv_setref_pv(newSV(0), "Net::GetDNS::XS::DictPtr", (void *)response)));
XPUSHs(sv_2mortal(newSVsv(cb->userarg)));
XPUSHs(sv_2mortal(newSVuv(transaction_id)));
PUTBACK;
call_sv((SV*)(cb->callbackfn), G_VOID);
FREETMPS;
LEAVE;
SvREFCNT_dec(cb->callbackfn);
Safefree(cb);
}
static SV* _amf0_sv(amf0_data_t* data) {
SV* sv = NULL;
SV* svh;
SV* sva;
HV* hv;
AV* av;
int i;
amf0_object_t* obj;
const char* key;
amf0_data_t* value;
switch (data->type) {
case AMF0_NUMBER:
sv = newSVnv(((amf0_number_t*)data)->value);
break;
case AMF0_BOOLEAN:
sv = newSViv(((amf0_boolean_t*)data)->value);
break;
case AMF0_STRING:
sv = newSV(0);
sv_setpv(sv, ((amf0_string_t*)data)->value);
break;
case AMF0_OBJECT:
hv = newHV();
obj = (amf0_object_t*)data;
for (i = 0; i < obj->used; ++i) {
key = obj->data[i]->key;
value = obj->data[i]->value;
svh = _amf0_sv(value);
hv_store(hv, key, strlen(key), svh, 0);
}
sv = newRV(sv_2mortal((SV*)hv));
break;
case AMF0_NULL:
case AMF0_UNDEFINED:
sv = newSV(0);
break;
case AMF0_STRICTARRAY:
av = newAV();
for (i = 0; i < ((amf0_strictarray_t*)data)->used; ++i) {
sva = _amf0_sv(((amf0_strictarray_t*)data)->data[i]);
av_push(av, sva);
}
sv = newRV(sv_2mortal((SV *)av));
break;
default:
Perl_croak(aTHX_ "Unsupported datatype: %d\n", data->type);
break;
}
return sv;
}
static SV *make_env(request_rec *r, psgi_dir_config *c)
{
dTHX;
HV *env;
AV *version;
char *url_scheme, *script_name, *vpath, *path_info;
SV *input, *errors;
env = newHV();
ap_add_cgi_vars(r);
ap_add_common_vars(r);
/* fix SCRIPT_NAME & PATH_INFO */
if (c->location == NULL || strcmp(c->location, "/") == 0) {
script_name = "";
} else {
script_name = c->location;
}
vpath = apr_pstrcat(r->pool,
apr_table_get(r->subprocess_env, "SCRIPT_NAME"),
apr_table_get(r->subprocess_env, "PATH_INFO"),
NULL);
path_info = &vpath[strlen(script_name)];
apr_table_set(r->subprocess_env, "PATH_INFO", path_info);
apr_table_set(r->subprocess_env, "SCRIPT_NAME", script_name);
apr_table_do(copy_env, env, r->subprocess_env, NULL);
version = newAV();
av_push(version, newSViv(1));
av_push(version, newSViv(0));
(void) hv_store(env, "psgi.version", 12, newRV_noinc((SV *) version), 0);
url_scheme = apr_table_get(r->subprocess_env, "HTTPS") == NULL ? "http" : "https";
(void) hv_store(env, "psgi.url_scheme", 15, newSVpv(url_scheme, 0), 0);
input = newRV_noinc(newSV(0));
sv_magic(SvRV(input), NULL, PERL_MAGIC_ext, NULL, 0);
mg_find(SvRV(input), PERL_MAGIC_ext)->mg_obj = (void *) r;
sv_bless(input, gv_stashpv("ModPSGI::Input", 1));
(void) hv_store(env, "psgi.input", 10, input, 0);
errors = newRV_noinc(newSV(0));
sv_magic(SvRV(errors), NULL, PERL_MAGIC_ext, NULL, 0);
mg_find(SvRV(errors), PERL_MAGIC_ext)->mg_obj = (void *) r;
sv_bless(errors, gv_stashpv("ModPSGI::Errors", 1));
(void) hv_store(env, "psgi.errors", 11, errors, 0);
(void) hv_store(env, "psgi.multithread", 16, newSViv(psgi_multithread), 0);
(void) hv_store(env, "psgi.multiprocess", 17, newSViv(psgi_multiprocess), 0);
(void) hv_store(env, "psgi.run_once", 13, newSViv(0), 0);
(void) hv_store(env, "psgi.nonblocking", 16, newSViv(0), 0);
return newRV_inc((SV *) env);
}
bool PerlSortCondition::operator() (const RowHandle *r1, const RowHandle *r2) const
{
dSP;
if (cbCompare_.isNull())
return false; // should never happen but just in case
// the rows are passed to Perl as Rows, not RowHandles, because
// wrapping the RowHandle requires a table pointer which is not available
WrapRow *wr1 = new WrapRow(rt_, const_cast<Row *>(r1->getRow()));
SV *svr1 = newSV(0);
sv_setref_pv(svr1, "Triceps::Row", (void *)wr1);
WrapRow *wr2 = new WrapRow(rt_, const_cast<Row *>(r2->getRow()));
SV *svr2 = newSV(0);
sv_setref_pv(svr2, "Triceps::Row", (void *)wr2);
PerlCallbackStartCall(cbCompare_);
XPUSHs(svr1);
XPUSHs(svr2);
SV *svrcode = NULL;
PerlCallbackDoCallScalar(cbCompare_, svrcode);
SvREFCNT_dec(svr1);
SvREFCNT_dec(svr2);
bool result = false; // the safe default, collapses all keys into one
if (SvTRUE(ERRSV)) {
Erref err;
err.f("Error in PerlSortedIndex(%s) comparator: %s",
name_.c_str(), SvPV_nolen(ERRSV));
// XXX print the source code of comparator is available
table_->setStickyError(err);
} else if (svrcode == NULL) {
Erref err;
err.f("Error in PerlSortedIndex(%s) comparator: comparator returned no value",
name_.c_str());
// XXX print the source code of comparator is available
table_->setStickyError(err);
} else if (!SvIOK(svrcode)) {
Erref err;
err.f("Error in PerlSortedIndex(%s) comparator: comparator returned a non-integer value '%s'",
name_.c_str(), SvPV_nolen(svrcode));
// XXX print the source code of comparator is available
table_->setStickyError(err);
} else {
result = (SvIV(svrcode) < 0); // the Less
}
if (svrcode != NULL)
SvREFCNT_dec(svrcode);
return result;
}
/*----------------------------------------------------------------------------
do_bulk_match__()
The pattern match function which includes loading perl interpreter and
doing the global perl pattern match, and storing the results in the global
array of bulkMatchList.
argument:
input: char* string -- input text
char* pattern -- match pattern
output: int* num_match -- the number of the matches
----------------------------------------------------------------------------*/
int do_bulk_match__( void )
{
AV *match_list; /* AV storage of matches list*/
SV *text; /* storage for the embedded perl cmd */
SV *string_buff; /* storage for the embedded perl cmd */
int num_match; /* the number of the matches */
int i;
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
/* first load the perl interpreter, if unloaded */
if (perlObjectStatus == UNLOADED) load_perl__();
text = newSV(0);
string_buff = newSV(0);
sv_setpv(text, ptoc_string(CTXTc 1)); /*put the string into an SV */
/*------------------------------------------------------------------------
free the old match list space and allocate new space for current match list
-----------------------------------------------------------------------*/
for ( i=0; i<preBulkMatchNumber; i++ )
free(bulkMatchList[i]);
if (bulkMatchList != NULL ) free(bulkMatchList);
bulkMatchList = NULL;
/*------------------------------------------------------------------------
do bulk match
----------------------------------------------------------------------*/
num_match = all_matches(text, ptoc_string(CTXTc 2),&match_list);
/* allocate the space to store the matches */
if ( num_match != 0 ) {
preBulkMatchNumber = num_match; /* reset the pre bulk match number */
bulkMatchList = (char **)malloc(num_match*sizeof(char *));
if ( bulkMatchList == NULL )
xsb_abort("Cannot alocate memory to store the results for bulk match");
}
/*get the matches from the AV */
for ( i=0;i<num_match;i++ ) {
string_buff = av_shift(match_list);
bulkMatchList[i] = (char *)malloc( strlen(SvPV(string_buff,PL_na))+1 );
strcpy((char *)bulkMatchList[i], SvPV(string_buff,PL_na) );
}
SvREFCNT_dec(string_buff); /* release space*/
SvREFCNT_dec(text);
ctop_int(CTXTc 3, num_match); /*return the number of matches*/
return SUCCESS;
}
/* Load a YAML scalar into a Perl scalar */
SV *
load_scalar(perl_yaml_loader_t *loader)
{
SV *scalar;
char *string = (char *)loader->event.data.scalar.value;
STRLEN length = (STRLEN)loader->event.data.scalar.length;
char *anchor = (char *)loader->event.data.scalar.anchor;
char *tag = (char *)loader->event.data.scalar.tag;
if (tag) {
char *class;
char *prefix = TAG_PERL_PREFIX "regexp";
if (strnEQ(tag, prefix, strlen(prefix)))
return load_regexp(loader);
prefix = TAG_PERL_PREFIX "scalar:";
if (*tag == '!')
prefix = "!";
else if (strlen(tag) <= strlen(prefix) ||
! strnEQ(tag, prefix, strlen(prefix))
) croak(ERRMSG "bad tag found for scalar: '%s'", tag);
class = tag + strlen(prefix);
scalar = sv_setref_pvn(newSV(0), class, string, strlen(string));
SvUTF8_on(scalar);
return scalar;
}
if (loader->event.data.scalar.style == YAML_PLAIN_SCALAR_STYLE) {
if (strEQ(string, "~"))
return newSV(0);
else if (strEQ(string, ""))
return newSV(0);
else if (strEQ(string, "null"))
return newSV(0);
else if (strEQ(string, "true"))
return &PL_sv_yes;
else if (strEQ(string, "false"))
return &PL_sv_no;
}
scalar = newSVpvn(string, length);
if (loader->event.data.scalar.style == YAML_PLAIN_SCALAR_STYLE && looks_like_number(scalar) ) {
/* numify */
SvIV_please(scalar);
}
SvUTF8_on(scalar);
if (anchor)
hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(scalar), 0);
return scalar;
}
SV*
Line::to_AV() {
AV* av = newAV();
av_extend(av, 1);
SV* sv = newSV(0);
sv_setref_pv( sv, perl_class_name_ref(&this->a), &(this->a) );
av_store(av, 0, sv);
sv = newSV(0);
sv_setref_pv( sv, perl_class_name_ref(&this->b), &(this->b) );
av_store(av, 1, sv);
return newRV_noinc((SV*)av);
}
SV*
Line::to_AV() {
AV* av = newAV();
av_extend(av, 1);
SV* sv = newSV(0);
sv_setref_pv( sv, "Slic3r::Point::Ref", &(this->a) );
av_store(av, 0, sv);
sv = newSV(0);
sv_setref_pv( sv, "Slic3r::Point::Ref", &(this->b) );
av_store(av, 1, sv);
return newRV_noinc((SV*)av);
}
SV*
c2p_syncdb(void *db)
{
SV *rv = newSV(0);
sv_setref_pv(rv, "ALPM::DB::Sync", db);
return rv;
}
SV*
c2p_localdb(void *db)
{
SV *rv = newSV(0);
sv_setref_pv(rv, "ALPM::DB::Local", db);
return rv;
}
static void
S_lazy_init_host_obj(kino_Obj *self)
{
SV *inner_obj = newSV(0);
SvOBJECT_on(inner_obj);
PL_sv_objcount++;
SvUPGRADE(inner_obj, SVt_PVMG);
sv_setiv(inner_obj, PTR2IV(self));
// Connect class association.
kino_CharBuf *class_name = Kino_VTable_Get_Name(self->vtable);
HV *stash = gv_stashpvn((char*)Kino_CB_Get_Ptr8(class_name),
Kino_CB_Get_Size(class_name), TRUE);
SvSTASH_set(inner_obj, (HV*)SvREFCNT_inc(stash));
/* Up till now we've been keeping track of the refcount in
* self->ref.count. We're replacing ref.count with ref.host_obj, which
* will assume responsibility for maintaining the refcount. ref.host_obj
* starts off with a refcount of 1, so we need to transfer any refcounts
* in excess of that. */
size_t old_refcount = self->ref.count;
self->ref.host_obj = inner_obj;
while (old_refcount > 1) {
SvREFCNT_inc_simple_void_NN(inner_obj);
old_refcount--;
}
}
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;
}
PJS_Function *
PJS_DefineFunction(PJS_Context *inContext, const char *functionName, SV *perlCallback) {
PJS_Function *function;
JSContext *js_context = inContext->cx;
SV *sv;
if (PJS_GetFunctionByName(inContext, functionName) != NULL) {
warn("Function named '%s' is already defined in the context");
return NULL;
}
if ((function = PJS_CreateFunction(functionName, perlCallback)) == NULL) {
return NULL;
}
/* Add the function to the javascript context */
if (JS_DefineFunction(js_context, JS_GetGlobalObject(js_context), functionName, PJS_invoke_perl_function, 0, 0) == JS_FALSE) {
warn("Failed to define function");
PJS_DestroyFunction(function);
return NULL;
}
sv = newSV(0);
sv_setref_pv(sv, "JavaScript::PerlFunction", (void*) function);
if (functionName != NULL) {
SvREFCNT_inc(sv);
hv_store(inContext->function_by_name, functionName, strlen(functionName), sv, 0);
}
return function;
}
void decode_list(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
struct cc_type *inner_type;
int i;
AV *the_list;
SV *the_rv;
STRLEN pos;
inner_type = type->inner_type;
assert(inner_type);
if (UNLIKELY(len < 4))
croak("decode_list: len < 4");
int32_t num_elements = (int32_t)ntohl(*(uint32_t*)(input));
if (UNLIKELY(num_elements < 0))
croak("decode_list: num_elements < 0");
the_list = newAV();
the_rv = newRV_noinc((SV*)the_list);
sv_setsv(output, the_rv);
SvREFCNT_dec(the_rv);
pos = 4;
for (i = 0; i < num_elements; i++) {
SV *decoded = newSV(0);
av_push(the_list, decoded);
decode_cell(aTHX_ input, len, &pos, inner_type, decoded);
}
}
Datum
hstore_to_plperl(PG_FUNCTION_ARGS)
{
HStore *in = PG_GETARG_HS(0);
int i;
int count = HS_COUNT(in);
char *base = STRPTR(in);
HEntry *entries = ARRPTR(in);
HV *hv;
hv = newHV();
for (i = 0; i < count; i++)
{
const char *key;
SV *value;
key = pnstrdup(HS_KEY(entries, base, i), HS_KEYLEN(entries, i));
value = HS_VALISNULL(entries, i) ? newSV(0) : cstr2sv(pnstrdup(HS_VAL(entries, base, i), HS_VALLEN(entries, i)));
(void) hv_store(hv, key, strlen(key), value, 0);
}
return PointerGetDatum(newRV((SV *) hv));
}
static bool do_script_list(sourceinfo_t *si)
{
bool retval = true;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
SV *arg = newSV(0);
sv_setref_pv(arg, "Atheme::Sourceinfo", si);
XPUSHs(sv_2mortal(arg));
PUTBACK;
call_pv("Atheme::Init::list_scripts", G_EVAL | G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV))
{
retval = false;
mowgli_strlcpy(perl_error, SvPV_nolen(ERRSV), sizeof(perl_error));
POPs;
}
FREETMPS;
LEAVE;
invalidate_object_references();
return retval;
}
SV*
Polyline::to_SV_clone_ref() const
{
SV* sv = newSV(0);
sv_setref_pv( sv, "Slic3r::Polyline", new Polyline(*this) );
return sv;
}
/* The newSVpvn function was introduced in perl5.004_05 */
static SV *
newSVpvn(char *s, STRLEN len)
{
register SV *sv = newSV(0);
sv_setpvn(sv,s,len);
return sv;
}
void decode_tuple(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
SV *the_rv;
AV *the_tuple;
struct cc_tuple *tuple;
int i;
STRLEN pos;
the_tuple = newAV();
the_rv = newRV_noinc((SV*)the_tuple);
sv_setsv(output, the_rv);
SvREFCNT_dec(the_rv);
tuple = type->tuple;
assert(tuple);
pos = 0;
for (i = 0; i < tuple->field_count; i++) {
struct cc_type *type = &tuple->fields[i];
SV *decoded = newSV(0);
av_push(the_tuple, decoded);
decode_cell(aTHX_ input, len, &pos, type, decoded);
}
}
void decode_udt(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output)
{
struct cc_udt *udt;
int i;
STRLEN pos;
HV *the_obj;
SV *the_rv;
the_obj = newHV();
the_rv = newRV_noinc((SV*)the_obj);
sv_setsv(output, the_rv);
SvREFCNT_dec(the_rv);
udt = type->udt;
assert(udt && udt->fields);
pos = 0;
for (i = 0; i < udt->field_count; i++) {
if (len == pos) {
break;
}
struct cc_udt_field *field;
SV *value;
field = &udt->fields[i];
value = newSV(0);
hv_store_ent(the_obj, field->name, value, field->name_hash);
decode_cell(aTHX_ input, len, &pos, &field->type, value);
}
}
static SV *parser_fn(OP *(fn)(pTHX_ U32), bool named) {
I32 floor;
CV *code;
U8 errors;
ENTER;
PL_curcop = &PL_compiling;
SAVEVPTR(PL_op);
SAVEI8(PL_parser->error_count);
PL_parser->error_count = 0;
floor = start_subparse(0, named ? 0 : CVf_ANON);
code = newATTRSUB(floor, NULL, NULL, NULL, fn(aTHX_ 0));
errors = PL_parser->error_count;
LEAVE;
if (errors) {
++PL_parser->error_count;
return newSV(0);
}
else {
if (CvCLONE(code)) {
code = cv_clone(code);
}
return newRV_inc((SV*)code);
}
}
SV*
newPerlPyObject_noinc(PyObject *pyo)
{
SV* rv;
SV* sv;
MAGIC *mg;
dCTXP;
ASSERT_LOCK_PERL;
if (!pyo)
croak("Missing pyo reference argument");
rv = newSV(0);
sv = newSVrv(rv, "Python::Object");
sv_setiv(sv, (IV)pyo);
sv_magic(sv, 0, '~', 0, 0);
mg = mg_find(sv, '~');
if (!mg) {
SvREFCNT_dec(rv);
croak("Can't assign magic to Python::Object");
}
mg->mg_virtual = &vtbl_free_pyo;
SvREADONLY(sv);
#ifdef REF_TRACE
printf("Bind pyo %p\n", pyo);
#endif
ASSERT_LOCK_PERL;
return rv;
}
SV *
PLCBA_construct(const char *pkg, AV *options)
{
PLCBA_t *async;
char *host, *username, *password, *bucket;
libcouchbase_t instance;
SV *blessed_obj;
Newxz(async, 1, PLCBA_t);
extract_async_options(async, options);
plcb_ctor_conversion_opts(&async->base, options);
plcb_ctor_cbc_opts(options, &host, &username, &password, &bucket);
instance = libcouchbase_create(host, username, password, bucket,
plcba_make_io_opts(async));
if(!instance) {
die("Couldn't create instance!");
}
plcb_ctor_init_common(&async->base, instance, options);
plcba_setup_callbacks(async);
async->base_rv = newRV_inc(newSViv(PTR2IV(&(async->base))));
blessed_obj = newSV(0);
sv_setiv(newSVrv(blessed_obj, pkg), PTR2IV(async));
return blessed_obj;
}
SV*
Polyline::to_SV_ref()
{
SV* sv = newSV(0);
sv_setref_pv( sv, "Slic3r::Polyline::Ref", (void*)this );
return sv;
}
KHARON_DECL void
undef_begin(ssp_val *ret)
{
*ret = newSV(0);
D(fprintf(stderr, "undef_begin(%p):\n", *ret));
}
/*----------------------------------------------------------------------------
perl_substitute__()
The pattern substitution function which includes loading perl interpreter
and doing the pattern substitution, then returning the replaced string.
arguments:
input: char* string, input text
char* pattern, match pattern
output:char* string, output text
----------------------------------------------------------------------------*/
int perl_substitute__( void )
{
SV *text; /* Perl representation for the string to be
modified by substitution */
char *subst_cmd = ptoc_string(CTXTc 2);
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
/* first load the perl interpreter, if unloaded */
if (perlObjectStatus == UNLOADED) load_perl__();
text = newSV(0);
sv_setpv(text, ptoc_string(CTXTc 1)); /* put the string to the SV */
if( !substitute(&text, subst_cmd) )
return(FAILURE);
global_pattern_mode = is_global_pattern(subst_cmd);
if (substituteString != NULL ) free(substituteString);
substituteString = malloc(strlen(SvPV(text,PL_na))+1);
strcpy(substituteString,SvPV(text,PL_na));
SvREFCNT_dec(text); /*release space*/
ctop_string(CTXTc 3, string_find(substituteString,1)); /*return changed text*/
return SUCCESS;
}
static HV*
S_thaw_fields(lucy_InStream *instream) {
// Read frozen data into an SV buffer.
size_t len = (size_t)LUCY_InStream_Read_C64(instream);
SV *buf_sv = newSV(len + 1);
SvPOK_on(buf_sv);
SvCUR_set(buf_sv, len);
char *buf = SvPVX(buf_sv);
LUCY_InStream_Read_Bytes(instream, buf, len);
// Call back to Storable to thaw the frozen hash.
dSP;
ENTER;
SAVETMPS;
EXTEND(SP, 1);
PUSHMARK(SP);
mPUSHs(buf_sv);
PUTBACK;
call_pv("Storable::thaw", G_SCALAR);
SPAGAIN;
SV *frozen = POPs;
if (frozen && !SvROK(frozen)) {
CFISH_THROW(CFISH_ERR, "thaw failed");
}
HV *fields = (HV*)SvRV(frozen);
(void)SvREFCNT_inc((SV*)fields);
PUTBACK;
FREETMPS;
LEAVE;
return fields;
}
/* maps to mod_mime_magic::apprentice */
static int
fmm_parse_magic_file(PerlFMM *state, char *file)
{
int ws_offset;
int lineno;
int errs;
/* char line[BUFSIZ + 1];*/
PerlIO *fhandle;
SV *err;
SV *sv = sv_2mortal(newSV(BUFSIZ));
SV *PL_rs_orig = newSVsv(PL_rs);
char *line;
fhandle = PerlIO_open(file, "r");
if (! fhandle) {
err = newSVpvf(
"Failed to open %s: %s", file, strerror(errno));
FMM_SET_ERROR(state, err);
PerlIO_close(fhandle);
return -1;
}
/*
* Parse it line by line
* $/ (slurp mode) is needed here
*/
PL_rs = sv_2mortal(newSVpvn("\n", 1));
for(lineno = 1; sv_gets(sv, fhandle, 0) != NULL; lineno++) {
line = SvPV_nolen(sv);
/* delete newline */
if (line[0]) {
line[strlen(line) - 1] = '\0';
}
/* skip leading whitespace */
ws_offset = 0;
while (line[ws_offset] && isSPACE(line[ws_offset])) {
ws_offset++;
}
/* skip blank lines */
if (line[ws_offset] == 0) {
continue;
}
if (line[ws_offset] == '#') {
continue;
}
if (fmm_parse_magic_line(state, line, lineno) != 0) {
++errs;
}
}
PerlIO_close(fhandle);
PL_rs = PL_rs_orig;
return 1;
}
