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