static int
image_gif_read_buf(GifFileType *gif, GifByteType *data, int len)
{
image *im = (image *)gif->UserData;
//DEBUG_TRACE("GIF read_buf wants %d bytes, %d in buffer\n", len, buffer_len(im->buf));
if (im->fh != NULL) {
if ( !_check_buf(im->fh, im->buf, len, MAX(len, BUFFER_SIZE)) ) {
warn("Image::Scale not enough GIF data (%s)\n", SvPVX(im->path));
return 0;
}
}
else {
if (len > buffer_len(im->buf)) {
// read from SV into buffer
int sv_readlen = len - buffer_len(im->buf);
if (sv_readlen > sv_len(im->sv_data) - im->sv_offset) {
warn("Image::Scale not enough GIF data (%s)\n", SvPVX(im->path));
return 0;
}
DEBUG_TRACE(" Reading %d bytes of SV data @ %d\n", sv_readlen, im->sv_offset);
buffer_append(im->buf, SvPVX(im->sv_data) + im->sv_offset, sv_readlen);
im->sv_offset += sv_readlen;
}
}
memcpy(data, buffer_ptr(im->buf), len);
buffer_consume(im->buf, len);
return len;
}
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);
}
}
}
void fatal(const char *f, ...)
{
dTHX;
va_list l;
SV *sv = newSVpvn("", 0);
va_start(l, f);
sv_catpv(sv,
"============================================\n"
" FATAL ERROR in " XSCLASS "!\n"
"--------------------------------------------\n"
);
sv_vcatpvf(sv, f, &l);
sv_catpv(sv,
"\n"
"--------------------------------------------\n"
" please report this error to [email protected]\n"
"============================================\n"
);
va_end(l);
fprintf(stderr, "%s", SvPVX(sv));
SvREFCNT_dec(sv);
abort();
}
void modperl_perl_call_list(pTHX_ AV *subs, const char *name)
{
I32 i, oldscope = PL_scopestack_ix;
SV **ary = AvARRAY(subs);
MP_TRACE_g(MP_FUNC, "pid %lu" MP_TRACEf_TID MP_TRACEf_PERLID
" running %d %s subs",
(unsigned long)getpid(), MP_TRACEv_TID_ MP_TRACEv_PERLID_
AvFILLp(subs)+1, name);
for (i=0; i<=AvFILLp(subs); i++) {
CV *cv = (CV*)ary[i];
SV *atsv = ERRSV;
PUSHMARK(PL_stack_sp);
call_sv((SV*)cv, G_EVAL|G_DISCARD);
if (SvCUR(atsv)) {
Perl_sv_catpvf(aTHX_ atsv, "%s failed--call queue aborted",
name);
while (PL_scopestack_ix > oldscope) {
LEAVE;
}
Perl_croak(aTHX_ "%s", SvPVX(atsv));
}
}
}
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;
}
modperl_handler_t *modperl_handler_new_from_sv(pTHX_ apr_pool_t *p, SV *sv)
{
char *name = NULL;
GV *gv;
if (SvROK(sv)) {
sv = SvRV(sv);
}
switch (SvTYPE(sv)) {
case SVt_PV:
name = SvPVX(sv);
return modperl_handler_new(p, apr_pstrdup(p, name));
break;
case SVt_PVCV:
if (CvANON((CV*)sv)) {
return modperl_handler_new_anon(aTHX_ p, (CV*)sv);
}
if (!(gv = CvGV((CV*)sv))) {
Perl_croak(aTHX_ "can't resolve the code reference");
}
name = apr_pstrcat(p, HvNAME(GvSTASH(gv)), "::", GvNAME(gv), NULL);
return modperl_handler_new(p, name);
default:
break;
};
return NULL;
}
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;
}
IV
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
STRLEN oldcur = SvCUR(s->var);
STRLEN newlen;
switch (whence) {
case SEEK_SET:
s->posn = offset;
break;
case SEEK_CUR:
s->posn = offset + s->posn;
break;
case SEEK_END:
s->posn = offset + SvCUR(s->var);
break;
}
if (s->posn < 0) {
if (ckWARN(WARN_LAYER))
Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
SETERRNO(EINVAL, SS_IVCHAN);
return -1;
}
newlen = (STRLEN) s->posn;
if (newlen > oldcur) {
(void) SvGROW(s->var, newlen);
Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
/* No SvCUR_set(), though. This is just a seek, not a write. */
}
bool EQWParser::dosub(const char * subname, const std::vector<std::string> &args, std::string &error, int mode) {
bool err = false;
dSP; // initialize stack pointer
ENTER; // everything created after here
SAVETMPS; // ...is a temporary variable
PUSHMARK(SP); // remember the stack pointer
if(!args.empty())
{
for (auto i = args.begin(); i != args.end(); ++i) { /* push the arguments onto the perl stack */
XPUSHs(sv_2mortal(newSVpv(i->c_str(), i->length())));
}
}
PUTBACK; // make local stack pointer global
call_pv(subname, mode); /*eval our code*/
SPAGAIN; // refresh stack pointer
if(SvTRUE(ERRSV)) {
err = true;
}
FREETMPS; // free temp values
LEAVE; // ...and the XPUSHed "mortal" args.
if(err) {
error = "Perl runtime error: ";
error += SvPVX(ERRSV);
return(false);
}
return(true);
}
GV *
Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
{
register const char *nend;
const char *nsplit = 0;
GV* gv;
for (nend = name; *nend; nend++) {
if (*nend == '\'')
nsplit = nend;
else if (*nend == ':' && *(nend + 1) == ':')
nsplit = ++nend;
}
if (nsplit) {
const char *origname = name;
name = nsplit + 1;
if (*nsplit == ':')
--nsplit;
if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
CopSTASHPV(PL_curcop)));
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
}
else
stash = gv_stashpvn(origname, nsplit - origname, TRUE);
}
gv = gv_fetchmeth(stash, name, nend - name, 0);
if (!gv) {
if (strEQ(name,"import") || strEQ(name,"unimport"))
gv = (GV*)&PL_sv_yes;
else if (autoload)
gv = gv_autoload4(stash, name, nend - name, TRUE);
}
else if (autoload) {
CV* cv = GvCV(gv);
if (!CvROOT(cv) && !CvXSUB(cv)) {
GV* stubgv;
GV* autogv;
if (CvANON(cv))
stubgv = gv;
else {
stubgv = CvGV(cv);
if (GvCV(stubgv) != cv) /* orphaned import */
stubgv = gv;
}
autogv = gv_autoload4(GvSTASH(stubgv),
GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
if (autogv)
gv = autogv;
}
}
return gv;
}
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);
}
int execute_perl( const char *function, char **args, char *data ) {
int count = 0, i, ret_value = 1;
STRLEN na;
SV *sv_args[0];
dSP;
PERL_SET_CONTEXT( my_perl );
/*
* Set up the perl environment, push arguments onto the perl stack, then
* call the given function
*/
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK( sp );
for ( i = 0; i < ( int )sizeof( args ) - 1; i++ ) {
if ( args[i] != NULL ) {
sv_args[i] = sv_2mortal( newSVpv( args[i], 0 ) );
XPUSHs( sv_args[i] );
}
}
PUTBACK;
PERL_SET_CONTEXT( my_perl );
count = call_pv( function, G_EVAL | G_SCALAR );
SPAGAIN;
/*
* Check for "die," make sure we have 1 argument, and set our return value
*/
if ( SvTRUE( ERRSV ) ) {
sprintf( data,
"%sPerl function (%s) exited abnormally: %s",
( loaded ? "ERR " : "" ), function, SvPV( ERRSV, na ) );
( void )POPs;
}
else if ( count != 1 ) {
/*
* This should NEVER happen. G_SCALAR ensures that we WILL have 1
* parameter
*/
sprintf( data,
"%sPerl error executing '%s': expected 1 return value; received %s",
( loaded ? "ERR " : "" ), function, count );
}
else {
sprintf( data, "%s%s", ( loaded ? "OK " : "" ), POPpx );
}
/* Check for changed arguments */
for ( i = 0; i < ( int )sizeof( args ) - 1; i++ ) {
if ( args[i] && strcmp( args[i], SvPVX( sv_args[i] ) ) ) {
args[i] = strdup( SvPV( sv_args[i], na ) );
}
}
PUTBACK;
FREETMPS;
LEAVE;
return ret_value;
}
PERL_STATIC_INLINE UV*
S__get_invlist_len_addr(pTHX_ SV* invlist)
{
/* Return the address of the UV that contains the current number
* of used elements in the inversion list */
PERL_ARGS_ASSERT__GET_INVLIST_LEN_ADDR;
return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
}
char *
Perl_sv_pv(pTHX_ SV *sv)
{
PERL_ARGS_ASSERT_SV_PV;
if (SvPOK(sv))
return SvPVX(sv);
return sv_2pv(sv, NULL);
}
/* maxlen 0 = read one text line */
I32
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
{
filter_t funcp;
SV *datasv = NULL;
if (!PL_rsfp_filters)
return -1;
if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
/* Provide a default input filter to make life easy. */
/* Note that we append to the line. This is handy. */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: from rsfp\n", idx));
if (maxlen) {
/* Want a block */
int len ;
const int old_len = SvCUR(buf_sv);
/* ensure buf_sv is large enough */
SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
if (PerlIO_error(PL_rsfp))
return -1; /* error */
else
return 0 ; /* end of file */
}
SvCUR_set(buf_sv, old_len + len) ;
} else {
/* Want a line */
if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
if (PerlIO_error(PL_rsfp))
return -1; /* error */
else
return 0 ; /* end of file */
}
}
return SvCUR(buf_sv);
}
/* Skip this filter slot if filter has been deleted */
if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: skipped (filter deleted)\n",
idx));
return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
}
/* Get function pointer hidden within datasv */
funcp = DPTR2FPTR(filter_t, IoANY(datasv));
DEBUG_P(PerlIO_printf(Perl_debug_log,
"filter_read %d: via function %p (%s)\n",
idx, datasv, SvPV_nolen_const(datasv)));
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
/* Return: <0:error, =0:eof, >0:not eof */
return (*funcp)(aTHX_ idx, buf_sv, maxlen);
}
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);
}
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);
}
static SV *sv_soundex_utf8 (SV* source)
{
U8 *source_p;
U8 *source_end;
{
STRLEN source_len;
source_p = (U8 *) SvPV(source, source_len);
source_end = &source_p[source_len];
}
while (source_p < source_end)
{
STRLEN offset;
UV c = utf8n_to_uvchr(source_p, source_end-source_p, &offset, 0);
char codepart_last = (c <= 0xFF) ? sv_soundex_table[c] : '\0';
source_p = (offset >= 1) ? &source_p[offset] : source_end;
if (codepart_last != '\0')
{
SV *code = newSV(SOUNDEX_ACCURACY);
char *code_p = SvPVX(code);
char *code_end = &code_p[SOUNDEX_ACCURACY];
SvCUR_set(code, SOUNDEX_ACCURACY);
SvPOK_only(code);
*code_p++ = toupper(c);
while (source_p != source_end && code_p != code_end)
{
char codepart;
c = utf8n_to_uvchr(source_p, source_end-source_p, &offset, 0);
codepart = (c <= 0xFF) ? sv_soundex_table[c] : '\0';
source_p = (offset >= 1) ? &source_p[offset] : source_end;
if (codepart != '\0')
if (codepart != codepart_last && (codepart_last = codepart) != '0')
*code_p++ = codepart;
}
while (code_p != code_end)
*code_p++ = '0';
*code_end = '\0';
return code;
}
source_p++;
}
return SvREFCNT_inc(perl_get_sv("Text::Soundex::nocode", FALSE));
}
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;
}
char * get_command_line(void) {
/* debug
* printf("%s\n", INIT_TERM_READLINE) ;
*/
SV *cmd_line ;
char *command_line ;
cmd_line = my_eval_pv(DO_READLINE) ;
command_line = SvPVX(cmd_line) ;
/* command_line = SvPV(cmd_line, n_a) ; */
return command_line ;
}
static
int
nkf_putchar_grow(unsigned int c)
{
/* extends string length */
o_len += incsize;
SvGROW(result, o_len);
/* to avoid linear growing, increase extension size */
incsize *= 2;
output = SvPVX(result);
/* SvPV(result,o_len) breaks o_len */
return output[output_ctr++] = c;
}
void Embperl::dosub(const char * subname, const std::vector<std::string> * args, int mode)
{//as seen in perlembed docs
#if EQDEBUG >= 5
if(InUse()) {
LogFile->write(EQCLog::Debug, "Warning: Perl dosub called for %s when perl is allready in use.\n", subname);
}
#endif
in_use = true;
bool err = false;
try {
SV **sp = PL_stack_sp;
/* initialize stack pointer */
} catch(const char *err)
{//this should never happen, so if it does, it is something really serious (like a bad perl install), so we'll shutdown.
EQC::Common::Log(EQCLog::Error,CP_ZONESERVER, "Fatal error initializing perl: %s", err);
}
dSP;
ENTER; /* everything created after here */
SAVETMPS; /* ...is a temporary variable. */
PUSHMARK(SP); /* remember the stack pointer */
if(args && args->size())
{
for(std::vector<std::string>::const_iterator i = args->begin(); i != args->end(); ++i)
{/* push the arguments onto the perl stack */
XPUSHs(sv_2mortal(newSVpv(i->c_str(), i->length())));
}
}
PUTBACK; /* make local stack pointer global */
int result = call_pv(subname, mode); /*eval our code*/
SPAGAIN; /* refresh stack pointer */
//if(SvTRUE(ERRSV))
//{
// err = true;
//}
FREETMPS; /* free temp values */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
in_use = false;
if(err)
{
errmsg = "Perl runtime error: ";
errmsg += SvPVX(ERRSV);
throw errmsg.c_str();
}
}
int Embperl::dosub(const char * subname, const std::vector<std::string> * args, int mode)
{
dSP;
int ret_value = 0;
int count;
std::string error;
ENTER;
SAVETMPS;
PUSHMARK(SP);
if(args && args->size())
{
for(std::vector<std::string>::const_iterator i = args->begin(); i != args->end(); ++i)
{
XPUSHs(sv_2mortal(newSVpv(i->c_str(), i->length())));
}
}
PUTBACK;
count = call_pv(subname, mode);
SPAGAIN;
if(SvTRUE(ERRSV))
{
error = SvPV_nolen(ERRSV);
POPs;
}
else
{
if(count == 1) {
SV *ret = POPs;
if(SvTYPE(ret) == SVt_IV) {
IV v = SvIV(ret);
ret_value = v;
}
PUTBACK;
}
}
FREETMPS;
LEAVE;
if(error.length() > 0)
{
std::string errmsg = "Perl runtime error: ";
errmsg += SvPVX(ERRSV);
throw errmsg.c_str();
}
return ret_value;
}
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;
}
int
Tcl_GetLongFromObj (Tcl_Interp *interp, Tcl_Obj *obj, long *longPtr)
{
dTHX;
SV *sv = ForceScalar(aTHX_ obj);
if (SvIOK(sv) || looks_like_number(sv))
*longPtr = SvIV(sv);
else
{
*longPtr = 0;
return EXPIRE((interp, "'%s' isn't numeric", SvPVX(sv)));
}
return TCL_OK;
}
int
Tcl_GetDoubleFromObj (Tcl_Interp *interp, Tcl_Obj *obj, double *doublePtr)
{
dTHX;
SV *sv = ForceScalar(aTHX_ obj);
if (SvNOK(sv) || looks_like_number(sv))
*doublePtr = SvNV(sv);
else
{
*doublePtr = 0;
return EXPIRE((interp, "'%s' isn't numeric", SvPVX(sv)));
}
return TCL_OK;
}
static SV *sv_soundex (SV *source)
{
char *source_p;
char *source_end;
{
STRLEN source_len;
source_p = SvPV(source, source_len);
source_end = &source_p[source_len];
}
while (source_p != source_end)
{
char codepart_last = sv_soundex_table[(unsigned char) *source_p];
if (codepart_last != '\0')
{
SV *code = newSV(SOUNDEX_ACCURACY);
char *code_p = SvPVX(code);
char *code_end = &code_p[SOUNDEX_ACCURACY];
SvCUR_set(code, SOUNDEX_ACCURACY);
SvPOK_only(code);
*code_p++ = toupper(*source_p++);
while (source_p != source_end && code_p != code_end)
{
char c = *source_p++;
char codepart = sv_soundex_table[(unsigned char) c];
if (codepart != '\0')
if (codepart != codepart_last && (codepart_last = codepart) != '0')
*code_p++ = codepart;
}
while (code_p != code_end)
*code_p++ = '0';
*code_end = '\0';
return code;
}
source_p++;
}
return SvREFCNT_inc(perl_get_sv("Text::Soundex::nocode", FALSE));
}
static int modperl_package_is_dynamic(pTHX_ const char *package,
I32 *dl_index)
{
I32 i;
AV *modules = get_av(dl_modules, FALSE);
for (i=0; i<av_len(modules); i++) {
SV *module = *av_fetch(modules, i, 0);
if (strEQ(package, SvPVX(module))) {
*dl_index = i;
return TRUE;
}
}
return FALSE;
}
static int
tn_buffer_init(struct tn_buffer *buf, size_t size)
{
assert(buf);
buf->sv = newSV(size);
if(!buf->sv) {
return 0;
}
SvPOK_only(buf->sv);
buf->start = SvPVX(buf->sv);
buf->cursor = buf->start + size;
*buf->cursor = '\0';
buf->size = size;
return 1;
}
void
Perl_set_version(pTHX_ const char *name, STRLEN nlen, const char *strval, STRLEN plen, NV nvval)
{
SV* ver = GvSV(gv_add_by_type(gv_fetchpvn(name, nlen, GV_ADD, SVt_PVNV),
SVt_PVNV));
PERL_ARGS_ASSERT_SET_VERSION;
SvREADONLY_off(ver);
SvUPGRADE(ver, SVt_PVNV);
SvPVX(ver) = SvGROW(ver, plen+1);
Move(strval, SvPVX(ver), plen, char);
SvCUR_set(ver, plen);
SvNVX(ver) = nvval;
/* not the PROTECT bit */
SvFLAGS(ver) |= (SVf_NOK|SVp_NOK|SVf_POK|SVp_POK|SVf_READONLY);
}
