src/if_perl.xs

/* vi:set ts=8 sts=4 sw=4 noet:
 *
 * 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 */

/*
 * Currently 32-bit version of ActivePerl is built with VC6 (or MinGW since
 * ActivePerl 5.18).
 * (http://community.activestate.com/faq/windows-compilers-perl-modules)
 * It means that time_t should be 32-bit. However the default size of
 * time_t is 64-bit since VC8. So we have to define _USE_32BIT_TIME_T.
 */
#if defined(WIN32) && !defined(_WIN64)
# define _USE_32BIT_TIME_T
#endif

/*
 * Prevent including winsock.h.  perl.h tries to detect whether winsock.h is
 * already included before including winsock2.h, because winsock2.h isn't
 * compatible with winsock.h.  However the detection doesn't work with some
 * versions of MinGW.  If WIN32_LEAN_AND_MEAN is defined, windows.h will not
 * include winsock.h.
 */
#ifdef WIN32
# define WIN32_LEAN_AND_MEAN
#endif

#include "vim.h"

/* Work around for perl-5.18.
 * Don't include "perl\lib\CORE\inline.h" for now,
 * include it after Perl_sv_free2 is defined. */
#ifdef DYNAMIC_PERL
# define PERL_NO_INLINE_FUNCTIONS
#endif

#ifdef _MSC_VER
// Work around for using MSVC and ActivePerl 5.18.
# define __inline__ __inline
// Work around for using MSVC and Strawberry Perl 5.30.
# define __builtin_expect(expr, val) (expr)
// Work around for using MSVC and Strawberry Perl 5.32.
# define NO_THREAD_SAFE_LOCALE
#endif

#ifdef __GNUC__
# pragma GCC diagnostic push
# pragma GCC diagnostic ignored "-Wunused-variable"
#endif

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
# include <perliol.h>
#endif

/* Workaround for perl < 5.8.7 */
#ifndef PERLIO_FUNCS_DECL
# ifdef PERLIO_FUNCS_CONST
#  define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
#  define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
# else
#  define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
#  define PERLIO_FUNCS_CAST(funcs) (funcs)
# endif
#endif
#ifndef SvREFCNT_inc_void_NN
# define SvREFCNT_inc_void_NN SvREFCNT_inc
#endif

/*
 * 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


// Work around for ActivePerl 5.20.3+: Avoid generating (g)vim.lib.
#if defined(ACTIVEPERL_VERSION) && (ACTIVEPERL_VERSION >= 2003) \
	&& defined(MSWIN) && defined(USE_DYNAMIC_LOADING)
# undef XS_EXTERNAL
# define XS_EXTERNAL(name) XSPROTO(name)
#endif

/*
 * Quoting Jan Dubois of Active State:
 *    ActivePerl build 822 still identifies itself as 5.8.8 but already
 *    contains many of the changes from the upcoming Perl 5.8.9 release.
 *
 * The changes include addition of two symbols (Perl_sv_2iv_flags,
 * Perl_newXS_flags) not present in earlier releases.
 *
 * Jan Dubois suggested the following guarding scheme.
 *
 * Active State defined ACTIVEPERL_VERSION as a string in versions before
 * 5.8.8; and so the comparison to 822 below needs to be guarded.
 */
#if (PERL_REVISION == 5) && (PERL_VERSION == 8) && (PERL_SUBVERSION >= 8)
# if (ACTIVEPERL_VERSION >= 822) || (PERL_SUBVERSION >= 9)
#  define PERL589_OR_LATER
# endif
#endif
#if (PERL_REVISION == 5) && (PERL_VERSION >= 9)
# define PERL589_OR_LATER
#endif

#if (PERL_REVISION == 5) && ((PERL_VERSION > 10) || \
    (PERL_VERSION == 10) && (PERL_SUBVERSION >= 1))
# define PERL5101_OR_LATER
#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(pTHX);
static void VIM_init(void);
EXTERN_C void boot_DynaLoader(pTHX_ CV*);

/*
 * For dynamic linked perl.
 */
#if defined(DYNAMIC_PERL) || defined(PROTO)

# ifndef DYNAMIC_PERL /* just generating prototypes */
#  ifdef MSWIN
typedef int HANDLE;
#  endif
typedef int XSINIT_t;
typedef int XSUBADDR_t;
# endif
# ifndef USE_ITHREADS
typedef int perl_key;
# endif

# ifndef MSWIN
#  include <dlfcn.h>
#  define HANDLE void*
#  define PERL_PROC void*
#  define load_dll(n) dlopen((n), RTLD_LAZY|RTLD_GLOBAL)
#  define symbol_from_dll dlsym
#  define close_dll dlclose
#  define load_dll_error dlerror
# else
#  define PERL_PROC FARPROC
#  define load_dll vimLoadLib
#  define symbol_from_dll GetProcAddress
#  define close_dll FreeLibrary
#  define load_dll_error GetWin32Error
# endif
/*
 * 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
# ifdef PERL5101_OR_LATER
#  define Perl_croak_xs_usage dll_Perl_croak_xs_usage
# endif
# ifndef PROTO
#  ifdef PERL_IMPLICIT_CONTEXT
#   define Perl_croak_nocontext dll_Perl_croak_nocontext
#  endif
#  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
# if (PERL_REVISION == 5) && (PERL_VERSION >= 28)
#  define Perl_mg_get dll_Perl_mg_get
# endif
# 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
# if (PERL_REVISION == 5) && (PERL_VERSION >= 20)
#  define Perl_save_strlen dll_Perl_save_strlen
# endif
# define Perl_stack_grow dll_Perl_stack_grow
# define Perl_set_context dll_Perl_set_context
# if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
#  define Perl_sv_2bool_flags dll_Perl_sv_2bool_flags
#  if (PERL_REVISION == 5) && (PERL_VERSION < 22)
#   define Perl_xs_apiversion_bootcheck dll_Perl_xs_apiversion_bootcheck
#  endif
# else
#  define Perl_sv_2bool dll_Perl_sv_2bool
# endif
# 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
# if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
#  define Perl_sv_2pvbyte_flags dll_Perl_sv_2pvbyte_flags
# endif
# define Perl_sv_2pvbyte dll_Perl_sv_2pvbyte
# 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
# ifdef PERL589_OR_LATER
#  define Perl_sv_2iv_flags dll_Perl_sv_2iv_flags
#  define Perl_newXS_flags dll_Perl_newXS_flags
# endif
# define Perl_sv_free dll_Perl_sv_free
# if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
#  define Perl_sv_free2 dll_Perl_sv_free2
# endif
# 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
# define Perl_Gthr_key_ptr dll_Perl_Gthr_key_ptr

# define Perl_sys_init dll_Perl_sys_init
# define Perl_sys_term dll_Perl_sys_term
# define Perl_ISv_ptr dll_Perl_ISv_ptr
# define Perl_Istack_max_ptr dll_Perl_Istack_max_ptr
# define Perl_Istack_base_ptr dll_Perl_Istack_base_ptr
# define Perl_Itmps_ix_ptr dll_Perl_Itmps_ix_ptr
# define Perl_Itmps_floor_ptr dll_Perl_Itmps_floor_ptr
# define Perl_IXpv_ptr dll_Perl_IXpv_ptr
# define Perl_Ina_ptr dll_Perl_Ina_ptr
# define Perl_Imarkstack_ptr_ptr dll_Perl_Imarkstack_ptr_ptr
# define Perl_Imarkstack_max_ptr dll_Perl_Imarkstack_max_ptr
# define Perl_Istack_sp_ptr dll_Perl_Istack_sp_ptr
# define Perl_Iop_ptr dll_Perl_Iop_ptr
# define Perl_call_list dll_Perl_call_list
# define Perl_Iscopestack_ix_ptr dll_Perl_Iscopestack_ix_ptr
# define Perl_Iunitcheckav_ptr dll_Perl_Iunitcheckav_ptr
# if (PERL_REVISION == 5) && (PERL_VERSION >= 22)
#  define Perl_xs_handshake dll_Perl_xs_handshake
#  define Perl_xs_boot_epilog dll_Perl_xs_boot_epilog
# endif
# if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
#  ifdef USE_ITHREADS
#   define PL_thr_key *dll_PL_thr_key
#  endif
# endif
# define Perl_hv_iternext_flags dll_Perl_hv_iternext_flags
# define Perl_hv_iterinit dll_Perl_hv_iterinit
# define Perl_hv_iterkey dll_Perl_hv_iterkey
# define Perl_hv_iterval dll_Perl_hv_iterval
# define Perl_av_fetch dll_Perl_av_fetch
# define Perl_av_len dll_Perl_av_len
# define Perl_sv_2nv_flags dll_Perl_sv_2nv_flags
# if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
#  define PerlIOBase_pushed dll_PerlIOBase_pushed
#  define PerlIO_define_layer dll_PerlIO_define_layer
# endif
# if (PERL_REVISION == 5) && (PERL_VERSION >= 24)
#  define Perl_savetmps dll_Perl_savetmps
# 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__;
# ifdef PERL5101_OR_LATER
/* Perl-5.18 has a different Perl_croak_xs_usage signature. */
#  if (PERL_REVISION == 5) && (PERL_VERSION >= 18)
static void (*Perl_croak_xs_usage)(const CV *const, const char *const params)
						    __attribute__noreturn__;
#  else
static void (*Perl_croak_xs_usage)(pTHX_ const CV *const, const char *const params)
						    __attribute__noreturn__;
#  endif
# endif
# ifdef PERL_IMPLICIT_CONTEXT
static void (*Perl_croak_nocontext)(const char*, ...) __attribute__noreturn__;
# endif
static I32 (*Perl_dowantarray)(pTHX);
static void (*Perl_free_tmps)(pTHX);
static HV* (*Perl_gv_stashpv)(pTHX_ const char*, I32);
# if (PERL_REVISION == 5) && (PERL_VERSION >= 22)
static I32* (*Perl_markstack_grow)(pTHX);
# else
static void (*Perl_markstack_grow)(pTHX);
# endif
static MAGIC* (*Perl_mg_find)(pTHX_ SV*, int);
# if (PERL_REVISION == 5) && (PERL_VERSION >= 28)
static int (*Perl_mg_get)(pTHX_ SV*);
# endif
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*);
# if (PERL_REVISION == 5) && (PERL_VERSION >= 20)
static void (*Perl_save_strlen)(pTHX_ STRLEN* ptr);
# endif
static SV** (*Perl_stack_grow)(pTHX_ SV**, SV**p, int);
static SV** (*Perl_set_context)(void*);
# if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
static bool (*Perl_sv_2bool_flags)(pTHX_ SV*, I32);
#  if (PERL_REVISION == 5) && (PERL_VERSION < 22)
static void (*Perl_xs_apiversion_bootcheck)(pTHX_ SV *module, const char *api_p, STRLEN api_len);
#  endif
# else
static bool (*Perl_sv_2bool)(pTHX_ SV*);
# endif
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 char* (*Perl_sv_2pvbyte)(pTHX_ SV*, STRLEN*);
# if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
static char* (*Perl_sv_2pvbyte_flags)(pTHX_ SV*, STRLEN*, I32);
# 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
# ifdef PERL589_OR_LATER
static IV (*Perl_sv_2iv_flags)(pTHX_ SV* sv, I32 flags);
static CV * (*Perl_newXS_flags)(pTHX_ const char *name, XSUBADDR_t subaddr, const char *const filename, const char *const proto, U32 flags);
# 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);
# if (PERL_REVISION == 5) && (PERL_VERSION < 10)
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*);
# else
/* Perl-5.18 has a different Perl_sv_free2 signature. */
#  if (PERL_REVISION == 5) && (PERL_VERSION >= 18)
static void (*Perl_sv_free2)(pTHX_ SV*, const U32);
#  else
static void (*Perl_sv_free2)(pTHX_ SV*);
#  endif
static void (*Perl_sys_init)(int* argc, char*** argv);
static void (*Perl_sys_term)(void);
static void (*Perl_call_list)(pTHX_ I32, AV*);
#  if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
#  else
static SV** (*Perl_ISv_ptr)(register PerlInterpreter*);
static SV*** (*Perl_Istack_max_ptr)(register PerlInterpreter*);
static SV*** (*Perl_Istack_base_ptr)(register PerlInterpreter*);
static XPV** (*Perl_IXpv_ptr)(register PerlInterpreter*);
static I32* (*Perl_Itmps_ix_ptr)(register PerlInterpreter*);
static I32* (*Perl_Itmps_floor_ptr)(register PerlInterpreter*);
static STRLEN* (*Perl_Ina_ptr)(register PerlInterpreter*);
static I32** (*Perl_Imarkstack_ptr_ptr)(register PerlInterpreter*);
static I32** (*Perl_Imarkstack_max_ptr)(register PerlInterpreter*);
static SV*** (*Perl_Istack_sp_ptr)(register PerlInterpreter*);
static OP** (*Perl_Iop_ptr)(register PerlInterpreter*);
static I32* (*Perl_Iscopestack_ix_ptr)(register PerlInterpreter*);
static AV** (*Perl_Iunitcheckav_ptr)(register PerlInterpreter*);
#  endif
# endif
# if (PERL_REVISION == 5) && (PERL_VERSION >= 22)
static I32 (*Perl_xs_handshake)(const U32, void *, const char *, ...);
static void (*Perl_xs_boot_epilog)(pTHX_ const U32);
# endif

# if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
#  ifdef USE_ITHREADS
static perl_key* dll_PL_thr_key;
#  endif
# else
static GV** (*Perl_Idefgv_ptr)(register PerlInterpreter*);
static GV** (*Perl_Ierrgv_ptr)(register PerlInterpreter*);
static SV* (*Perl_Isv_yes_ptr)(register PerlInterpreter*);
static perl_key* (*Perl_Gthr_key_ptr)_((pTHX));
# endif
static void (*boot_DynaLoader)_((pTHX_ CV*));
static HE * (*Perl_hv_iternext_flags)(pTHX_ HV *, I32);
static I32 (*Perl_hv_iterinit)(pTHX_ HV *);
static char * (*Perl_hv_iterkey)(pTHX_ HE *, I32 *);
static SV * (*Perl_hv_iterval)(pTHX_ HV *, HE *);
static SV** (*Perl_av_fetch)(pTHX_ AV *, SSize_t, I32);
static SSize_t (*Perl_av_len)(pTHX_ AV *);
static NV (*Perl_sv_2nv_flags)(pTHX_ SV *const, const I32);
# if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
static IV (*PerlIOBase_pushed)(pTHX_ PerlIO *, const char *, SV *, PerlIO_funcs *);
static void (*PerlIO_define_layer)(pTHX_ PerlIO_funcs *);
# endif
# if (PERL_REVISION == 5) && (PERL_VERSION >= 24)
static void (*Perl_savetmps)(pTHX);
# endif

/*
 * Table of name to function pointer of perl.
 */
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},
# ifdef PERL5101_OR_LATER
    {"Perl_croak_xs_usage", (PERL_PROC*)&Perl_croak_xs_usage},
# endif
# ifdef PERL_IMPLICIT_CONTEXT
    {"Perl_croak_nocontext", (PERL_PROC*)&Perl_croak_nocontext},
# endif
    {"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},
# if (PERL_REVISION == 5) && (PERL_VERSION >= 28)
    {"Perl_mg_get", (PERL_PROC*)&Perl_mg_get},
# endif
    {"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},
# if (PERL_REVISION == 5) && (PERL_VERSION >= 20)
    {"Perl_save_strlen", (PERL_PROC*)&Perl_save_strlen},
# endif
    {"Perl_stack_grow", (PERL_PROC*)&Perl_stack_grow},
    {"Perl_set_context", (PERL_PROC*)&Perl_set_context},
# if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
    {"Perl_sv_2bool_flags", (PERL_PROC*)&Perl_sv_2bool_flags},
#  if (PERL_REVISION == 5) && (PERL_VERSION < 22)
    {"Perl_xs_apiversion_bootcheck",(PERL_PROC*)&Perl_xs_apiversion_bootcheck},
#  endif
# else
    {"Perl_sv_2bool", (PERL_PROC*)&Perl_sv_2bool},
# endif
    {"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_2pvbyte", (PERL_PROC*)&Perl_sv_2pvbyte},
# if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
    {"Perl_sv_2pvbyte_flags", (PERL_PROC*)&Perl_sv_2pvbyte_flags},
# endif
# ifdef PERL589_OR_LATER
    {"Perl_sv_2iv_flags", (PERL_PROC*)&Perl_sv_2iv_flags},
    {"Perl_newXS_flags", (PERL_PROC*)&Perl_newXS_flags},
# 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},
# if (PERL_REVISION == 5) && (PERL_VERSION < 10)
    {"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},
# else
    {"Perl_sv_free2", (PERL_PROC*)&Perl_sv_free2},
    {"Perl_sys_init", (PERL_PROC*)&Perl_sys_init},
    {"Perl_sys_term", (PERL_PROC*)&Perl_sys_term},
    {"Perl_call_list", (PERL_PROC*)&Perl_call_list},
#  if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
#  else
    {"Perl_ISv_ptr", (PERL_PROC*)&Perl_ISv_ptr},
    {"Perl_Istack_max_ptr", (PERL_PROC*)&Perl_Istack_max_ptr},
    {"Perl_Istack_base_ptr", (PERL_PROC*)&Perl_Istack_base_ptr},
    {"Perl_IXpv_ptr", (PERL_PROC*)&Perl_IXpv_ptr},
    {"Perl_Itmps_ix_ptr", (PERL_PROC*)&Perl_Itmps_ix_ptr},
    {"Perl_Itmps_floor_ptr", (PERL_PROC*)&Perl_Itmps_floor_ptr},
    {"Perl_Ina_ptr", (PERL_PROC*)&Perl_Ina_ptr},
    {"Perl_Imarkstack_ptr_ptr", (PERL_PROC*)&Perl_Imarkstack_ptr_ptr},
    {"Perl_Imarkstack_max_ptr", (PERL_PROC*)&Perl_Imarkstack_max_ptr},
    {"Perl_Istack_sp_ptr", (PERL_PROC*)&Perl_Istack_sp_ptr},
    {"Perl_Iop_ptr", (PERL_PROC*)&Perl_Iop_ptr},
    {"Perl_Iscopestack_ix_ptr", (PERL_PROC*)&Perl_Iscopestack_ix_ptr},
    {"Perl_Iunitcheckav_ptr", (PERL_PROC*)&Perl_Iunitcheckav_ptr},
#  endif
# endif
# if (PERL_REVISION == 5) && (PERL_VERSION >= 22)
    {"Perl_xs_handshake", (PERL_PROC*)&Perl_xs_handshake},
    {"Perl_xs_boot_epilog", (PERL_PROC*)&Perl_xs_boot_epilog},
# endif
# if (PERL_REVISION == 5) && (PERL_VERSION >= 14)
#  ifdef USE_ITHREADS
    {"PL_thr_key", (PERL_PROC*)&dll_PL_thr_key},
#  endif
# else
    {"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},
    {"Perl_Gthr_key_ptr", (PERL_PROC*)&Perl_Gthr_key_ptr},
# endif
    {"boot_DynaLoader", (PERL_PROC*)&boot_DynaLoader},
    {"Perl_hv_iternext_flags", (PERL_PROC*)&Perl_hv_iternext_flags},
    {"Perl_hv_iterinit", (PERL_PROC*)&Perl_hv_iterinit},
    {"Perl_hv_iterkey", (PERL_PROC*)&Perl_hv_iterkey},
    {"Perl_hv_iterval", (PERL_PROC*)&Perl_hv_iterval},
    {"Perl_av_fetch", (PERL_PROC*)&Perl_av_fetch},
    {"Perl_av_len", (PERL_PROC*)&Perl_av_len},
    {"Perl_sv_2nv_flags", (PERL_PROC*)&Perl_sv_2nv_flags},
# if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
    {"PerlIOBase_pushed", (PERL_PROC*)&PerlIOBase_pushed},
    {"PerlIO_define_layer", (PERL_PROC*)&PerlIO_define_layer},
# endif
# if (PERL_REVISION == 5) && (PERL_VERSION >= 24)
    {"Perl_savetmps", (PERL_PROC*)&Perl_savetmps},
# endif
    {"", NULL},
};

/* Work around for perl-5.18.
 * For now, only the definitions of S_SvREFCNT_dec are needed in
 * "perl\lib\CORE\inline.h". */
# if (PERL_REVISION == 5) && (PERL_VERSION >= 18)
static void
S_SvREFCNT_dec(pTHX_ SV *sv)
{
    if (LIKELY(sv != NULL)) {
	U32 rc = SvREFCNT(sv);
	if (LIKELY(rc > 1))
	    SvREFCNT(sv) = rc - 1;
	else
	    Perl_sv_free2(aTHX_ sv, rc);
    }
}
# endif

/* perl-5.32 needs Perl_SvREFCNT_dec */
# if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
#  define Perl_SvREFCNT_dec S_SvREFCNT_dec
# endif

/* perl-5.26 also needs S_TOPMARK and S_POPMARK. */
# if (PERL_REVISION == 5) && (PERL_VERSION >= 26)
PERL_STATIC_INLINE I32
S_TOPMARK(pTHX)
{
    DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
				 "MARK top  %p %" IVdf "\n",
				  PL_markstack_ptr,
				  (IV)*PL_markstack_ptr)));
    return *PL_markstack_ptr;
}

PERL_STATIC_INLINE I32
S_POPMARK(pTHX)
{
    DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
				 "MARK pop  %p %" IVdf "\n",
				  (PL_markstack_ptr-1),
				  (IV)*(PL_markstack_ptr-1))));
    assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
    return *PL_markstack_ptr--;
}
# endif

/* perl-5.32 needs Perl_POPMARK */
# if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
#  define Perl_POPMARK S_POPMARK
# endif

/* perl-5.34 needs Perl_SvTRUE_common; used in SvTRUE_nomg_NN */
# if (PERL_REVISION == 5) && (PERL_VERSION >= 34)
PERL_STATIC_INLINE bool
Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
{
    if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
	return SvIMMORTAL_TRUE(sv);

    if (! SvOK(sv))
	return FALSE;

    if (SvPOK(sv))
	return SvPVXtrue(sv);

    if (SvIOK(sv))
	return SvIVX(sv) != 0; /* casts to bool */

    if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
	return TRUE;

    if (sv_2bool_is_fallback)
	return sv_2bool_nomg(sv);

    return isGV_with_GP(sv);
}
# endif

/* perl-5.32 needs Perl_SvTRUE */
# if (PERL_REVISION == 5) && (PERL_VERSION >= 32)
PERL_STATIC_INLINE bool
Perl_SvTRUE(pTHX_ SV *sv) {
    if (!LIKELY(sv))
	return FALSE;
    SvGETMAGIC(sv);
    return SvTRUE_nomg_NN(sv);
}
# endif

/*
 * Make all runtime-links of perl.
 *
 * 1. Get module handle using dlopen() or vimLoadLib().
 * 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 = load_dll(libname)) == NULL)
    {
	if (verbose)
	    semsg(_("E370: Could not load library %s"), libname);
	return FAIL;
    }
    for (i = 0; perl_funcname_table[i].ptr; ++i)
    {
	if (!(*perl_funcname_table[i].ptr = symbol_from_dll(hPerlLib,
			perl_funcname_table[i].name)))
	{
	    close_dll(hPerlLib);
	    hPerlLib = NULL;
	    if (verbose)
		semsg((const char *)_(e_could_not_load_library_function_str), 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(int verbose)
{
    return perl_runtime_link_init((char *)p_perldll, verbose) == OK;
}
#endif /* DYNAMIC_PERL */

#if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
static void vim_IOLayer_init(void);
#endif

/*
 * 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(void)
{
    char *bootargs[] = { "VI", NULL };
    int argc = 3;
    static char *argv[] = { "", "-e", "" };

#if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
    Perl_sys_init(&argc, (char***)&argv);
#endif
    perl_interp = perl_alloc();
    perl_construct(perl_interp);
    perl_parse(perl_interp, xs_init, argc, argv, 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);
#elif defined(PERLIO_LAYERS)
    vim_IOLayer_init();
#endif
}

/*
 * Clean up after ourselves.
 */
    void
perl_end(void)
{
    if (perl_interp)
    {
	perl_run(perl_interp);
	perl_destruct(perl_interp);
	perl_free(perl_interp);
	perl_interp = NULL;
#if (PERL_REVISION == 5) && (PERL_VERSION >= 10)
	Perl_sys_term();
#endif
    }
}

/*
 * msg_split(): send a message to the message handling routines
 * split at '\n' first though.
 */
    void
msg_split(
    char_u	*s,
    int		attr)	/* highlighting attributes */
{
    char *next;
    char *token = (char *)s;

    while ((next = strchr(token, '\n')) && !got_int)
    {
	*next++ = '\0';			/* replace \n with \0 */
	msg_attr(token, attr);
	token = next;
    }
    if (*token && !got_int)
	msg_attr(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(
    char_u	*arg UNUSED,
    int		convert UNUSED,
    int		use_simple_function UNUSED)
{
    return NULL;
}
#endif

/*
 * Create a new reference to an SV pointing to the SCR structure
 * The b_perl_private/w_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),
 * b_perl_private/w_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)
 */

    static SV *
newWINrv(SV *rv, win_T *ptr)
{
    sv_upgrade(rv, SVt_RV);
    if (ptr->w_perl_private == NULL)
    {
	ptr->w_perl_private = newSV(0);
	sv_setiv(ptr->w_perl_private, PTR2IV(ptr));
    }
    SvREFCNT_inc_void_NN(ptr->w_perl_private);
    SvRV(rv) = ptr->w_perl_private;
    SvROK_on(rv);
    return sv_bless(rv, gv_stashpv("VIWIN", TRUE));
}

    static SV *
newBUFrv(SV *rv, buf_T *ptr)
{
    sv_upgrade(rv, SVt_RV);
    if (ptr->b_perl_private == NULL)
    {
	ptr->b_perl_private = newSV(0);
	sv_setiv(ptr->b_perl_private, PTR2IV(ptr));
    }
    SvREFCNT_inc_void_NN(ptr->b_perl_private);
    SvRV(rv) = ptr->b_perl_private;
    SvROK_on(rv);
    return sv_bless(rv, gv_stashpv("VIBUF", TRUE));
}

#if 0
SV *__sv_save[1024];
int __sv_save_ix;
#  define D_Save_Sv(sv) do { if (__sv_save_ix < 1024) __sv_save[__sv_save_ix++] = (sv); } while (0)
#else
#  define D_Save_Sv(sv) NOOP
#endif

/*
 * perl_win_free
 *	Remove all references to the window to be destroyed
 */
    void
perl_win_free(win_T *wp)
{
    if (wp->w_perl_private && perl_interp != NULL)
    {
	SV *sv = (SV*)wp->w_perl_private;
	D_Save_Sv(sv);
	sv_setiv(sv, 0);
	SvREFCNT_dec(sv);
    }
    wp->w_perl_private = NULL;
}

    void
perl_buf_free(buf_T *bp)
{
    if (bp->b_perl_private && perl_interp != NULL)
    {
	SV *sv = (SV *)bp->b_perl_private;
	D_Save_Sv(sv);
	sv_setiv(sv, 0);
	SvREFCNT_dec(sv);
    }
    bp->b_perl_private = NULL;
}

#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);

    if (SvRV(sv) != SvRV(rv))
	// XXX: This magic variable is a bit confusing...
	// Is currently refcounted ?
	sv_setsv(sv, rv);

    SvREFCNT_dec(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(void)
{
    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(exarg_T *eap)
{
    char	*err;
    char	*script;
    STRLEN	length;
    SV		*sv;
#ifdef HAVE_SANDBOX
    SV		*safe;
#endif

    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);
    }

    if (sandbox || secure)
    {
	safe = perl_get_sv("VIM::safe", FALSE);
# ifndef MAKE_TEST  /* avoid a warning for unreachable code */
	if (safe == NULL || !SvTRUE(safe))
	    emsg(_(e_perl_evaluation_forbidden_in_sandbox_without_safe_module));
	else
# endif
	{
	    PUSHMARK(SP);
	    XPUSHs(safe);
	    XPUSHs(sv);
	    PUTBACK;
	    perl_call_method("reval", G_DISCARD);
	}
    }
    else
	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(linenr_T *line, linenr_T *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);
	deleted_lines_mark(*line, 1L);
	--(*end);
	--(*line);
    }
    return OK;
}

static struct ref_map_S {
    void *vim_ref;
    SV   *perl_ref;
    struct ref_map_S *next;
} *ref_map = NULL;

    static void
ref_map_free(void)
{
    struct ref_map_S *tofree;
    struct ref_map_S *refs = ref_map;

    while (refs) {
	tofree = refs;
	refs = refs->next;
	vim_free(tofree);
    }
    ref_map = NULL;
}

    static struct ref_map_S *
ref_map_find_SV(SV *const sv)
{
    struct ref_map_S *refs = ref_map;
    int count = 350;

    while (refs) {
	if (refs->perl_ref == sv)
	    break;
	refs = refs->next;
	count--;
    }

    if (!refs && count > 0) {
	refs = (struct ref_map_S *)alloc(sizeof(struct ref_map_S));
	if (!refs)
	    return NULL;
	refs->perl_ref = sv;
	refs->vim_ref = NULL;
	refs->next = ref_map;
	ref_map = refs;
    }

    return refs;
}

    static int
perl_to_vim(SV *sv, typval_T *rettv)
{
    if (SvROK(sv))
	sv = SvRV(sv);

    switch (SvTYPE(sv)) {
	case SVt_NULL:
	    break;
	case SVt_NV:	/* float */
	    rettv->v_type	= VAR_FLOAT;
	    rettv->vval.v_float = SvNV(sv);
	    break;
	case SVt_IV:	/* integer */
	    if (!SvROK(sv)) { /* references should be string */
		rettv->vval.v_number = SvIV(sv);
		break;
	    }
	    /* FALLTHROUGH */
	case SVt_PV:	/* string */
	{
	    size_t  len		= 0;
	    char *  str_from	= SvPV(sv, len);
	    char_u *str_to	= (char_u*)alloc(
				      (unsigned)(sizeof(char_u) * (len + 1)));

	    if (str_to) {
		str_to[len] = '\0';

		while (len--) {
		    if (str_from[len] == '\0')
			str_to[len] = '\n';
		    else
			str_to[len] = str_from[len];
		}
	    }

	    rettv->v_type	    = VAR_STRING;
	    rettv->vval.v_string    = str_to;
	    break;
	}
	case SVt_PVAV:	/* list */
	{
	    SSize_t		size;
	    listitem_T *	item;
	    SV **		item2;
	    list_T *		list;
	    struct ref_map_S *	refs;

	    if ((refs = ref_map_find_SV(sv)) == NULL)
		return FAIL;

	    if (refs->vim_ref)
		list = (list_T *) refs->vim_ref;
	    else
	    {
		if ((list = list_alloc()) == NULL)
		    return FAIL;
		refs->vim_ref = list;

		for (size = av_len((AV*)sv); size >= 0; size--)
		{
		    if ((item = listitem_alloc()) == NULL)
			break;

		    item->li_tv.v_type		= VAR_NUMBER;
		    item->li_tv.v_lock		= 0;
		    item->li_tv.vval.v_number	= 0;
		    list_insert(list, item, list->lv_first);

		    item2 = av_fetch((AV *)sv, size, 0);

		    if (item2 == NULL || *item2 == NULL ||
				    perl_to_vim(*item2, &item->li_tv) == FAIL)
			break;
		}
	    }

	    rettv_list_set(rettv, list);
	    break;
	}
	case SVt_PVHV:	/* dictionary */
	{
	    HE *		entry;
	    I32			key_len;
	    char *		key;
	    dictitem_T *	item;
	    SV *		item2;
	    dict_T *		dict;
	    struct ref_map_S *	refs;

	    if ((refs = ref_map_find_SV(sv)) == NULL)
		return FAIL;

	    if (refs->vim_ref)
		dict = (dict_T *) refs->vim_ref;
	    else
	    {

		if ((dict = dict_alloc()) == NULL)
		    return FAIL;
		refs->vim_ref = dict;

		hv_iterinit((HV *)sv);

		for (entry = hv_iternext((HV *)sv); entry; entry = hv_iternext((HV *)sv))
		{
		    key_len = 0;
		    key = hv_iterkey(entry, &key_len);

		    if (!key || !key_len || strlen(key) < (size_t)key_len) {
			semsg("Malformed key Dictionary '%s'", key && *key ? key : "(empty)");
			break;
		    }

		    if ((item = dictitem_alloc((char_u *)key)) == NULL)
			break;
		    item->di_tv.v_type = VAR_NUMBER;
		    item->di_tv.vval.v_number = 0;

		    if (dict_add(dict, item) == FAIL) {
			dictitem_free(item);
			break;
		    }
		    item2 = hv_iterval((HV *)sv, entry);
		    if (item2 == NULL || perl_to_vim(item2, &item->di_tv) == FAIL)
			break;
		}
	    }

	    rettv_dict_set(rettv, dict);
	    break;
	}
	default:	/* not convertible */
	{
	    char *val	    = SvPV_nolen(sv);
	    rettv->v_type   = VAR_STRING;
	    rettv->vval.v_string = val ? vim_strsave((char_u *)val) : NULL;
	    break;
	}
    }
    return OK;
}

/*
 * "perleval()"
 */
    void
do_perleval(char_u *str, typval_T *rettv)
{
    char	*err = NULL;
    STRLEN	err_len = 0;
    SV		*sv = NULL;
#ifdef HAVE_SANDBOX
    SV		*safe;
#endif

    if (perl_interp == NULL)
    {
#ifdef DYNAMIC_PERL
	if (!perl_enabled(TRUE))
	{
	    emsg(_(e_noperl));
	    return;
	}
#endif
	perl_init();
    }

    {
	dSP;
	ENTER;
	SAVETMPS;

	if (sandbox || secure)
	{
	    safe = get_sv("VIM::safe", FALSE);
# ifndef MAKE_TEST  /* avoid a warning for unreachable code */
	    if (safe == NULL || !SvTRUE(safe))
		emsg(_(e_perl_evaluation_forbidden_in_sandbox_without_safe_module));
	    else
# endif
	    {
		sv = newSVpv((char *)str, 0);
		PUSHMARK(SP);
		XPUSHs(safe);
		XPUSHs(sv);
		PUTBACK;
		call_method("reval", G_SCALAR);
		SPAGAIN;
		SvREFCNT_dec(sv);
		sv = POPs;
		PUTBACK;
	    }
	}
	else
	    sv = eval_pv((char *)str, 0);

	if (sv) {
	    perl_to_vim(sv, rettv);
	    ref_map_free();
	    err = SvPV(GvSV(PL_errgv), err_len);
	}
	FREETMPS;
	LEAVE;
    }
    if (err_len)
	msg_split((char_u *)err, highlight_attr[HLF_E]);
}

/*
 * ":perldo".
 */
    void
ex_perldo(exarg_T *eap)
{
    STRLEN	length;
    SV		*sv;
    char	*str;
    linenr_T	i;
    buf_T	*was_curbuf = curbuf;

    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++)
    {
	/* Check the line number, the command my have deleted lines. */
	if (i > curbuf->b_ml.ml_line_count)
	    break;
	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 || curbuf != was_curbuf)
	    break;
	SPAGAIN;
	if (SvTRUEx(POPs))
	{
	    if (replace_line(&i, &eap->line2) != OK)
	    {
		PUTBACK;
		break;
	    }
	}
	PUTBACK;
    }
    FREETMPS;
    LEAVE;
    check_cursor();
    update_screen(UPD_NOT_VALID);
    if (!length)
	return;

err:
    msg_split((char_u *)str, highlight_attr[HLF_E]);
    return;
    }
}

#if defined(PERLIO_LAYERS) && !defined(USE_SFIO)
typedef struct {
    struct _PerlIO base;
    int attr;
} PerlIOVim;

    static IV
PerlIOVim_pushed(pTHX_ PerlIO *f, const char *mode,
		 SV *arg, PerlIO_funcs *tab)
{
    PerlIOVim *s = PerlIOSelf(f, PerlIOVim);
    s->attr = 0;
    if (arg && SvPOK(arg))
	s->attr = syn_name2attr((char_u *)SvPV_nolen(arg));
    return PerlIOBase_pushed(aTHX_ f, mode, (SV *)NULL, tab);
}

    static SSize_t
PerlIOVim_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
    char_u *str;
    PerlIOVim * s = PerlIOSelf(f, PerlIOVim);

    str = vim_strnsave((char_u *)vbuf, count);
    if (str == NULL)
	return 0;
    msg_split((char_u *)str, s->attr);
    vim_free(str);

    return (SSize_t)count;
}

static PERLIO_FUNCS_DECL(PerlIO_Vim) = {
    sizeof(PerlIO_funcs),
    "Vim",
    sizeof(PerlIOVim),
    PERLIO_K_DUMMY,	/* flags */
    PerlIOVim_pushed,
    NULL,		/* popped */
    NULL,		/* open */
    NULL,		/* binmode */
    NULL,		/* arg */
    NULL,		/* fileno */
    NULL,		/* dup */
    NULL,		/* read */
    NULL,		/* unread */
    PerlIOVim_write,
    NULL,		/* seek */
    NULL,		/* tell */
    NULL,		/* close */
    NULL,		/* flush */
    NULL,		/* fill */
    NULL,		/* eof */
    NULL,		/* error */
    NULL,		/* clearerr */
    NULL,		/* setlinebuf */
    NULL,		/* get_base */
    NULL,		/* get_bufsiz */
    NULL,		/* get_ptr */
    NULL,		/* get_cnt */
    NULL		/* set_ptrcnt */
};

/* Use Vim routine for print operator */
    static void
vim_IOLayer_init(void)
{
    PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_Vim));
    (void)eval_pv(   "binmode(STDOUT, ':Vim')"
                "  && binmode(STDERR, ':Vim(ErrorMsg)');", 0);
}
#endif /* PERLIO_LAYERS && !USE_SFIO */

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;

    PPCODE:
    if (text != NULL)
    {
	attr = 0;
	if (hl != NULL)
	    attr = syn_name2attr((char_u *)hl);
	msg_split((char_u *)text, attr);
    }

void
SetOption(line)
    char *line;

    PPCODE:
    if (line != NULL)
	do_set((char_u *)line, 0);
    update_screen(UPD_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, TRUE, FALSE);
	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);
	}

SV*
Blob(SV* sv)
    PREINIT:
    STRLEN	len;
    char	*s;
    unsigned	i;
    char	buf[3];
    SV*		newsv;

    CODE:
    s = SvPVbyte(sv, len);
    newsv = newSVpv("0z", 2);
    for (i = 0; i < len; i++)
    {
	sprintf(buf, "%02X", (unsigned char)(s[i]));
	sv_catpvn(newsv, buf, 2);
    }
    RETVAL = newsv;
    OUTPUT:
    RETVAL

void
Buffers(...)

    PREINIT:
    buf_T *vimbuf;
    int i, b;

    PPCODE:
    if (items == 0)
    {
	if (GIMME == G_SCALAR)
	{
	    i = 0;
	    FOR_ALL_BUFFERS(vimbuf)
		++i;

	    XPUSHs(sv_2mortal(newSViv(i)));
	}
	else
	{
	    FOR_ALL_BUFFERS(vimbuf)
		XPUSHs(sv_2mortal(newBUFrv(newSV(0), vimbuf)));
	}
    }
    else
    {
	for (i = 0; i < items; i++)
	{
	    SV *sv = ST(i);
	    if (SvIOK(sv))
		b = (int) SvIV(ST(i));
	    else
	    {
		char_u *pat;
		STRLEN len;

		pat = (char_u *)SvPV(sv, len);
		++emsg_off;
		b = buflist_findpat(pat, pat + len, TRUE, FALSE, FALSE);
		--emsg_off;
	    }

	    if (b >= 0)
	    {
		vimbuf = buflist_findnr(b);
		if (vimbuf)
		    XPUSHs(sv_2mortal(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_ALL_WINDOWS(vimwin)
		XPUSHs(sv_2mortal(newWINrv(newSV(0), vimwin)));
	}
    }
    else
    {
	for (i = 0; i < items; i++)
	{
	    w = (int) SvIV(ST(i));
	    vimwin = win_find_nr(w);
	    if (vimwin)
		XPUSHs(sv_2mortal(newWINrv(newSV(0), vimwin)));
	}
    }

MODULE = VIM	    PACKAGE = VIWIN

void
DESTROY(win)
    VIWIN win

    CODE:
    if (win_valid(win))
	win->w_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 = (int) SvIV(ST(1));
      col = (int) SvIV(ST(2));
      win->w_cursor.lnum = lnum;
      win->w_cursor.col = col;
      win->w_set_curswant = TRUE;
      check_cursor();		    /* put cursor on an existing line */
      update_screen(UPD_NOT_VALID);
    }

MODULE = VIM	    PACKAGE = VIBUF

void
DESTROY(vimbuf)
    VIBUF vimbuf;

    CODE:
    if (buf_valid(vimbuf))
	vimbuf->b_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 = (long) 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;
    PPCODE:
    if (buf_valid(vimbuf))
    {
	if (items < 3)
	    croak("Usage: VIBUF::Set(vimbuf, lnum, @lines)");

	lnum = (long) 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)
	    {
		aco_save_T	aco;

		/* set curwin/curbuf for "vimbuf" and save some things */
		aucmd_prepbuf(&aco, vimbuf);

		if (u_savesub(lnum) == OK)
		{
		    ml_replace(lnum, (char_u *)line, TRUE);
		    changed_bytes(lnum, 0);
		}

		/* restore curwin/curbuf and a few other things */
		aucmd_restbuf(&aco);
		/* Careful: autocommands may have made "vimbuf" invalid! */
	    }
	}
    }

void
Delete(vimbuf, ...)
    VIBUF vimbuf;

    PREINIT:
    long i, lnum = 0, count = 0;
    PPCODE:
    if (buf_valid(vimbuf))
    {
	if (items == 2)
	{
	    lnum = (long) SvIV(ST(1));
	    count = 1;
	}
	else if (items == 3)
	{
	    lnum = (long) SvIV(ST(1));
	    count = (long) 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)
		{
		    aco_save_T	aco;

		    /* set curwin/curbuf for "vimbuf" and save some things */
		    aucmd_prepbuf(&aco, vimbuf);

		    if (u_savedel(lnum, 1) == OK)
		    {
			ml_delete(lnum);
			check_cursor();
			deleted_lines_mark(lnum, 1L);
		    }

		    /* restore curwin/curbuf and a few other things */
		    aucmd_restbuf(&aco);
		    /* Careful: autocommands may have made "vimbuf" invalid! */

		    update_curbuf(UPD_VALID);
		}
	    }
	}
    }

void
Append(vimbuf, ...)
    VIBUF vimbuf;

    PREINIT:
    int		i;
    long	lnum;
    char	*line;
    PPCODE:
    if (buf_valid(vimbuf))
    {
	if (items < 3)
	    croak("Usage: VIBUF::Append(vimbuf, lnum, @lines)");

	lnum = (long) 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)
	    {
		aco_save_T	aco;

		/* set curwin/curbuf for "vimbuf" and save some things */
		aucmd_prepbuf(&aco, vimbuf);

		if (u_inssub(lnum + 1) == OK)
		{
		    ml_append(lnum, (char_u *)line, (colnr_T)0, FALSE);
		    appended_lines_mark(lnum, 1L);
		}

		/* restore curwin/curbuf and a few other things */
		aucmd_restbuf(&aco);
		/* Careful: autocommands may have made "vimbuf" invalid! */

		update_curbuf(UPD_VALID);
	    }
	}
    }

#ifdef __GNUC__
# pragma GCC diagnostic pop
#endif