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;
}
static void aurora_init(server_rec *s, pool *p) {
STRLEN len = 0;
SV *version;
char *serverstring;
version = perl_get_sv("Aurora::VERSION", TRUE | GV_ADDMULTI);
serverstring = ap_psprintf(p, "Aurora/%s", SvPV(version, len));
ap_add_version_component(serverstring);
}
char match(char *string, char *pattern)
{
char *command;
command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 37);
sprintf(command, "$string = '%s'; $return = $string =~ %s",
string, pattern);
perl_eval_pv(command, TRUE);
free(command);
return SvIV(perl_get_sv("return", FALSE));
}
/*
**
** sets a Perl scalar variable
**
*/
void Perl5_SetScalar(pTHX_ char *pname, char *vname, char *vvalue)
{
dTHR;
ENTER;
save_hptr(&PL_curstash);
PL_curstash = gv_stashpv(pname, TRUE);
sv_setpv(perl_get_sv(vname, TRUE), vvalue);
LEAVE;
return;
}
/* from mod_perl 1.x */
apr_pool_t * perl_get_startup_pool (void)
{
SV *sv ;
dTHX ;
sv = perl_get_sv("Apache::__POOL", FALSE);
if(sv) {
IV tmp = SvIV((SV*)SvRV(sv));
return (pool *)tmp;
}
return NULL;
}
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));
}
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));
}
void t ()
{
MAGIC *m;
/* Create a variable*/
char *var = "main::foo";
SV *sv = perl_get_sv(var,TRUE);
/* Upgrade the sv to a magical variable*/
sv_magic(sv, NULL, '~', var, strlen(var));
/* sv_magic adds a MAGIC structure (of type '~') to the SV.
Get it and set the virtual table pointer */
m = mg_find(sv, '~');
m->mg_virtual = &foo_accessors;
SvMAGICAL_on(sv);
sv_dump(sv);
}
/* keep this simple for now, don't count % tokens, etc */
char *
setErrMsg ( char ** gErrMsg, int count, ... )
{
int i;
int argLength = 1, length;
char * strings[5];
va_list ap;
va_start ( ap, count );
for ( i = 0; i < count; i++ ) {
strings[i] = va_arg ( ap, char* );
argLength += strlen ( strings[i] );
}
va_end ( ap );
if ( *gErrMsg )
free ( *gErrMsg );
*gErrMsg = (char *)safemalloc ( argLength * sizeof (char) );
switch ( count ) {
case 1:
strcpy ( *gErrMsg, strings[0] );
break;
case 2:
sprintf ( *gErrMsg, strings[0], strings[1] );
break;
case 3:
sprintf ( *gErrMsg, strings[0], strings[1], strings[2] );
break;
case 4:
sprintf ( *gErrMsg, strings[0], strings[1], strings[2], strings[3] );
break;
case 5:
sprintf ( *gErrMsg, strings[0], strings[1], strings[2], strings[3], strings[4] );
break;
}
// sv_setpv ( perl_get_sv("!",0), gErrMsg );
sv_setpv ( perl_get_sv("@",0), *gErrMsg );
return ( *gErrMsg );
}
static int
hbm_perl_exec (HBArgs *d, char *code)
{
dSP;
SV *args;
SV *retval;
args = perl_get_sv("args", TRUE);
if (!args)
printf("PANIC: No args\n");
sv_setref_pv(args, "hbargsPtr", (void*) d);
retval = perl_eval_pv(code, TRUE);
return SvIV(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;
}
void t1 ()
{
sv_dump(perl_get_sv("main::foo",FALSE));
}
