#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 */
# 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.
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.
{"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},
};
perl_free(perl_interp);
perl_interp = NULL;
#if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
- Perl_sys_term();
+ Perl_sys_term();
#endif
}
#ifdef DYNAMIC_PERL
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;
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".
*/
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;
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;
--- /dev/null
+" 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
projects / vim / commitdiff