patch 7.4.1125v7.4.1125

Problem:    There is no perleval().
Solution:   Add perleval(). (Damien)

8 files changed, 413 insertions, 19 deletions

diff --git a/runtime/doc/eval.txt b/runtime/doc/eval.txt
index fb6a851447..7b6ce981c4 100644
--- a/runtime/doc/eval.txt
+++ b/runtime/doc/eval.txt
@@ -1,4 +1,4 @@
-*eval.txt*	For Vim version 7.4.  Last change: 2016 Jan 16
+*eval.txt*	For Vim version 7.4.  Last change: 2016 Jan 17
 
 
 		  VIM REFERENCE MANUAL	  by Bram Moolenaar
@@ -1950,6 +1950,7 @@ nextnonblank( {lnum})		Number	line nr of non-blank line >= {lnum}
 nr2char( {expr}[, {utf8}])	String	single char with ASCII/UTF8 value {expr}
 or( {expr}, {expr})		Number  bitwise OR
 pathshorten( {expr})		String	shorten directory names in a path
+perleval( {expr})		any	evaluate |Perl| expression
 pow( {x}, {y})			Float	{x} to the power of {y}
 prevnonblank( {lnum})		Number	line nr of non-blank line <= {lnum}
 printf( {fmt}, {expr1}...)	String	format text
@@ -4778,6 +4779,17 @@ pathshorten({expr})					*pathshorten()*
 <			~/.v/a/myfile.vim ~
 		It doesn't matter if the path exists or not.
 
+perleval({expr})					*perleval()*
+		Evaluate Perl expression {expr} in scalar context and return
+		its result converted to Vim data structures. If value can't be
+		converted, it returned as string Perl representation.
+		Note: If you want a array or hash, {expr} must returns an
+		reference of it.
+		Example: >
+			:echo perleval('[1 .. 4]')
+<			[1, 2, 3, 4]
+		{only available when compiled with the |+perl| feature}
+
 pow({x}, {y})						*pow()*
 		Return the power of {x} to the exponent {y} as a |Float|.
 		{x} and {y} must evaluate to a |Float| or a |Number|.
diff --git a/runtime/doc/usr_41.txt b/runtime/doc/usr_41.txt
index 2194dc14bc..7ef10e3b42 100644
--- a/runtime/doc/usr_41.txt
+++ b/runtime/doc/usr_41.txt
@@ -921,6 +921,7 @@ Various:					*various-functions*
 
 	luaeval()		evaluate Lua expression
 	mzeval()		evaluate |MzScheme| expression
+	perleval()		evaluate Perl expression (|+perl|)
 	py3eval()		evaluate Python expression (|+python3|)
 	pyeval()		evaluate Python expression (|+python|)
 	wordcount()             get byte/word/char count of buffer
diff --git a/src/eval.c b/src/eval.c
index aec1ea9873..c39d2cdfa3 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 098b62e099..840de7d973 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 fe0301b0b0..3272814759 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 69fd936cd1..87fcbf9dbc 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 0000000000..3741fc7d5d
--- /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 a1eb08399c..239d38535d 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,