diff options
Diffstat (limited to 'src/if_perl.xs')
| -rw-r--r-- | src/if_perl.xs | 1150 |
1 files changed, 1150 insertions, 0 deletions
diff --git a/src/if_perl.xs b/src/if_perl.xs new file mode 100644 index 000000000..96608ef6b --- /dev/null +++ b/src/if_perl.xs @@ -0,0 +1,1150 @@ +/* vi:set ts=8 sts=4 sw=4: + * + * VIM - Vi IMproved by Bram Moolenaar + * + * Do ":help uganda" in Vim to read copying and usage conditions. + * Do ":help credits" in Vim to see a list of people who contributed. + */ +/* + * if_perl.xs: Main code for Perl interface support. + * Mostly written by Sven Verdoolaege. + */ + +#define _memory_h /* avoid memset redeclaration */ +#define IN_PERL_FILE /* don't include if_perl.pro from proto.h */ + +#include "vim.h" + + +/* + * Work around clashes between Perl and Vim namespace. proto.h doesn't + * include if_perl.pro and perlsfio.pro when IN_PERL_FILE is defined, because + * we need the CV typedef. proto.h can't be moved to after including + * if_perl.h, because we get all sorts of name clashes then. + */ +#ifndef PROTO +#ifndef __MINGW32__ +# include "proto/if_perl.pro" +# include "proto/if_perlsfio.pro" +#endif +#endif + +/* Perl compatibility stuff. This should ensure compatibility with older + * versions of Perl. + */ + +#ifndef PERL_VERSION +# include <patchlevel.h> +# define PERL_REVISION 5 +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION +#endif + +#ifndef pTHX +# define pTHX void +# define pTHX_ +#endif + +#ifndef EXTERN_C +# define EXTERN_C +#endif + +/* Compatibility hacks over */ + +static PerlInterpreter *perl_interp = NULL; +static void xs_init __ARGS((pTHX)); +static void VIM_init __ARGS((void)); +EXTERN_C void boot_DynaLoader __ARGS((pTHX_ CV*)); + +/* + * For dynamic linked perl. (Windows) + */ +#if defined(DYNAMIC_PERL) || defined(PROTO) +/* + * Wrapper defines + */ +# define perl_alloc dll_perl_alloc +# define perl_construct dll_perl_construct +# define perl_parse dll_perl_parse +# define perl_run dll_perl_run +# define perl_destruct dll_perl_destruct +# define perl_free dll_perl_free +# define Perl_get_context dll_Perl_get_context +# define Perl_croak dll_Perl_croak +# ifndef PROTO +# define Perl_croak_nocontext dll_Perl_croak_nocontext +# define Perl_call_argv dll_Perl_call_argv +# define Perl_call_pv dll_Perl_call_pv +# define Perl_eval_sv dll_Perl_eval_sv +# define Perl_get_sv dll_Perl_get_sv +# define Perl_eval_pv dll_Perl_eval_pv +# define Perl_call_method dll_Perl_call_method +# endif +# define Perl_dowantarray dll_Perl_dowantarray +# define Perl_free_tmps dll_Perl_free_tmps +# define Perl_gv_stashpv dll_Perl_gv_stashpv +# define Perl_markstack_grow dll_Perl_markstack_grow +# define Perl_mg_find dll_Perl_mg_find +# define Perl_newXS dll_Perl_newXS +# define Perl_newSV dll_Perl_newSV +# define Perl_newSViv dll_Perl_newSViv +# define Perl_newSVpv dll_Perl_newSVpv +# define Perl_pop_scope dll_Perl_pop_scope +# define Perl_push_scope dll_Perl_push_scope +# define Perl_save_int dll_Perl_save_int +# define Perl_stack_grow dll_Perl_stack_grow +# define Perl_set_context dll_Perl_set_context +# define Perl_sv_2bool dll_Perl_sv_2bool +# define Perl_sv_2iv dll_Perl_sv_2iv +# define Perl_sv_2mortal dll_Perl_sv_2mortal +# if (PERL_REVISION == 5) && (PERL_VERSION >= 8) +# define Perl_sv_2pv_flags dll_Perl_sv_2pv_flags +# define Perl_sv_2pv_nolen dll_Perl_sv_2pv_nolen +# else +# define Perl_sv_2pv dll_Perl_sv_2pv +# endif +# define Perl_sv_bless dll_Perl_sv_bless +# if (PERL_REVISION == 5) && (PERL_VERSION >= 8) +# define Perl_sv_catpvn_flags dll_Perl_sv_catpvn_flags +# else +# define Perl_sv_catpvn dll_Perl_sv_catpvn +# endif +# define Perl_sv_free dll_Perl_sv_free +# define Perl_sv_isa dll_Perl_sv_isa +# define Perl_sv_magic dll_Perl_sv_magic +# define Perl_sv_setiv dll_Perl_sv_setiv +# define Perl_sv_setpv dll_Perl_sv_setpv +# define Perl_sv_setpvn dll_Perl_sv_setpvn +# if (PERL_REVISION == 5) && (PERL_VERSION >= 8) +# define Perl_sv_setsv_flags dll_Perl_sv_setsv_flags +# else +# define Perl_sv_setsv dll_Perl_sv_setsv +# endif +# define Perl_sv_upgrade dll_Perl_sv_upgrade +# define Perl_Tstack_sp_ptr dll_Perl_Tstack_sp_ptr +# define Perl_Top_ptr dll_Perl_Top_ptr +# define Perl_Tstack_base_ptr dll_Perl_Tstack_base_ptr +# define Perl_Tstack_max_ptr dll_Perl_Tstack_max_ptr +# define Perl_Ttmps_ix_ptr dll_Perl_Ttmps_ix_ptr +# define Perl_Ttmps_floor_ptr dll_Perl_Ttmps_floor_ptr +# define Perl_Tmarkstack_ptr_ptr dll_Perl_Tmarkstack_ptr_ptr +# define Perl_Tmarkstack_max_ptr dll_Perl_Tmarkstack_max_ptr +# define Perl_TSv_ptr dll_Perl_TSv_ptr +# define Perl_TXpv_ptr dll_Perl_TXpv_ptr +# define Perl_Tna_ptr dll_Perl_Tna_ptr +# define Perl_Idefgv_ptr dll_Perl_Idefgv_ptr +# define Perl_Ierrgv_ptr dll_Perl_Ierrgv_ptr +# define Perl_Isv_yes_ptr dll_Perl_Isv_yes_ptr +# define boot_DynaLoader dll_boot_DynaLoader + +#ifndef DYNAMIC_PERL /* just generating prototypes */ +typedef int HANDLE; +typedef int XSINIT_t; +typedef int XSUBADDR_t; +#endif + +/* + * Declare HANDLE for perl.dll and function pointers. + */ +static HANDLE hPerlLib = NULL; + +static PerlInterpreter* (*perl_alloc)(); +static void (*perl_construct)(PerlInterpreter*); +static void (*perl_destruct)(PerlInterpreter*); +static void (*perl_free)(PerlInterpreter*); +static int (*perl_run)(PerlInterpreter*); +static int (*perl_parse)(PerlInterpreter*, XSINIT_t, int, char**, char**); +static void* (*Perl_get_context)(void); +static void (*Perl_croak)(pTHX_ const char*, ...) __attribute__((noreturn)); +static void (*Perl_croak_nocontext)(const char*, ...) __attribute__((noreturn)); +static I32 (*Perl_dowantarray)(pTHX); +static void (*Perl_free_tmps)(pTHX); +static HV* (*Perl_gv_stashpv)(pTHX_ const char*, I32); +static void (*Perl_markstack_grow)(pTHX); +static MAGIC* (*Perl_mg_find)(pTHX_ SV*, int); +static CV* (*Perl_newXS)(pTHX_ char*, XSUBADDR_t, char*); +static SV* (*Perl_newSV)(pTHX_ STRLEN); +static SV* (*Perl_newSViv)(pTHX_ IV); +static SV* (*Perl_newSVpv)(pTHX_ const char*, STRLEN); +static I32 (*Perl_call_argv)(pTHX_ const char*, I32, char**); +static I32 (*Perl_call_pv)(pTHX_ const char*, I32); +static I32 (*Perl_eval_sv)(pTHX_ SV*, I32); +static SV* (*Perl_get_sv)(pTHX_ const char*, I32); +static SV* (*Perl_eval_pv)(pTHX_ const char*, I32); +static SV* (*Perl_call_method)(pTHX_ const char*, I32); +static void (*Perl_pop_scope)(pTHX); +static void (*Perl_push_scope)(pTHX); +static void (*Perl_save_int)(pTHX_ int*); +static SV** (*Perl_stack_grow)(pTHX_ SV**, SV**p, int); +static SV** (*Perl_set_context)(void*); +static bool (*Perl_sv_2bool)(pTHX_ SV*); +static IV (*Perl_sv_2iv)(pTHX_ SV*); +static SV* (*Perl_sv_2mortal)(pTHX_ SV*); +#if (PERL_REVISION == 5) && (PERL_VERSION >= 8) +static char* (*Perl_sv_2pv_flags)(pTHX_ SV*, STRLEN*, I32); +static char* (*Perl_sv_2pv_nolen)(pTHX_ SV*); +#else +static char* (*Perl_sv_2pv)(pTHX_ SV*, STRLEN*); +#endif +static SV* (*Perl_sv_bless)(pTHX_ SV*, HV*); +#if (PERL_REVISION == 5) && (PERL_VERSION >= 8) +static void (*Perl_sv_catpvn_flags)(pTHX_ SV* , const char*, STRLEN, I32); +#else +static void (*Perl_sv_catpvn)(pTHX_ SV*, const char*, STRLEN); +#endif +static void (*Perl_sv_free)(pTHX_ SV*); +static int (*Perl_sv_isa)(pTHX_ SV*, const char*); +static void (*Perl_sv_magic)(pTHX_ SV*, SV*, int, const char*, I32); +static void (*Perl_sv_setiv)(pTHX_ SV*, IV); +static void (*Perl_sv_setpv)(pTHX_ SV*, const char*); +static void (*Perl_sv_setpvn)(pTHX_ SV*, const char*, STRLEN); +#if (PERL_REVISION == 5) && (PERL_VERSION >= 8) +static void (*Perl_sv_setsv_flags)(pTHX_ SV*, SV*, I32); +#else +static void (*Perl_sv_setsv)(pTHX_ SV*, SV*); +#endif +static bool (*Perl_sv_upgrade)(pTHX_ SV*, U32); +static SV*** (*Perl_Tstack_sp_ptr)(register PerlInterpreter*); +static OP** (*Perl_Top_ptr)(register PerlInterpreter*); +static SV*** (*Perl_Tstack_base_ptr)(register PerlInterpreter*); +static SV*** (*Perl_Tstack_max_ptr)(register PerlInterpreter*); +static I32* (*Perl_Ttmps_ix_ptr)(register PerlInterpreter*); +static I32* (*Perl_Ttmps_floor_ptr)(register PerlInterpreter*); +static I32** (*Perl_Tmarkstack_ptr_ptr)(register PerlInterpreter*); +static I32** (*Perl_Tmarkstack_max_ptr)(register PerlInterpreter*); +static SV** (*Perl_TSv_ptr)(register PerlInterpreter*); +static XPV** (*Perl_TXpv_ptr)(register PerlInterpreter*); +static STRLEN* (*Perl_Tna_ptr)(register PerlInterpreter*); +static GV** (*Perl_Idefgv_ptr)(register PerlInterpreter*); +static GV** (*Perl_Ierrgv_ptr)(register PerlInterpreter*); +static SV* (*Perl_Isv_yes_ptr)(register PerlInterpreter*); +static void (*boot_DynaLoader)_((pTHX_ CV*)); + + +/* + * Table of name to function pointer of perl. + */ +#define PERL_PROC FARPROC +static struct { + char* name; + PERL_PROC* ptr; +} perl_funcname_table[] = { + {"perl_alloc", (PERL_PROC*)&perl_alloc}, + {"perl_construct", (PERL_PROC*)&perl_construct}, + {"perl_destruct", (PERL_PROC*)&perl_destruct}, + {"perl_free", (PERL_PROC*)&perl_free}, + {"perl_run", (PERL_PROC*)&perl_run}, + {"perl_parse", (PERL_PROC*)&perl_parse}, + {"Perl_get_context", (PERL_PROC*)&Perl_get_context}, + {"Perl_croak", (PERL_PROC*)&Perl_croak}, + {"Perl_croak_nocontext", (PERL_PROC*)&Perl_croak_nocontext}, + {"Perl_dowantarray", (PERL_PROC*)&Perl_dowantarray}, + {"Perl_free_tmps", (PERL_PROC*)&Perl_free_tmps}, + {"Perl_gv_stashpv", (PERL_PROC*)&Perl_gv_stashpv}, + {"Perl_markstack_grow", (PERL_PROC*)&Perl_markstack_grow}, + {"Perl_mg_find", (PERL_PROC*)&Perl_mg_find}, + {"Perl_newXS", (PERL_PROC*)&Perl_newXS}, + {"Perl_newSV", (PERL_PROC*)&Perl_newSV}, + {"Perl_newSViv", (PERL_PROC*)&Perl_newSViv}, + {"Perl_newSVpv", (PERL_PROC*)&Perl_newSVpv}, + {"Perl_call_argv", (PERL_PROC*)&Perl_call_argv}, + {"Perl_call_pv", (PERL_PROC*)&Perl_call_pv}, + {"Perl_eval_sv", (PERL_PROC*)&Perl_eval_sv}, + {"Perl_get_sv", (PERL_PROC*)&Perl_get_sv}, + {"Perl_eval_pv", (PERL_PROC*)&Perl_eval_pv}, + {"Perl_call_method", (PERL_PROC*)&Perl_call_method}, + {"Perl_pop_scope", (PERL_PROC*)&Perl_pop_scope}, + {"Perl_push_scope", (PERL_PROC*)&Perl_push_scope}, + {"Perl_save_int", (PERL_PROC*)&Perl_save_int}, + {"Perl_stack_grow", (PERL_PROC*)&Perl_stack_grow}, + {"Perl_set_context", (PERL_PROC*)&Perl_set_context}, + {"Perl_sv_2bool", (PERL_PROC*)&Perl_sv_2bool}, + {"Perl_sv_2iv", (PERL_PROC*)&Perl_sv_2iv}, + {"Perl_sv_2mortal", (PERL_PROC*)&Perl_sv_2mortal}, +#if (PERL_REVISION == 5) && (PERL_VERSION >= 8) + {"Perl_sv_2pv_flags", (PERL_PROC*)&Perl_sv_2pv_flags}, + {"Perl_sv_2pv_nolen", (PERL_PROC*)&Perl_sv_2pv_nolen}, +#else + {"Perl_sv_2pv", (PERL_PROC*)&Perl_sv_2pv}, +#endif + {"Perl_sv_bless", (PERL_PROC*)&Perl_sv_bless}, +#if (PERL_REVISION == 5) && (PERL_VERSION >= 8) + {"Perl_sv_catpvn_flags", (PERL_PROC*)&Perl_sv_catpvn_flags}, +#else + {"Perl_sv_catpvn", (PERL_PROC*)&Perl_sv_catpvn}, +#endif + {"Perl_sv_free", (PERL_PROC*)&Perl_sv_free}, + {"Perl_sv_isa", (PERL_PROC*)&Perl_sv_isa}, + {"Perl_sv_magic", (PERL_PROC*)&Perl_sv_magic}, + {"Perl_sv_setiv", (PERL_PROC*)&Perl_sv_setiv}, + {"Perl_sv_setpv", (PERL_PROC*)&Perl_sv_setpv}, + {"Perl_sv_setpvn", (PERL_PROC*)&Perl_sv_setpvn}, +#if (PERL_REVISION == 5) && (PERL_VERSION >= 8) + {"Perl_sv_setsv_flags", (PERL_PROC*)&Perl_sv_setsv_flags}, +#else + {"Perl_sv_setsv", (PERL_PROC*)&Perl_sv_setsv}, +#endif + {"Perl_sv_upgrade", (PERL_PROC*)&Perl_sv_upgrade}, + {"Perl_Tstack_sp_ptr", (PERL_PROC*)&Perl_Tstack_sp_ptr}, + {"Perl_Top_ptr", (PERL_PROC*)&Perl_Top_ptr}, + {"Perl_Tstack_base_ptr", (PERL_PROC*)&Perl_Tstack_base_ptr}, + {"Perl_Tstack_max_ptr", (PERL_PROC*)&Perl_Tstack_max_ptr}, + {"Perl_Ttmps_ix_ptr", (PERL_PROC*)&Perl_Ttmps_ix_ptr}, + {"Perl_Ttmps_floor_ptr", (PERL_PROC*)&Perl_Ttmps_floor_ptr}, + {"Perl_Tmarkstack_ptr_ptr", (PERL_PROC*)&Perl_Tmarkstack_ptr_ptr}, + {"Perl_Tmarkstack_max_ptr", (PERL_PROC*)&Perl_Tmarkstack_max_ptr}, + {"Perl_TSv_ptr", (PERL_PROC*)&Perl_TSv_ptr}, + {"Perl_TXpv_ptr", (PERL_PROC*)&Perl_TXpv_ptr}, + {"Perl_Tna_ptr", (PERL_PROC*)&Perl_Tna_ptr}, + {"Perl_Idefgv_ptr", (PERL_PROC*)&Perl_Idefgv_ptr}, + {"Perl_Ierrgv_ptr", (PERL_PROC*)&Perl_Ierrgv_ptr}, + {"Perl_Isv_yes_ptr", (PERL_PROC*)&Perl_Isv_yes_ptr}, + {"boot_DynaLoader", (PERL_PROC*)&boot_DynaLoader}, + {"", NULL}, +}; + +/* + * Make all runtime-links of perl. + * + * 1. Get module handle using LoadLibraryEx. + * 2. Get pointer to perl function by GetProcAddress. + * 3. Repeat 2, until get all functions will be used. + * + * Parameter 'libname' provides name of DLL. + * Return OK or FAIL. + */ + static int +perl_runtime_link_init(char *libname, int verbose) +{ + int i; + + if (hPerlLib != NULL) + return OK; + if (!(hPerlLib = LoadLibraryEx(libname, NULL, 0))) + { + if (verbose) + EMSG2(_("E370: Could not load library %s"), libname); + return FAIL; + } + for (i = 0; perl_funcname_table[i].ptr; ++i) + { + if (!(*perl_funcname_table[i].ptr = GetProcAddress(hPerlLib, + perl_funcname_table[i].name))) + { + FreeLibrary(hPerlLib); + hPerlLib = NULL; + if (verbose) + EMSG2(_(e_loadfunc), perl_funcname_table[i].name); + return FAIL; + } + } + return OK; +} + +/* + * If runtime-link-perl(DLL) was loaded successfully, return TRUE. + * There were no DLL loaded, return FALSE. + */ + int +perl_enabled(verbose) + int verbose; +{ + return perl_runtime_link_init(DYNAMIC_PERL_DLL, verbose) == OK; +} +#endif /* DYNAMIC_PERL */ + +/* + * perl_init(): initialize perl interpreter + * We have to call perl_parse to initialize some structures, + * there's nothing to actually parse. + */ + static void +perl_init() +{ + char *bootargs[] = { "VI", NULL }; + static char *args[] = { "", "-e", "" }; + + perl_interp = perl_alloc(); + perl_construct(perl_interp); + perl_parse(perl_interp, xs_init, 3, args, 0); + perl_call_argv("VIM::bootstrap", (long)G_DISCARD, bootargs); + VIM_init(); +#ifdef USE_SFIO + sfdisc(PerlIO_stdout(), sfdcnewvim()); + sfdisc(PerlIO_stderr(), sfdcnewvim()); + sfsetbuf(PerlIO_stdout(), NULL, 0); + sfsetbuf(PerlIO_stderr(), NULL, 0); +#endif +} + +/* + * perl_end(): clean up after ourselves + */ + void +perl_end() +{ + if (perl_interp) + { + perl_run(perl_interp); + perl_destruct(perl_interp); + perl_free(perl_interp); + perl_interp = NULL; + } +#ifdef DYNAMIC_PERL + if (hPerlLib) + { + FreeLibrary(hPerlLib); + hPerlLib = NULL; + } +#endif +} + +/* + * msg_split(): send a message to the message handling routines + * split at '\n' first though. + */ + void +msg_split(s, attr) + char_u *s; + int attr; /* highlighting attributes */ +{ + char *next; + char *token = (char *)s; + + while ((next = strchr(token, '\n'))) + { + *next++ = '\0'; /* replace \n with \0 */ + msg_attr((char_u *)token, attr); + token = next; + } + if (*token) + msg_attr((char_u *)token, attr); +} + +#ifndef FEAT_EVAL +/* + * This stub is needed because an "#ifdef FEAT_EVAL" around Eval() doesn't + * work properly. + */ + char_u * +eval_to_string(arg, nextcmd) + char_u *arg; + char_u **nextcmd; +{ + return NULL; +} +#endif + +/* + * Create a new reference to an SV pointing to the SCR structure + * The perl_private part of the SCR structure points to the SV, + * so there can only be one such SV for a particular SCR structure. + * When the last reference has gone (DESTROY is called), + * perl_private is reset; When the screen goes away before + * all references are gone, the value of the SV is reset; + * any subsequent use of any of those reference will produce + * a warning. (see typemap) + */ +#define newANYrv(TYPE, TNAME) \ +static SV * \ +new ## TNAME ## rv(rv, ptr) \ + SV *rv; \ + TYPE *ptr; \ +{ \ + sv_upgrade(rv, SVt_RV); \ + if (!ptr->perl_private) \ + { \ + ptr->perl_private = newSV(0); \ + sv_setiv(ptr->perl_private, (IV)ptr); \ + } \ + else \ + SvREFCNT_inc(ptr->perl_private); \ + SvRV(rv) = ptr->perl_private; \ + SvROK_on(rv); \ + return sv_bless(rv, gv_stashpv("VI" #TNAME, TRUE)); \ +} + +newANYrv(win_T, WIN) +newANYrv(buf_T, BUF) + +/* + * perl_win_free + * Remove all refences to the window to be destroyed + */ + void +perl_win_free(wp) + win_T *wp; +{ + if (wp->perl_private) + sv_setiv((SV *)wp->perl_private, 0); + return; +} + + void +perl_buf_free(bp) + buf_T *bp; +{ + if (bp->perl_private) + sv_setiv((SV *)bp->perl_private, 0); + return; +} + +#ifndef PROTO +# if (PERL_REVISION == 5) && (PERL_VERSION >= 8) +I32 cur_val(pTHX_ IV iv, SV *sv); +# else +I32 cur_val(IV iv, SV *sv); +#endif + +/* + * Handler for the magic variables $main::curwin and $main::curbuf. + * The handler is put into the magic vtbl for these variables. + * (This is effectively a C-level equivalent of a tied variable). + * There is no "set" function as the variables are read-only. + */ +# if (PERL_REVISION == 5) && (PERL_VERSION >= 8) +I32 cur_val(pTHX_ IV iv, SV *sv) +# else +I32 cur_val(IV iv, SV *sv) +# endif +{ + SV *rv; + if (iv == 0) + rv = newWINrv(newSV(0), curwin); + else + rv = newBUFrv(newSV(0), curbuf); + sv_setsv(sv, rv); + return 0; +} +#endif /* !PROTO */ + +struct ufuncs cw_funcs = { cur_val, 0, 0 }; +struct ufuncs cb_funcs = { cur_val, 0, 1 }; + +/* + * VIM_init(): Vim-specific initialisation. + * Make the magical main::curwin and main::curbuf variables + */ + static void +VIM_init() +{ + static char cw[] = "main::curwin"; + static char cb[] = "main::curbuf"; + SV *sv; + + sv = perl_get_sv(cw, TRUE); + sv_magic(sv, NULL, 'U', (char *)&cw_funcs, sizeof(cw_funcs)); + SvREADONLY_on(sv); + + sv = perl_get_sv(cb, TRUE); + sv_magic(sv, NULL, 'U', (char *)&cb_funcs, sizeof(cb_funcs)); + SvREADONLY_on(sv); + + /* + * Setup the Safe compartment. + * It shouldn't be a fatal error if the Safe module is missing. + * XXX: Only shares the 'Msg' routine (which has to be called + * like 'Msg(...)'). + */ + (void)perl_eval_pv( "if ( eval( 'require Safe' ) ) { $VIM::safe = Safe->new(); $VIM::safe->share_from( 'VIM', ['Msg'] ); }", G_DISCARD | G_VOID ); + +} + +#ifdef DYNAMIC_PERL +static char *e_noperl = N_("Sorry, this command is disabled: the Perl library could not be loaded."); +#endif + +/* + * ":perl" + */ + void +ex_perl(eap) + exarg_T *eap; +{ + char *err; + char *script; + STRLEN length; + SV *sv; + SV *safe; + + script = (char *)script_get(eap, eap->arg); + if (eap->skip) + { + vim_free(script); + return; + } + + if (perl_interp == NULL) + { +#ifdef DYNAMIC_PERL + if (!perl_enabled(TRUE)) + { + EMSG(_(e_noperl)); + vim_free(script); + return; + } +#endif + perl_init(); + } + + { + dSP; + ENTER; + SAVETMPS; + + if (script == NULL) + sv = newSVpv((char *)eap->arg, 0); + else + { + sv = newSVpv(script, 0); + vim_free(script); + } + +#ifdef HAVE_SANDBOX + if (sandbox) + { + if ((safe = perl_get_sv( "VIM::safe", FALSE )) == NULL || !SvTRUE(safe)) + EMSG(_("E299: Perl evaluation forbidden in sandbox without the Safe module")); + else + { + PUSHMARK(SP); + XPUSHs(safe); + XPUSHs(sv); + PUTBACK; + perl_call_method("reval", G_DISCARD); + } + } + else +#endif + perl_eval_sv(sv, G_DISCARD | G_NOARGS); + + SvREFCNT_dec(sv); + + err = SvPV(GvSV(PL_errgv), length); + + FREETMPS; + LEAVE; + + if (!length) + return; + + msg_split((char_u *)err, highlight_attr[HLF_E]); + return; + } +} + + static int +replace_line(line, end) + linenr_T *line, *end; +{ + char *str; + + if (SvOK(GvSV(PL_defgv))) + { + str = SvPV(GvSV(PL_defgv), PL_na); + ml_replace(*line, (char_u *)str, 1); + changed_bytes(*line, 0); + } + else + { + ml_delete(*line, FALSE); + deleted_lines_mark(*line, 1L); + --(*end); + --(*line); + } + return OK; +} + +/* + * ":perldo". + */ + void +ex_perldo(eap) + exarg_T *eap; +{ + STRLEN length; + SV *sv; + char *str; + linenr_T i; + + if (bufempty()) + return; + + if (perl_interp == NULL) + { +#ifdef DYNAMIC_PERL + if (!perl_enabled(TRUE)) + { + EMSG(_(e_noperl)); + return; + } +#endif + perl_init(); + } + { + dSP; + length = strlen((char *)eap->arg); + sv = newSV(length + sizeof("sub VIM::perldo {")-1 + 1); + sv_setpvn(sv, "sub VIM::perldo {", sizeof("sub VIM::perldo {")-1); + sv_catpvn(sv, (char *)eap->arg, length); + sv_catpvn(sv, "}", 1); + perl_eval_sv(sv, G_DISCARD | G_NOARGS); + SvREFCNT_dec(sv); + str = SvPV(GvSV(PL_errgv), length); + if (length) + goto err; + + if (u_save(eap->line1 - 1, eap->line2 + 1) != OK) + return; + + ENTER; + SAVETMPS; + for (i = eap->line1; i <= eap->line2; i++) + { + sv_setpv(GvSV(PL_defgv),(char *)ml_get(i)); + PUSHMARK(sp); + perl_call_pv("VIM::perldo", G_SCALAR | G_EVAL); + str = SvPV(GvSV(PL_errgv), length); + if (length) + break; + SPAGAIN; + if (SvTRUEx(POPs)) + { + if (replace_line(&i, &eap->line2) != OK) + { + PUTBACK; + break; + } + } + PUTBACK; + } + FREETMPS; + LEAVE; + check_cursor(); + update_screen(NOT_VALID); + if (!length) + return; + +err: + msg_split((char_u *)str, highlight_attr[HLF_E]); + return; + } +} + +XS(XS_VIM_Msg); +XS(XS_VIM_SetOption); +XS(XS_VIM_DoCommand); +XS(XS_VIM_Eval); +XS(XS_VIM_Buffers); +XS(XS_VIM_Windows); +XS(XS_VIWIN_DESTROY); +XS(XS_VIWIN_Buffer); +XS(XS_VIWIN_SetHeight); +XS(XS_VIWIN_Cursor); +XS(XS_VIBUF_DESTROY); +XS(XS_VIBUF_Name); +XS(XS_VIBUF_Number); +XS(XS_VIBUF_Count); +XS(XS_VIBUF_Get); +XS(XS_VIBUF_Set); +XS(XS_VIBUF_Delete); +XS(XS_VIBUF_Append); +XS(boot_VIM); + + static void +xs_init(pTHX) +{ + char *file = __FILE__; + + /* DynaLoader is a special case */ + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); + newXS("VIM::bootstrap", boot_VIM, file); +} + +typedef win_T * VIWIN; +typedef buf_T * VIBUF; + +MODULE = VIM PACKAGE = VIM + +void +Msg(text, hl=NULL) + char *text; + char *hl; + + PREINIT: + int attr; + int id; + + PPCODE: + if (text != NULL) + { + attr = 0; + if (hl != NULL) + { + id = syn_name2id((char_u *)hl); + if (id != 0) + attr = syn_id2attr(id); + } + msg_split((char_u *)text, attr); + } + +void +SetOption(line) + char *line; + + PPCODE: + if (line != NULL) + do_set((char_u *)line, 0); + update_screen(NOT_VALID); + +void +DoCommand(line) + char *line; + + PPCODE: + if (line != NULL) + do_cmdline_cmd((char_u *)line); + +void +Eval(str) + char *str; + + PREINIT: + char_u *value; + PPCODE: + value = eval_to_string((char_u *)str, (char_u**)0); + if (value == NULL) + { + XPUSHs(sv_2mortal(newSViv(0))); + XPUSHs(sv_2mortal(newSVpv("", 0))); + } + else + { + XPUSHs(sv_2mortal(newSViv(1))); + XPUSHs(sv_2mortal(newSVpv((char *)value, 0))); + vim_free(value); + } + +void +Buffers(...) + + PREINIT: + buf_T *vimbuf; + int i, b; + + PPCODE: + if (items == 0) + { + if (GIMME == G_SCALAR) + { + i = 0; + for (vimbuf = firstbuf; vimbuf; vimbuf = vimbuf->b_next) + ++i; + + XPUSHs(sv_2mortal(newSViv(i))); + } + else + { + for (vimbuf = firstbuf; vimbuf; vimbuf = vimbuf->b_next) + XPUSHs(newBUFrv(newSV(0), vimbuf)); + } + } + else + { + for (i = 0; i < items; i++) + { + SV *sv = ST(i); + if (SvIOK(sv)) + b = SvIV(ST(i)); + else + { + char_u *pat; + STRLEN len; + + pat = (char_u *)SvPV(sv, len); + ++emsg_off; + b = buflist_findpat(pat, pat+len, FALSE, FALSE); + --emsg_off; + } + + if (b >= 0) + { + vimbuf = buflist_findnr(b); + if (vimbuf) + XPUSHs(newBUFrv(newSV(0), vimbuf)); + } + } + } + +void +Windows(...) + + PREINIT: + win_T *vimwin; + int i, w; + + PPCODE: + if (items == 0) + { + if (GIMME == G_SCALAR) + XPUSHs(sv_2mortal(newSViv(win_count()))); + else + { + for (vimwin = firstwin; vimwin != NULL; vimwin = W_NEXT(vimwin)) + XPUSHs(newWINrv(newSV(0), vimwin)); + } + } + else + { + for (i = 0; i < items; i++) + { + w = SvIV(ST(i)); + vimwin = win_find_nr(w); + if (vimwin) + XPUSHs(newWINrv(newSV(0), vimwin)); + } + } + +MODULE = VIM PACKAGE = VIWIN + +void +DESTROY(win) + VIWIN win + + CODE: + if (win_valid(win)) + win->perl_private = 0; + +SV * +Buffer(win) + VIWIN win + + CODE: + if (!win_valid(win)) + win = curwin; + RETVAL = newBUFrv(newSV(0), win->w_buffer); + OUTPUT: + RETVAL + +void +SetHeight(win, height) + VIWIN win + int height; + + PREINIT: + win_T *savewin; + + PPCODE: + if (!win_valid(win)) + win = curwin; + savewin = curwin; + curwin = win; + win_setheight(height); + curwin = savewin; + +void +Cursor(win, ...) + VIWIN win + + PPCODE: + if(items == 1) + { + EXTEND(sp, 2); + if (!win_valid(win)) + win = curwin; + PUSHs(sv_2mortal(newSViv(win->w_cursor.lnum))); + PUSHs(sv_2mortal(newSViv(win->w_cursor.col))); + } + else if(items == 3) + { + int lnum, col; + + if (!win_valid(win)) + win = curwin; + lnum = SvIV(ST(1)); + col = SvIV(ST(2)); + win->w_cursor.lnum = lnum; + win->w_cursor.col = col; + check_cursor(); /* put cursor on an existing line */ + update_screen(NOT_VALID); + } + +MODULE = VIM PACKAGE = VIBUF + +void +DESTROY(vimbuf) + VIBUF vimbuf; + + CODE: + if (buf_valid(vimbuf)) + vimbuf->perl_private = 0; + +void +Name(vimbuf) + VIBUF vimbuf; + + PPCODE: + if (!buf_valid(vimbuf)) + vimbuf = curbuf; + /* No file name returns an empty string */ + if (vimbuf->b_fname == NULL) + XPUSHs(sv_2mortal(newSVpv("", 0))); + else + XPUSHs(sv_2mortal(newSVpv((char *)vimbuf->b_fname, 0))); + +void +Number(vimbuf) + VIBUF vimbuf; + + PPCODE: + if (!buf_valid(vimbuf)) + vimbuf = curbuf; + XPUSHs(sv_2mortal(newSViv(vimbuf->b_fnum))); + +void +Count(vimbuf) + VIBUF vimbuf; + + PPCODE: + if (!buf_valid(vimbuf)) + vimbuf = curbuf; + XPUSHs(sv_2mortal(newSViv(vimbuf->b_ml.ml_line_count))); + +void +Get(vimbuf, ...) + VIBUF vimbuf; + + PREINIT: + char_u *line; + int i; + long lnum; + PPCODE: + if (buf_valid(vimbuf)) + { + for (i = 1; i < items; i++) + { + lnum = SvIV(ST(i)); + if (lnum > 0 && lnum <= vimbuf->b_ml.ml_line_count) + { + line = ml_get_buf(vimbuf, lnum, FALSE); + XPUSHs(sv_2mortal(newSVpv((char *)line, 0))); + } + } + } + +void +Set(vimbuf, ...) + VIBUF vimbuf; + + PREINIT: + int i; + long lnum; + char *line; + buf_T *savebuf; + PPCODE: + if (buf_valid(vimbuf)) + { + if (items < 3) + croak("Usage: VIBUF::Set(vimbuf, lnum, @lines)"); + + lnum = SvIV(ST(1)); + for(i = 2; i < items; i++, lnum++) + { + line = SvPV(ST(i),PL_na); + if (lnum > 0 && lnum <= vimbuf->b_ml.ml_line_count && line != NULL) + { + savebuf = curbuf; + curbuf = vimbuf; + if (u_savesub(lnum) == OK) + { + ml_replace(lnum, (char_u *)line, TRUE); + changed_bytes(lnum, 0); + } + curbuf = savebuf; + } + } + } + +void +Delete(vimbuf, ...) + VIBUF vimbuf; + + PREINIT: + long i, lnum = 0, count = 0; + buf_T *savebuf; + PPCODE: + if (buf_valid(vimbuf)) + { + if (items == 2) + { + lnum = SvIV(ST(1)); + count = 1; + } + else if (items == 3) + { + lnum = SvIV(ST(1)); + count = 1 + SvIV(ST(2)) - lnum; + if(count == 0) + count = 1; + if(count < 0) + { + lnum -= count; + count = -count; + } + } + if (items >= 2) + { + for (i = 0; i < count; i++) + { + if (lnum > 0 && lnum <= vimbuf->b_ml.ml_line_count) + { + savebuf = curbuf; + curbuf = vimbuf; + if (u_savedel(lnum, 1) == OK) + { + ml_delete(lnum, 0); + deleted_lines_mark(lnum, 1L); + if (savebuf == curbuf) + check_cursor(); + } + curbuf = savebuf; + update_curbuf(VALID); + } + } + } + } + +void +Append(vimbuf, ...) + VIBUF vimbuf; + + PREINIT: + int i; + long lnum; + char *line; + buf_T *savebuf; + PPCODE: + if (buf_valid(vimbuf)) + { + if (items < 3) + croak("Usage: VIBUF::Append(vimbuf, lnum, @lines)"); + + lnum = SvIV(ST(1)); + for (i = 2; i < items; i++, lnum++) + { + line = SvPV(ST(i),PL_na); + if (lnum >= 0 && lnum <= vimbuf->b_ml.ml_line_count && line != NULL) + { + savebuf = curbuf; + curbuf = vimbuf; + if (u_inssub(lnum + 1) == OK) + { + ml_append(lnum, (char_u *)line, (colnr_T)0, FALSE); + appended_lines_mark(lnum, 1L); + } + curbuf = savebuf; + update_curbuf(VALID); + } + } + } + |