src/if_perl.xs

   1 /* vi:set ts=8 sts=4 sw=4:
   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 #include "vim.h"
  17
  18
  19 /*
  20  * Work around clashes between Perl and Vim namespace.  proto.h doesn't
  21  * include if_perl.pro and perlsfio.pro when IN_PERL_FILE is defined, because
  22  * we need the CV typedef.  proto.h can't be moved to after including
  23  * if_perl.h, because we get all sorts of name clashes then.
  24  */
  25 #ifndef PROTO
  26 #ifndef __MINGW32__
  27 # include "proto/if_perl.pro"
  28 # include "proto/if_perlsfio.pro"
  29 #endif
  30 #endif
  31
  32 /* Perl compatibility stuff. This should ensure compatibility with older
  33  * versions of Perl.
  34  */
  35
  36 #ifndef PERL_VERSION
  37 #    include <patchlevel.h>
  38 #    define PERL_REVISION   5
  39 #    define PERL_VERSION    PATCHLEVEL
  40 #    define PERL_SUBVERSION SUBVERSION
  41 #endif
  42
  43 /*
  44  * Quoting Jan Dubois of Active State:
  45  *    ActivePerl build 822 still identifies itself as 5.8.8 but already
  46  *    contains many of the changes from the upcoming Perl 5.8.9 release.
  47  *
  48  * The changes include addition of two symbols (Perl_sv_2iv_flags,
  49  * Perl_newXS_flags) not present in earlier releases.
  50  *
  51  * Jan Dubois suggested the following guarding scheme.
  52  *
  53  * Active State defined ACTIVEPERL_VERSION as a string in versions before
  54  * 5.8.8; and so the comparison to 822 below needs to be guarded.
  55  */
  56 #if (PERL_REVISION == 5) && (PERL_VERSION == 8) && (PERL_SUBVERSION >= 8)
  57 # if (ACTIVEPERL_VERSION >= 822) || (PERL_SUBVERSION >= 9)
  58 #  define PERL589_OR_LATER
  59 # endif
  60 #endif
  61 #if (PERL_REVISION == 5) && (PERL_VERSION >= 9)
  62 # define PERL589_OR_LATER
  63 #endif
  64
  65 #ifndef pTHX
  66 #    define pTHX void
  67 #    define pTHX_
  68 #endif
  69
  70 #ifndef EXTERN_C
  71 # define EXTERN_C
  72 #endif
  73
  74 /* Compatibility hacks over */
  75
  76 static PerlInterpreter *perl_interp = NULL;
  77 static void xs_init __ARGS((pTHX));
  78 static void VIM_init __ARGS((void));
  79 EXTERN_C void boot_DynaLoader __ARGS((pTHX_ CV*));
  80
  81 /*
  82  * For dynamic linked perl. (Windows)
  83  */
  84 #if defined(DYNAMIC_PERL) || defined(PROTO)
  85 /*
  86  * Wrapper defines
  87  */
  88 # define perl_alloc dll_perl_alloc
  89 # define perl_construct dll_perl_construct
  90 # define perl_parse dll_perl_parse
  91 # define perl_run dll_perl_run
  92 # define perl_destruct dll_perl_destruct
  93 # define perl_free dll_perl_free
  94 # define Perl_get_context dll_Perl_get_context
  95 # define Perl_croak dll_Perl_croak
  96 # ifndef PROTO
  97 #  define Perl_croak_nocontext dll_Perl_croak_nocontext
  98 #  define Perl_call_argv dll_Perl_call_argv
  99 #  define Perl_call_pv dll_Perl_call_pv
 100 #  define Perl_eval_sv dll_Perl_eval_sv
 101 #  define Perl_get_sv dll_Perl_get_sv
 102 #  define Perl_eval_pv dll_Perl_eval_pv
 103 #  define Perl_call_method dll_Perl_call_method
 104 # endif
 105 # define Perl_dowantarray dll_Perl_dowantarray
 106 # define Perl_free_tmps dll_Perl_free_tmps
 107 # define Perl_gv_stashpv dll_Perl_gv_stashpv
 108 # define Perl_markstack_grow dll_Perl_markstack_grow
 109 # define Perl_mg_find dll_Perl_mg_find
 110 # define Perl_newXS dll_Perl_newXS
 111 # define Perl_newSV dll_Perl_newSV
 112 # define Perl_newSViv dll_Perl_newSViv
 113 # define Perl_newSVpv dll_Perl_newSVpv
 114 # define Perl_pop_scope dll_Perl_pop_scope
 115 # define Perl_push_scope dll_Perl_push_scope
 116 # define Perl_save_int dll_Perl_save_int
 117 # define Perl_stack_grow dll_Perl_stack_grow
 118 # define Perl_set_context dll_Perl_set_context
 119 # define Perl_sv_2bool dll_Perl_sv_2bool
 120 # define Perl_sv_2iv dll_Perl_sv_2iv
 121 # define Perl_sv_2mortal dll_Perl_sv_2mortal
 122 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 123 #  define Perl_sv_2pv_flags dll_Perl_sv_2pv_flags
 124 #  define Perl_sv_2pv_nolen dll_Perl_sv_2pv_nolen
 125 # else
 126 #  define Perl_sv_2pv dll_Perl_sv_2pv
 127 # endif
 128 # define Perl_sv_bless dll_Perl_sv_bless
 129 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 130 #  define Perl_sv_catpvn_flags dll_Perl_sv_catpvn_flags
 131 # else
 132 #  define Perl_sv_catpvn dll_Perl_sv_catpvn
 133 # endif
 134 #ifdef PERL589_OR_LATER
 135 #  define Perl_sv_2iv_flags dll_Perl_sv_2iv_flags
 136 #  define Perl_newXS_flags dll_Perl_newXS_flags
 137 #endif
 138 # define Perl_sv_free dll_Perl_sv_free
 139 # define Perl_sv_isa dll_Perl_sv_isa
 140 # define Perl_sv_magic dll_Perl_sv_magic
 141 # define Perl_sv_setiv dll_Perl_sv_setiv
 142 # define Perl_sv_setpv dll_Perl_sv_setpv
 143 # define Perl_sv_setpvn dll_Perl_sv_setpvn
 144 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 145 #  define Perl_sv_setsv_flags dll_Perl_sv_setsv_flags
 146 # else
 147 #  define Perl_sv_setsv dll_Perl_sv_setsv
 148 # endif
 149 # define Perl_sv_upgrade dll_Perl_sv_upgrade
 150 # define Perl_Tstack_sp_ptr dll_Perl_Tstack_sp_ptr
 151 # define Perl_Top_ptr dll_Perl_Top_ptr
 152 # define Perl_Tstack_base_ptr dll_Perl_Tstack_base_ptr
 153 # define Perl_Tstack_max_ptr dll_Perl_Tstack_max_ptr
 154 # define Perl_Ttmps_ix_ptr dll_Perl_Ttmps_ix_ptr
 155 # define Perl_Ttmps_floor_ptr dll_Perl_Ttmps_floor_ptr
 156 # define Perl_Tmarkstack_ptr_ptr dll_Perl_Tmarkstack_ptr_ptr
 157 # define Perl_Tmarkstack_max_ptr dll_Perl_Tmarkstack_max_ptr
 158 # define Perl_TSv_ptr dll_Perl_TSv_ptr
 159 # define Perl_TXpv_ptr dll_Perl_TXpv_ptr
 160 # define Perl_Tna_ptr dll_Perl_Tna_ptr
 161 # define Perl_Idefgv_ptr dll_Perl_Idefgv_ptr
 162 # define Perl_Ierrgv_ptr dll_Perl_Ierrgv_ptr
 163 # define Perl_Isv_yes_ptr dll_Perl_Isv_yes_ptr
 164 # define boot_DynaLoader dll_boot_DynaLoader
 165
 166 #ifndef DYNAMIC_PERL /* just generating prototypes */
 167 typedef int HANDLE;
 168 typedef int XSINIT_t;
 169 typedef int XSUBADDR_t;
 170 #endif
 171
 172 /*
 173  * Declare HANDLE for perl.dll and function pointers.
 174  */
 175 static HANDLE hPerlLib = NULL;
 176
 177 static PerlInterpreter* (*perl_alloc)();
 178 static void (*perl_construct)(PerlInterpreter*);
 179 static void (*perl_destruct)(PerlInterpreter*);
 180 static void (*perl_free)(PerlInterpreter*);
 181 static int (*perl_run)(PerlInterpreter*);
 182 static int (*perl_parse)(PerlInterpreter*, XSINIT_t, int, char**, char**);
 183 static void* (*Perl_get_context)(void);
 184 static void (*Perl_croak)(pTHX_ const char*, ...);
 185 static void (*Perl_croak_nocontext)(const char*, ...);
 186 static I32 (*Perl_dowantarray)(pTHX);
 187 static void (*Perl_free_tmps)(pTHX);
 188 static HV* (*Perl_gv_stashpv)(pTHX_ const char*, I32);
 189 static void (*Perl_markstack_grow)(pTHX);
 190 static MAGIC* (*Perl_mg_find)(pTHX_ SV*, int);
 191 static CV* (*Perl_newXS)(pTHX_ char*, XSUBADDR_t, char*);
 192 static SV* (*Perl_newSV)(pTHX_ STRLEN);
 193 static SV* (*Perl_newSViv)(pTHX_ IV);
 194 static SV* (*Perl_newSVpv)(pTHX_ const char*, STRLEN);
 195 static I32 (*Perl_call_argv)(pTHX_ const char*, I32, char**);
 196 static I32 (*Perl_call_pv)(pTHX_ const char*, I32);
 197 static I32 (*Perl_eval_sv)(pTHX_ SV*, I32);
 198 static SV* (*Perl_get_sv)(pTHX_ const char*, I32);
 199 static SV* (*Perl_eval_pv)(pTHX_ const char*, I32);
 200 static SV* (*Perl_call_method)(pTHX_ const char*, I32);
 201 static void (*Perl_pop_scope)(pTHX);
 202 static void (*Perl_push_scope)(pTHX);
 203 static void (*Perl_save_int)(pTHX_ int*);
 204 static SV** (*Perl_stack_grow)(pTHX_ SV**, SV**p, int);
 205 static SV** (*Perl_set_context)(void*);
 206 static bool (*Perl_sv_2bool)(pTHX_ SV*);
 207 static IV (*Perl_sv_2iv)(pTHX_ SV*);
 208 static SV* (*Perl_sv_2mortal)(pTHX_ SV*);
 209 #if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 210 static char* (*Perl_sv_2pv_flags)(pTHX_ SV*, STRLEN*, I32);
 211 static char* (*Perl_sv_2pv_nolen)(pTHX_ SV*);
 212 #else
 213 static char* (*Perl_sv_2pv)(pTHX_ SV*, STRLEN*);
 214 #endif
 215 static SV* (*Perl_sv_bless)(pTHX_ SV*, HV*);
 216 #if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 217 static void (*Perl_sv_catpvn_flags)(pTHX_ SV* , const char*, STRLEN, I32);
 218 #else
 219 static void (*Perl_sv_catpvn)(pTHX_ SV*, const char*, STRLEN);
 220 #endif
 221 #ifdef PERL589_OR_LATER
 222 static IV (*Perl_sv_2iv_flags)(pTHX_ SV* sv, I32 flags);
 223 static CV * (*Perl_newXS_flags)(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags);
 224 #endif
 225 static void (*Perl_sv_free)(pTHX_ SV*);
 226 static int (*Perl_sv_isa)(pTHX_ SV*, const char*);
 227 static void (*Perl_sv_magic)(pTHX_ SV*, SV*, int, const char*, I32);
 228 static void (*Perl_sv_setiv)(pTHX_ SV*, IV);
 229 static void (*Perl_sv_setpv)(pTHX_ SV*, const char*);
 230 static void (*Perl_sv_setpvn)(pTHX_ SV*, const char*, STRLEN);
 231 #if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 232 static void (*Perl_sv_setsv_flags)(pTHX_ SV*, SV*, I32);
 233 #else
 234 static void (*Perl_sv_setsv)(pTHX_ SV*, SV*);
 235 #endif
 236 static bool (*Perl_sv_upgrade)(pTHX_ SV*, U32);
 237 static SV*** (*Perl_Tstack_sp_ptr)(register PerlInterpreter*);
 238 static OP** (*Perl_Top_ptr)(register PerlInterpreter*);
 239 static SV*** (*Perl_Tstack_base_ptr)(register PerlInterpreter*);
 240 static SV*** (*Perl_Tstack_max_ptr)(register PerlInterpreter*);
 241 static I32* (*Perl_Ttmps_ix_ptr)(register PerlInterpreter*);
 242 static I32* (*Perl_Ttmps_floor_ptr)(register PerlInterpreter*);
 243 static I32** (*Perl_Tmarkstack_ptr_ptr)(register PerlInterpreter*);
 244 static I32** (*Perl_Tmarkstack_max_ptr)(register PerlInterpreter*);
 245 static SV** (*Perl_TSv_ptr)(register PerlInterpreter*);
 246 static XPV** (*Perl_TXpv_ptr)(register PerlInterpreter*);
 247 static STRLEN* (*Perl_Tna_ptr)(register PerlInterpreter*);
 248 static GV** (*Perl_Idefgv_ptr)(register PerlInterpreter*);
 249 static GV** (*Perl_Ierrgv_ptr)(register PerlInterpreter*);
 250 static SV* (*Perl_Isv_yes_ptr)(register PerlInterpreter*);
 251 static void (*boot_DynaLoader)_((pTHX_ CV*));
 252
 253
 254 /*
 255  * Table of name to function pointer of perl.
 256  */
 257 #define PERL_PROC FARPROC
 258 static struct {
 259     char* name;
 260     PERL_PROC* ptr;
 261 } perl_funcname_table[] = {
 262     {"perl_alloc", (PERL_PROC*)&perl_alloc},
 263     {"perl_construct", (PERL_PROC*)&perl_construct},
 264     {"perl_destruct", (PERL_PROC*)&perl_destruct},
 265     {"perl_free", (PERL_PROC*)&perl_free},
 266     {"perl_run", (PERL_PROC*)&perl_run},
 267     {"perl_parse", (PERL_PROC*)&perl_parse},
 268     {"Perl_get_context", (PERL_PROC*)&Perl_get_context},
 269     {"Perl_croak", (PERL_PROC*)&Perl_croak},
 270     {"Perl_croak_nocontext", (PERL_PROC*)&Perl_croak_nocontext},
 271     {"Perl_dowantarray", (PERL_PROC*)&Perl_dowantarray},
 272     {"Perl_free_tmps", (PERL_PROC*)&Perl_free_tmps},
 273     {"Perl_gv_stashpv", (PERL_PROC*)&Perl_gv_stashpv},
 274     {"Perl_markstack_grow", (PERL_PROC*)&Perl_markstack_grow},
 275     {"Perl_mg_find", (PERL_PROC*)&Perl_mg_find},
 276     {"Perl_newXS", (PERL_PROC*)&Perl_newXS},
 277     {"Perl_newSV", (PERL_PROC*)&Perl_newSV},
 278     {"Perl_newSViv", (PERL_PROC*)&Perl_newSViv},
 279     {"Perl_newSVpv", (PERL_PROC*)&Perl_newSVpv},
 280     {"Perl_call_argv", (PERL_PROC*)&Perl_call_argv},
 281     {"Perl_call_pv", (PERL_PROC*)&Perl_call_pv},
 282     {"Perl_eval_sv", (PERL_PROC*)&Perl_eval_sv},
 283     {"Perl_get_sv", (PERL_PROC*)&Perl_get_sv},
 284     {"Perl_eval_pv", (PERL_PROC*)&Perl_eval_pv},
 285     {"Perl_call_method", (PERL_PROC*)&Perl_call_method},
 286     {"Perl_pop_scope", (PERL_PROC*)&Perl_pop_scope},
 287     {"Perl_push_scope", (PERL_PROC*)&Perl_push_scope},
 288     {"Perl_save_int", (PERL_PROC*)&Perl_save_int},
 289     {"Perl_stack_grow", (PERL_PROC*)&Perl_stack_grow},
 290     {"Perl_set_context", (PERL_PROC*)&Perl_set_context},
 291     {"Perl_sv_2bool", (PERL_PROC*)&Perl_sv_2bool},
 292     {"Perl_sv_2iv", (PERL_PROC*)&Perl_sv_2iv},
 293     {"Perl_sv_2mortal", (PERL_PROC*)&Perl_sv_2mortal},
 294 #if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 295     {"Perl_sv_2pv_flags", (PERL_PROC*)&Perl_sv_2pv_flags},
 296     {"Perl_sv_2pv_nolen", (PERL_PROC*)&Perl_sv_2pv_nolen},
 297 #else
 298     {"Perl_sv_2pv", (PERL_PROC*)&Perl_sv_2pv},
 299 #endif
 300 #ifdef PERL589_OR_LATER
 301     {"Perl_sv_2iv_flags", (PERL_PROC*)&Perl_sv_2iv_flags},
 302     {"Perl_newXS_flags", (PERL_PROC*)&Perl_newXS_flags},
 303 #endif
 304     {"Perl_sv_bless", (PERL_PROC*)&Perl_sv_bless},
 305 #if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 306     {"Perl_sv_catpvn_flags", (PERL_PROC*)&Perl_sv_catpvn_flags},
 307 #else
 308     {"Perl_sv_catpvn", (PERL_PROC*)&Perl_sv_catpvn},
 309 #endif
 310     {"Perl_sv_free", (PERL_PROC*)&Perl_sv_free},
 311     {"Perl_sv_isa", (PERL_PROC*)&Perl_sv_isa},
 312     {"Perl_sv_magic", (PERL_PROC*)&Perl_sv_magic},
 313     {"Perl_sv_setiv", (PERL_PROC*)&Perl_sv_setiv},
 314     {"Perl_sv_setpv", (PERL_PROC*)&Perl_sv_setpv},
 315     {"Perl_sv_setpvn", (PERL_PROC*)&Perl_sv_setpvn},
 316 #if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 317     {"Perl_sv_setsv_flags", (PERL_PROC*)&Perl_sv_setsv_flags},
 318 #else
 319     {"Perl_sv_setsv", (PERL_PROC*)&Perl_sv_setsv},
 320 #endif
 321     {"Perl_sv_upgrade", (PERL_PROC*)&Perl_sv_upgrade},
 322     {"Perl_Tstack_sp_ptr", (PERL_PROC*)&Perl_Tstack_sp_ptr},
 323     {"Perl_Top_ptr", (PERL_PROC*)&Perl_Top_ptr},
 324     {"Perl_Tstack_base_ptr", (PERL_PROC*)&Perl_Tstack_base_ptr},
 325     {"Perl_Tstack_max_ptr", (PERL_PROC*)&Perl_Tstack_max_ptr},
 326     {"Perl_Ttmps_ix_ptr", (PERL_PROC*)&Perl_Ttmps_ix_ptr},
 327     {"Perl_Ttmps_floor_ptr", (PERL_PROC*)&Perl_Ttmps_floor_ptr},
 328     {"Perl_Tmarkstack_ptr_ptr", (PERL_PROC*)&Perl_Tmarkstack_ptr_ptr},
 329     {"Perl_Tmarkstack_max_ptr", (PERL_PROC*)&Perl_Tmarkstack_max_ptr},
 330     {"Perl_TSv_ptr", (PERL_PROC*)&Perl_TSv_ptr},
 331     {"Perl_TXpv_ptr", (PERL_PROC*)&Perl_TXpv_ptr},
 332     {"Perl_Tna_ptr", (PERL_PROC*)&Perl_Tna_ptr},
 333     {"Perl_Idefgv_ptr", (PERL_PROC*)&Perl_Idefgv_ptr},
 334     {"Perl_Ierrgv_ptr", (PERL_PROC*)&Perl_Ierrgv_ptr},
 335     {"Perl_Isv_yes_ptr", (PERL_PROC*)&Perl_Isv_yes_ptr},
 336     {"boot_DynaLoader", (PERL_PROC*)&boot_DynaLoader},
 337     {"", NULL},
 338 };
 339
 340 /*
 341  * Make all runtime-links of perl.
 342  *
 343  * 1. Get module handle using LoadLibraryEx.
 344  * 2. Get pointer to perl function by GetProcAddress.
 345  * 3. Repeat 2, until get all functions will be used.
 346  *
 347  * Parameter 'libname' provides name of DLL.
 348  * Return OK or FAIL.
 349  */
 350     static int
 351 perl_runtime_link_init(char *libname, int verbose)
 352 {
 353     int i;
 354
 355     if (hPerlLib != NULL)
 356         return OK;
 357     if (!(hPerlLib = LoadLibraryEx(libname, NULL, 0)))
 358     {
 359         if (verbose)
 360             EMSG2(_("E370: Could not load library %s"), libname);
 361         return FAIL;
 362     }
 363     for (i = 0; perl_funcname_table[i].ptr; ++i)
 364     {
 365         if (!(*perl_funcname_table[i].ptr = GetProcAddress(hPerlLib,
 366                         perl_funcname_table[i].name)))
 367         {
 368             FreeLibrary(hPerlLib);
 369             hPerlLib = NULL;
 370             if (verbose)
 371                 EMSG2(_(e_loadfunc), perl_funcname_table[i].name);
 372             return FAIL;
 373         }
 374     }
 375     return OK;
 376 }
 377
 378 /*
 379  * If runtime-link-perl(DLL) was loaded successfully, return TRUE.
 380  * There were no DLL loaded, return FALSE.
 381  */
 382     int
 383 perl_enabled(verbose)
 384     int         verbose;
 385 {
 386     return perl_runtime_link_init(DYNAMIC_PERL_DLL, verbose) == OK;
 387 }
 388 #endif /* DYNAMIC_PERL */
 389
 390 /*
 391  * perl_init(): initialize perl interpreter
 392  * We have to call perl_parse to initialize some structures,
 393  * there's nothing to actually parse.
 394  */
 395     static void
 396 perl_init()
 397 {
 398     char        *bootargs[] = { "VI", NULL };
 399     static char *args[] = { "", "-e", "" };
 400
 401     perl_interp = perl_alloc();
 402     perl_construct(perl_interp);
 403     perl_parse(perl_interp, xs_init, 3, args, 0);
 404     perl_call_argv("VIM::bootstrap", (long)G_DISCARD, bootargs);
 405     VIM_init();
 406 #ifdef USE_SFIO
 407     sfdisc(PerlIO_stdout(), sfdcnewvim());
 408     sfdisc(PerlIO_stderr(), sfdcnewvim());
 409     sfsetbuf(PerlIO_stdout(), NULL, 0);
 410     sfsetbuf(PerlIO_stderr(), NULL, 0);
 411 #endif
 412 }
 413
 414 /*
 415  * perl_end(): clean up after ourselves
 416  */
 417     void
 418 perl_end()
 419 {
 420     if (perl_interp)
 421     {
 422         perl_run(perl_interp);
 423         perl_destruct(perl_interp);
 424         perl_free(perl_interp);
 425         perl_interp = NULL;
 426     }
 427 #ifdef DYNAMIC_PERL
 428     if (hPerlLib)
 429     {
 430         FreeLibrary(hPerlLib);
 431         hPerlLib = NULL;
 432     }
 433 #endif
 434 }
 435
 436 /*
 437  * msg_split(): send a message to the message handling routines
 438  * split at '\n' first though.
 439  */
 440     void
 441 msg_split(s, attr)
 442     char_u      *s;
 443     int         attr;   /* highlighting attributes */
 444 {
 445     char *next;
 446     char *token = (char *)s;
 447
 448     while ((next = strchr(token, '\n')) && !got_int)
 449     {
 450         *next++ = '\0';                 /* replace \n with \0 */
 451         msg_attr((char_u *)token, attr);
 452         token = next;
 453     }
 454     if (*token && !got_int)
 455         msg_attr((char_u *)token, attr);
 456 }
 457
 458 #ifndef FEAT_EVAL
 459 /*
 460  * This stub is needed because an "#ifdef FEAT_EVAL" around Eval() doesn't
 461  * work properly.
 462  */
 463     char_u *
 464 eval_to_string(arg, nextcmd, dolist)
 465     char_u      *arg;
 466     char_u      **nextcmd;
 467     int         dolist;
 468 {
 469     return NULL;
 470 }
 471 #endif
 472
 473 /*
 474  * Create a new reference to an SV pointing to the SCR structure
 475  * The b_perl_private/w_perl_private part of the SCR structure points to the
 476  * SV, so there can only be one such SV for a particular SCR structure.  When
 477  * the last reference has gone (DESTROY is called),
 478  * b_perl_private/w_perl_private is reset; When the screen goes away before
 479  * all references are gone, the value of the SV is reset;
 480  * any subsequent use of any of those reference will produce
 481  * a warning. (see typemap)
 482  */
 483
 484     static SV *
 485 newWINrv(rv, ptr)
 486     SV      *rv;
 487     win_T   *ptr;
 488 {
 489     sv_upgrade(rv, SVt_RV);
 490     if (ptr->w_perl_private == NULL)
 491     {
 492         ptr->w_perl_private = newSV(0);
 493         sv_setiv(ptr->w_perl_private, (IV)ptr);
 494     }
 495     else
 496         SvREFCNT_inc(ptr->w_perl_private);
 497     SvRV(rv) = ptr->w_perl_private;
 498     SvROK_on(rv);
 499     return sv_bless(rv, gv_stashpv("VIWIN", TRUE));
 500 }
 501
 502     static SV *
 503 newBUFrv(rv, ptr)
 504     SV      *rv;
 505     buf_T   *ptr;
 506 {
 507     sv_upgrade(rv, SVt_RV);
 508     if (ptr->b_perl_private == NULL)
 509     {
 510         ptr->b_perl_private = newSV(0);
 511         sv_setiv(ptr->b_perl_private, (IV)ptr);
 512     }
 513     else
 514         SvREFCNT_inc(ptr->b_perl_private);
 515     SvRV(rv) = ptr->b_perl_private;
 516     SvROK_on(rv);
 517     return sv_bless(rv, gv_stashpv("VIBUF", TRUE));
 518 }
 519
 520 /*
 521  * perl_win_free
 522  *      Remove all refences to the window to be destroyed
 523  */
 524     void
 525 perl_win_free(wp)
 526     win_T *wp;
 527 {
 528     if (wp->w_perl_private)
 529         sv_setiv((SV *)wp->w_perl_private, 0);
 530     return;
 531 }
 532
 533     void
 534 perl_buf_free(bp)
 535     buf_T *bp;
 536 {
 537     if (bp->b_perl_private)
 538         sv_setiv((SV *)bp->b_perl_private, 0);
 539     return;
 540 }
 541
 542 #ifndef PROTO
 543 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 544 I32 cur_val(pTHX_ IV iv, SV *sv);
 545 # else
 546 I32 cur_val(IV iv, SV *sv);
 547 #endif
 548
 549 /*
 550  * Handler for the magic variables $main::curwin and $main::curbuf.
 551  * The handler is put into the magic vtbl for these variables.
 552  * (This is effectively a C-level equivalent of a tied variable).
 553  * There is no "set" function as the variables are read-only.
 554  */
 555 # if (PERL_REVISION == 5) && (PERL_VERSION >= 8)
 556 I32 cur_val(pTHX_ IV iv, SV *sv)
 557 # else
 558 I32 cur_val(IV iv, SV *sv)
 559 # endif
 560 {
 561     SV *rv;
 562     if (iv == 0)
 563         rv = newWINrv(newSV(0), curwin);
 564     else
 565         rv = newBUFrv(newSV(0), curbuf);
 566     sv_setsv(sv, rv);
 567     return 0;
 568 }
 569 #endif /* !PROTO */
 570
 571 struct ufuncs cw_funcs = { cur_val, 0, 0 };
 572 struct ufuncs cb_funcs = { cur_val, 0, 1 };
 573
 574 /*
 575  * VIM_init(): Vim-specific initialisation.
 576  * Make the magical main::curwin and main::curbuf variables
 577  */
 578     static void
 579 VIM_init()
 580 {
 581     static char cw[] = "main::curwin";
 582     static char cb[] = "main::curbuf";
 583     SV *sv;
 584
 585     sv = perl_get_sv(cw, TRUE);
 586     sv_magic(sv, NULL, 'U', (char *)&cw_funcs, sizeof(cw_funcs));
 587     SvREADONLY_on(sv);
 588
 589     sv = perl_get_sv(cb, TRUE);
 590     sv_magic(sv, NULL, 'U', (char *)&cb_funcs, sizeof(cb_funcs));
 591     SvREADONLY_on(sv);
 592
 593     /*
 594      * Setup the Safe compartment.
 595      * It shouldn't be a fatal error if the Safe module is missing.
 596      * XXX: Only shares the 'Msg' routine (which has to be called
 597      * like 'Msg(...)').
 598      */
 599     (void)perl_eval_pv( "if ( eval( 'require Safe' ) ) { $VIM::safe = Safe->new(); $VIM::safe->share_from( 'VIM', ['Msg'] ); }", G_DISCARD | G_VOID );
 600
 601 }
 602
 603 #ifdef DYNAMIC_PERL
 604 static char *e_noperl = N_("Sorry, this command is disabled: the Perl library could not be loaded.");
 605 #endif
 606
 607 /*
 608  * ":perl"
 609  */
 610     void
 611 ex_perl(eap)
 612     exarg_T     *eap;
 613 {
 614     char        *err;
 615     char        *script;
 616     STRLEN      length;
 617     SV          *sv;
 618     SV          *safe;
 619
 620     script = (char *)script_get(eap, eap->arg);
 621     if (eap->skip)
 622     {
 623         vim_free(script);
 624         return;
 625     }
 626
 627     if (perl_interp == NULL)
 628     {
 629 #ifdef DYNAMIC_PERL
 630         if (!perl_enabled(TRUE))
 631         {
 632             EMSG(_(e_noperl));
 633             vim_free(script);
 634             return;
 635         }
 636 #endif
 637         perl_init();
 638     }
 639
 640     {
 641     dSP;
 642     ENTER;
 643     SAVETMPS;
 644
 645     if (script == NULL)
 646         sv = newSVpv((char *)eap->arg, 0);
 647     else
 648     {
 649         sv = newSVpv(script, 0);
 650         vim_free(script);
 651     }
 652
 653 #ifdef HAVE_SANDBOX
 654     if (sandbox)
 655     {
 656         if ((safe = perl_get_sv( "VIM::safe", FALSE )) == NULL || !SvTRUE(safe))
 657             EMSG(_("E299: Perl evaluation forbidden in sandbox without the Safe module"));
 658         else
 659         {
 660             PUSHMARK(SP);
 661             XPUSHs(safe);
 662             XPUSHs(sv);
 663             PUTBACK;
 664             perl_call_method("reval", G_DISCARD);
 665         }
 666     }
 667     else
 668 #endif
 669         perl_eval_sv(sv, G_DISCARD | G_NOARGS);
 670
 671     SvREFCNT_dec(sv);
 672
 673     err = SvPV(GvSV(PL_errgv), length);
 674
 675     FREETMPS;
 676     LEAVE;
 677
 678     if (!length)
 679         return;
 680
 681     msg_split((char_u *)err, highlight_attr[HLF_E]);
 682     return;
 683     }
 684 }
 685
 686     static int
 687 replace_line(line, end)
 688     linenr_T    *line, *end;
 689 {
 690     char *str;
 691
 692     if (SvOK(GvSV(PL_defgv)))
 693     {
 694         str = SvPV(GvSV(PL_defgv), PL_na);
 695         ml_replace(*line, (char_u *)str, 1);
 696         changed_bytes(*line, 0);
 697     }
 698     else
 699     {
 700         ml_delete(*line, FALSE);
 701         deleted_lines_mark(*line, 1L);
 702         --(*end);
 703         --(*line);
 704     }
 705     return OK;
 706 }
 707
 708 /*
 709  * ":perldo".
 710  */
 711     void
 712 ex_perldo(eap)
 713     exarg_T     *eap;
 714 {
 715     STRLEN      length;
 716     SV          *sv;
 717     char        *str;
 718     linenr_T    i;
 719
 720     if (bufempty())
 721         return;
 722
 723     if (perl_interp == NULL)
 724     {
 725 #ifdef DYNAMIC_PERL
 726         if (!perl_enabled(TRUE))
 727         {
 728             EMSG(_(e_noperl));
 729             return;
 730         }
 731 #endif
 732         perl_init();
 733     }
 734     {
 735     dSP;
 736     length = strlen((char *)eap->arg);
 737     sv = newSV(length + sizeof("sub VIM::perldo {") - 1 + 1);
 738     sv_setpvn(sv, "sub VIM::perldo {", sizeof("sub VIM::perldo {") - 1);
 739     sv_catpvn(sv, (char *)eap->arg, length);
 740     sv_catpvn(sv, "}", 1);
 741     perl_eval_sv(sv, G_DISCARD | G_NOARGS);
 742     SvREFCNT_dec(sv);
 743     str = SvPV(GvSV(PL_errgv), length);
 744     if (length)
 745         goto err;
 746
 747     if (u_save(eap->line1 - 1, eap->line2 + 1) != OK)
 748         return;
 749
 750     ENTER;
 751     SAVETMPS;
 752     for (i = eap->line1; i <= eap->line2; i++)
 753     {
 754         sv_setpv(GvSV(PL_defgv), (char *)ml_get(i));
 755         PUSHMARK(sp);
 756         perl_call_pv("VIM::perldo", G_SCALAR | G_EVAL);
 757         str = SvPV(GvSV(PL_errgv), length);
 758         if (length)
 759             break;
 760         SPAGAIN;
 761         if (SvTRUEx(POPs))
 762         {
 763             if (replace_line(&i, &eap->line2) != OK)
 764             {
 765                 PUTBACK;
 766                 break;
 767             }
 768         }
 769         PUTBACK;
 770     }
 771     FREETMPS;
 772     LEAVE;
 773     check_cursor();
 774     update_screen(NOT_VALID);
 775     if (!length)
 776         return;
 777
 778 err:
 779     msg_split((char_u *)str, highlight_attr[HLF_E]);
 780     return;
 781     }
 782 }
 783
 784 XS(XS_VIM_Msg);
 785 XS(XS_VIM_SetOption);
 786 XS(XS_VIM_DoCommand);
 787 XS(XS_VIM_Eval);
 788 XS(XS_VIM_Buffers);
 789 XS(XS_VIM_Windows);
 790 XS(XS_VIWIN_DESTROY);
 791 XS(XS_VIWIN_Buffer);
 792 XS(XS_VIWIN_SetHeight);
 793 XS(XS_VIWIN_Cursor);
 794 XS(XS_VIBUF_DESTROY);
 795 XS(XS_VIBUF_Name);
 796 XS(XS_VIBUF_Number);
 797 XS(XS_VIBUF_Count);
 798 XS(XS_VIBUF_Get);
 799 XS(XS_VIBUF_Set);
 800 XS(XS_VIBUF_Delete);
 801 XS(XS_VIBUF_Append);
 802 XS(boot_VIM);
 803
 804     static void
 805 xs_init(pTHX)
 806 {
 807     char *file = __FILE__;
 808
 809     /* DynaLoader is a special case */
 810     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 811     newXS("VIM::bootstrap", boot_VIM, file);
 812 }
 813
 814 typedef win_T * VIWIN;
 815 typedef buf_T * VIBUF;
 816
 817 MODULE = VIM        PACKAGE = VIM
 818
 819 void
 820 Msg(text, hl=NULL)
 821     char        *text;
 822     char        *hl;
 823
 824     PREINIT:
 825     int         attr;
 826     int         id;
 827
 828     PPCODE:
 829     if (text != NULL)
 830     {
 831         attr = 0;
 832         if (hl != NULL)
 833         {
 834             id = syn_name2id((char_u *)hl);
 835             if (id != 0)
 836                 attr = syn_id2attr(id);
 837         }
 838         msg_split((char_u *)text, attr);
 839     }
 840
 841 void
 842 SetOption(line)
 843     char *line;
 844
 845     PPCODE:
 846     if (line != NULL)
 847         do_set((char_u *)line, 0);
 848     update_screen(NOT_VALID);
 849
 850 void
 851 DoCommand(line)
 852     char *line;
 853
 854     PPCODE:
 855     if (line != NULL)
 856         do_cmdline_cmd((char_u *)line);
 857
 858 void
 859 Eval(str)
 860     char *str;
 861
 862     PREINIT:
 863         char_u *value;
 864     PPCODE:
 865         value = eval_to_string((char_u *)str, (char_u **)0, TRUE);
 866         if (value == NULL)
 867         {
 868             XPUSHs(sv_2mortal(newSViv(0)));
 869             XPUSHs(sv_2mortal(newSVpv("", 0)));
 870         }
 871         else
 872         {
 873             XPUSHs(sv_2mortal(newSViv(1)));
 874             XPUSHs(sv_2mortal(newSVpv((char *)value, 0)));
 875             vim_free(value);
 876         }
 877
 878 void
 879 Buffers(...)
 880
 881     PREINIT:
 882     buf_T *vimbuf;
 883     int i, b;
 884
 885     PPCODE:
 886     if (items == 0)
 887     {
 888         if (GIMME == G_SCALAR)
 889         {
 890             i = 0;
 891             for (vimbuf = firstbuf; vimbuf; vimbuf = vimbuf->b_next)
 892                 ++i;
 893
 894             XPUSHs(sv_2mortal(newSViv(i)));
 895         }
 896         else
 897         {
 898             for (vimbuf = firstbuf; vimbuf; vimbuf = vimbuf->b_next)
 899                 XPUSHs(newBUFrv(newSV(0), vimbuf));
 900         }
 901     }
 902     else
 903     {
 904         for (i = 0; i < items; i++)
 905         {
 906             SV *sv = ST(i);
 907             if (SvIOK(sv))
 908                 b = SvIV(ST(i));
 909             else
 910             {
 911                 char_u *pat;
 912                 STRLEN len;
 913
 914                 pat = (char_u *)SvPV(sv, len);
 915                 ++emsg_off;
 916                 b = buflist_findpat(pat, pat+len, FALSE, FALSE);
 917                 --emsg_off;
 918             }
 919
 920             if (b >= 0)
 921             {
 922                 vimbuf = buflist_findnr(b);
 923                 if (vimbuf)
 924                     XPUSHs(newBUFrv(newSV(0), vimbuf));
 925             }
 926         }
 927     }
 928
 929 void
 930 Windows(...)
 931
 932     PREINIT:
 933     win_T   *vimwin;
 934     int     i, w;
 935
 936     PPCODE:
 937     if (items == 0)
 938     {
 939         if (GIMME == G_SCALAR)
 940             XPUSHs(sv_2mortal(newSViv(win_count())));
 941         else
 942         {
 943             for (vimwin = firstwin; vimwin != NULL; vimwin = W_NEXT(vimwin))
 944                 XPUSHs(newWINrv(newSV(0), vimwin));
 945         }
 946     }
 947     else
 948     {
 949         for (i = 0; i < items; i++)
 950         {
 951             w = SvIV(ST(i));
 952             vimwin = win_find_nr(w);
 953             if (vimwin)
 954                 XPUSHs(newWINrv(newSV(0), vimwin));
 955         }
 956     }
 957
 958 MODULE = VIM        PACKAGE = VIWIN
 959
 960 void
 961 DESTROY(win)
 962     VIWIN win
 963
 964     CODE:
 965     if (win_valid(win))
 966         win->w_perl_private = 0;
 967
 968 SV *
 969 Buffer(win)
 970     VIWIN win
 971
 972     CODE:
 973     if (!win_valid(win))
 974         win = curwin;
 975     RETVAL = newBUFrv(newSV(0), win->w_buffer);
 976     OUTPUT:
 977     RETVAL
 978
 979 void
 980 SetHeight(win, height)
 981     VIWIN win
 982     int height;
 983
 984     PREINIT:
 985     win_T *savewin;
 986
 987     PPCODE:
 988     if (!win_valid(win))
 989         win = curwin;
 990     savewin = curwin;
 991     curwin = win;
 992     win_setheight(height);
 993     curwin = savewin;
 994
 995 void
 996 Cursor(win, ...)
 997     VIWIN win
 998
 999     PPCODE:
1000     if(items == 1)
1001     {
1002       EXTEND(sp, 2);
1003       if (!win_valid(win))
1004           win = curwin;
1005       PUSHs(sv_2mortal(newSViv(win->w_cursor.lnum)));
1006       PUSHs(sv_2mortal(newSViv(win->w_cursor.col)));
1007     }
1008     else if(items == 3)
1009     {
1010       int lnum, col;
1011
1012       if (!win_valid(win))
1013           win = curwin;
1014       lnum = SvIV(ST(1));
1015       col = SvIV(ST(2));
1016       win->w_cursor.lnum = lnum;
1017       win->w_cursor.col = col;
1018       check_cursor();               /* put cursor on an existing line */
1019       update_screen(NOT_VALID);
1020     }
1021
1022 MODULE = VIM        PACKAGE = VIBUF
1023
1024 void
1025 DESTROY(vimbuf)
1026     VIBUF vimbuf;
1027
1028     CODE:
1029     if (buf_valid(vimbuf))
1030         vimbuf->b_perl_private = 0;
1031
1032 void
1033 Name(vimbuf)
1034     VIBUF vimbuf;
1035
1036     PPCODE:
1037     if (!buf_valid(vimbuf))
1038         vimbuf = curbuf;
1039     /* No file name returns an empty string */
1040     if (vimbuf->b_fname == NULL)
1041         XPUSHs(sv_2mortal(newSVpv("", 0)));
1042     else
1043         XPUSHs(sv_2mortal(newSVpv((char *)vimbuf->b_fname, 0)));
1044
1045 void
1046 Number(vimbuf)
1047     VIBUF vimbuf;
1048
1049     PPCODE:
1050     if (!buf_valid(vimbuf))
1051         vimbuf = curbuf;
1052     XPUSHs(sv_2mortal(newSViv(vimbuf->b_fnum)));
1053
1054 void
1055 Count(vimbuf)
1056     VIBUF vimbuf;
1057
1058     PPCODE:
1059     if (!buf_valid(vimbuf))
1060         vimbuf = curbuf;
1061     XPUSHs(sv_2mortal(newSViv(vimbuf->b_ml.ml_line_count)));
1062
1063 void
1064 Get(vimbuf, ...)
1065     VIBUF vimbuf;
1066
1067     PREINIT:
1068     char_u *line;
1069     int i;
1070     long lnum;
1071     PPCODE:
1072     if (buf_valid(vimbuf))
1073     {
1074         for (i = 1; i < items; i++)
1075         {
1076             lnum = SvIV(ST(i));
1077             if (lnum > 0 && lnum <= vimbuf->b_ml.ml_line_count)
1078             {
1079                 line = ml_get_buf(vimbuf, lnum, FALSE);
1080                 XPUSHs(sv_2mortal(newSVpv((char *)line, 0)));
1081             }
1082         }
1083     }
1084
1085 void
1086 Set(vimbuf, ...)
1087     VIBUF vimbuf;
1088
1089     PREINIT:
1090     int i;
1091     long lnum;
1092     char *line;
1093     PPCODE:
1094     if (buf_valid(vimbuf))
1095     {
1096         if (items < 3)
1097             croak("Usage: VIBUF::Set(vimbuf, lnum, @lines)");
1098
1099         lnum = SvIV(ST(1));
1100         for(i = 2; i < items; i++, lnum++)
1101         {
1102             line = SvPV(ST(i),PL_na);
1103             if (lnum > 0 && lnum <= vimbuf->b_ml.ml_line_count && line != NULL)
1104             {
1105                 aco_save_T      aco;
1106
1107                 /* set curwin/curbuf for "vimbuf" and save some things */
1108                 aucmd_prepbuf(&aco, vimbuf);
1109
1110                 if (u_savesub(lnum) == OK)
1111                 {
1112                     ml_replace(lnum, (char_u *)line, TRUE);
1113                     changed_bytes(lnum, 0);
1114                 }
1115
1116                 /* restore curwin/curbuf and a few other things */
1117                 aucmd_restbuf(&aco);
1118                 /* Careful: autocommands may have made "vimbuf" invalid! */
1119             }
1120         }
1121     }
1122
1123 void
1124 Delete(vimbuf, ...)
1125     VIBUF vimbuf;
1126
1127     PREINIT:
1128     long i, lnum = 0, count = 0;
1129     PPCODE:
1130     if (buf_valid(vimbuf))
1131     {
1132         if (items == 2)
1133         {
1134             lnum = SvIV(ST(1));
1135             count = 1;
1136         }
1137         else if (items == 3)
1138         {
1139             lnum = SvIV(ST(1));
1140             count = 1 + SvIV(ST(2)) - lnum;
1141             if(count == 0)
1142                 count = 1;
1143             if(count < 0)
1144             {
1145                 lnum -= count;
1146                 count = -count;
1147             }
1148         }
1149         if (items >= 2)
1150         {
1151             for (i = 0; i < count; i++)
1152             {
1153                 if (lnum > 0 && lnum <= vimbuf->b_ml.ml_line_count)
1154                 {
1155                     aco_save_T  aco;
1156
1157                     /* set curwin/curbuf for "vimbuf" and save some things */
1158                     aucmd_prepbuf(&aco, vimbuf);
1159
1160                     if (u_savedel(lnum, 1) == OK)
1161                     {
1162                         ml_delete(lnum, 0);
1163                         deleted_lines_mark(lnum, 1L);
1164                         if (aco.save_buf == curbuf)
1165                             check_cursor();
1166                     }
1167
1168                     /* restore curwin/curbuf and a few other things */
1169                     aucmd_restbuf(&aco);
1170                     /* Careful: autocommands may have made "vimbuf" invalid! */
1171
1172                     update_curbuf(VALID);
1173                 }
1174             }
1175         }
1176     }
1177
1178 void
1179 Append(vimbuf, ...)
1180     VIBUF vimbuf;
1181
1182     PREINIT:
1183     int         i;
1184     long        lnum;
1185     char        *line;
1186     PPCODE:
1187     if (buf_valid(vimbuf))
1188     {
1189         if (items < 3)
1190             croak("Usage: VIBUF::Append(vimbuf, lnum, @lines)");
1191
1192         lnum = SvIV(ST(1));
1193         for (i = 2; i < items; i++, lnum++)
1194         {
1195             line = SvPV(ST(i),PL_na);
1196             if (lnum >= 0 && lnum <= vimbuf->b_ml.ml_line_count && line != NULL)
1197             {
1198                 aco_save_T      aco;
1199
1200                 /* set curwin/curbuf for "vimbuf" and save some things */
1201                 aucmd_prepbuf(&aco, vimbuf);
1202
1203                 if (u_inssub(lnum + 1) == OK)
1204                 {
1205                     ml_append(lnum, (char_u *)line, (colnr_T)0, FALSE);
1206                     appended_lines_mark(lnum, 1L);
1207                 }
1208
1209                 /* restore curwin/curbuf and a few other things */
1210                 aucmd_restbuf(&aco);
1211                 /* Careful: autocommands may have made "vimbuf" invalid! */
1212
1213                 update_curbuf(VALID);
1214             }
1215         }
1216     }
1217