summaryrefslogtreecommitdiffstats
path: root/src/if_perl.xs
diff options
context:
space:
mode:
authorBram Moolenaar <Bram@vim.org>2016-01-17 21:15:58 +0100
committerBram Moolenaar <Bram@vim.org>2016-01-17 21:15:58 +0100
commite9b892ebcd8596bf813793a1eed5a460a9495a28 (patch)
tree209bed14093b4006bc946bbffdedc15d048db039 /src/if_perl.xs
parent25b2b94ea73eff2aeef624d2ba7f59a1a265a0c1 (diff)
patch 7.4.1125v7.4.1125
Problem: There is no perleval(). Solution: Add perleval(). (Damien)
Diffstat (limited to 'src/if_perl.xs')
-rw-r--r--src/if_perl.xs314
1 files changed, 297 insertions, 17 deletions
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;