diff options
author | Bram Moolenaar <Bram@vim.org> | 2016-01-17 21:15:58 +0100 |
---|---|---|
committer | Bram Moolenaar <Bram@vim.org> | 2016-01-17 21:15:58 +0100 |
commit | e9b892ebcd8596bf813793a1eed5a460a9495a28 (patch) | |
tree | 209bed14093b4006bc946bbffdedc15d048db039 /src/if_perl.xs | |
parent | 25b2b94ea73eff2aeef624d2ba7f59a1a265a0c1 (diff) | |
download | vim-git-e9b892ebcd8596bf813793a1eed5a460a9495a28.tar.gz |
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.xs | 314 |
1 files changed, 297 insertions, 17 deletions
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; |