diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/eval.c | 23 | ||||
| -rw-r--r-- | src/if_perl.xs | 314 | ||||
| -rw-r--r-- | src/proto/if_perl.pro | 1 | ||||
| -rw-r--r-- | src/testdir/Make_all.mak | 3 | ||||
| -rw-r--r-- | src/testdir/test_perl.vim | 74 | ||||
| -rw-r--r-- | src/version.c | 2 |
6 files changed, 399 insertions, 18 deletions
diff --git a/src/eval.c b/src/eval.c index aec1ea987..c39d2cdfa 100644 --- a/src/eval.c +++ b/src/eval.c @@ -657,6 +657,9 @@ static void f_nextnonblank __ARGS((typval_T *argvars, typval_T *rettv)); static void f_nr2char __ARGS((typval_T *argvars, typval_T *rettv)); static void f_or __ARGS((typval_T *argvars, typval_T *rettv)); static void f_pathshorten __ARGS((typval_T *argvars, typval_T *rettv)); +#ifdef FEAT_PERL +static void f_perleval __ARGS((typval_T *argvars, typval_T *rettv)); +#endif #ifdef FEAT_FLOAT static void f_pow __ARGS((typval_T *argvars, typval_T *rettv)); #endif @@ -8270,6 +8273,9 @@ static struct fst {"nr2char", 1, 2, f_nr2char}, {"or", 2, 2, f_or}, {"pathshorten", 1, 1, f_pathshorten}, +#ifdef FEAT_PERL + {"perleval", 1, 1, f_perleval}, +#endif #ifdef FEAT_FLOAT {"pow", 2, 2, f_pow}, #endif @@ -15480,6 +15486,23 @@ f_pathshorten(argvars, rettv) } } +#ifdef FEAT_PERL +/* + * "perleval()" function + */ + static void +f_perleval(argvars, rettv) + typval_T *argvars; + typval_T *rettv; +{ + char_u *str; + char_u buf[NUMBUFLEN]; + + str = get_tv_string_buf(&argvars[0], buf); + do_perleval(str, rettv); +} +#endif + #ifdef FEAT_FLOAT /* * "pow()" function diff --git a/src/if_perl.xs b/src/if_perl.xs index 098b62e09..840de7d97 100644 --- a/src/if_perl.xs +++ b/src/if_perl.xs @@ -117,7 +117,9 @@ #if (PERL_REVISION == 5) && (PERL_VERSION >= 14) && defined(_MSC_VER) /* Using PL_errgv to get the error message after perl_eval_sv() causes a crash * with MSVC and Perl version 5.14. */ -# define AVOID_PL_ERRGV +# define CHECK_EVAL_ERR(len) SvPV(perl_get_sv("@", GV_ADD), (len)); +#else +# define CHECK_EVAL_ERR(len) SvPV(GvSV(PL_errgv), (len)); #endif /* Compatibility hacks over */ @@ -279,6 +281,13 @@ typedef int perl_key; # define PL_thr_key *dll_PL_thr_key # endif # endif +# define Perl_hv_iternext_flags dll_Perl_hv_iternext_flags +# define Perl_hv_iterinit dll_Perl_hv_iterinit +# define Perl_hv_iterkey dll_Perl_hv_iterkey +# define Perl_hv_iterval dll_Perl_hv_iterval +# define Perl_av_fetch dll_Perl_av_fetch +# define Perl_av_len dll_Perl_av_len +# define Perl_sv_2nv_flags dll_Perl_sv_2nv_flags /* * Declare HANDLE for perl.dll and function pointers. @@ -422,6 +431,13 @@ static SV* (*Perl_Isv_yes_ptr)(register PerlInterpreter*); static perl_key* (*Perl_Gthr_key_ptr)_((pTHX)); #endif static void (*boot_DynaLoader)_((pTHX_ CV*)); +static HE * (*Perl_hv_iternext_flags)(pTHX_ HV *, I32); +static I32 (*Perl_hv_iterinit)(pTHX_ HV *); +static char * (*Perl_hv_iterkey)(pTHX_ HE *, I32 *); +static SV * (*Perl_hv_iterval)(pTHX_ HV *, HE *); +static SV** (*Perl_av_fetch)(pTHX_ AV *, SSize_t, I32); +static SSize_t (*Perl_av_len)(pTHX_ AV *); +static NV (*Perl_sv_2nv_flags)(pTHX_ SV *const, const I32); /* * Table of name to function pointer of perl. @@ -554,6 +570,13 @@ static struct { {"Perl_Gthr_key_ptr", (PERL_PROC*)&Perl_Gthr_key_ptr}, #endif {"boot_DynaLoader", (PERL_PROC*)&boot_DynaLoader}, + {"Perl_hv_iternext_flags", (PERL_PROC*)&Perl_hv_iternext_flags}, + {"Perl_hv_iterinit", (PERL_PROC*)&Perl_hv_iterinit}, + {"Perl_hv_iterkey", (PERL_PROC*)&Perl_hv_iterkey}, + {"Perl_hv_iterval", (PERL_PROC*)&Perl_hv_iterval}, + {"Perl_av_fetch", (PERL_PROC*)&Perl_av_fetch}, + {"Perl_av_len", (PERL_PROC*)&Perl_av_len}, + {"Perl_sv_2nv_flags", (PERL_PROC*)&Perl_sv_2nv_flags}, {"", NULL}, }; @@ -656,7 +679,7 @@ perl_end() perl_free(perl_interp); perl_interp = NULL; #if (PERL_REVISION == 5) && (PERL_VERSION >= 10) - Perl_sys_term(); + Perl_sys_term(); #endif } #ifdef DYNAMIC_PERL @@ -910,11 +933,7 @@ ex_perl(eap) SvREFCNT_dec(sv); -#ifdef AVOID_PL_ERRGV - err = SvPV(perl_get_sv("@", GV_ADD), length); -#else - err = SvPV(GvSV(PL_errgv), length); -#endif + err = CHECK_EVAL_ERR(length); FREETMPS; LEAVE; @@ -949,6 +968,275 @@ replace_line(line, end) return OK; } +static struct ref_map_S { + void *vim_ref; + SV *perl_ref; + struct ref_map_S *next; +} *ref_map = NULL; + + static void +ref_map_free(void) +{ + struct ref_map_S *tofree; + struct ref_map_S *refs = ref_map; + + while (refs) { + tofree = refs; + refs = refs->next; + vim_free(tofree); + } + ref_map = NULL; +} + + static struct ref_map_S * +ref_map_find_SV(sv) + SV *const sv; +{ + struct ref_map_S *refs = ref_map; + int count = 350; + + while (refs) { + if (refs->perl_ref == sv) + break; + refs = refs->next; + count--; + } + + if (!refs && count > 0) { + refs = (struct ref_map_S *)alloc(sizeof(struct ref_map_S)); + if (!refs) + return NULL; + refs->perl_ref = sv; + refs->vim_ref = NULL; + refs->next = ref_map; + ref_map = refs; + } + + return refs; +} + + static int +perl_to_vim(sv, rettv) + SV *sv; + typval_T *rettv; +{ + if (SvROK(sv)) + sv = SvRV(sv); + + switch (SvTYPE(sv)) { + case SVt_NULL: + break; + case SVt_NV: /* float */ +#ifdef FEAT_FLOAT + rettv->v_type = VAR_FLOAT; + rettv->vval.v_float = SvNV(sv); + break; +#endif + case SVt_IV: /* integer */ + if (!SvROK(sv)) { /* references should be string */ + rettv->vval.v_number = SvIV(sv); + break; + } + case SVt_PV: /* string */ + { + size_t len = 0; + char * str_from = SvPV(sv, len); + char_u *str_to = (char_u*)alloc(sizeof(char_u) * (len + 1)); + + if (str_to) { + str_to[len] = '\0'; + + while (len--) { + if (str_from[len] == '\0') + str_to[len] = '\n'; + else + str_to[len] = str_from[len]; + } + } + + rettv->v_type = VAR_STRING; + rettv->vval.v_string = str_to; + break; + } + case SVt_PVAV: /* list */ + { + SSize_t size; + listitem_T * item; + SV ** item2; + list_T * list; + struct ref_map_S * refs; + + if ((refs = ref_map_find_SV(sv)) == NULL) + return FAIL; + + if (refs->vim_ref) + list = (list_T *) refs->vim_ref; + else + { + if ((list = list_alloc()) == NULL) + return FAIL; + refs->vim_ref = list; + + for (size = av_len((AV*)sv); size >= 0; size--) + { + if ((item = listitem_alloc()) == NULL) + break; + + item->li_tv.v_type = VAR_NUMBER; + item->li_tv.v_lock = 0; + item->li_tv.vval.v_number = 0; + list_insert(list, item, list->lv_first); + + item2 = av_fetch((AV *)sv, size, 0); + + if (item2 == NULL || *item2 == NULL || + perl_to_vim(*item2, &item->li_tv) == FAIL) + break; + } + } + + list->lv_refcount++; + rettv->v_type = VAR_LIST; + rettv->vval.v_list = list; + break; + } + case SVt_PVHV: /* dictionary */ + { + HE * entry; + size_t key_len; + char * key; + dictitem_T * item; + SV * item2; + dict_T * dict; + struct ref_map_S * refs; + + if ((refs = ref_map_find_SV(sv)) == NULL) + return FAIL; + + if (refs->vim_ref) + dict = (dict_T *) refs->vim_ref; + else + { + + if ((dict = dict_alloc()) == NULL) + return FAIL; + refs->vim_ref = dict; + + hv_iterinit((HV *)sv); + + for (entry = hv_iternext((HV *)sv); entry; entry = hv_iternext((HV *)sv)) + { + key_len = 0; + key = hv_iterkey(entry, (I32 *)&key_len); + + if (!key || !key_len || strlen(key) < key_len) { + EMSG2("Malformed key Dictionary '%s'", key && *key ? key : "(empty)"); + break; + } + + if ((item = dictitem_alloc((char_u *)key)) == NULL) + break; + + item->di_tv.v_type = VAR_NUMBER; + item->di_tv.v_lock = 0; + item->di_tv.vval.v_number = 0; + + if (dict_add(dict, item) == FAIL) { + dictitem_free(item); + break; + } + item2 = hv_iterval((HV *)sv, entry); + if (item2 == NULL || perl_to_vim(item2, &item->di_tv) == FAIL) + break; + } + } + + dict->dv_refcount++; + rettv->v_type = VAR_DICT; + rettv->vval.v_dict = dict; + break; + } + default: /* not convertible */ + { + char *val = SvPV_nolen(sv); + rettv->v_type = VAR_STRING; + rettv->vval.v_string = val ? vim_strsave((char_u *)val) : NULL; + break; + } + } + return OK; +} + +/* + * "perleval()" + */ + void +do_perleval(str, rettv) + char_u *str; + typval_T *rettv; +{ + char *err = NULL; + STRLEN err_len = 0; + SV *sv = NULL; +#ifdef HAVE_SANDBOX + SV *safe; +#endif + + if (perl_interp == NULL) + { +#ifdef DYNAMIC_PERL + if (!perl_enabled(TRUE)) + { + EMSG(_(e_noperl)); + return; + } +#endif + perl_init(); + } + + { + dSP; + ENTER; + SAVETMPS; + +#ifdef HAVE_SANDBOX + if (sandbox) + { + safe = get_sv("VIM::safe", FALSE); +# ifndef MAKE_TEST /* avoid a warning for unreachable code */ + if (safe == NULL || !SvTRUE(safe)) + EMSG(_("E299: Perl evaluation forbidden in sandbox without the Safe module")); + else +# endif + { + sv = newSVpv((char *)str, 0); + PUSHMARK(SP); + XPUSHs(safe); + XPUSHs(sv); + PUTBACK; + call_method("reval", G_SCALAR); + SPAGAIN; + SvREFCNT_dec(sv); + sv = POPs; + } + } + else +#endif /* HAVE_SANDBOX */ + sv = eval_pv((char *)str, 0); + + if (sv) { + perl_to_vim(sv, rettv); + ref_map_free(); + err = CHECK_EVAL_ERR(err_len); + } + PUTBACK; + FREETMPS; + LEAVE; + } + if (err_len) + msg_split((char_u *)err, highlight_attr[HLF_E]); +} + /* * ":perldo". */ @@ -984,11 +1272,7 @@ ex_perldo(eap) sv_catpvn(sv, "}", 1); perl_eval_sv(sv, G_DISCARD | G_NOARGS); SvREFCNT_dec(sv); -#ifdef AVOID_PL_ERRGV - str = SvPV(perl_get_sv("@", GV_ADD), length); -#else - str = SvPV(GvSV(PL_errgv), length); -#endif + str = CHECK_EVAL_ERR(length); if (length) goto err; @@ -1002,11 +1286,7 @@ ex_perldo(eap) sv_setpv(GvSV(PL_defgv), (char *)ml_get(i)); PUSHMARK(sp); perl_call_pv("VIM::perldo", G_SCALAR | G_EVAL); -#ifdef AVOID_PL_ERRGV - str = SvPV(perl_get_sv("@", GV_ADD), length); -#else - str = SvPV(GvSV(PL_errgv), length); -#endif + str = CHECK_EVAL_ERR(length); if (length) break; SPAGAIN; diff --git a/src/proto/if_perl.pro b/src/proto/if_perl.pro index fe0301b0b..327281475 100644 --- a/src/proto/if_perl.pro +++ b/src/proto/if_perl.pro @@ -6,3 +6,4 @@ void perl_win_free __ARGS((win_T *wp)); void perl_buf_free __ARGS((buf_T *bp)); void ex_perl __ARGS((exarg_T *eap)); void ex_perldo __ARGS((exarg_T *eap)); +void do_perleval __ARGS((char_u *str, typval_T *rettv)); diff --git a/src/testdir/Make_all.mak b/src/testdir/Make_all.mak index 69fd936cd..87fcbf9db 100644 --- a/src/testdir/Make_all.mak +++ b/src/testdir/Make_all.mak @@ -178,7 +178,8 @@ NEW_TESTS = test_arglist.res \ test_increment.res \ test_quickfix.res \ test_viml.res \ - test_alot.res + test_alot.res \ + test_perl.res # Explicit dependencies. diff --git a/src/testdir/test_perl.vim b/src/testdir/test_perl.vim new file mode 100644 index 000000000..3741fc7d5 --- /dev/null +++ b/src/testdir/test_perl.vim @@ -0,0 +1,74 @@ +" Tests for Perl interface + +if !has('perl') + finish +end + +set nocp viminfo+=nviminfo + +fu <SID>catch_peval(expr) + try + call perleval(a:expr) + catch + return v:exception + endtry + call assert_true(0, 'no exception for `perleval("'.a:expr.'")`') + return '' +endf + +function Test_perleval() + call assert_false(perleval('undef')) + + " scalar + call assert_equal(0, perleval('0')) + call assert_equal(2, perleval('2')) + call assert_equal(-2, perleval('-2')) + if has('float') + call assert_equal(2.5, perleval('2.5')) + else + call assert_equal(2, perleval('2.5')) + end + + sandbox call assert_equal(2, perleval('2')) + + call assert_equal('abc', perleval('"abc"')) + call assert_equal("abc\ndef", perleval('"abc\0def"')) + + " ref + call assert_equal([], perleval('[]')) + call assert_equal(['word', 42, [42],{}], perleval('["word", 42, [42], {}]')) + + call assert_equal({}, perleval('{}')) + call assert_equal({'foo': 'bar'}, perleval('{foo => "bar"}')) + + perl our %h; our @a; + let a = perleval('[\(%h, %h, @a, @a)]') + call assert_true((a[0] is a[1])) + call assert_true((a[2] is a[3])) + perl undef %h; undef @a; + + call assert_true(<SID>catch_peval('{"" , 0}') =~ 'Malformed key Dictionary') + call assert_true(<SID>catch_peval('{"\0" , 0}') =~ 'Malformed key Dictionary') + call assert_true(<SID>catch_peval('{"foo\0bar" , 0}') =~ 'Malformed key Dictionary') + + call assert_equal('*VIM', perleval('"*VIM"')) + call assert_true(perleval('\\0') =~ 'SCALAR(0x\x\+)') +endf + +function Test_perldo() + sp __TEST__ + exe 'read ' g:testname + perldo s/perl/vieux_chameau/g + 1 + call assert_false(search('\Cperl')) + bw! +endf + +function Test_VIM_package() + perl VIM::DoCommand('let l:var = "foo"') + call assert_equal(l:var, 'foo') + + set noet + perl VIM::SetOption('et') + call assert_true(&et) +endf diff --git a/src/version.c b/src/version.c index a1eb08399..239d38535 100644 --- a/src/version.c +++ b/src/version.c @@ -742,6 +742,8 @@ static char *(features[]) = static int included_patches[] = { /* Add new patch number below this line */ /**/ + 1125, +/**/ 1124, /**/ 1123, |