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)); }