Mercurial > vim

comparison src/if_perl.xs @ 7651:c7575b07de98 v7.4.1125

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
commit https://github.com/vim/vim/commit/e9b892ebcd8596bf813793a1eed5a460a9495a28 Author: Bram Moolenaar <Bram@vim.org> Date: Sun Jan 17 21:15:58 2016 +0100 patch 7.4.1125 Problem: There is no perleval(). Solution: Add perleval(). (Damien)
author Christian Brabandt <cb@256bit.org>
date Sun, 17 Jan 2016 21:30:04 +0100
parents 53163e4d9e4f
children 1a5d34492798
comparison
equal deleted inserted replaced
7650:fbc4cabe6704 7651:c7575b07de98
115 #endif 115 #endif
116 116
117 #if (PERL_REVISION == 5) && (PERL_VERSION >= 14) && defined(_MSC_VER) 117 #if (PERL_REVISION == 5) && (PERL_VERSION >= 14) && defined(_MSC_VER)
118 /* Using PL_errgv to get the error message after perl_eval_sv() causes a crash 118 /* Using PL_errgv to get the error message after perl_eval_sv() causes a crash
119 * with MSVC and Perl version 5.14. */ 119 * with MSVC and Perl version 5.14. */
120 # define AVOID_PL_ERRGV 120 # define CHECK_EVAL_ERR(len) SvPV(perl_get_sv("@", GV_ADD), (len));
121 #else
122 # define CHECK_EVAL_ERR(len) SvPV(GvSV(PL_errgv), (len));
121 #endif 123 #endif
122 124
123 /* Compatibility hacks over */ 125 /* Compatibility hacks over */
124 126
125 static PerlInterpreter *perl_interp = NULL; 127 static PerlInterpreter *perl_interp = NULL;
277 # if (PERL_REVISION == 5) && (PERL_VERSION >= 14) 279 # if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
278 # ifdef USE_ITHREADS 280 # ifdef USE_ITHREADS
279 # define PL_thr_key *dll_PL_thr_key 281 # define PL_thr_key *dll_PL_thr_key
280 # endif 282 # endif
281 # endif 283 # endif
284 # define Perl_hv_iternext_flags dll_Perl_hv_iternext_flags
285 # define Perl_hv_iterinit dll_Perl_hv_iterinit
286 # define Perl_hv_iterkey dll_Perl_hv_iterkey
287 # define Perl_hv_iterval dll_Perl_hv_iterval
288 # define Perl_av_fetch dll_Perl_av_fetch
289 # define Perl_av_len dll_Perl_av_len
290 # define Perl_sv_2nv_flags dll_Perl_sv_2nv_flags
282 291
283 /* 292 /*
284 * Declare HANDLE for perl.dll and function pointers. 293 * Declare HANDLE for perl.dll and function pointers.
285 */ 294 */
286 static HANDLE hPerlLib = NULL; 295 static HANDLE hPerlLib = NULL;
420 static GV** (*Perl_Ierrgv_ptr)(register PerlInterpreter*); 429 static GV** (*Perl_Ierrgv_ptr)(register PerlInterpreter*);
421 static SV* (*Perl_Isv_yes_ptr)(register PerlInterpreter*); 430 static SV* (*Perl_Isv_yes_ptr)(register PerlInterpreter*);
422 static perl_key* (*Perl_Gthr_key_ptr)_((pTHX)); 431 static perl_key* (*Perl_Gthr_key_ptr)_((pTHX));
423 #endif 432 #endif
424 static void (*boot_DynaLoader)_((pTHX_ CV*)); 433 static void (*boot_DynaLoader)_((pTHX_ CV*));
434 static HE * (*Perl_hv_iternext_flags)(pTHX_ HV *, I32);
435 static I32 (*Perl_hv_iterinit)(pTHX_ HV *);
436 static char * (*Perl_hv_iterkey)(pTHX_ HE *, I32 *);
437 static SV * (*Perl_hv_iterval)(pTHX_ HV *, HE *);
438 static SV** (*Perl_av_fetch)(pTHX_ AV *, SSize_t, I32);
439 static SSize_t (*Perl_av_len)(pTHX_ AV *);
440 static NV (*Perl_sv_2nv_flags)(pTHX_ SV *const, const I32);
425 441
426 /* 442 /*
427 * Table of name to function pointer of perl. 443 * Table of name to function pointer of perl.
428 */ 444 */
429 static struct { 445 static struct {
552 {"Perl_Ierrgv_ptr", (PERL_PROC*)&Perl_Ierrgv_ptr}, 568 {"Perl_Ierrgv_ptr", (PERL_PROC*)&Perl_Ierrgv_ptr},
553 {"Perl_Isv_yes_ptr", (PERL_PROC*)&Perl_Isv_yes_ptr}, 569 {"Perl_Isv_yes_ptr", (PERL_PROC*)&Perl_Isv_yes_ptr},
554 {"Perl_Gthr_key_ptr", (PERL_PROC*)&Perl_Gthr_key_ptr}, 570 {"Perl_Gthr_key_ptr", (PERL_PROC*)&Perl_Gthr_key_ptr},
555 #endif 571 #endif
556 {"boot_DynaLoader", (PERL_PROC*)&boot_DynaLoader}, 572 {"boot_DynaLoader", (PERL_PROC*)&boot_DynaLoader},
573 {"Perl_hv_iternext_flags", (PERL_PROC*)&Perl_hv_iternext_flags},
574 {"Perl_hv_iterinit", (PERL_PROC*)&Perl_hv_iterinit},
575 {"Perl_hv_iterkey", (PERL_PROC*)&Perl_hv_iterkey},
576 {"Perl_hv_iterval", (PERL_PROC*)&Perl_hv_iterval},
577 {"Perl_av_fetch", (PERL_PROC*)&Perl_av_fetch},
578 {"Perl_av_len", (PERL_PROC*)&Perl_av_len},
579 {"Perl_sv_2nv_flags", (PERL_PROC*)&Perl_sv_2nv_flags},
557 {"", NULL}, 580 {"", NULL},
558 }; 581 };
559 582
560 /* Work around for perl-5.18. 583 /* Work around for perl-5.18.
561 * The definitions of S_SvREFCNT_inc and S_SvREFCNT_dec are needed, so include 584 * The definitions of S_SvREFCNT_inc and S_SvREFCNT_dec are needed, so include
654 perl_run(perl_interp); 677 perl_run(perl_interp);
655 perl_destruct(perl_interp); 678 perl_destruct(perl_interp);
656 perl_free(perl_interp); 679 perl_free(perl_interp);
657 perl_interp = NULL; 680 perl_interp = NULL;
658 #if (PERL_REVISION == 5) && (PERL_VERSION >= 10) 681 #if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
659 Perl_sys_term(); 682 Perl_sys_term();
660 #endif 683 #endif
661 } 684 }
662 #ifdef DYNAMIC_PERL 685 #ifdef DYNAMIC_PERL
663 if (hPerlLib) 686 if (hPerlLib)
664 { 687 {
908 #endif 931 #endif
909 perl_eval_sv(sv, G_DISCARD | G_NOARGS); 932 perl_eval_sv(sv, G_DISCARD | G_NOARGS);
910 933
911 SvREFCNT_dec(sv); 934 SvREFCNT_dec(sv);
912 935
913 #ifdef AVOID_PL_ERRGV 936 err = CHECK_EVAL_ERR(length);
914 err = SvPV(perl_get_sv("@", GV_ADD), length);
915 #else
916 err = SvPV(GvSV(PL_errgv), length);
917 #endif
918 937
919 FREETMPS; 938 FREETMPS;
920 LEAVE; 939 LEAVE;
921 940
922 if (!length) 941 if (!length)
945 deleted_lines_mark(*line, 1L); 964 deleted_lines_mark(*line, 1L);
946 --(*end); 965 --(*end);
947 --(*line); 966 --(*line);
948 } 967 }
949 return OK; 968 return OK;
969 }
970
971 static struct ref_map_S {
972 void *vim_ref;
973 SV *perl_ref;
974 struct ref_map_S *next;
975 } *ref_map = NULL;
976
977 static void
978 ref_map_free(void)
979 {
980 struct ref_map_S *tofree;
981 struct ref_map_S *refs = ref_map;
982
983 while (refs) {
984 tofree = refs;
985 refs = refs->next;
986 vim_free(tofree);
987 }
988 ref_map = NULL;
989 }
990
991 static struct ref_map_S *
992 ref_map_find_SV(sv)
993 SV *const sv;
994 {
995 struct ref_map_S *refs = ref_map;
996 int count = 350;
997
998 while (refs) {
999 if (refs->perl_ref == sv)
1000 break;
1001 refs = refs->next;
1002 count--;
1003 }
1004
1005 if (!refs && count > 0) {
1006 refs = (struct ref_map_S *)alloc(sizeof(struct ref_map_S));
1007 if (!refs)
1008 return NULL;
1009 refs->perl_ref = sv;
1010 refs->vim_ref = NULL;
1011 refs->next = ref_map;
1012 ref_map = refs;
1013 }
1014
1015 return refs;
1016 }
1017
1018 static int
1019 perl_to_vim(sv, rettv)
1020 SV *sv;
1021 typval_T *rettv;
1022 {
1023 if (SvROK(sv))
1024 sv = SvRV(sv);
1025
1026 switch (SvTYPE(sv)) {
1027 case SVt_NULL:
1028 break;
1029 case SVt_NV: /* float */
1030 #ifdef FEAT_FLOAT
1031 rettv->v_type = VAR_FLOAT;
1032 rettv->vval.v_float = SvNV(sv);
1033 break;
1034 #endif
1035 case SVt_IV: /* integer */
1036 if (!SvROK(sv)) { /* references should be string */
1037 rettv->vval.v_number = SvIV(sv);
1038 break;
1039 }
1040 case SVt_PV: /* string */
1041 {
1042 size_t len = 0;
1043 char * str_from = SvPV(sv, len);
1044 char_u *str_to = (char_u*)alloc(sizeof(char_u) * (len + 1));
1045
1046 if (str_to) {
1047 str_to[len] = '\0';
1048
1049 while (len--) {
1050 if (str_from[len] == '\0')
1051 str_to[len] = '\n';
1052 else
1053 str_to[len] = str_from[len];
1054 }
1055 }
1056
1057 rettv->v_type = VAR_STRING;
1058 rettv->vval.v_string = str_to;
1059 break;
1060 }
1061 case SVt_PVAV: /* list */
1062 {
1063 SSize_t size;
1064 listitem_T * item;
1065 SV ** item2;
1066 list_T * list;
1067 struct ref_map_S * refs;
1068
1069 if ((refs = ref_map_find_SV(sv)) == NULL)
1070 return FAIL;
1071
1072 if (refs->vim_ref)
1073 list = (list_T *) refs->vim_ref;
1074 else
1075 {
1076 if ((list = list_alloc()) == NULL)
1077 return FAIL;
1078 refs->vim_ref = list;
1079
1080 for (size = av_len((AV*)sv); size >= 0; size--)
1081 {
1082 if ((item = listitem_alloc()) == NULL)
1083 break;
1084
1085 item->li_tv.v_type = VAR_NUMBER;
1086 item->li_tv.v_lock = 0;
1087 item->li_tv.vval.v_number = 0;
1088 list_insert(list, item, list->lv_first);
1089
1090 item2 = av_fetch((AV *)sv, size, 0);
1091
1092 if (item2 == NULL || *item2 == NULL ||
1093 perl_to_vim(*item2, &item->li_tv) == FAIL)
1094 break;
1095 }
1096 }
1097
1098 list->lv_refcount++;
1099 rettv->v_type = VAR_LIST;
1100 rettv->vval.v_list = list;
1101 break;
1102 }
1103 case SVt_PVHV: /* dictionary */
1104 {
1105 HE * entry;
1106 size_t key_len;
1107 char * key;
1108 dictitem_T * item;
1109 SV * item2;
1110 dict_T * dict;
1111 struct ref_map_S * refs;
1112
1113 if ((refs = ref_map_find_SV(sv)) == NULL)
1114 return FAIL;
1115
1116 if (refs->vim_ref)
1117 dict = (dict_T *) refs->vim_ref;
1118 else
1119 {
1120
1121 if ((dict = dict_alloc()) == NULL)
1122 return FAIL;
1123 refs->vim_ref = dict;
1124
1125 hv_iterinit((HV *)sv);
1126
1127 for (entry = hv_iternext((HV *)sv); entry; entry = hv_iternext((HV *)sv))
1128 {
1129 key_len = 0;
1130 key = hv_iterkey(entry, (I32 *)&key_len);
1131
1132 if (!key || !key_len || strlen(key) < key_len) {
1133 EMSG2("Malformed key Dictionary '%s'", key && *key ? key : "(empty)");
1134 break;
1135 }
1136
1137 if ((item = dictitem_alloc((char_u *)key)) == NULL)
1138 break;
1139
1140 item->di_tv.v_type = VAR_NUMBER;
1141 item->di_tv.v_lock = 0;
1142 item->di_tv.vval.v_number = 0;
1143
1144 if (dict_add(dict, item) == FAIL) {
1145 dictitem_free(item);
1146 break;
1147 }
1148 item2 = hv_iterval((HV *)sv, entry);
1149 if (item2 == NULL || perl_to_vim(item2, &item->di_tv) == FAIL)
1150 break;
1151 }
1152 }
1153
1154 dict->dv_refcount++;
1155 rettv->v_type = VAR_DICT;
1156 rettv->vval.v_dict = dict;
1157 break;
1158 }
1159 default: /* not convertible */
1160 {
1161 char *val = SvPV_nolen(sv);
1162 rettv->v_type = VAR_STRING;
1163 rettv->vval.v_string = val ? vim_strsave((char_u *)val) : NULL;
1164 break;
1165 }
1166 }
1167 return OK;
1168 }
1169
1170 /*
1171 * "perleval()"
1172 */
1173 void
1174 do_perleval(str, rettv)
1175 char_u *str;
1176 typval_T *rettv;
1177 {
1178 char *err = NULL;
1179 STRLEN err_len = 0;
1180 SV *sv = NULL;
1181 #ifdef HAVE_SANDBOX
1182 SV *safe;
1183 #endif
1184
1185 if (perl_interp == NULL)
1186 {
1187 #ifdef DYNAMIC_PERL
1188 if (!perl_enabled(TRUE))
1189 {
1190 EMSG(_(e_noperl));
1191 return;
1192 }
1193 #endif
1194 perl_init();
1195 }
1196
1197 {
1198 dSP;
1199 ENTER;
1200 SAVETMPS;
1201
1202 #ifdef HAVE_SANDBOX
1203 if (sandbox)
1204 {
1205 safe = get_sv("VIM::safe", FALSE);
1206 # ifndef MAKE_TEST /* avoid a warning for unreachable code */
1207 if (safe == NULL || !SvTRUE(safe))
1208 EMSG(_("E299: Perl evaluation forbidden in sandbox without the Safe module"));
1209 else
1210 # endif
1211 {
1212 sv = newSVpv((char *)str, 0);
1213 PUSHMARK(SP);
1214 XPUSHs(safe);
1215 XPUSHs(sv);
1216 PUTBACK;
1217 call_method("reval", G_SCALAR);
1218 SPAGAIN;
1219 SvREFCNT_dec(sv);
1220 sv = POPs;
1221 }
1222 }
1223 else
1224 #endif /* HAVE_SANDBOX */
1225 sv = eval_pv((char *)str, 0);
1226
1227 if (sv) {
1228 perl_to_vim(sv, rettv);
1229 ref_map_free();
1230 err = CHECK_EVAL_ERR(err_len);
1231 }
1232 PUTBACK;
1233 FREETMPS;
1234 LEAVE;
1235 }
1236 if (err_len)
1237 msg_split((char_u *)err, highlight_attr[HLF_E]);
950 } 1238 }
951 1239
952 /* 1240 /*
953 * ":perldo". 1241 * ":perldo".
954 */ 1242 */
982 sv_setpvn(sv, "sub VIM::perldo {", sizeof("sub VIM::perldo {") - 1); 1270 sv_setpvn(sv, "sub VIM::perldo {", sizeof("sub VIM::perldo {") - 1);
983 sv_catpvn(sv, (char *)eap->arg, length); 1271 sv_catpvn(sv, (char *)eap->arg, length);
984 sv_catpvn(sv, "}", 1); 1272 sv_catpvn(sv, "}", 1);
985 perl_eval_sv(sv, G_DISCARD | G_NOARGS); 1273 perl_eval_sv(sv, G_DISCARD | G_NOARGS);
986 SvREFCNT_dec(sv); 1274 SvREFCNT_dec(sv);
987 #ifdef AVOID_PL_ERRGV 1275 str = CHECK_EVAL_ERR(length);
988 str = SvPV(perl_get_sv("@", GV_ADD), length);
989 #else
990 str = SvPV(GvSV(PL_errgv), length);
991 #endif
992 if (length) 1276 if (length)
993 goto err; 1277 goto err;
994 1278
995 if (u_save(eap->line1 - 1, eap->line2 + 1) != OK) 1279 if (u_save(eap->line1 - 1, eap->line2 + 1) != OK)
996 return; 1280 return;
1000 for (i = eap->line1; i <= eap->line2; i++) 1284 for (i = eap->line1; i <= eap->line2; i++)
1001 { 1285 {
1002 sv_setpv(GvSV(PL_defgv), (char *)ml_get(i)); 1286 sv_setpv(GvSV(PL_defgv), (char *)ml_get(i));
1003 PUSHMARK(sp); 1287 PUSHMARK(sp);
1004 perl_call_pv("VIM::perldo", G_SCALAR | G_EVAL); 1288 perl_call_pv("VIM::perldo", G_SCALAR | G_EVAL);
1005 #ifdef AVOID_PL_ERRGV 1289 str = CHECK_EVAL_ERR(length);
1006 str = SvPV(perl_get_sv("@", GV_ADD), length);
1007 #else
1008 str = SvPV(GvSV(PL_errgv), length);
1009 #endif
1010 if (length) 1290 if (length)
1011 break; 1291 break;
1012 SPAGAIN; 1292 SPAGAIN;
1013 if (SvTRUEx(POPs)) 1293 if (SvTRUEx(POPs))
1014 { 1294 {