1 /* vi:set ts=8 sts=4 sw=4 noet:
2 *
3 * VIM - Vi IMproved by Bram Moolenaar
4 *
5 * Do ":help uganda" in Vim to read copying and usage conditions.
6 * Do ":help credits" in Vim to see a list of people who contributed.
7 */
8 /*
9 * if_perl.xs: Main code for Perl interface support.
10 * Mostly written by Sven Verdoolaege.
11 */
12
13 #define _memory_h /* avoid memset redeclaration */
14 #define IN_PERL_FILE /* don't include if_perl.pro from proto.h */
15
16 /*
17 * Currently 32-bit version of ActivePerl is built with VC6 (or MinGW since
18 * ActivePerl 5.18).
19 * (http://community.activestate.com/faq/windows-compilers-perl-modules)
20 * It means that time_t should be 32-bit. However the default size of
21 * time_t is 64-bit since VC8. So we have to define _USE_32BIT_TIME_T.
22 */
23 #if defined(WIN32) && !defined(_WIN64)
24 # define _USE_32BIT_TIME_T
25 #endif
26
27 /*
28 * Prevent including winsock.h. perl.h tries to detect whether winsock.h is
29 * already included before including winsock2.h, because winsock2.h isn't
30 * compatible with winsock.h. However the detection doesn't work with some
31 * versions of MinGW. If WIN32_LEAN_AND_MEAN is defined, windows.h will not
32 * include winsock.h.
33 */
34 #ifdef WIN32
35 # define WIN32_LEAN_AND_MEAN
36 #endif
37
38 #include "vim.h"
39
40 /* Work around for perl-5.18.
41 * Don't include "perl\lib\CORE\inline.h" for now,
42 * include it after Perl_sv_free2 is defined. */
43 #ifdef DYNAMIC_PERL
44 # define PERL_NO_INLINE_FUNCTIONS
45 #endif
46
47 #ifdef _MSC_VER
48 // Work around for using MSVC and ActivePerl 5.18.
49 # define __inline__ __inline
50 // Work around for using MSVC and Strawberry Perl 5.30.
51 # define __builtin_expect(expr, val) (expr)
52 // Work around for using MSVC and Strawberry Perl 5.32.
53 # define NO_THREAD_SAFE_LOCALE
54 #endif
55
56 #ifdef __GNUC__
57 # pragma GCC diagnostic push
58 # pragma GCC diagnostic ignored "-Wunused-variable"
59 #endif
60
61 #include <EXTERN.h>
62 #include <perl.h>
63 #include <XSUB.h>
64 #if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
65 # include <perliol.h>
66 #endif
67
68 /* Workaround for perl < 5.8.7 */
69 #ifndef PERLIO_FUNCS_DECL
70 # ifdef PERLIO_FUNCS_CONST
71 # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
72 # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
73 # else
74 # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
75 # define PERLIO_FUNCS_CAST(funcs) (funcs)
76 # endif
77 #endif
78 #ifndef SvREFCNT_inc_void_NN
79 # define SvREFCNT_inc_void_NN SvREFCNT_inc
80 #endif
81
82 /*
83 * Work around clashes between Perl and Vim namespace. proto.h doesn't
84 * include if_perl.pro and perlsfio.pro when IN_PERL_FILE is defined, because
85 * we need the CV typedef. proto.h can't be moved to after including
86 * if_perl.h, because we get all sorts of name clashes then.
87 */
88 #ifndef PROTO
89 # ifndef __MINGW32__
90 # include "proto/if_perl.pro"
91 # include "proto/if_perlsfio.pro"
92 # endif
93 #endif
94
95 // Perl compatibility stuff. This should ensure compatibility with older
96 // versions of Perl.
97 #ifndef PERL_VERSION
98 # include <patchlevel.h>
99 # define PERL_REVISION 5
100 # define PERL_VERSION PATCHLEVEL
101 # define PERL_SUBVERSION SUBVERSION
102 #endif
103
104
105 // Work around for ActivePerl 5.20.3+: Avoid generating (g)vim.lib.
106 #if defined(ACTIVEPERL_VERSION) && (ACTIVEPERL_VERSION >= 2003) \
107 && defined(MSWIN) && defined(USE_DYNAMIC_LOADING)
108 # undef XS_EXTERNAL
109 # define XS_EXTERNAL(name) XSPROTO(name)
110 #endif
111
112 /*
113 * Quoting Jan Dubois of Active State:
114 * ActivePerl build 822 still identifies itself as 5.8.8 but already
115 * contains many of the changes from the upcoming Perl 5.8.9 release.
116 *
117 * The changes include addition of two symbols (Perl_sv_2iv_flags,
118 * Perl_newXS_flags) not present in earlier releases.
119 *
120 * Jan Dubois suggested the following guarding scheme.
121 *
122 * Active State defined ACTIVEPERL_VERSION as a string in versions before
123 * 5.8.8; and so the comparison to 822 below needs to be guarded.
124 */
125 #if (PERL_REVISION == 5) && (PERL_VERSION == 8) && (PERL_SUBVERSION >= 8)
126 # if (ACTIVEPERL_VERSION >= 822) || (PERL_SUBVERSION >= 9)
127 # define PERL589_OR_LATER
128 # endif
129 #endif
130 #if (PERL_REVISION == 5) && (PERL_VERSION >= 9)
131 # define PERL589_OR_LATER
132 #endif
133
134 #if (PERL_REVISION == 5) && ((PERL_VERSION > 10) || \
135 (PERL_VERSION == 10) && (PERL_SUBVERSION >= 1))
136 # define PERL5101_OR_LATER
137 #endif
138
139 #ifndef pTHX
140 # define pTHX void
141 # define pTHX_
142 #endif
143
144 #ifndef EXTERN_C
145 # define EXTERN_C
146 #endif
147
148 /* Compatibility hacks over */
149
150 static PerlInterpreter *perl_interp = NULL;
151 static void xs_init(pTHX);
152 static void VIM_init(void);
153 EXTERN_C void boot_DynaLoader(pTHX_ CV*);
154
155 /*
156 * For dynamic linked perl.
157 */
158 #if defined(DYNAMIC_PERL) || defined(PROTO)
159
160 # ifndef DYNAMIC_PERL /* just generating prototypes */
161 # ifdef MSWIN
162 typedef int HANDLE;
163 # endif
164 typedef int XSINIT_t;
165 typedef int XSUBADDR_t;
166 # endif
167 # ifndef USE_ITHREADS
168 typedef int perl_key;
169 # endif
170
171 # ifndef MSWIN
172 # include <dlfcn.h>
173 # define HANDLE void*
174 # define PERL_PROC void*
175 # define load_dll(n) dlopen((n), RTLD_LAZY|RTLD_GLOBAL)
176 # define symbol_from_dll dlsym
177 # define close_dll dlclose
178 # define load_dll_error dlerror
179 # else
180 # define PERL_PROC FARPROC
181 # define load_dll vimLoadLib
182 # define symbol_from_dll GetProcAddress
183 # define close_dll FreeLibrary
184 # define load_dll_error GetWin32Error
185 # endif
186 /*
187 * Wrapper defines
188 */
189 # define perl_alloc dll_perl_alloc
190 # define perl_construct dll_perl_construct
191 # define perl_parse dll_perl_parse
192 # define perl_run dll_perl_run
193 # define perl_destruct dll_perl_destruct
194 # define perl_free dll_perl_free
195 # define Perl_get_context dll_Perl_get_context
196 # define Perl_croak dll_Perl_croak
197 # ifdef PERL5101_OR_LATER
198 # define Perl_croak_xs_usage dll_Perl_croak_xs_usage
199 # endif
200 # ifndef PROTO
201 # ifdef PERL_IMPLICIT_CONTEXT
202 # define Perl_croak_nocontext dll_Perl_croak_nocontext
203 # endif
204 # define Perl_call_argv dll_Perl_call_argv
205 # define Perl_call_pv dll_Perl_call_pv
206 # define Perl_eval_sv dll_Perl_eval_sv
207 # define Perl_get_sv dll_Perl_get_sv
208 # define Perl_eval_pv dll_Perl_eval_pv
209 # define Perl_call_method dll_Perl_call_method
210 # endif
211 # define Perl_dowantarray dll_Perl_dowantarray
212 # define Perl_free_tmps dll_Perl_free_tmps
213 # define Perl_gv_stashpv dll_Perl_gv_stashpv
214 # define Perl_markstack_grow dll_Perl_markstack_grow
215 # define Perl_mg_find dll_Perl_mg_find
216 # if (PERL_REVISION == 5) && (PERL_VERSION >= 28)
217 # define Perl_mg_get dll_Perl_mg_get
218 # endif
219 # define Perl_newXS dll_Perl_newXS
220 # define Perl_newSV dll_Perl_newSV
221 # define Perl_newSViv dll_Perl_newSViv
222 # define Perl_newSVpv dll_Perl_newSVpv
223 # define Perl_pop_scope dll_Perl_pop_scope
224 # define Perl_push_scope dll_Perl_push_scope
225 # define Perl_save_int dll_Perl_save_int
226 # if (PERL_REVISION == 5) && (PERL_VERSION >= 20)
227 # define Perl_save_strlen dll_Perl_save_strlen
228 # endif
229 # define Perl_stack_grow dll_Perl_stack_grow
230 # define Perl_set_context dll_Perl_set_context
231 # if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
232 # define Perl_sv_2bool_flags dll_Perl_sv_2bool_flags
233 # if (PERL_REVISION == 5) && (PERL_VERSION < 22)
234 # define Perl_xs_apiversion_bootcheck dll_Perl_xs_apiversion_bootcheck
235 # endif
236 # else
237 # define Perl_sv_2bool dll_Perl_sv_2bool
238 # endif
239 # define Perl_sv_2iv dll_Perl_sv_2iv
240 # define Perl_sv_2mortal dll_Perl_sv_2mortal
241 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
242 # define Perl_sv_2pv_flags dll_Perl_sv_2pv_flags
243 # define Perl_sv_2pv_nolen dll_Perl_sv_2pv_nolen
244 # else
245 # define Perl_sv_2pv dll_Perl_sv_2pv
246 # endif
247 # if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
248 # define Perl_sv_2pvbyte_flags dll_Perl_sv_2pvbyte_flags
249 # endif
250 # define Perl_sv_2pvbyte dll_Perl_sv_2pvbyte
251 # define Perl_sv_bless dll_Perl_sv_bless
252 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
253 # define Perl_sv_catpvn_flags dll_Perl_sv_catpvn_flags
254 # else
255 # define Perl_sv_catpvn dll_Perl_sv_catpvn
256 # endif
257 # ifdef PERL589_OR_LATER
258 # define Perl_sv_2iv_flags dll_Perl_sv_2iv_flags
259 # define Perl_newXS_flags dll_Perl_newXS_flags
260 # endif
261 # define Perl_sv_free dll_Perl_sv_free
262 # if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
263 # define Perl_sv_free2 dll_Perl_sv_free2
264 # endif
265 # define Perl_sv_isa dll_Perl_sv_isa
266 # define Perl_sv_magic dll_Perl_sv_magic
267 # define Perl_sv_setiv dll_Perl_sv_setiv
268 # define Perl_sv_setpv dll_Perl_sv_setpv
269 # define Perl_sv_setpvn dll_Perl_sv_setpvn
270 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
271 # define Perl_sv_setsv_flags dll_Perl_sv_setsv_flags
272 # else
273 # define Perl_sv_setsv dll_Perl_sv_setsv
274 # endif
275 # define Perl_sv_upgrade dll_Perl_sv_upgrade
276 # define Perl_Tstack_sp_ptr dll_Perl_Tstack_sp_ptr
277 # define Perl_Top_ptr dll_Perl_Top_ptr
278 # define Perl_Tstack_base_ptr dll_Perl_Tstack_base_ptr
279 # define Perl_Tstack_max_ptr dll_Perl_Tstack_max_ptr
280 # define Perl_Ttmps_ix_ptr dll_Perl_Ttmps_ix_ptr
281 # define Perl_Ttmps_floor_ptr dll_Perl_Ttmps_floor_ptr
282 # define Perl_Tmarkstack_ptr_ptr dll_Perl_Tmarkstack_ptr_ptr
283 # define Perl_Tmarkstack_max_ptr dll_Perl_Tmarkstack_max_ptr
284 # define Perl_TSv_ptr dll_Perl_TSv_ptr
285 # define Perl_TXpv_ptr dll_Perl_TXpv_ptr
286 # define Perl_Tna_ptr dll_Perl_Tna_ptr
287 # define Perl_Idefgv_ptr dll_Perl_Idefgv_ptr
288 # define Perl_Ierrgv_ptr dll_Perl_Ierrgv_ptr
289 # define Perl_Isv_yes_ptr dll_Perl_Isv_yes_ptr
290 # define boot_DynaLoader dll_boot_DynaLoader
291 # define Perl_Gthr_key_ptr dll_Perl_Gthr_key_ptr
292
293 # define Perl_sys_init dll_Perl_sys_init
294 # define Perl_sys_term dll_Perl_sys_term
295 # define Perl_ISv_ptr dll_Perl_ISv_ptr
296 # define Perl_Istack_max_ptr dll_Perl_Istack_max_ptr
297 # define Perl_Istack_base_ptr dll_Perl_Istack_base_ptr
298 # define Perl_Itmps_ix_ptr dll_Perl_Itmps_ix_ptr
299 # define Perl_Itmps_floor_ptr dll_Perl_Itmps_floor_ptr
300 # define Perl_IXpv_ptr dll_Perl_IXpv_ptr
301 # define Perl_Ina_ptr dll_Perl_Ina_ptr
302 # define Perl_Imarkstack_ptr_ptr dll_Perl_Imarkstack_ptr_ptr
303 # define Perl_Imarkstack_max_ptr dll_Perl_Imarkstack_max_ptr
304 # define Perl_Istack_sp_ptr dll_Perl_Istack_sp_ptr
305 # define Perl_Iop_ptr dll_Perl_Iop_ptr
306 # define Perl_call_list dll_Perl_call_list
307 # define Perl_Iscopestack_ix_ptr dll_Perl_Iscopestack_ix_ptr
308 # define Perl_Iunitcheckav_ptr dll_Perl_Iunitcheckav_ptr
309 # if (PERL_REVISION == 5) && (PERL_VERSION >= 22)
310 # define Perl_xs_handshake dll_Perl_xs_handshake
311 # define Perl_xs_boot_epilog dll_Perl_xs_boot_epilog
312 # endif
313 # if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
314 # ifdef USE_ITHREADS
315 # define PL_thr_key *dll_PL_thr_key
316 # endif
317 # endif
318 # define Perl_hv_iternext_flags dll_Perl_hv_iternext_flags
319 # define Perl_hv_iterinit dll_Perl_hv_iterinit
320 # define Perl_hv_iterkey dll_Perl_hv_iterkey
321 # define Perl_hv_iterval dll_Perl_hv_iterval
322 # define Perl_av_fetch dll_Perl_av_fetch
323 # define Perl_av_len dll_Perl_av_len
324 # define Perl_sv_2nv_flags dll_Perl_sv_2nv_flags
325 # if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
326 # define PerlIOBase_pushed dll_PerlIOBase_pushed
327 # define PerlIO_define_layer dll_PerlIO_define_layer
328 # endif
329 # if (PERL_REVISION == 5) && (PERL_VERSION >= 24)
330 # define Perl_savetmps dll_Perl_savetmps
331 # endif
332
333 /*
334 * Declare HANDLE for perl.dll and function pointers.
335 */
336 static HANDLE hPerlLib = NULL;
337
338 static PerlInterpreter* (*perl_alloc)();
339 static void (*perl_construct)(PerlInterpreter*);
340 static void (*perl_destruct)(PerlInterpreter*);
341 static void (*perl_free)(PerlInterpreter*);
342 static int (*perl_run)(PerlInterpreter*);
343 static int (*perl_parse)(PerlInterpreter*, XSINIT_t, int, char**, char**);
344 static void* (*Perl_get_context)(void);
345 static void (*Perl_croak)(pTHX_ const char*, ...) __attribute__noreturn__;
346 # ifdef PERL5101_OR_LATER
347 /* Perl-5.18 has a different Perl_croak_xs_usage signature. */
348 # if (PERL_REVISION == 5) && (PERL_VERSION >= 18)
349 static void (*Perl_croak_xs_usage)(const CV *const, const char *const params)
350 __attribute__noreturn__;
351 # else
352 static void (*Perl_croak_xs_usage)(pTHX_ const CV *const, const char *const params)
353 __attribute__noreturn__;
354 # endif
355 # endif
356 # ifdef PERL_IMPLICIT_CONTEXT
357 static void (*Perl_croak_nocontext)(const char*, ...) __attribute__noreturn__;
358 # endif
359 static I32 (*Perl_dowantarray)(pTHX);
360 static void (*Perl_free_tmps)(pTHX);
361 static HV* (*Perl_gv_stashpv)(pTHX_ const char*, I32);
362 # if (PERL_REVISION == 5) && (PERL_VERSION >= 22)
363 static I32* (*Perl_markstack_grow)(pTHX);
364 # else
365 static void (*Perl_markstack_grow)(pTHX);
366 # endif
367 static MAGIC* (*Perl_mg_find)(pTHX_ SV*, int);
368 # if (PERL_REVISION == 5) && (PERL_VERSION >= 28)
369 static int (*Perl_mg_get)(pTHX_ SV*);
370 # endif
371 static CV* (*Perl_newXS)(pTHX_ char*, XSUBADDR_t, char*);
372 static SV* (*Perl_newSV)(pTHX_ STRLEN);
373 static SV* (*Perl_newSViv)(pTHX_ IV);
374 static SV* (*Perl_newSVpv)(pTHX_ const char*, STRLEN);
375 static I32 (*Perl_call_argv)(pTHX_ const char*, I32, char**);
376 static I32 (*Perl_call_pv)(pTHX_ const char*, I32);
377 static I32 (*Perl_eval_sv)(pTHX_ SV*, I32);
378 static SV* (*Perl_get_sv)(pTHX_ const char*, I32);
379 static SV* (*Perl_eval_pv)(pTHX_ const char*, I32);
380 static SV* (*Perl_call_method)(pTHX_ const char*, I32);
381 static void (*Perl_pop_scope)(pTHX);
382 static void (*Perl_push_scope)(pTHX);
383 static void (*Perl_save_int)(pTHX_ int*);
384 # if (PERL_REVISION == 5) && (PERL_VERSION >= 20)
385 static void (*Perl_save_strlen)(pTHX_ STRLEN* ptr);
386 # endif
387 static SV** (*Perl_stack_grow)(pTHX_ SV**, SV**p, int);
388 static SV** (*Perl_set_context)(void*);
389 # if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
390 static bool (*Perl_sv_2bool_flags)(pTHX_ SV*, I32);
391 # if (PERL_REVISION == 5) && (PERL_VERSION < 22)
392 static void (*Perl_xs_apiversion_bootcheck)(pTHX_ SV *module, const char *api_p, STRLEN api_len);
393 # endif
394 # else
395 static bool (*Perl_sv_2bool)(pTHX_ SV*);
396 # endif
397 static IV (*Perl_sv_2iv)(pTHX_ SV*);
398 static SV* (*Perl_sv_2mortal)(pTHX_ SV*);
399 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
400 static char* (*Perl_sv_2pv_flags)(pTHX_ SV*, STRLEN*, I32);
401 static char* (*Perl_sv_2pv_nolen)(pTHX_ SV*);
402 # else
403 static char* (*Perl_sv_2pv)(pTHX_ SV*, STRLEN*);
404 # endif
405 static char* (*Perl_sv_2pvbyte)(pTHX_ SV*, STRLEN*);
406 # if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
407 static char* (*Perl_sv_2pvbyte_flags)(pTHX_ SV*, STRLEN*, I32);
408 # endif
409 static SV* (*Perl_sv_bless)(pTHX_ SV*, HV*);
410 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
411 static void (*Perl_sv_catpvn_flags)(pTHX_ SV* , const char*, STRLEN, I32);
412 # else
413 static void (*Perl_sv_catpvn)(pTHX_ SV*, const char*, STRLEN);
414 # endif
415 # ifdef PERL589_OR_LATER
416 static IV (*Perl_sv_2iv_flags)(pTHX_ SV* sv, I32 flags);
417 static CV * (*Perl_newXS_flags)(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags);
418 # endif
419 static void (*Perl_sv_free)(pTHX_ SV*);
420 static int (*Perl_sv_isa)(pTHX_ SV*, const char*);
421 static void (*Perl_sv_magic)(pTHX_ SV*, SV*, int, const char*, I32);
422 static void (*Perl_sv_setiv)(pTHX_ SV*, IV);
423 static void (*Perl_sv_setpv)(pTHX_ SV*, const char*);
424 static void (*Perl_sv_setpvn)(pTHX_ SV*, const char*, STRLEN);
425 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
426 static void (*Perl_sv_setsv_flags)(pTHX_ SV*, SV*, I32);
427 # else
428 static void (*Perl_sv_setsv)(pTHX_ SV*, SV*);
429 # endif
430 static bool (*Perl_sv_upgrade)(pTHX_ SV*, U32);
431 # if (PERL_REVISION == 5) && (PERL_VERSION < 10)
432 static SV*** (*Perl_Tstack_sp_ptr)(register PerlInterpreter*);
433 static OP** (*Perl_Top_ptr)(register PerlInterpreter*);
434 static SV*** (*Perl_Tstack_base_ptr)(register PerlInterpreter*);
435 static SV*** (*Perl_Tstack_max_ptr)(register PerlInterpreter*);
436 static I32* (*Perl_Ttmps_ix_ptr)(register PerlInterpreter*);
437 static I32* (*Perl_Ttmps_floor_ptr)(register PerlInterpreter*);
438 static I32** (*Perl_Tmarkstack_ptr_ptr)(register PerlInterpreter*);
439 static I32** (*Perl_Tmarkstack_max_ptr)(register PerlInterpreter*);
440 static SV** (*Perl_TSv_ptr)(register PerlInterpreter*);
441 static XPV** (*Perl_TXpv_ptr)(register PerlInterpreter*);
442 static STRLEN* (*Perl_Tna_ptr)(register PerlInterpreter*);
443 # else
444 /* Perl-5.18 has a different Perl_sv_free2 signature. */
445 # if (PERL_REVISION == 5) && (PERL_VERSION >= 18)
446 static void (*Perl_sv_free2)(pTHX_ SV*, const U32);
447 # else
448 static void (*Perl_sv_free2)(pTHX_ SV*);
449 # endif
450 static void (*Perl_sys_init)(int* argc, char*** argv);
451 static void (*Perl_sys_term)(void);
452 static void (*Perl_call_list)(pTHX_ I32, AV*);
453 # if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
454 # else
455 static SV** (*Perl_ISv_ptr)(register PerlInterpreter*);
456 static SV*** (*Perl_Istack_max_ptr)(register PerlInterpreter*);
457 static SV*** (*Perl_Istack_base_ptr)(register PerlInterpreter*);
458 static XPV** (*Perl_IXpv_ptr)(register PerlInterpreter*);
459 static I32* (*Perl_Itmps_ix_ptr)(register PerlInterpreter*);
460 static I32* (*Perl_Itmps_floor_ptr)(register PerlInterpreter*);
461 static STRLEN* (*Perl_Ina_ptr)(register PerlInterpreter*);
462 static I32** (*Perl_Imarkstack_ptr_ptr)(register PerlInterpreter*);
463 static I32** (*Perl_Imarkstack_max_ptr)(register PerlInterpreter*);
464 static SV*** (*Perl_Istack_sp_ptr)(register PerlInterpreter*);
465 static OP** (*Perl_Iop_ptr)(register PerlInterpreter*);
466 static I32* (*Perl_Iscopestack_ix_ptr)(register PerlInterpreter*);
467 static AV** (*Perl_Iunitcheckav_ptr)(register PerlInterpreter*);
468 # endif
469 # endif
470 # if (PERL_REVISION == 5) && (PERL_VERSION >= 22)
471 static I32 (*Perl_xs_handshake)(const U32, void *, const char *, ...);
472 static void (*Perl_xs_boot_epilog)(pTHX_ const U32);
473 # endif
474
475 # if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
476 # ifdef USE_ITHREADS
477 static perl_key* dll_PL_thr_key;
478 # endif
479 # else
480 static GV** (*Perl_Idefgv_ptr)(register PerlInterpreter*);
481 static GV** (*Perl_Ierrgv_ptr)(register PerlInterpreter*);
482 static SV* (*Perl_Isv_yes_ptr)(register PerlInterpreter*);
483 static perl_key* (*Perl_Gthr_key_ptr)_((pTHX));
484 # endif
485 static void (*boot_DynaLoader)_((pTHX_ CV*));
486 static HE * (*Perl_hv_iternext_flags)(pTHX_ HV *, I32);
487 static I32 (*Perl_hv_iterinit)(pTHX_ HV *);
488 static char * (*Perl_hv_iterkey)(pTHX_ HE *, I32 *);
489 static SV * (*Perl_hv_iterval)(pTHX_ HV *, HE *);
490 static SV** (*Perl_av_fetch)(pTHX_ AV *, SSize_t, I32);
491 static SSize_t (*Perl_av_len)(pTHX_ AV *);
492 static NV (*Perl_sv_2nv_flags)(pTHX_ SV *const, const I32);
493 # if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
494 static IV (*PerlIOBase_pushed)(pTHX_ PerlIO *, const char *, SV *, PerlIO_funcs *);
495 static void (*PerlIO_define_layer)(pTHX_ PerlIO_funcs *);
496 # endif
497 # if (PERL_REVISION == 5) && (PERL_VERSION >= 24)
498 static void (*Perl_savetmps)(pTHX);
499 # endif
500
501 /*
502 * Table of name to function pointer of perl.
503 */
504 static struct {
505 char* name;
506 PERL_PROC* ptr;
507 } perl_funcname_table[] = {
508 {"perl_alloc", (PERL_PROC*)&perl_alloc},
509 {"perl_construct", (PERL_PROC*)&perl_construct},
510 {"perl_destruct", (PERL_PROC*)&perl_destruct},
511 {"perl_free", (PERL_PROC*)&perl_free},
512 {"perl_run", (PERL_PROC*)&perl_run},
513 {"perl_parse", (PERL_PROC*)&perl_parse},
514 {"Perl_get_context", (PERL_PROC*)&Perl_get_context},
515 {"Perl_croak", (PERL_PROC*)&Perl_croak},
516 # ifdef PERL5101_OR_LATER
517 {"Perl_croak_xs_usage", (PERL_PROC*)&Perl_croak_xs_usage},
518 # endif
519 # ifdef PERL_IMPLICIT_CONTEXT
520 {"Perl_croak_nocontext", (PERL_PROC*)&Perl_croak_nocontext},
521 # endif
522 {"Perl_dowantarray", (PERL_PROC*)&Perl_dowantarray},
523 {"Perl_free_tmps", (PERL_PROC*)&Perl_free_tmps},
524 {"Perl_gv_stashpv", (PERL_PROC*)&Perl_gv_stashpv},
525 {"Perl_markstack_grow", (PERL_PROC*)&Perl_markstack_grow},
526 {"Perl_mg_find", (PERL_PROC*)&Perl_mg_find},
527 # if (PERL_REVISION == 5) && (PERL_VERSION >= 28)
528 {"Perl_mg_get", (PERL_PROC*)&Perl_mg_get},
529 # endif
530 {"Perl_newXS", (PERL_PROC*)&Perl_newXS},
531 {"Perl_newSV", (PERL_PROC*)&Perl_newSV},
532 {"Perl_newSViv", (PERL_PROC*)&Perl_newSViv},
533 {"Perl_newSVpv", (PERL_PROC*)&Perl_newSVpv},
534 {"Perl_call_argv", (PERL_PROC*)&Perl_call_argv},
535 {"Perl_call_pv", (PERL_PROC*)&Perl_call_pv},
536 {"Perl_eval_sv", (PERL_PROC*)&Perl_eval_sv},
537 {"Perl_get_sv", (PERL_PROC*)&Perl_get_sv},
538 {"Perl_eval_pv", (PERL_PROC*)&Perl_eval_pv},
539 {"Perl_call_method", (PERL_PROC*)&Perl_call_method},
540 {"Perl_pop_scope", (PERL_PROC*)&Perl_pop_scope},
541 {"Perl_push_scope", (PERL_PROC*)&Perl_push_scope},
542 {"Perl_save_int", (PERL_PROC*)&Perl_save_int},
543 # if (PERL_REVISION == 5) && (PERL_VERSION >= 20)
544 {"Perl_save_strlen", (PERL_PROC*)&Perl_save_strlen},
545 # endif
546 {"Perl_stack_grow", (PERL_PROC*)&Perl_stack_grow},
547 {"Perl_set_context", (PERL_PROC*)&Perl_set_context},
548 # if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
549 {"Perl_sv_2bool_flags", (PERL_PROC*)&Perl_sv_2bool_flags},
550 # if (PERL_REVISION == 5) && (PERL_VERSION < 22)
551 {"Perl_xs_apiversion_bootcheck",(PERL_PROC*)&Perl_xs_apiversion_bootcheck},
552 # endif
553 # else
554 {"Perl_sv_2bool", (PERL_PROC*)&Perl_sv_2bool},
555 # endif
556 {"Perl_sv_2iv", (PERL_PROC*)&Perl_sv_2iv},
557 {"Perl_sv_2mortal", (PERL_PROC*)&Perl_sv_2mortal},
558 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
559 {"Perl_sv_2pv_flags", (PERL_PROC*)&Perl_sv_2pv_flags},
560 {"Perl_sv_2pv_nolen", (PERL_PROC*)&Perl_sv_2pv_nolen},
561 # else
562 {"Perl_sv_2pv", (PERL_PROC*)&Perl_sv_2pv},
563 # endif
564 {"Perl_sv_2pvbyte", (PERL_PROC*)&Perl_sv_2pvbyte},
565 # if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
566 {"Perl_sv_2pvbyte_flags", (PERL_PROC*)&Perl_sv_2pvbyte_flags},
567 # endif
568 # ifdef PERL589_OR_LATER
569 {"Perl_sv_2iv_flags", (PERL_PROC*)&Perl_sv_2iv_flags},
570 {"Perl_newXS_flags", (PERL_PROC*)&Perl_newXS_flags},
571 # endif
572 {"Perl_sv_bless", (PERL_PROC*)&Perl_sv_bless},
573 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
574 {"Perl_sv_catpvn_flags", (PERL_PROC*)&Perl_sv_catpvn_flags},
575 # else
576 {"Perl_sv_catpvn", (PERL_PROC*)&Perl_sv_catpvn},
577 # endif
578 {"Perl_sv_free", (PERL_PROC*)&Perl_sv_free},
579 {"Perl_sv_isa", (PERL_PROC*)&Perl_sv_isa},
580 {"Perl_sv_magic", (PERL_PROC*)&Perl_sv_magic},
581 {"Perl_sv_setiv", (PERL_PROC*)&Perl_sv_setiv},
582 {"Perl_sv_setpv", (PERL_PROC*)&Perl_sv_setpv},
583 {"Perl_sv_setpvn", (PERL_PROC*)&Perl_sv_setpvn},
584 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
585 {"Perl_sv_setsv_flags", (PERL_PROC*)&Perl_sv_setsv_flags},
586 # else
587 {"Perl_sv_setsv", (PERL_PROC*)&Perl_sv_setsv},
588 # endif
589 {"Perl_sv_upgrade", (PERL_PROC*)&Perl_sv_upgrade},
590 # if (PERL_REVISION == 5) && (PERL_VERSION < 10)
591 {"Perl_Tstack_sp_ptr", (PERL_PROC*)&Perl_Tstack_sp_ptr},
592 {"Perl_Top_ptr", (PERL_PROC*)&Perl_Top_ptr},
593 {"Perl_Tstack_base_ptr", (PERL_PROC*)&Perl_Tstack_base_ptr},
594 {"Perl_Tstack_max_ptr", (PERL_PROC*)&Perl_Tstack_max_ptr},
595 {"Perl_Ttmps_ix_ptr", (PERL_PROC*)&Perl_Ttmps_ix_ptr},
596 {"Perl_Ttmps_floor_ptr", (PERL_PROC*)&Perl_Ttmps_floor_ptr},
597 {"Perl_Tmarkstack_ptr_ptr", (PERL_PROC*)&Perl_Tmarkstack_ptr_ptr},
598 {"Perl_Tmarkstack_max_ptr", (PERL_PROC*)&Perl_Tmarkstack_max_ptr},
599 {"Perl_TSv_ptr", (PERL_PROC*)&Perl_TSv_ptr},
600 {"Perl_TXpv_ptr", (PERL_PROC*)&Perl_TXpv_ptr},
601 {"Perl_Tna_ptr", (PERL_PROC*)&Perl_Tna_ptr},
602 # else
603 {"Perl_sv_free2", (PERL_PROC*)&Perl_sv_free2},
604 {"Perl_sys_init", (PERL_PROC*)&Perl_sys_init},
605 {"Perl_sys_term", (PERL_PROC*)&Perl_sys_term},
606 {"Perl_call_list", (PERL_PROC*)&Perl_call_list},
607 # if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
608 # else
609 {"Perl_ISv_ptr", (PERL_PROC*)&Perl_ISv_ptr},
610 {"Perl_Istack_max_ptr", (PERL_PROC*)&Perl_Istack_max_ptr},
611 {"Perl_Istack_base_ptr", (PERL_PROC*)&Perl_Istack_base_ptr},
612 {"Perl_IXpv_ptr", (PERL_PROC*)&Perl_IXpv_ptr},
613 {"Perl_Itmps_ix_ptr", (PERL_PROC*)&Perl_Itmps_ix_ptr},
614 {"Perl_Itmps_floor_ptr", (PERL_PROC*)&Perl_Itmps_floor_ptr},
615 {"Perl_Ina_ptr", (PERL_PROC*)&Perl_Ina_ptr},
616 {"Perl_Imarkstack_ptr_ptr", (PERL_PROC*)&Perl_Imarkstack_ptr_ptr},
617 {"Perl_Imarkstack_max_ptr", (PERL_PROC*)&Perl_Imarkstack_max_ptr},
618 {"Perl_Istack_sp_ptr", (PERL_PROC*)&Perl_Istack_sp_ptr},
619 {"Perl_Iop_ptr", (PERL_PROC*)&Perl_Iop_ptr},
620 {"Perl_Iscopestack_ix_ptr", (PERL_PROC*)&Perl_Iscopestack_ix_ptr},
621 {"Perl_Iunitcheckav_ptr", (PERL_PROC*)&Perl_Iunitcheckav_ptr},
622 # endif
623 # endif
624 # if (PERL_REVISION == 5) && (PERL_VERSION >= 22)
625 {"Perl_xs_handshake", (PERL_PROC*)&Perl_xs_handshake},
626 {"Perl_xs_boot_epilog", (PERL_PROC*)&Perl_xs_boot_epilog},
627 # endif
628 # if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
629 # ifdef USE_ITHREADS
630 {"PL_thr_key", (PERL_PROC*)&dll_PL_thr_key},
631 # endif
632 # else
633 {"Perl_Idefgv_ptr", (PERL_PROC*)&Perl_Idefgv_ptr},
634 {"Perl_Ierrgv_ptr", (PERL_PROC*)&Perl_Ierrgv_ptr},
635 {"Perl_Isv_yes_ptr", (PERL_PROC*)&Perl_Isv_yes_ptr},
636 {"Perl_Gthr_key_ptr", (PERL_PROC*)&Perl_Gthr_key_ptr},
637 # endif
638 {"boot_DynaLoader", (PERL_PROC*)&boot_DynaLoader},
639 {"Perl_hv_iternext_flags", (PERL_PROC*)&Perl_hv_iternext_flags},
640 {"Perl_hv_iterinit", (PERL_PROC*)&Perl_hv_iterinit},
641 {"Perl_hv_iterkey", (PERL_PROC*)&Perl_hv_iterkey},
642 {"Perl_hv_iterval", (PERL_PROC*)&Perl_hv_iterval},
643 {"Perl_av_fetch", (PERL_PROC*)&Perl_av_fetch},
644 {"Perl_av_len", (PERL_PROC*)&Perl_av_len},
645 {"Perl_sv_2nv_flags", (PERL_PROC*)&Perl_sv_2nv_flags},
646 # if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
647 {"PerlIOBase_pushed", (PERL_PROC*)&PerlIOBase_pushed},
648 {"PerlIO_define_layer", (PERL_PROC*)&PerlIO_define_layer},
649 # endif
650 # if (PERL_REVISION == 5) && (PERL_VERSION >= 24)
651 {"Perl_savetmps", (PERL_PROC*)&Perl_savetmps},
652 # endif
653 {"", NULL},
654 };
655
656 /* Work around for perl-5.18.
657 * For now, only the definitions of S_SvREFCNT_dec are needed in
658 * "perl\lib\CORE\inline.h". */
659 # if (PERL_REVISION == 5) && (PERL_VERSION >= 18)
660 static void
S_SvREFCNT_dec(pTHX_ SV * sv)661 S_SvREFCNT_dec(pTHX_ SV *sv)
662 {
663 if (LIKELY(sv != NULL)) {
664 U32 rc = SvREFCNT(sv);
665 if (LIKELY(rc > 1))
666 SvREFCNT(sv) = rc - 1;
667 else
668 Perl_sv_free2(aTHX_ sv, rc);
669 }
670 }
671 # endif
672
673 /* perl-5.32 needs Perl_SvREFCNT_dec */
674 # if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
675 # define Perl_SvREFCNT_dec S_SvREFCNT_dec
676 # endif
677
678 /* perl-5.26 also needs S_TOPMARK and S_POPMARK. */
679 # if (PERL_REVISION == 5) && (PERL_VERSION >= 26)
680 PERL_STATIC_INLINE I32
S_TOPMARK(pTHX)681 S_TOPMARK(pTHX)
682 {
683 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
684 "MARK top %p %" IVdf "\n",
685 PL_markstack_ptr,
686 (IV)*PL_markstack_ptr)));
687 return *PL_markstack_ptr;
688 }
689
690 PERL_STATIC_INLINE I32
S_POPMARK(pTHX)691 S_POPMARK(pTHX)
692 {
693 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
694 "MARK pop %p %" IVdf "\n",
695 (PL_markstack_ptr-1),
696 (IV)*(PL_markstack_ptr-1))));
697 assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
698 return *PL_markstack_ptr--;
699 }
700 # endif
701
702 /* perl-5.32 needs Perl_POPMARK */
703 # if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
704 # define Perl_POPMARK S_POPMARK
705 # endif
706
707 /* perl-5.34 needs Perl_SvTRUE_common; used in SvTRUE_nomg_NN */
708 # if (PERL_REVISION == 5) && (PERL_VERSION >= 34)
709 PERL_STATIC_INLINE bool
Perl_SvTRUE_common(pTHX_ SV * sv,const bool sv_2bool_is_fallback)710 Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
711 {
712 if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
713 return SvIMMORTAL_TRUE(sv);
714
715 if (! SvOK(sv))
716 return FALSE;
717
718 if (SvPOK(sv))
719 return SvPVXtrue(sv);
720
721 if (SvIOK(sv))
722 return SvIVX(sv) != 0; /* casts to bool */
723
724 if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
725 return TRUE;
726
727 if (sv_2bool_is_fallback)
728 return sv_2bool_nomg(sv);
729
730 return isGV_with_GP(sv);
731 }
732 # endif
733
734 /* perl-5.32 needs Perl_SvTRUE */
735 # if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
736 PERL_STATIC_INLINE bool
Perl_SvTRUE(pTHX_ SV * sv)737 Perl_SvTRUE(pTHX_ SV *sv) {
738 if (!LIKELY(sv))
739 return FALSE;
740 SvGETMAGIC(sv);
741 return SvTRUE_nomg_NN(sv);
742 }
743 # endif
744
745 /*
746 * Make all runtime-links of perl.
747 *
748 * 1. Get module handle using dlopen() or vimLoadLib().
749 * 2. Get pointer to perl function by GetProcAddress.
750 * 3. Repeat 2, until get all functions will be used.
751 *
752 * Parameter 'libname' provides name of DLL.
753 * Return OK or FAIL.
754 */
755 static int
perl_runtime_link_init(char * libname,int verbose)756 perl_runtime_link_init(char *libname, int verbose)
757 {
758 int i;
759
760 if (hPerlLib != NULL)
761 return OK;
762 if ((hPerlLib = load_dll(libname)) == NULL)
763 {
764 if (verbose)
765 semsg(_("E370: Could not load library %s"), libname);
766 return FAIL;
767 }
768 for (i = 0; perl_funcname_table[i].ptr; ++i)
769 {
770 if (!(*perl_funcname_table[i].ptr = symbol_from_dll(hPerlLib,
771 perl_funcname_table[i].name)))
772 {
773 close_dll(hPerlLib);
774 hPerlLib = NULL;
775 if (verbose)
776 semsg((const char *)_(e_loadfunc), perl_funcname_table[i].name);
777 return FAIL;
778 }
779 }
780 return OK;
781 }
782
783 /*
784 * If runtime-link-perl(DLL) was loaded successfully, return TRUE.
785 * There were no DLL loaded, return FALSE.
786 */
787 int
perl_enabled(int verbose)788 perl_enabled(int verbose)
789 {
790 return perl_runtime_link_init((char *)p_perldll, verbose) == OK;
791 }
792 #endif /* DYNAMIC_PERL */
793
794 #if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
795 static void vim_IOLayer_init(void);
796 #endif
797
798 /*
799 * perl_init(): initialize perl interpreter
800 * We have to call perl_parse to initialize some structures,
801 * there's nothing to actually parse.
802 */
803 static void
perl_init(void)804 perl_init(void)
805 {
806 char *bootargs[] = { "VI", NULL };
807 int argc = 3;
808 static char *argv[] = { "", "-e", "" };
809
810 #if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
811 Perl_sys_init(&argc, (char***)&argv);
812 #endif
813 perl_interp = perl_alloc();
814 perl_construct(perl_interp);
815 perl_parse(perl_interp, xs_init, argc, argv, 0);
816 perl_call_argv("VIM::bootstrap", (long)G_DISCARD, bootargs);
817 VIM_init();
818 #ifdef USE_SFIO
819 sfdisc(PerlIO_stdout(), sfdcnewvim());
820 sfdisc(PerlIO_stderr(), sfdcnewvim());
821 sfsetbuf(PerlIO_stdout(), NULL, 0);
822 sfsetbuf(PerlIO_stderr(), NULL, 0);
823 #elif defined(PERLIO_LAYERS)
824 vim_IOLayer_init();
825 #endif
826 }
827
828 /*
829 * Clean up after ourselves.
830 */
831 void
perl_end(void)832 perl_end(void)
833 {
834 if (perl_interp)
835 {
836 perl_run(perl_interp);
837 perl_destruct(perl_interp);
838 perl_free(perl_interp);
839 perl_interp = NULL;
840 #if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
841 Perl_sys_term();
842 #endif
843 }
844 }
845
846 /*
847 * msg_split(): send a message to the message handling routines
848 * split at '\n' first though.
849 */
850 void
msg_split(char_u * s,int attr)851 msg_split(
852 char_u *s,
853 int attr) /* highlighting attributes */
854 {
855 char *next;
856 char *token = (char *)s;
857
858 while ((next = strchr(token, '\n')) && !got_int)
859 {
860 *next++ = '\0'; /* replace \n with \0 */
861 msg_attr(token, attr);
862 token = next;
863 }
864 if (*token && !got_int)
865 msg_attr(token, attr);
866 }
867
868 #ifndef FEAT_EVAL
869 /*
870 * This stub is needed because an "#ifdef FEAT_EVAL" around Eval() doesn't
871 * work properly.
872 */
873 char_u *
eval_to_string(char_u * arg UNUSED,int dolist UNUSED)874 eval_to_string(
875 char_u *arg UNUSED,
876 int dolist UNUSED)
877 {
878 return NULL;
879 }
880 #endif
881
882 /*
883 * Create a new reference to an SV pointing to the SCR structure
884 * The b_perl_private/w_perl_private part of the SCR structure points to the
885 * SV, so there can only be one such SV for a particular SCR structure. When
886 * the last reference has gone (DESTROY is called),
887 * b_perl_private/w_perl_private is reset; When the screen goes away before
888 * all references are gone, the value of the SV is reset;
889 * any subsequent use of any of those reference will produce
890 * a warning. (see typemap)
891 */
892
893 static SV *
newWINrv(SV * rv,win_T * ptr)894 newWINrv(SV *rv, win_T *ptr)
895 {
896 sv_upgrade(rv, SVt_RV);
897 if (ptr->w_perl_private == NULL)
898 {
899 ptr->w_perl_private = newSV(0);
900 sv_setiv(ptr->w_perl_private, PTR2IV(ptr));
901 }
902 SvREFCNT_inc_void_NN(ptr->w_perl_private);
903 SvRV(rv) = ptr->w_perl_private;
904 SvROK_on(rv);
905 return sv_bless(rv, gv_stashpv("VIWIN", TRUE));
906 }
907
908 static SV *
newBUFrv(SV * rv,buf_T * ptr)909 newBUFrv(SV *rv, buf_T *ptr)
910 {
911 sv_upgrade(rv, SVt_RV);
912 if (ptr->b_perl_private == NULL)
913 {
914 ptr->b_perl_private = newSV(0);
915 sv_setiv(ptr->b_perl_private, PTR2IV(ptr));
916 }
917 SvREFCNT_inc_void_NN(ptr->b_perl_private);
918 SvRV(rv) = ptr->b_perl_private;
919 SvROK_on(rv);
920 return sv_bless(rv, gv_stashpv("VIBUF", TRUE));
921 }
922
923 #if 0
924 SV *__sv_save[1024];
925 int __sv_save_ix;
926 # define D_Save_Sv(sv) do { if (__sv_save_ix < 1024) __sv_save[__sv_save_ix++] = (sv); } while (0)
927 #else
928 # define D_Save_Sv(sv) NOOP
929 #endif
930
931 /*
932 * perl_win_free
933 * Remove all references to the window to be destroyed
934 */
935 void
perl_win_free(win_T * wp)936 perl_win_free(win_T *wp)
937 {
938 if (wp->w_perl_private && perl_interp != NULL)
939 {
940 SV *sv = (SV*)wp->w_perl_private;
941 D_Save_Sv(sv);
942 sv_setiv(sv, 0);
943 SvREFCNT_dec(sv);
944 }
945 wp->w_perl_private = NULL;
946 }
947
948 void
perl_buf_free(buf_T * bp)949 perl_buf_free(buf_T *bp)
950 {
951 if (bp->b_perl_private && perl_interp != NULL)
952 {
953 SV *sv = (SV *)bp->b_perl_private;
954 D_Save_Sv(sv);
955 sv_setiv(sv, 0);
956 SvREFCNT_dec(sv);
957 }
958 bp->b_perl_private = NULL;
959 }
960
961 #ifndef PROTO
962 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
963 I32 cur_val(pTHX_ IV iv, SV *sv);
964 # else
965 I32 cur_val(IV iv, SV *sv);
966 # endif
967
968 /*
969 * Handler for the magic variables $main::curwin and $main::curbuf.
970 * The handler is put into the magic vtbl for these variables.
971 * (This is effectively a C-level equivalent of a tied variable).
972 * There is no "set" function as the variables are read-only.
973 */
974 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
cur_val(pTHX_ IV iv,SV * sv)975 I32 cur_val(pTHX_ IV iv, SV *sv)
976 # else
977 I32 cur_val(IV iv, SV *sv)
978 # endif
979 {
980 SV *rv;
981
982 if (iv == 0)
983 rv = newWINrv(newSV(0), curwin);
984 else
985 rv = newBUFrv(newSV(0), curbuf);
986
987 if (SvRV(sv) != SvRV(rv))
988 // XXX: This magic variable is a bit confusing...
989 // Is currently refcounted ?
990 sv_setsv(sv, rv);
991
992 SvREFCNT_dec(rv);
993
994 return 0;
995 }
996 #endif /* !PROTO */
997
998 struct ufuncs cw_funcs = { cur_val, 0, 0 };
999 struct ufuncs cb_funcs = { cur_val, 0, 1 };
1000
1001 /*
1002 * VIM_init(): Vim-specific initialisation.
1003 * Make the magical main::curwin and main::curbuf variables
1004 */
1005 static void
VIM_init(void)1006 VIM_init(void)
1007 {
1008 static char cw[] = "main::curwin";
1009 static char cb[] = "main::curbuf";
1010 SV *sv;
1011
1012 sv = perl_get_sv(cw, TRUE);
1013 sv_magic(sv, NULL, 'U', (char *)&cw_funcs, sizeof(cw_funcs));
1014 SvREADONLY_on(sv);
1015
1016 sv = perl_get_sv(cb, TRUE);
1017 sv_magic(sv, NULL, 'U', (char *)&cb_funcs, sizeof(cb_funcs));
1018 SvREADONLY_on(sv);
1019
1020 /*
1021 * Setup the Safe compartment.
1022 * It shouldn't be a fatal error if the Safe module is missing.
1023 * XXX: Only shares the 'Msg' routine (which has to be called
1024 * like 'Msg(...)').
1025 */
1026 (void)perl_eval_pv( "if ( eval( 'require Safe' ) ) { $VIM::safe = Safe->new(); $VIM::safe->share_from( 'VIM', ['Msg'] ); }", G_DISCARD | G_VOID );
1027
1028 }
1029
1030 #ifdef DYNAMIC_PERL
1031 static char *e_noperl = N_("Sorry, this command is disabled: the Perl library could not be loaded.");
1032 #endif
1033 static char *e_perlsandbox = N_("E299: Perl evaluation forbidden in sandbox without the Safe module");
1034
1035 /*
1036 * ":perl"
1037 */
1038 void
ex_perl(exarg_T * eap)1039 ex_perl(exarg_T *eap)
1040 {
1041 char *err;
1042 char *script;
1043 STRLEN length;
1044 SV *sv;
1045 #ifdef HAVE_SANDBOX
1046 SV *safe;
1047 #endif
1048
1049 script = (char *)script_get(eap, eap->arg);
1050 if (eap->skip)
1051 {
1052 vim_free(script);
1053 return;
1054 }
1055
1056 if (perl_interp == NULL)
1057 {
1058 #ifdef DYNAMIC_PERL
1059 if (!perl_enabled(TRUE))
1060 {
1061 emsg(_(e_noperl));
1062 vim_free(script);
1063 return;
1064 }
1065 #endif
1066 perl_init();
1067 }
1068
1069 {
1070 dSP;
1071 ENTER;
1072 SAVETMPS;
1073
1074 if (script == NULL)
1075 sv = newSVpv((char *)eap->arg, 0);
1076 else
1077 {
1078 sv = newSVpv(script, 0);
1079 vim_free(script);
1080 }
1081
1082 if (sandbox || secure)
1083 {
1084 safe = perl_get_sv("VIM::safe", FALSE);
1085 # ifndef MAKE_TEST /* avoid a warning for unreachable code */
1086 if (safe == NULL || !SvTRUE(safe))
1087 emsg(_(e_perlsandbox));
1088 else
1089 # endif
1090 {
1091 PUSHMARK(SP);
1092 XPUSHs(safe);
1093 XPUSHs(sv);
1094 PUTBACK;
1095 perl_call_method("reval", G_DISCARD);
1096 }
1097 }
1098 else
1099 perl_eval_sv(sv, G_DISCARD | G_NOARGS);
1100
1101 SvREFCNT_dec(sv);
1102
1103 err = SvPV(GvSV(PL_errgv), length);
1104
1105 FREETMPS;
1106 LEAVE;
1107
1108 if (!length)
1109 return;
1110
1111 msg_split((char_u *)err, highlight_attr[HLF_E]);
1112 return;
1113 }
1114 }
1115
1116 static int
replace_line(linenr_T * line,linenr_T * end)1117 replace_line(linenr_T *line, linenr_T *end)
1118 {
1119 char *str;
1120
1121 if (SvOK(GvSV(PL_defgv)))
1122 {
1123 str = SvPV(GvSV(PL_defgv), PL_na);
1124 ml_replace(*line, (char_u *)str, 1);
1125 changed_bytes(*line, 0);
1126 }
1127 else
1128 {
1129 ml_delete(*line);
1130 deleted_lines_mark(*line, 1L);
1131 --(*end);
1132 --(*line);
1133 }
1134 return OK;
1135 }
1136
1137 static struct ref_map_S {
1138 void *vim_ref;
1139 SV *perl_ref;
1140 struct ref_map_S *next;
1141 } *ref_map = NULL;
1142
1143 static void
ref_map_free(void)1144 ref_map_free(void)
1145 {
1146 struct ref_map_S *tofree;
1147 struct ref_map_S *refs = ref_map;
1148
1149 while (refs) {
1150 tofree = refs;
1151 refs = refs->next;
1152 vim_free(tofree);
1153 }
1154 ref_map = NULL;
1155 }
1156
1157 static struct ref_map_S *
ref_map_find_SV(SV * const sv)1158 ref_map_find_SV(SV *const sv)
1159 {
1160 struct ref_map_S *refs = ref_map;
1161 int count = 350;
1162
1163 while (refs) {
1164 if (refs->perl_ref == sv)
1165 break;
1166 refs = refs->next;
1167 count--;
1168 }
1169
1170 if (!refs && count > 0) {
1171 refs = (struct ref_map_S *)alloc(sizeof(struct ref_map_S));
1172 if (!refs)
1173 return NULL;
1174 refs->perl_ref = sv;
1175 refs->vim_ref = NULL;
1176 refs->next = ref_map;
1177 ref_map = refs;
1178 }
1179
1180 return refs;
1181 }
1182
1183 static int
perl_to_vim(SV * sv,typval_T * rettv)1184 perl_to_vim(SV *sv, typval_T *rettv)
1185 {
1186 if (SvROK(sv))
1187 sv = SvRV(sv);
1188
1189 switch (SvTYPE(sv)) {
1190 case SVt_NULL:
1191 break;
1192 case SVt_NV: /* float */
1193 #ifdef FEAT_FLOAT
1194 rettv->v_type = VAR_FLOAT;
1195 rettv->vval.v_float = SvNV(sv);
1196 break;
1197 #endif
1198 case SVt_IV: /* integer */
1199 if (!SvROK(sv)) { /* references should be string */
1200 rettv->vval.v_number = SvIV(sv);
1201 break;
1202 }
1203 /* FALLTHROUGH */
1204 case SVt_PV: /* string */
1205 {
1206 size_t len = 0;
1207 char * str_from = SvPV(sv, len);
1208 char_u *str_to = (char_u*)alloc(
1209 (unsigned)(sizeof(char_u) * (len + 1)));
1210
1211 if (str_to) {
1212 str_to[len] = '\0';
1213
1214 while (len--) {
1215 if (str_from[len] == '\0')
1216 str_to[len] = '\n';
1217 else
1218 str_to[len] = str_from[len];
1219 }
1220 }
1221
1222 rettv->v_type = VAR_STRING;
1223 rettv->vval.v_string = str_to;
1224 break;
1225 }
1226 case SVt_PVAV: /* list */
1227 {
1228 SSize_t size;
1229 listitem_T * item;
1230 SV ** item2;
1231 list_T * list;
1232 struct ref_map_S * refs;
1233
1234 if ((refs = ref_map_find_SV(sv)) == NULL)
1235 return FAIL;
1236
1237 if (refs->vim_ref)
1238 list = (list_T *) refs->vim_ref;
1239 else
1240 {
1241 if ((list = list_alloc()) == NULL)
1242 return FAIL;
1243 refs->vim_ref = list;
1244
1245 for (size = av_len((AV*)sv); size >= 0; size--)
1246 {
1247 if ((item = listitem_alloc()) == NULL)
1248 break;
1249
1250 item->li_tv.v_type = VAR_NUMBER;
1251 item->li_tv.v_lock = 0;
1252 item->li_tv.vval.v_number = 0;
1253 list_insert(list, item, list->lv_first);
1254
1255 item2 = av_fetch((AV *)sv, size, 0);
1256
1257 if (item2 == NULL || *item2 == NULL ||
1258 perl_to_vim(*item2, &item->li_tv) == FAIL)
1259 break;
1260 }
1261 }
1262
1263 rettv_list_set(rettv, list);
1264 break;
1265 }
1266 case SVt_PVHV: /* dictionary */
1267 {
1268 HE * entry;
1269 I32 key_len;
1270 char * key;
1271 dictitem_T * item;
1272 SV * item2;
1273 dict_T * dict;
1274 struct ref_map_S * refs;
1275
1276 if ((refs = ref_map_find_SV(sv)) == NULL)
1277 return FAIL;
1278
1279 if (refs->vim_ref)
1280 dict = (dict_T *) refs->vim_ref;
1281 else
1282 {
1283
1284 if ((dict = dict_alloc()) == NULL)
1285 return FAIL;
1286 refs->vim_ref = dict;
1287
1288 hv_iterinit((HV *)sv);
1289
1290 for (entry = hv_iternext((HV *)sv); entry; entry = hv_iternext((HV *)sv))
1291 {
1292 key_len = 0;
1293 key = hv_iterkey(entry, &key_len);
1294
1295 if (!key || !key_len || strlen(key) < (size_t)key_len) {
1296 semsg("Malformed key Dictionary '%s'", key && *key ? key : "(empty)");
1297 break;
1298 }
1299
1300 if ((item = dictitem_alloc((char_u *)key)) == NULL)
1301 break;
1302 item->di_tv.v_type = VAR_NUMBER;
1303 item->di_tv.vval.v_number = 0;
1304
1305 if (dict_add(dict, item) == FAIL) {
1306 dictitem_free(item);
1307 break;
1308 }
1309 item2 = hv_iterval((HV *)sv, entry);
1310 if (item2 == NULL || perl_to_vim(item2, &item->di_tv) == FAIL)
1311 break;
1312 }
1313 }
1314
1315 rettv_dict_set(rettv, dict);
1316 break;
1317 }
1318 default: /* not convertible */
1319 {
1320 char *val = SvPV_nolen(sv);
1321 rettv->v_type = VAR_STRING;
1322 rettv->vval.v_string = val ? vim_strsave((char_u *)val) : NULL;
1323 break;
1324 }
1325 }
1326 return OK;
1327 }
1328
1329 /*
1330 * "perleval()"
1331 */
1332 void
do_perleval(char_u * str,typval_T * rettv)1333 do_perleval(char_u *str, typval_T *rettv)
1334 {
1335 char *err = NULL;
1336 STRLEN err_len = 0;
1337 SV *sv = NULL;
1338 #ifdef HAVE_SANDBOX
1339 SV *safe;
1340 #endif
1341
1342 if (perl_interp == NULL)
1343 {
1344 #ifdef DYNAMIC_PERL
1345 if (!perl_enabled(TRUE))
1346 {
1347 emsg(_(e_noperl));
1348 return;
1349 }
1350 #endif
1351 perl_init();
1352 }
1353
1354 {
1355 dSP;
1356 ENTER;
1357 SAVETMPS;
1358
1359 if (sandbox || secure)
1360 {
1361 safe = get_sv("VIM::safe", FALSE);
1362 # ifndef MAKE_TEST /* avoid a warning for unreachable code */
1363 if (safe == NULL || !SvTRUE(safe))
1364 emsg(_(e_perlsandbox));
1365 else
1366 # endif
1367 {
1368 sv = newSVpv((char *)str, 0);
1369 PUSHMARK(SP);
1370 XPUSHs(safe);
1371 XPUSHs(sv);
1372 PUTBACK;
1373 call_method("reval", G_SCALAR);
1374 SPAGAIN;
1375 SvREFCNT_dec(sv);
1376 sv = POPs;
1377 }
1378 }
1379 else
1380 sv = eval_pv((char *)str, 0);
1381
1382 if (sv) {
1383 perl_to_vim(sv, rettv);
1384 ref_map_free();
1385 err = SvPV(GvSV(PL_errgv), err_len);
1386 }
1387 PUTBACK;
1388 FREETMPS;
1389 LEAVE;
1390 }
1391 if (err_len)
1392 msg_split((char_u *)err, highlight_attr[HLF_E]);
1393 }
1394
1395 /*
1396 * ":perldo".
1397 */
1398 void
ex_perldo(exarg_T * eap)1399 ex_perldo(exarg_T *eap)
1400 {
1401 STRLEN length;
1402 SV *sv;
1403 char *str;
1404 linenr_T i;
1405 buf_T *was_curbuf = curbuf;
1406
1407 if (BUFEMPTY())
1408 return;
1409
1410 if (perl_interp == NULL)
1411 {
1412 #ifdef DYNAMIC_PERL
1413 if (!perl_enabled(TRUE))
1414 {
1415 emsg(_(e_noperl));
1416 return;
1417 }
1418 #endif
1419 perl_init();
1420 }
1421 {
1422 dSP;
1423 length = strlen((char *)eap->arg);
1424 sv = newSV(length + sizeof("sub VIM::perldo {") - 1 + 1);
1425 sv_setpvn(sv, "sub VIM::perldo {", sizeof("sub VIM::perldo {") - 1);
1426 sv_catpvn(sv, (char *)eap->arg, length);
1427 sv_catpvn(sv, "}", 1);
1428 perl_eval_sv(sv, G_DISCARD | G_NOARGS);
1429 SvREFCNT_dec(sv);
1430 str = SvPV(GvSV(PL_errgv), length);
1431 if (length)
1432 goto err;
1433
1434 if (u_save(eap->line1 - 1, eap->line2 + 1) != OK)
1435 return;
1436
1437 ENTER;
1438 SAVETMPS;
1439 for (i = eap->line1; i <= eap->line2; i++)
1440 {
1441 /* Check the line number, the command my have deleted lines. */
1442 if (i > curbuf->b_ml.ml_line_count)
1443 break;
1444 sv_setpv(GvSV(PL_defgv), (char *)ml_get(i));
1445 PUSHMARK(sp);
1446 perl_call_pv("VIM::perldo", G_SCALAR | G_EVAL);
1447 str = SvPV(GvSV(PL_errgv), length);
1448 if (length || curbuf != was_curbuf)
1449 break;
1450 SPAGAIN;
1451 if (SvTRUEx(POPs))
1452 {
1453 if (replace_line(&i, &eap->line2) != OK)
1454 {
1455 PUTBACK;
1456 break;
1457 }
1458 }
1459 PUTBACK;
1460 }
1461 FREETMPS;
1462 LEAVE;
1463 check_cursor();
1464 update_screen(NOT_VALID);
1465 if (!length)
1466 return;
1467
1468 err:
1469 msg_split((char_u *)str, highlight_attr[HLF_E]);
1470 return;
1471 }
1472 }
1473
1474 #if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
1475 typedef struct {
1476 struct _PerlIO base;
1477 int attr;
1478 } PerlIOVim;
1479
1480 static IV
PerlIOVim_pushed(pTHX_ PerlIO * f,const char * mode,SV * arg,PerlIO_funcs * tab)1481 PerlIOVim_pushed(pTHX_ PerlIO *f, const char *mode,
1482 SV *arg, PerlIO_funcs *tab)
1483 {
1484 PerlIOVim *s = PerlIOSelf(f, PerlIOVim);
1485 s->attr = 0;
1486 if (arg && SvPOK(arg))
1487 s->attr = syn_name2attr((char_u *)SvPV_nolen(arg));
1488 return PerlIOBase_pushed(aTHX_ f, mode, (SV *)NULL, tab);
1489 }
1490
1491 static SSize_t
PerlIOVim_write(pTHX_ PerlIO * f,const void * vbuf,Size_t count)1492 PerlIOVim_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
1493 {
1494 char_u *str;
1495 PerlIOVim * s = PerlIOSelf(f, PerlIOVim);
1496
1497 str = vim_strnsave((char_u *)vbuf, count);
1498 if (str == NULL)
1499 return 0;
1500 msg_split((char_u *)str, s->attr);
1501 vim_free(str);
1502
1503 return (SSize_t)count;
1504 }
1505
1506 static PERLIO_FUNCS_DECL(PerlIO_Vim) = {
1507 sizeof(PerlIO_funcs),
1508 "Vim",
1509 sizeof(PerlIOVim),
1510 PERLIO_K_DUMMY, /* flags */
1511 PerlIOVim_pushed,
1512 NULL, /* popped */
1513 NULL, /* open */
1514 NULL, /* binmode */
1515 NULL, /* arg */
1516 NULL, /* fileno */
1517 NULL, /* dup */
1518 NULL, /* read */
1519 NULL, /* unread */
1520 PerlIOVim_write,
1521 NULL, /* seek */
1522 NULL, /* tell */
1523 NULL, /* close */
1524 NULL, /* flush */
1525 NULL, /* fill */
1526 NULL, /* eof */
1527 NULL, /* error */
1528 NULL, /* clearerr */
1529 NULL, /* setlinebuf */
1530 NULL, /* get_base */
1531 NULL, /* get_bufsiz */
1532 NULL, /* get_ptr */
1533 NULL, /* get_cnt */
1534 NULL /* set_ptrcnt */
1535 };
1536
1537 /* Use Vim routine for print operator */
1538 static void
vim_IOLayer_init(void)1539 vim_IOLayer_init(void)
1540 {
1541 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_Vim));
1542 (void)eval_pv( "binmode(STDOUT, ':Vim')"
1543 " && binmode(STDERR, ':Vim(ErrorMsg)');", 0);
1544 }
1545 #endif /* PERLIO_LAYERS && !USE_SFIO */
1546
1547 XS(boot_VIM);
1548
1549 static void
xs_init(pTHX)1550 xs_init(pTHX)
1551 {
1552 char *file = __FILE__;
1553
1554 /* DynaLoader is a special case */
1555 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1556 newXS("VIM::bootstrap", boot_VIM, file);
1557 }
1558
1559 typedef win_T * VIWIN;
1560 typedef buf_T * VIBUF;
1561
1562 MODULE = VIM PACKAGE = VIM
1563
1564 void
1565 Msg(text, hl=NULL)
1566 char *text;
1567 char *hl;
1568
1569 PREINIT:
1570 int attr;
1571
1572 PPCODE:
1573 if (text != NULL)
1574 {
1575 attr = 0;
1576 if (hl != NULL)
1577 attr = syn_name2attr((char_u *)hl);
1578 msg_split((char_u *)text, attr);
1579 }
1580
1581 void
1582 SetOption(line)
1583 char *line;
1584
1585 PPCODE:
1586 if (line != NULL)
1587 do_set((char_u *)line, 0);
1588 update_screen(NOT_VALID);
1589
1590 void
1591 DoCommand(line)
1592 char *line;
1593
1594 PPCODE:
1595 if (line != NULL)
1596 do_cmdline_cmd((char_u *)line);
1597
1598 void
1599 Eval(str)
1600 char *str;
1601
1602 PREINIT:
1603 char_u *value;
1604 PPCODE:
1605 value = eval_to_string((char_u *)str, TRUE);
1606 if (value == NULL)
1607 {
1608 XPUSHs(sv_2mortal(newSViv(0)));
1609 XPUSHs(sv_2mortal(newSVpv("", 0)));
1610 }
1611 else
1612 {
1613 XPUSHs(sv_2mortal(newSViv(1)));
1614 XPUSHs(sv_2mortal(newSVpv((char *)value, 0)));
1615 vim_free(value);
1616 }
1617
1618 SV*
1619 Blob(SV* sv)
1620 PREINIT:
1621 STRLEN len;
1622 char *s;
1623 unsigned i;
1624 char buf[3];
1625 SV* newsv;
1626
1627 CODE:
1628 s = SvPVbyte(sv, len);
1629 newsv = newSVpv("0z", 2);
1630 for (i = 0; i < len; i++)
1631 {
1632 sprintf(buf, "%02X", (unsigned char)(s[i]));
1633 sv_catpvn(newsv, buf, 2);
1634 }
1635 RETVAL = newsv;
1636 OUTPUT:
1637 RETVAL
1638
1639 void
1640 Buffers(...)
1641
1642 PREINIT:
1643 buf_T *vimbuf;
1644 int i, b;
1645
1646 PPCODE:
1647 if (items == 0)
1648 {
1649 if (GIMME == G_SCALAR)
1650 {
1651 i = 0;
1652 FOR_ALL_BUFFERS(vimbuf)
1653 ++i;
1654
1655 XPUSHs(sv_2mortal(newSViv(i)));
1656 }
1657 else
1658 {
1659 FOR_ALL_BUFFERS(vimbuf)
1660 XPUSHs(sv_2mortal(newBUFrv(newSV(0), vimbuf)));
1661 }
1662 }
1663 else
1664 {
1665 for (i = 0; i < items; i++)
1666 {
1667 SV *sv = ST(i);
1668 if (SvIOK(sv))
1669 b = (int) SvIV(ST(i));
1670 else
1671 {
1672 char_u *pat;
1673 STRLEN len;
1674
1675 pat = (char_u *)SvPV(sv, len);
1676 ++emsg_off;
1677 b = buflist_findpat(pat, pat + len, TRUE, FALSE, FALSE);
1678 --emsg_off;
1679 }
1680
1681 if (b >= 0)
1682 {
1683 vimbuf = buflist_findnr(b);
1684 if (vimbuf)
1685 XPUSHs(sv_2mortal(newBUFrv(newSV(0), vimbuf)));
1686 }
1687 }
1688 }
1689
1690 void
1691 Windows(...)
1692
1693 PREINIT:
1694 win_T *vimwin;
1695 int i, w;
1696
1697 PPCODE:
1698 if (items == 0)
1699 {
1700 if (GIMME == G_SCALAR)
1701 XPUSHs(sv_2mortal(newSViv(win_count())));
1702 else
1703 {
1704 FOR_ALL_WINDOWS(vimwin)
1705 XPUSHs(sv_2mortal(newWINrv(newSV(0), vimwin)));
1706 }
1707 }
1708 else
1709 {
1710 for (i = 0; i < items; i++)
1711 {
1712 w = (int) SvIV(ST(i));
1713 vimwin = win_find_nr(w);
1714 if (vimwin)
1715 XPUSHs(sv_2mortal(newWINrv(newSV(0), vimwin)));
1716 }
1717 }
1718
1719 MODULE = VIM PACKAGE = VIWIN
1720
1721 void
1722 DESTROY(win)
1723 VIWIN win
1724
1725 CODE:
1726 if (win_valid(win))
1727 win->w_perl_private = 0;
1728
1729 SV *
1730 Buffer(win)
1731 VIWIN win
1732
1733 CODE:
1734 if (!win_valid(win))
1735 win = curwin;
1736 RETVAL = newBUFrv(newSV(0), win->w_buffer);
1737 OUTPUT:
1738 RETVAL
1739
1740 void
1741 SetHeight(win, height)
1742 VIWIN win
1743 int height;
1744
1745 PREINIT:
1746 win_T *savewin;
1747
1748 PPCODE:
1749 if (!win_valid(win))
1750 win = curwin;
1751 savewin = curwin;
1752 curwin = win;
1753 win_setheight(height);
1754 curwin = savewin;
1755
1756 void
1757 Cursor(win, ...)
1758 VIWIN win
1759
1760 PPCODE:
1761 if (items == 1)
1762 {
1763 EXTEND(sp, 2);
1764 if (!win_valid(win))
1765 win = curwin;
1766 PUSHs(sv_2mortal(newSViv(win->w_cursor.lnum)));
1767 PUSHs(sv_2mortal(newSViv(win->w_cursor.col)));
1768 }
1769 else if (items == 3)
1770 {
1771 int lnum, col;
1772
1773 if (!win_valid(win))
1774 win = curwin;
1775 lnum = (int) SvIV(ST(1));
1776 col = (int) SvIV(ST(2));
1777 win->w_cursor.lnum = lnum;
1778 win->w_cursor.col = col;
1779 win->w_set_curswant = TRUE;
1780 check_cursor(); /* put cursor on an existing line */
1781 update_screen(NOT_VALID);
1782 }
1783
1784 MODULE = VIM PACKAGE = VIBUF
1785
1786 void
1787 DESTROY(vimbuf)
1788 VIBUF vimbuf;
1789
1790 CODE:
1791 if (buf_valid(vimbuf))
1792 vimbuf->b_perl_private = 0;
1793
1794 void
1795 Name(vimbuf)
1796 VIBUF vimbuf;
1797
1798 PPCODE:
1799 if (!buf_valid(vimbuf))
1800 vimbuf = curbuf;
1801 /* No file name returns an empty string */
1802 if (vimbuf->b_fname == NULL)
1803 XPUSHs(sv_2mortal(newSVpv("", 0)));
1804 else
1805 XPUSHs(sv_2mortal(newSVpv((char *)vimbuf->b_fname, 0)));
1806
1807 void
1808 Number(vimbuf)
1809 VIBUF vimbuf;
1810
1811 PPCODE:
1812 if (!buf_valid(vimbuf))
1813 vimbuf = curbuf;
1814 XPUSHs(sv_2mortal(newSViv(vimbuf->b_fnum)));
1815
1816 void
1817 Count(vimbuf)
1818 VIBUF vimbuf;
1819
1820 PPCODE:
1821 if (!buf_valid(vimbuf))
1822 vimbuf = curbuf;
1823 XPUSHs(sv_2mortal(newSViv(vimbuf->b_ml.ml_line_count)));
1824
1825 void
1826 Get(vimbuf, ...)
1827 VIBUF vimbuf;
1828
1829 PREINIT:
1830 char_u *line;
1831 int i;
1832 long lnum;
1833 PPCODE:
1834 if (buf_valid(vimbuf))
1835 {
1836 for (i = 1; i < items; i++)
1837 {
1838 lnum = (long) SvIV(ST(i));
1839 if (lnum > 0 && lnum <= vimbuf->b_ml.ml_line_count)
1840 {
1841 line = ml_get_buf(vimbuf, lnum, FALSE);
1842 XPUSHs(sv_2mortal(newSVpv((char *)line, 0)));
1843 }
1844 }
1845 }
1846
1847 void
1848 Set(vimbuf, ...)
1849 VIBUF vimbuf;
1850
1851 PREINIT:
1852 int i;
1853 long lnum;
1854 char *line;
1855 PPCODE:
1856 if (buf_valid(vimbuf))
1857 {
1858 if (items < 3)
1859 croak("Usage: VIBUF::Set(vimbuf, lnum, @lines)");
1860
1861 lnum = (long) SvIV(ST(1));
1862 for(i = 2; i < items; i++, lnum++)
1863 {
1864 line = SvPV(ST(i),PL_na);
1865 if (lnum > 0 && lnum <= vimbuf->b_ml.ml_line_count && line != NULL)
1866 {
1867 aco_save_T aco;
1868
1869 /* set curwin/curbuf for "vimbuf" and save some things */
1870 aucmd_prepbuf(&aco, vimbuf);
1871
1872 if (u_savesub(lnum) == OK)
1873 {
1874 ml_replace(lnum, (char_u *)line, TRUE);
1875 changed_bytes(lnum, 0);
1876 }
1877
1878 /* restore curwin/curbuf and a few other things */
1879 aucmd_restbuf(&aco);
1880 /* Careful: autocommands may have made "vimbuf" invalid! */
1881 }
1882 }
1883 }
1884
1885 void
1886 Delete(vimbuf, ...)
1887 VIBUF vimbuf;
1888
1889 PREINIT:
1890 long i, lnum = 0, count = 0;
1891 PPCODE:
1892 if (buf_valid(vimbuf))
1893 {
1894 if (items == 2)
1895 {
1896 lnum = (long) SvIV(ST(1));
1897 count = 1;
1898 }
1899 else if (items == 3)
1900 {
1901 lnum = (long) SvIV(ST(1));
1902 count = (long) 1 + SvIV(ST(2)) - lnum;
1903 if (count == 0)
1904 count = 1;
1905 if (count < 0)
1906 {
1907 lnum -= count;
1908 count = -count;
1909 }
1910 }
1911 if (items >= 2)
1912 {
1913 for (i = 0; i < count; i++)
1914 {
1915 if (lnum > 0 && lnum <= vimbuf->b_ml.ml_line_count)
1916 {
1917 aco_save_T aco;
1918
1919 /* set curwin/curbuf for "vimbuf" and save some things */
1920 aucmd_prepbuf(&aco, vimbuf);
1921
1922 if (u_savedel(lnum, 1) == OK)
1923 {
1924 ml_delete(lnum);
1925 check_cursor();
1926 deleted_lines_mark(lnum, 1L);
1927 }
1928
1929 /* restore curwin/curbuf and a few other things */
1930 aucmd_restbuf(&aco);
1931 /* Careful: autocommands may have made "vimbuf" invalid! */
1932
1933 update_curbuf(VALID);
1934 }
1935 }
1936 }
1937 }
1938
1939 void
1940 Append(vimbuf, ...)
1941 VIBUF vimbuf;
1942
1943 PREINIT:
1944 int i;
1945 long lnum;
1946 char *line;
1947 PPCODE:
1948 if (buf_valid(vimbuf))
1949 {
1950 if (items < 3)
1951 croak("Usage: VIBUF::Append(vimbuf, lnum, @lines)");
1952
1953 lnum = (long) SvIV(ST(1));
1954 for (i = 2; i < items; i++, lnum++)
1955 {
1956 line = SvPV(ST(i),PL_na);
1957 if (lnum >= 0 && lnum <= vimbuf->b_ml.ml_line_count && line != NULL)
1958 {
1959 aco_save_T aco;
1960
1961 /* set curwin/curbuf for "vimbuf" and save some things */
1962 aucmd_prepbuf(&aco, vimbuf);
1963
1964 if (u_inssub(lnum + 1) == OK)
1965 {
1966 ml_append(lnum, (char_u *)line, (colnr_T)0, FALSE);
1967 appended_lines_mark(lnum, 1L);
1968 }
1969
1970 /* restore curwin/curbuf and a few other things */
1971 aucmd_restbuf(&aco);
1972 /* Careful: autocommands may have made "vimbuf" invalid! */
1973
1974 update_curbuf(VALID);
1975 }
1976 }
1977 }
1978
1979 #ifdef __GNUC__
1980 # pragma GCC diagnostic pop
1981 #endif
1982