pa/eqemu-server
2
0
Fork 0
mirror of https://github.com/EQEmu/Server.git synced 2026-04-16 22:12:25 +00:00
Code Issues Actions Packages Projects Releases Wiki Activity

Add perlbind library

Browse Source
This commit is contained in:
hg 2022-04-09 19:54:38 -04:00
parent be00aa1b60
commit a2c6252c58
28 changed files with 2231 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CMakeLists.txt
View File

@ -373,7 +373,7 @@ ENDIF()
IF(PERL_LIBRARY_ENABLED) IF(PERL_LIBRARY_ENABLED)
OPTION(EQEMU_BUILD_PERL "Build Perl parser." ON) OPTION(EQEMU_BUILD_PERL "Build Perl parser." ON)
IF(EQEMU_BUILD_PERL) IF(EQEMU_BUILD_PERL)
SET(SERVER_LIBS ${SERVER_LIBS} ${PERL_LIBRARY_LIBS}) SET(SERVER_LIBS ${SERVER_LIBS} ${PERL_LIBRARY_LIBS} perlbind)
INCLUDE_DIRECTORIES(SYSTEM "${PERL_LIBRARY_INCLUDE}") INCLUDE_DIRECTORIES(SYSTEM "${PERL_LIBRARY_INCLUDE}")
ADD_DEFINITIONS(-DEMBPERL) ADD_DEFINITIONS(-DEMBPERL)
ADD_DEFINITIONS(-DEMBPERL_PLUGIN) ADD_DEFINITIONS(-DEMBPERL_PLUGIN)

4
libs/CMakeLists.txt
View File

@ -1,3 +1,7 @@
IF(EQEMU_BUILD_LUA) IF(EQEMU_BUILD_LUA)
ADD_SUBDIRECTORY(luabind) ADD_SUBDIRECTORY(luabind)
ENDIF(EQEMU_BUILD_LUA) ENDIF(EQEMU_BUILD_LUA)
IF(EQEMU_BUILD_PERL)
ADD_SUBDIRECTORY(perlbind)
ENDIF(EQEMU_BUILD_PERL)

21
libs/perlbind/.gitignore vendored Normal file
View File

@ -0,0 +1,21 @@
*
!.gitignore
!.editorconfig
!CMakeLists.txt
!LICENSE
!README.md
!.github/
!.github/**
!doc/
!doc/**
!include/
!include/**
!src/
!src/*
!test/
!test/*

64
libs/perlbind/CMakeLists.txt Normal file
View File

@ -0,0 +1,64 @@
cmake_minimum_required(VERSION 3.7)
project(perlbind LANGUAGES CXX)
set(CMAKE_FIND_LIBRARY_SUFFIXES ".lib" ".so" ".a")
find_package(PerlLibs)
set(PERLBIND_HEADERS
include/perlbind/array.h
include/perlbind/forward.h
include/perlbind/function.h
include/perlbind/hash.h
include/perlbind/interpreter.h
include/perlbind/iterator.h
include/perlbind/package.h
include/perlbind/perlbind.h
include/perlbind/scalar.h
include/perlbind/stack.h
include/perlbind/stack_push.h
include/perlbind/stack_read.h
include/perlbind/subcaller.h
include/perlbind/traits.h
include/perlbind/typemap.h
include/perlbind/types.h
include/perlbind/util.h
include/perlbind/version.h
)
set(PERLBIND_SOURCES
src/function.cpp
src/hash.cpp
src/interpreter.cpp
src/package.cpp
)
if(MSVC)
set(PERLBIND_SOURCES ${PERLBIND_SOURCES} src/perlbind.natvis)
endif()
add_library(perlbind ${PERLBIND_SOURCES} ${PERLBIND_HEADERS})
target_include_directories(perlbind PUBLIC
${PERL_INCLUDE_PATH}
$<BUILD_INTERFACE:${CMAKE_CURRENT_SOURCE_DIR}/include>
$<INSTALL_INTERFACE:include>)
option(PERLBIND_BUILD_TESTS "Build tests" OFF)
option(PERLBIND_ENABLE_ASAN "Build with address sanitizer" OFF)
if(PERLBIND_ENABLE_ASAN)
target_compile_options(perlbind PRIVATE -fsanitize=address -fno-omit-frame-pointer)
target_link_options(perlbind PRIVATE -fsanitize=address -fno-omit-frame-pointer)
endif()
if(PERLBIND_BUILD_TESTS)
enable_testing()
add_subdirectory(test)
set_property(DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} PROPERTY VS_STARTUP_PROJECT tests)
target_include_directories(tests PRIVATE
${PERL_INCLUDE_PATH}
${CMAKE_CURRENT_SOURCE_DIR}/include)
endif()

19
libs/perlbind/LICENSE Normal file
View File

@ -0,0 +1,19 @@
Copyright (c) 2022 hg
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

119
libs/perlbind/include/perlbind/array.h Normal file
View File

@ -0,0 +1,119 @@
#pragma once
#include "types.h"
#include "iterator.h"
#include <stdexcept>
namespace perlbind {
struct array : public type_base
{
using iterator = detail::array_iterator;
~array() noexcept
{
SvREFCNT_dec(m_av);
}
array() noexcept
: type_base(), m_av(newAV()) {}
array(PerlInterpreter* interp) noexcept
: type_base(interp), m_av(newAV()) {}
array(const array& other) noexcept
: type_base(other.my_perl), m_av(copy_array(other.m_av)) {}
array(array&& other) noexcept
: type_base(other.my_perl), m_av(other.m_av)
{
other.m_av = newAV();
}
array(AV*& value) noexcept
: type_base(), m_av(copy_array(value)) {}
array(AV*&& value) noexcept
: type_base(), m_av(value) {} // take ownership
array(scalar ref)
: type_base(ref.my_perl)
{
if (!ref.is_array_ref())
throw std::runtime_error("cannot construct array from non-array reference");
reset(reinterpret_cast<AV*>(SvREFCNT_inc(*ref)));
}
array(scalar_proxy proxy)
: array(scalar(SvREFCNT_inc(proxy.sv()))) {}
array& operator=(const array& other) noexcept
{
if (this != &other)
m_av = copy_array(other.m_av);
return *this;
}
array& operator=(array&& other) noexcept
{
if (this != &other)
std::swap(m_av, other.m_av);
return *this;
}
array& operator=(AV*& value) noexcept
{
if (m_av != value)
m_av = copy_array(value);
return *this;
}
array& operator=(AV*&& value) noexcept
{
reset(value);
return *this;
}
operator AV*() const { return m_av; }
operator SV*() const { return reinterpret_cast<SV*>(m_av); }
AV* release() noexcept
{
AV* tmp = m_av;
m_av = newAV();
return tmp;
}
void reset(AV* value) noexcept
{
SvREFCNT_dec(m_av);
m_av = value;
}
void clear() noexcept { av_clear(m_av); } // decreases refcnt of all SV elements
scalar pop_back() noexcept { return av_pop(m_av); }
scalar pop_front() noexcept { return av_shift(m_av); }
void push_back(const scalar& value) { av_push(m_av, newSVsv(value)); }
void push_back(scalar&& value) { av_push(m_av, value.release()); }
void reserve(size_t count) { av_extend(m_av, count > 0 ? count - 1 : 0); }
size_t size() const { return av_len(m_av) + 1; }
SV* sv() const { return reinterpret_cast<SV*>(m_av); }
// returns a proxy that takes ownership of one reference to the SV element
// extends the array and creates an undef SV if index out of range
scalar_proxy operator[](size_t index)
{
SV** sv = av_fetch(m_av, index, 1);
return scalar_proxy(my_perl, SvREFCNT_inc(*sv));
}
iterator begin() const noexcept { return { my_perl, m_av, 0 }; }
iterator end() const noexcept { return { my_perl, m_av, size() }; }
private:
AV* copy_array(AV* other)
{
return av_make(av_len(other)+1, AvARRAY(other));
}
AV* m_av = nullptr;
};
} // namespace perlbind

22
libs/perlbind/include/perlbind/forward.h Normal file
View File

@ -0,0 +1,22 @@
#pragma once
namespace perlbind {
namespace detail {
class xsub_stack;
struct function_base;
struct array_iterator;
struct hash_iterator;
} // namespace detail
class interpreter;
class package;
struct scalar;
struct scalar_proxy;
struct reference;
struct array;
struct hash;
} // namespace perlbind

144
libs/perlbind/include/perlbind/function.h Normal file
View File

@ -0,0 +1,144 @@
#pragma once
namespace perlbind { namespace detail {
// traits for function and class method exports
template <typename Ret, typename Class, typename... Args>
struct base_traits
{
using return_t = Ret;
using sig_t = util::type_name<Args...>;
using stack_tuple = std::conditional_t<std::is_void<Class>::value,
std::tuple<Args...>,
std::tuple<Class*, Args...>>;
static constexpr int arity = sizeof...(Args);
static constexpr int stack_arity = sizeof...(Args) + (std::is_void<Class>::value ? 0 : 1);
static constexpr int vararg_count = count_of<array, Args...>::value +
count_of<hash, Args...>::value;
static constexpr bool is_vararg = vararg_count > 0;
static constexpr bool is_vararg_last = is_last<array, Args...>::value ||
is_last<hash, Args...>::value;
static_assert(!is_vararg || (vararg_count == 1 && is_vararg_last),
"A function may only accept a single array or hash and it must be "
"be the last parameter. Prefer using reference parameters instead.");
};
template <typename T, bool = std::is_class<T>::value>
struct function_traits : public function_traits<decltype(&T::operator()), true> {};
template <typename Ret, typename... Args>
struct function_traits<Ret(*)(Args...), false> : base_traits<Ret, void, Args...>
{
using type = Ret(*)(Args...);
};
template <typename Ret, typename Class, typename... Args>
struct function_traits<Ret(Class::*)(Args...), false> : base_traits<Ret, Class, Args...>
{
using type = Ret(Class::*)(Args...);
};
template <typename Ret, typename Class, typename... Args>
struct function_traits<Ret(Class::*)(Args...) const, false> : base_traits<Ret, Class, Args...>
{
using type = Ret(Class::*)(Args...) const;
};
template <typename Ret, typename Class, typename... Args>
struct function_traits<Ret(Class::*)(Args...) const, true> : base_traits<Ret, void, Args...>
{
using type = Ret(*)(Args...);
};
// represents a bound native function
struct function_base
{
virtual ~function_base() = default;
virtual std::string get_signature() const = 0;
virtual bool is_compatible(xsub_stack&) const = 0;
virtual void call(xsub_stack&) const = 0;
static const MGVTBL mgvtbl;
};
template <typename T>
struct function : public function_base, function_traits<T>
{
using target_t = typename function::type;
using return_t = typename function::return_t;
function() = delete;
function(PerlInterpreter* interp, T func)
: my_perl(interp), m_func(func) {}
std::string get_signature() const override
{
return util::type_name<target_t>::str();
};
bool is_compatible(xsub_stack& stack) const override
{
return function::is_vararg || stack.check_types(typename function::stack_tuple{});
}
void call(xsub_stack& stack) const override
{
if (!function::is_vararg && stack.size() != function::stack_arity)
{
using sig = typename function::sig_t;
int count = std::is_member_function_pointer<T>::value ? stack.size() - 1 : stack.size();
SV* err = newSVpvf("'%s(%s)' called with %d argument(s), expected %d\n argument(s): (%s)\n",
stack.name().c_str(), sig::str().c_str(), count, function::arity, stack.types().c_str());
err = sv_2mortal(err);
throw std::runtime_error(SvPV_nolen(err));
}
call_impl(stack, std::is_void<function::return_t>());
}
private:
void call_impl(xsub_stack& stack, std::false_type) const
{
return_t result = apply(m_func, stack.convert_stack(typename function::stack_tuple{}));
stack.push_return(std::move(result));
}
void call_impl(xsub_stack& stack, std::true_type) const
{
apply(m_func, stack.convert_stack(typename function::stack_tuple{}));
}
// c++14 call function template with tuple arg unpacking (c++17 can use std::apply())
template <typename F, typename Tuple, size_t... I>
auto call_func(F func, Tuple&& t, std::index_sequence<I...>) const
{
return func(std::get<I>(std::forward<Tuple>(t))...);
}
template <typename F, typename Tuple, size_t... I>
auto call_member(F method, Tuple&& t, std::index_sequence<I...>) const
{
return (std::get<0>(t)->*method)(std::get<I + 1>(std::forward<Tuple>(t))...);
}
template <typename F, typename Tuple, std::enable_if_t<!std::is_member_function_pointer<F>::value, bool> = true>
auto apply(F func, Tuple&& t) const
{
using make_sequence = std::make_index_sequence<std::tuple_size<Tuple>::value>;
return call_func(func, std::forward<Tuple>(t), make_sequence{});
}
template <typename F, typename Tuple, std::enable_if_t<std::is_member_function_pointer<F>::value, bool> = true>
auto apply(F func, Tuple&& t) const
{
using make_sequence = std::make_index_sequence<std::tuple_size<Tuple>::value - 1>;
return call_member(func, std::forward<Tuple>(t), make_sequence{});
}
PerlInterpreter* my_perl = nullptr;
T m_func;
};
} // namespace detail
} // namespace perlbind

124
libs/perlbind/include/perlbind/hash.h Normal file
View File

@ -0,0 +1,124 @@
#pragma once
#include "types.h"
#include <string>
namespace perlbind {
struct hash : public type_base
{
using iterator = detail::hash_iterator;
~hash() noexcept
{
SvREFCNT_dec(m_hv);
}
hash() noexcept
: type_base(), m_hv(newHV()) {}
hash(PerlInterpreter* interp) noexcept
: type_base(interp), m_hv(newHV()) {}
hash(const hash& other) noexcept
: type_base(other.my_perl), m_hv(copy_hash(other.m_hv)) {}
hash(hash&& other) noexcept
: type_base(other.my_perl), m_hv(other.m_hv)
{
other.m_hv = newHV();
}
hash(HV*& value) noexcept
: type_base(), m_hv(copy_hash(value)) {}
hash(HV*&& value) noexcept
: type_base(), m_hv(value) {} // take ownership
hash(scalar ref);
hash(scalar_proxy proxy);
hash& operator=(const hash& other) noexcept
{
if (this != &other)
m_hv = copy_hash(other.m_hv);
return *this;
}
hash& operator=(hash&& other) noexcept
{
if (this != &other)
std::swap(m_hv, other.m_hv);
return *this;
}
hash& operator=(HV*& value) noexcept
{
if (m_hv != value)
m_hv = copy_hash(value);
return *this;
}
hash& operator=(HV*&& value) noexcept
{
reset(value);
return *this;
}
operator HV*() const { return m_hv; }
operator SV*() const { return reinterpret_cast<SV*>(m_hv); }
HV* release() noexcept
{
HV* tmp = m_hv;
m_hv = newHV();
return tmp;
}
void reset(HV* value) noexcept
{
SvREFCNT_dec(m_hv);
m_hv = value;
}
scalar at(const char* key);
scalar at(const std::string& key);
void clear() noexcept { hv_clear(m_hv); }
bool exists(const char* key) const
{
return hv_exists(m_hv, key, static_cast<I32>(strlen(key)));
}
bool exists(const std::string& key) const
{
return hv_exists(m_hv, key.c_str(), static_cast<I32>(key.size()));
}
void insert(const char* key, scalar value);
void insert(const std::string& key, scalar value);
void remove(const char* key)
{
hv_delete(m_hv, key, static_cast<I32>(strlen(key)), 0);
}
void remove(const std::string& key)
{
hv_delete(m_hv, key.c_str(), static_cast<I32>(key.size()), 0);
}
size_t size() const { return HvTOTALKEYS(m_hv); }
SV* sv() const { return reinterpret_cast<SV*>(m_hv); }
// returns a proxy that takes ownership of one reference to the SV value
// creates an undef SV entry for the key if it doesn't exist
scalar_proxy operator[](const std::string& key);
iterator begin() const noexcept;
iterator end() const noexcept;
iterator find(const char* key);
iterator find(const std::string& key);
private:
scalar at(const char* key, size_t size);
iterator find(const char* key, size_t size);
void insert(const char* key, size_t size, scalar value);
HV* copy_hash(HV* other) noexcept;
HV* m_hv = nullptr;
};
} // namespace perlbind

63
libs/perlbind/include/perlbind/interpreter.h Normal file
View File

@ -0,0 +1,63 @@
#pragma once
namespace perlbind {
class interpreter
{
public:
interpreter();
interpreter(PerlInterpreter* interp) : my_perl(interp) {}
interpreter(int argc, const char** argv);
interpreter(const interpreter& other) = delete;
interpreter(interpreter&& other) = delete;
interpreter& operator=(const interpreter& other) = delete;
interpreter& operator=(interpreter&& other) = delete;
~interpreter();
PerlInterpreter* get() const { return my_perl; }
void load_script(std::string packagename, std::string filename);
void eval(const char* str);
template <typename T, typename... Args>
T call_sub(const char* subname, Args&&... args) const
{
detail::sub_caller caller(my_perl);
return caller.call_sub<T>(subname, std::forward<Args>(args)...);
}
// returns interface to add bindings to package name
package new_package(const char* name)
{
return package(my_perl, name);
}
// registers type for blessing objects, returns interface
template <typename T>
class_<T> new_class(const char* name)
{
static_assert(!std::is_pointer<T>::value && !std::is_reference<T>::value,
"new_class<T> 'T' should not be a pointer or reference");
auto typemap = detail::typemap::get(my_perl);
auto type_id = detail::usertype<T*>::id();
typemap[type_id] = name;
return class_<T>(my_perl, name);
}
// helper to bind functions in default main:: package
template <typename T>
void add(const char* name, T&& func)
{
new_package("main").add(name, std::forward<T>(func));
}
private:
void init(int argc, const char** argv);
bool m_is_owner = false;
PerlInterpreter* my_perl = nullptr;
};
} // namespace perlbind

100
libs/perlbind/include/perlbind/iterator.h Normal file
View File

@ -0,0 +1,100 @@
#pragma once
namespace perlbind { namespace detail {
struct array_iterator
{
array_iterator() = default;
array_iterator(PerlInterpreter* interp, AV* av, size_t index)
: my_perl(interp), m_av(av), m_index(index), m_scalar(interp)
{
fetch();
}
bool operator!=(const array_iterator& other) const
{
return m_index != other.m_index;
}
array_iterator& operator++()
{
++m_index;
fetch();
return *this;
}
scalar* operator->()
{
return &m_scalar;
}
scalar& operator*()
{
return m_scalar;
}
private:
void fetch()
{
SV** sv = av_fetch(m_av, m_index, 0);
if (sv)
m_scalar = SvREFCNT_inc(*sv);
}
PerlInterpreter* my_perl;
AV* m_av;
size_t m_index;
scalar m_scalar;
};
struct hash_iterator
{
hash_iterator() = default;
hash_iterator(PerlInterpreter* interp, HV* hv, HE* he)
: my_perl(interp), m_hv(hv), m_he(he)
{
fetch();
}
bool operator==(const hash_iterator& other) const
{
return m_he == other.m_he;
}
bool operator!=(const hash_iterator& other) const
{
return !(*this == other);
}
hash_iterator& operator++()
{
m_he = hv_iternext(m_hv);
fetch();
return *this;
}
std::pair<const char*, scalar>* operator->()
{
return &m_pair;
}
std::pair<const char*, scalar>& operator*()
{
return m_pair;
}
private:
void fetch()
{
if (m_he)
m_pair = { HePV(m_he, PL_na), scalar(my_perl, SvREFCNT_inc(HeVAL(m_he))) };
}
PerlInterpreter* my_perl;
HV* m_hv;
HE* m_he;
std::pair<const char*, scalar> m_pair;
};
} // namespace detail
} // namespace perlbind

59
libs/perlbind/include/perlbind/package.h Normal file
View File

@ -0,0 +1,59 @@
#pragma once
#include <string>
namespace perlbind {
class package
{
public:
virtual ~package() = default;
package() = delete;
package(PerlInterpreter* interp, const char* name)
: my_perl(interp), m_name(name), m_stash(gv_stashpv(name, GV_ADD))
{}
// bind a function pointer to a function name in the package
// overloads with same name must be explicit (default parameters not supported)
// overloads have a runtime lookup cost and chooses the first compatible overload
template <typename T>
void add(const char* name, T func)
{
// ownership of function object is given to perl
auto function = new detail::function<T>(my_perl, func);
add_impl(name, static_cast<detail::function_base*>(function));
}
// specify a base class name for object inheritance (must be registered)
// calling object methods missing from the package will search parent classes
// base classes are searched in registered order and include any grandparents
void add_base_class(const char* name)
{
std::string package_isa = m_name + "::ISA";
AV* av = get_av(package_isa.c_str(), GV_ADD);
array isa_array = reinterpret_cast<AV*>(SvREFCNT_inc(av));
isa_array.push_back(name);
}
// add a constant value to this package namespace
template <typename T>
void add_const(const char* name, T&& value)
{
newCONSTSUB(m_stash, name, scalar(value).release());
}
private:
void add_impl(const char* name, detail::function_base* function);
std::string m_name;
PerlInterpreter* my_perl = nullptr;
HV* m_stash = nullptr;
};
template <typename T>
struct class_ : public package
{
using package::package;
};
} // namespace perlbind

55
libs/perlbind/include/perlbind/perlbind.h Normal file
View File

@ -0,0 +1,55 @@
#pragma once
// Defining PERLBIND_STRICT_NUMERIC_TYPES will enable strict type checks
// for integers and floats.This is required for overloads that depend on
// int and float type differences.
// #define PERLBIND_STRICT_NUMERIC_TYPES
// Defining PERLBIND_NO_STRICT_SCALAR_TYPES will disable strict type checks
// for all int, float, and string function arguments. These types will only
// be checked for scalar validity and converted to the function's expected
// paramter type. This will break overloads that depend on distinct types.
// This option overrides PERLBIND_STRICT_NUMERIC_TYPES.
//#define PERLBIND_NO_STRICT_SCALAR_TYPES
// defining PERL_NO_GET_CONTEXT gets context from local variable "my_perl"
// instead of calling Perl_get_context() in macros
#define PERL_NO_GET_CONTEXT
#define WIN32IO_IS_STDIO
#if _MSC_VER
#define __inline__ __inline
// perl 5.30+ defines HAS_BUILTIN_EXPECT for msvc which breaks builds
#define __builtin_expect(expr,val) (expr)
// avoid INT64_C and UINT64_C redefinition warnings
#if PERL_VERSION < 28
#include <cstdint>
#endif
#endif
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
// short name perl macros that cause issues
#undef Move
#undef Copy
#undef Zero
#undef list
#undef seed
#undef do_open
#undef do_close
#include <perlbind/version.h>
#include <perlbind/forward.h>
#include <perlbind/util.h>
#include <perlbind/traits.h>
#include <perlbind/hash.h>
#include <perlbind/typemap.h>
#include <perlbind/scalar.h>
#include <perlbind/array.h>
#include <perlbind/stack.h>
#include <perlbind/subcaller.h>
#include <perlbind/function.h>
#include <perlbind/package.h>
#include <perlbind/interpreter.h>

254
libs/perlbind/include/perlbind/scalar.h Normal file
View File

@ -0,0 +1,254 @@
#pragma once
#include "types.h"
#include <string>
#include <type_traits>
namespace perlbind {
struct scalar : type_base
{
virtual ~scalar() noexcept
{
SvREFCNT_dec(m_sv);
}
scalar() noexcept
: type_base(), m_sv(newSV(0)) {} // nothing allocated
scalar(PerlInterpreter* interp) noexcept
: type_base(interp), m_sv(newSV(0)) {}
scalar(PerlInterpreter* interp, SV*&& sv) noexcept
: type_base(interp), m_sv(sv) {}
scalar(const scalar& other) noexcept
: type_base(other.my_perl), m_sv(newSVsv(other.m_sv)) {}
scalar(scalar&& other) noexcept
: type_base(other.my_perl), m_sv(other.m_sv)
{
other.m_sv = newSV(0);
}
scalar(SV*& value) noexcept
: type_base(), m_sv(newSVsv(value)) {}
scalar(SV*&& value) noexcept
: type_base(), m_sv(value) {}
scalar(const char* value) noexcept
: type_base(), m_sv(newSVpv(value, 0)) {}
scalar(const std::string& value) noexcept
: type_base(), m_sv(newSVpvn(value.c_str(), value.size())) {}
template <typename T, std::enable_if_t<detail::is_signed_integral_or_enum<T>::value, bool> = true>
scalar(T value) noexcept : type_base(), m_sv(newSViv(static_cast<IV>(value))) {}
template <typename T, std::enable_if_t<std::is_unsigned<T>::value, bool> = true>
scalar(T value) noexcept : type_base(), m_sv(newSVuv(value)) {}
template <typename T, std::enable_if_t<std::is_floating_point<T>::value, bool> = true>
scalar(T value) noexcept : type_base(), m_sv(newSVnv(value)) {}
template <typename T, std::enable_if_t<std::is_pointer<T>::value, bool> = true>
scalar(T value) noexcept : type_base(), m_sv(newSV(0))
{
*this = std::move(value);
}
scalar& operator=(const scalar& other) noexcept
{
if (this != &other)
sv_setsv(m_sv, other.m_sv);
return *this;
}
scalar& operator=(scalar&& other) noexcept
{
if (this != &other)
std::swap(m_sv, other.m_sv);
return *this;
}
scalar& operator=(SV*& value) noexcept
{
sv_setsv(m_sv, value);
return *this;
}
scalar& operator=(SV*&& value) noexcept
{
reset(value);
return *this;
}
scalar& operator=(const char* value) noexcept
{
sv_setpv(m_sv, value);
return *this;
}
scalar& operator=(const std::string& value) noexcept
{
sv_setpvn(m_sv, value.c_str(), value.size());
return *this;
}
template <typename T, std::enable_if_t<detail::is_signed_integral_or_enum<T>::value, bool> = true>
scalar& operator=(T value) noexcept
{
sv_setiv(m_sv, static_cast<IV>(value));
return *this;
}
template <typename T, std::enable_if_t<std::is_unsigned<T>::value, bool> = true>
scalar& operator=(T value) noexcept
{
sv_setuv(m_sv, value);
return *this;
}
template <typename T, std::enable_if_t<std::is_floating_point<T>::value, bool> = true>
scalar& operator=(T value) noexcept
{
sv_setnv(m_sv, value);
return *this;
}
template <typename T, std::enable_if_t<std::is_pointer<T>::value, bool> = true>
scalar& operator=(T value) noexcept
{
// bless if it's in the typemap
const char* type_name = detail::typemap::template get_name<T>(my_perl);
sv_setref_pv(m_sv, type_name, static_cast<void*>(value));
return *this;
}
operator SV*() const { return m_sv; }
operator void*() const { return m_sv; }
operator const char*() const { return SvPV_nolen(m_sv); }
operator std::string() const { return SvPV_nolen(m_sv); }
template <typename T, std::enable_if_t<detail::is_signed_integral_or_enum<T>::value, bool> = true>
operator T() const { return static_cast<T>(SvIV(m_sv)); }
template <typename T, std::enable_if_t<std::is_unsigned<T>::value, bool> = true>
operator T() const { return static_cast<T>(SvUV(m_sv)); }
template <typename T, std::enable_if_t<std::is_floating_point<T>::value, bool> = true>
operator T() const { return static_cast<T>(SvNV(m_sv)); }
template <typename T, std::enable_if_t<std::is_pointer<T>::value, bool> = true>
operator T() const
{
const char* type_name = detail::typemap::template get_name<T>(my_perl);
if (type_name && sv_isobject(m_sv) && sv_derived_from(m_sv, type_name))
{
IV tmp = SvIV(SvRV(m_sv));
return INT2PTR(T, tmp);
}
return nullptr;
}
template <typename T>
T as() const { return static_cast<T>(*this); }
// release ownership of SV
SV* release() noexcept
{
SV* tmp = m_sv;
m_sv = newSV(0);
return tmp;
}
// take ownership of an SV
void reset(SV* value) noexcept
{
SvREFCNT_dec(m_sv);
m_sv = value;
}
SV* sv() const { return m_sv; }
SV* deref() const { return SvRV(m_sv); }
size_t size() const { return SvPOK(m_sv) ? sv_len(m_sv) : 0; }
svtype type() const { return SvTYPE(m_sv); }
const char* c_str() const { return SvPV_nolen(m_sv); }
SV* operator*() { return SvRV(m_sv); }
bool is_null() const { return type() == SVt_NULL; } //SvOK(m_sv)
bool is_integer() const { return SvIOK(m_sv); }
bool is_float() const { return SvNOK(m_sv); }
bool is_string() const { return SvPOK(m_sv); }
bool is_reference() const { return SvROK(m_sv); }
bool is_scalar_ref() const { return SvROK(m_sv) && SvTYPE(SvRV(m_sv)) < SVt_PVAV; }
bool is_array_ref() const { return SvROK(m_sv) && SvTYPE(SvRV(m_sv)) == SVt_PVAV; }
bool is_hash_ref() const { return SvROK(m_sv) && SvTYPE(SvRV(m_sv)) == SVt_PVHV; }
protected:
SV* m_sv = nullptr;
};
// references are scalars that take ownership of one new reference to a value
// use reset() to take ownership of an existing RV
struct reference : public scalar
{
reference() = default;
template <typename T, std::enable_if_t<std::is_base_of<type_base, T>::value, bool> = true>
reference(T& value) noexcept : scalar(value.my_perl, nullptr) { m_sv = newRV_inc(value); }
// increments referent for rvalues of scalar objects (not raw SVs) since they dec on destruct
template <typename T, std::enable_if_t<std::is_base_of<type_base, T>::value, bool> = true>
reference(T&& value) noexcept : scalar(value.my_perl, nullptr) { m_sv = newRV_inc(value); }
template <typename T, std::enable_if_t<detail::is_any<T, SV*, AV*, HV*>::value, bool> = true>
reference(T& value) noexcept { reset(newRV_inc(reinterpret_cast<SV*>(value))); }
template <typename T, std::enable_if_t<detail::is_any<T, SV*, AV*, HV*>::value, bool> = true>
reference(T&& value) noexcept { reset(newRV_noinc(reinterpret_cast<SV*>(value))); }
SV* operator*() { return SvRV(m_sv); }
};
// scalar proxy reference is used for array and hash index operator[] overloads
struct scalar_proxy
{
scalar_proxy() = delete;
scalar_proxy(PerlInterpreter* interp, scalar&& value) noexcept
: my_perl(interp), m_value(std::move(value)) {}
SV* sv() const { return m_value; }
const char* c_str() const { return static_cast<const char*>(m_value); }
template <typename T>
T as() const { return m_value.as<T>(); }
operator std::string() const { return m_value; }
// copying value to supported conversion types (e.g. int val = arr[i])
template <typename T, std::enable_if_t<!std::is_base_of<type_base, T>::value, bool> = true>
operator T() const
{
return static_cast<T>(m_value);
}
// taking a reference to the source SV (e.g. scalar val = arr[i])
template <typename T, std::enable_if_t<std::is_same<T, scalar>::value, bool> = true>
operator T() const
{
return SvREFCNT_inc(m_value);
}
// assigning scalar to proxy, the source SV is modified (arr[i] = "new value")
scalar_proxy& operator=(scalar value)
{
m_value = value;
return *this;
}
scalar_proxy& operator=(const scalar_proxy& other)
{
m_value = other.m_value;
return *this;
}
// todo: nested proxy[]
private:
PerlInterpreter* my_perl = nullptr;
scalar m_value;
};
} // namespace perlbind

137
libs/perlbind/include/perlbind/stack.h Normal file
View File

@ -0,0 +1,137 @@
#pragma once
#include "stack_push.h"
#include "stack_read.h"
#include <algorithm>
#include <string>
#include <tuple>
namespace perlbind { namespace detail {
// handles xsub call stack from perl, inherits stack::pusher to push return values
class xsub_stack : public stack::pusher
{
public:
xsub_stack() = delete;
xsub_stack(PerlInterpreter* my_perl, CV* cv)
: stack::pusher(my_perl)
{
GV* gv = CvGV(cv);
m_sub_name = GvNAME(gv);
m_pkg_name = HvNAME(GvSTASH(gv));
dXSARGS;
this->sp = sp;
this->ax = ax;
this->mark = mark;
this->items = items;
}
~xsub_stack() { XSRETURN(m_pushed); }
int size() const { return items; }
std::string name() const { return std::string(pkg_name()) + "::" + sub_name(); }
const char* pkg_name() const { return m_pkg_name; }
const char* sub_name() const { return m_sub_name; }
template <typename T>
void push_return(T&& value)
{
XSprePUSH;
push(std::forward<T>(value));
}
// returns true if all perl stack arguments are compatible with expected native arg types
template <typename Tuple>
bool check_types(Tuple&& types)
{
static constexpr int count = std::tuple_size<Tuple>::value;
if (items != count)
return false;
else if (count == 0)
return true;
using make_sequence = std::make_index_sequence<count>;
return check_stack(std::forward<Tuple>(types), make_sequence());
}
// returns tuple of converted perl stack arguments, throws on an incompatible type
template <typename Tuple>
auto convert_stack(Tuple&& types)
{
using make_sequence = std::make_index_sequence<std::tuple_size<Tuple>::value>;
return get_stack(std::forward<Tuple>(types), make_sequence());
}
std::string types()
{
std::string args;
for (int i = 0; i < items; ++i)
{
args += get_type_name(ST(i));
if (i < (items - 1))
args += ", ";
}
return args.empty() ? "void" : args;
}
protected:
int ax = 0;
int items = 0;
SV** mark = nullptr;
const char* m_pkg_name = nullptr;
const char* m_sub_name = nullptr;
std::string get_type_name(SV* item)
{
switch (SvTYPE(item))
{
case SVt_NULL: return "<undefined>";
case SVt_NV: return "double";
case SVt_PV: return "string";
case SVt_PVAV: return "array";
case SVt_PVHV: return "hash";
case SVt_IV:
if (sv_isobject(item))
return std::string(sv_reftype(SvRV(item), true)) + "*";
else if (SvROK(item))
return "ref";
else
return "int";
default:
return sv_reftype(item, true);
}
}
private:
template <typename T>
bool check_index(T t, size_t index)
{
return stack::read_as<T>::check(my_perl, static_cast<int>(index), ax, items);
}
// return true if perl stack matches all expected argument types in tuple
template <typename Tuple, size_t... I>
bool check_stack(Tuple&& t, std::index_sequence<I...>)
{
// lists compatibility of each expected arg type (no short-circuit)
std::initializer_list<bool> res = {
check_index(std::get<I>(std::forward<Tuple>(t)), I)... };
return std::all_of(res.begin(), res.end(), [](bool same) { return same; });
}
template <typename T>
T get_stack_index(T t, size_t index)
{
return stack::read_as<T>::get(my_perl, static_cast<int>(index), ax, items);
}
template <typename Tuple, size_t... I>
auto get_stack(Tuple&& t, std::index_sequence<I...>)
{
return Tuple{ get_stack_index(std::get<I>(std::forward<Tuple>(t)), I)... };
}
};
} // namespace detail
} // namespace perlbind

118
libs/perlbind/include/perlbind/stack_push.h Normal file
View File

@ -0,0 +1,118 @@
#pragma once
#include <string>
namespace perlbind { namespace stack {
// base class for pushing value types to perl stack
// methods use macros that push new mortalized SVs but do not extend the stack
// the stack is only extended when pushing an array, hash, or using push_args().
// this is because for xsubs the "stack is always large enough to take one return value"
struct pusher
{
virtual ~pusher() = default;
pusher() = delete;
pusher(PerlInterpreter* interp) : my_perl(interp), sp(PL_stack_sp) {}
SV* pop() { return POPs; }
void push(bool value) { PUSHs(boolSV(value)); ++m_pushed; }
void push(const char* value)
{
if (!value)
PUSHs(&PL_sv_undef);
else
mPUSHp(value, strlen(value));
++m_pushed;
}
void push(const std::string& value) { mPUSHp(value.c_str(), value.size()); ++m_pushed; }
void push(scalar value) { mPUSHs(value.release()); ++m_pushed; };
void push(reference value) { mPUSHs(value.release()); ++m_pushed; };
void push(array value)
{
int count = static_cast<int>(value.size());
EXTEND(sp, count);
for (int i = 0; i < count; ++i)
{
// mortalizes one reference to array element to avoid copying
PUSHs(sv_2mortal(SvREFCNT_inc(value[i].sv())));
}
m_pushed += count;
}
void push(hash value)
{
// hashes are pushed to the perl stack as alternating keys and values
// this is less efficient than pushing a reference to the hash
auto count = hv_iterinit(value) * 2;
EXTEND(sp, count);
while (HE* entry = hv_iternext(value))
{
auto val = HeVAL(entry);
PUSHs(hv_iterkeysv(entry)); // mortalizes new key sv (keys are not stored as sv)
PUSHs(sv_2mortal(SvREFCNT_inc(val)));
}
m_pushed += count;
}
template <typename T, std::enable_if_t<detail::is_signed_integral_or_enum<T>::value, bool> = true>
void push(T value) { mPUSHi(static_cast<IV>(value)); ++m_pushed; }
template <typename T, std::enable_if_t<std::is_unsigned<T>::value, bool> = true>
void push(T value) { mPUSHu(value); ++m_pushed; }
template <typename T, std::enable_if_t<std::is_floating_point<T>::value, bool> = true>
void push(T value) { mPUSHn(value); ++m_pushed; }
template <typename T, std::enable_if_t<std::is_pointer<T>::value, bool> = true>
void push(T value)
{
const char* type_name = detail::typemap::get_name<T>(my_perl);
if (!type_name)
{
throw std::runtime_error("cannot push unregistered pointer of type '" + util::type_name<T>::str() + "'");
}
SV* sv = sv_newmortal();
sv_setref_pv(sv, type_name, static_cast<void*>(value));
PUSHs(sv);
++m_pushed;
};
void push(void* value)
{
SV* sv = sv_newmortal();
sv_setref_pv(sv, nullptr, value); // unblessed
PUSHs(sv);
++m_pushed;
}
template <typename... Args>
void push_args(Args&&... args)
{
EXTEND(sp, sizeof...(Args));
push_args_impl(std::forward<Args>(args)...);
};
protected:
PerlInterpreter* my_perl = nullptr;
SV** sp = nullptr;
int m_pushed = 0;
private:
template <typename... Args>
void push_args_impl(Args&&... args) {}
template <typename T, typename... Args>
void push_args_impl(T&& value, Args&&... args)
{
push(std::forward<T>(value));
push_args(std::forward<Args>(args)...);
}
};
} // namespace stack
} // namespace perlbind

266
libs/perlbind/include/perlbind/stack_read.h Normal file
View File

@ -0,0 +1,266 @@
#pragma once
#include <string>
namespace perlbind { namespace stack {
// perl stack reader to convert types, throws if perl stack value isn't type compatible
template <typename T, typename = void>
struct read_as;
template <typename T>
struct read_as<T, std::enable_if_t<std::is_integral<T>::value || std::is_enum<T>::value>>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
#ifdef PERLBIND_NO_STRICT_SCALAR_TYPES
return SvTYPE(ST(i)) < SVt_PVAV;
#elif !defined PERLBIND_STRICT_NUMERIC_TYPES
return SvNIOK(ST(i));
#else
return SvIOK(ST(i));
#endif
}
static T get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (!check(my_perl, i, ax, items))
{
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be an integer");
}
return static_cast<T>(SvIV(ST(i))); // unsigned and bools casted
}
};
template <typename T>
struct read_as<T, std::enable_if_t<std::is_floating_point<T>::value>>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
#ifdef PERLBIND_NO_STRICT_SCALAR_TYPES
return SvTYPE(ST(i)) < SVt_PVAV;
#elif !defined PERLBIND_STRICT_NUMERIC_TYPES
return SvNIOK(ST(i));
#else
return SvNOK(ST(i));
#endif
}
static T get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (!check(my_perl, i, ax, items))
{
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be a floating point");
}
return static_cast<T>(SvNV(ST(i)));
}
};
template <>
struct read_as<const char*>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
#ifdef PERLBIND_NO_STRICT_SCALAR_TYPES
return SvTYPE(ST(i)) < SVt_PVAV;
#else
return SvPOK(ST(i));
#endif
}
static const char* get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (!check(my_perl, i, ax, items))
{
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be a string");
}
return static_cast<const char*>(SvPV_nolen(ST(i)));
}
};
template <>
struct read_as<std::string> : read_as<const char*>
{
};
template <>
struct read_as<void*>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
return sv_isobject(ST(i));
}
static void* get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (!check(my_perl, i, ax, items))
{
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be a reference to an object");
}
IV tmp = SvIV(SvRV(ST(i)));
return INT2PTR(void*, tmp);
}
};
template <typename T>
struct read_as<T, std::enable_if_t<std::is_pointer<T>::value>>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
const char* type_name = detail::typemap::get_name<T>(my_perl);
return type_name && sv_isobject(ST(i)) && sv_derived_from(ST(i), type_name);
}
static T get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (!check(my_perl, i, ax, items))
{
// would prefer to check for unregistered types at compile time (not possible?)
const char* type_name = detail::typemap::get_name<T>(my_perl);
if (!type_name)
{
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be a reference to an unregistered type (method unusable)");
}
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be a reference to an object of type '" + type_name + "'");
}
IV tmp = SvIV(SvRV(ST(i)));
return INT2PTR(T, tmp);
}
};
template <typename T>
struct read_as<nullable<T>>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
return true;
}
static nullable<T> get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (sv_isobject(ST(i)))
{
const char* type_name = detail::typemap::get_name<T>(my_perl);
if (type_name && sv_derived_from(ST(i), type_name))
{
IV tmp = SvIV(SvRV(ST(i)));
return INT2PTR(T, tmp);
}
}
return nullptr;
}
};
template <>
struct read_as<SV*>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
return i < items;
}
static SV* get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (!check(my_perl, i, ax, items))
{
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be valid scalar value");
}
return ST(i);
}
};
// scalar, array, and hash readers return reference to stack items (not copies)
template <>
struct read_as<scalar>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
return (SvROK(ST(i)) && SvTYPE(SvRV(ST(i))) < SVt_PVAV) || SvTYPE(ST(i)) < SVt_PVAV;
}
static scalar get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (!check(my_perl, i, ax, items))
{
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be a scalar or reference to a scalar");
}
return SvROK(ST(i)) ? SvREFCNT_inc(SvRV(ST(i))) : SvREFCNT_inc(ST(i));
}
};
template <>
struct read_as<reference>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
return SvROK(ST(i));
}
static reference get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (!check(my_perl, i, ax, items))
{
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be a reference");
}
// take ownership of a reference to the RV itself (avoid reference to a reference)
reference result;
result.reset(SvREFCNT_inc(ST(i)));
return result;
}
};
template <>
struct read_as<array>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
return items > i;
}
static array get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (!check(my_perl, i, ax, items))
{
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be start of a perl array");
}
array result;
result.reserve(items - i);
for (int index = i; index < items; ++index)
{
result.push_back(SvREFCNT_inc(ST(index)));
}
return result;
}
};
template <>
struct read_as<hash>
{
static bool check(PerlInterpreter* my_perl, int i, int ax, int items)
{
int remaining = items - i;
return remaining > 0 && remaining % 2 == 0 && SvTYPE(ST(i)) == SVt_PV;
}
static hash get(PerlInterpreter* my_perl, int i, int ax, int items)
{
if (!check(my_perl, i, ax, items))
{
throw std::runtime_error("expected argument " + std::to_string(i+1) + " to be start of a perl hash");
}
hash result;
for (int index = i; index < items; index += 2)
{
const char* key = SvPV_nolen(ST(index));
result[key] = SvREFCNT_inc(ST(index + 1));
}
return result;
}
};
} // namespace stack
} // namespace perlbind

78
libs/perlbind/include/perlbind/subcaller.h Normal file
View File

@ -0,0 +1,78 @@
#pragma once
#include <stdexcept>
namespace perlbind { namespace detail {
// handles calls to perl, inherits stack::pusher to push args to perl sub
class sub_caller : public stack::pusher
{
public:
sub_caller() = delete;
sub_caller(PerlInterpreter* my_perl) : stack::pusher(my_perl)
{
ENTER; // enter scope boundary for any mortals we create
SAVETMPS;
}
~sub_caller()
{
PUTBACK; // set global sp back to local for any popped return values
FREETMPS;
LEAVE; // leave scope, decref mortals and values returned by perl
}
template <typename T, typename... Args, std::enable_if_t<std::is_void<T>::value, bool> = true>
auto call_sub(const char* subname, Args&&... args)
{
call_sub_impl(subname, G_EVAL|G_VOID, std::forward<Args>(args)...);
}
template <typename T, typename... Args, std::enable_if_t<std::is_integral<T>::value, bool> = true>
auto call_sub(const char* subname, Args&&... args)
{
T result = 0;
try
{
int count = call_sub_impl(subname, G_EVAL|G_SCALAR, std::forward<Args>(args)...);
if (count == 1)
{
SV* sv_result = pop();
result = static_cast<T>(SvIV(sv_result));
}
}
catch (...)
{
pop(); // top of stack holds undef on error when called with these flags
throw;
}
return result;
}
private:
template <typename... Args>
int call_sub_impl(const char* subname, int flags, Args&&... args)
{
PUSHMARK(SP); // notify perl of local sp (required even if not pushing args)
push_args(std::forward<Args>(args)...);
PUTBACK; // set global sp back to local so call will know pushed arg count
int result_count = call_pv(subname, flags);
SPAGAIN; // refresh local sp since call may reallocate stack for scalar returns
// ERRSV doesn't work in perl 5.28+ here for unknown reasons
SV* err = get_sv("@", 0);
if (SvTRUE(err))
{
throw std::runtime_error("Perl error: " + std::string(SvPV_nolen(err)));
}
return result_count;
}
};
} //namespace detail
} // namespace perlbind

33
libs/perlbind/include/perlbind/traits.h Normal file
View File

@ -0,0 +1,33 @@
#pragma once
namespace perlbind { namespace detail {
template<typename T, typename... Rest>
struct is_any : std::false_type {};
template<typename T, typename Last>
struct is_any<T, Last> : std::is_same<T, Last> {};
template<typename T, typename First, typename... Rest>
struct is_any<T, First, Rest...> : std::integral_constant<bool, std::is_same<T, First>::value || is_any<T, Rest...>::value> {};
template <typename T>
struct is_signed_integral : std::integral_constant<bool, std::is_integral<T>::value && std::is_signed<T>::value> {};
template <typename T>
struct is_signed_integral_or_enum : std::integral_constant<bool, is_signed_integral<T>::value || std::is_enum<T>::value> {};
template <typename T, typename... Rest>
struct count_of : std::integral_constant<size_t, 0> {};
template <typename T, typename Last>
struct count_of<T, Last> : std::integral_constant<size_t, std::is_same<T, Last>::value ? 1 : 0> {};
template <typename T, typename Next, typename... Rest>
struct count_of<T, Next, Rest...> : std::integral_constant<size_t, count_of<T, Next>::value + count_of<T, Rest...>::value> {};
template <typename T, typename... Args>
struct is_last : std::false_type {};
template <typename T, typename Last>
struct is_last<T, Last> : std::is_same<T, Last> {};
template <typename T, typename Next, typename... Args>
struct is_last<T, Next, Args...> : std::integral_constant<bool, is_last<T, Args...>::value> {};
} // namespace detail
} // namespace perlbind

45
libs/perlbind/include/perlbind/typemap.h Normal file
View File

@ -0,0 +1,45 @@
#pragma once
namespace perlbind { namespace detail {
struct usertype_counter
{
static std::size_t next_id()
{
static std::size_t counter = 0;
return counter++;
}
};
template <typename T>
struct usertype
{
static std::string id()
{
static std::size_t id = usertype_counter::next_id();
return std::to_string(id);
}
};
namespace typemap
{
// type names are stored in a hash on interpreter when registered with
// unique id keys generated by usertype counter
inline hash get(PerlInterpreter* my_perl)
{
HV* hv = get_hv("__perlbind::typemap", GV_ADD);
return reinterpret_cast<HV*>(SvREFCNT_inc(hv));
}
template <typename T>
const char* get_name(PerlInterpreter* my_perl)
{
auto typemap = detail::typemap::get(my_perl);
auto type_id = detail::template usertype<T>::id();
return typemap.exists(type_id) ? typemap[type_id].c_str() : nullptr;
}
} // namespace typemap
} // namespace detail
} // namespace perlbind

25
libs/perlbind/include/perlbind/types.h Normal file
View File

@ -0,0 +1,25 @@
#pragma once
namespace perlbind {
struct type_base
{
type_base() : my_perl(PERL_GET_THX) {}
type_base(PerlInterpreter* interp) : my_perl(interp) {}
PerlInterpreter* my_perl = nullptr;
};
// helper type to allow null object reference arguments in bindings
template <typename T>
struct nullable
{
static_assert(std::is_pointer<T>::value, "nullable<T> 'T' must be pointer");
nullable() = default;
nullable(T ptr) : m_ptr(ptr) {}
T get() { return m_ptr; }
private:
T m_ptr = nullptr;
};
} // namespace perlbind

50
libs/perlbind/include/perlbind/util.h Normal file
View File

@ -0,0 +1,50 @@
#pragma once
#include <string>
#include <typeinfo>
#ifndef _MSC_VER
#include <cxxabi.h>
#endif
namespace perlbind { namespace util {
inline std::string demangle(const char* name)
{
#ifndef _MSC_VER
int status = 0;
char* res = abi::__cxa_demangle(name, nullptr, nullptr, &status);
if (res)
{
std::string demangled = res;
free(res);
return demangled;
}
return "<unknown>";
#else
return name;
#endif
}
template <typename... Args>
struct type_name;
template <>
struct type_name<>
{
static std::string str() { return "void"; }
};
template <typename T>
struct type_name<T>
{
static std::string str() { return demangle(typeid(T).name()); }
};
template <typename T, typename... Args>
struct type_name<T, Args...>
{
static std::string str() { return type_name<T>::str() + "," + type_name<Args...>::str(); }
};
} // namespace util
} // namespace perlbind

10
libs/perlbind/include/perlbind/version.h Normal file
View File

@ -0,0 +1,10 @@
#pragma once
constexpr int perlbind_version_major = 1;
constexpr int perlbind_version_minor = 0;
constexpr int perlbind_version_patch = 0;
constexpr int perlbind_version()
{
return perlbind_version_major * 10000 + perlbind_version_minor * 100 + perlbind_version_patch;
}

15
libs/perlbind/src/function.cpp Normal file
View File

@ -0,0 +1,15 @@
#include <perlbind/perlbind.h>
namespace perlbind { namespace detail {
extern "C" int gc(pTHX_ SV* sv, MAGIC* mg)
{
auto pfunc = INT2PTR(perlbind::detail::function_base*, SvIV(sv));
delete pfunc;
return 1;
}
const MGVTBL function_base::mgvtbl = { 0, 0, 0, 0, gc, 0, 0, 0 };
} // namespace detail
} // namespace perlbind

107
libs/perlbind/src/hash.cpp Normal file
View File

@ -0,0 +1,107 @@
#include <perlbind/perlbind.h>
#include <perlbind/iterator.h>
#include <stdexcept>
namespace perlbind {
hash::hash(scalar ref)
: type_base(ref.my_perl)
{
if (!ref.is_hash_ref())
throw std::runtime_error("cannot construct hash from non-hash reference");
reset(reinterpret_cast<HV*>(SvREFCNT_inc(*ref)));
}
hash::hash(scalar_proxy proxy)
: hash(scalar(SvREFCNT_inc(proxy.sv())))
{}
scalar hash::at(const char* key)
{
return at(key, strlen(key));
}
scalar hash::at(const std::string& key)
{
return at(key.c_str(), key.size());
}
scalar hash::at(const char* key, size_t size)
{
SV** sv = hv_fetch(m_hv, key, static_cast<I32>(size), 1);
return SvREFCNT_inc(*sv);
}
void hash::insert(const char* key, scalar value)
{
insert(key, strlen(key), value);
}
void hash::insert(const std::string& key, scalar value)
{
insert(key.c_str(), key.size(), value);
}
scalar_proxy hash::operator[](const std::string& key)
{
return scalar_proxy(my_perl, at(key.c_str(), key.size()));
}
hash::iterator hash::begin() const noexcept
{
hv_iterinit(m_hv);
return { my_perl, m_hv, hv_iternext(m_hv) };
}
hash::iterator hash::end() const noexcept
{
return { my_perl, m_hv, nullptr };
}
hash::iterator hash::find(const char* key)
{
return find(key, static_cast<I32>(strlen(key)));
}
hash::iterator hash::find(const std::string& key)
{
return find(key.c_str(), static_cast<I32>(key.size()));
}
hash::iterator hash::find(const char* key, size_t size)
{
// key sv made mortal with SVs_TEMP flag
SV* keysv = newSVpvn_flags(key, static_cast<I32>(size), SVs_TEMP);
HE* he = hv_fetch_ent(m_hv, keysv, 0, 0);
return { my_perl, m_hv, he };
}
void hash::insert(const char* key, size_t size, scalar value)
{
if (!hv_store(m_hv, key, static_cast<I32>(size), SvREFCNT_inc(value), 0))
{
SvREFCNT_dec(value);
}
}
HV* hash::copy_hash(HV* other) noexcept
{
HV* hv = newHV();
hv_iterinit(other);
while (HE* entry = hv_iternext(other))
{
size_t key_size;
auto key = HePV(entry, key_size);
auto value = newSVsv(HeVAL(entry));
if (!hv_store(hv, key, static_cast<I32>(key_size), value, HeHASH(entry)))
{
SvREFCNT_dec(value);
}
}
return hv;
}
} // namespace perlbind

98
libs/perlbind/src/interpreter.cpp Normal file
View File

@ -0,0 +1,98 @@
#include <perlbind/perlbind.h>
#include <fstream>
#include <sstream>
#include <stdexcept>
EXTERN_C
{
void boot_DynaLoader(pTHX_ CV* cv);
static void xs_init(pTHX)
{
newXS(const_cast<char*>("DynaLoader::boot_DynaLoader"), boot_DynaLoader, const_cast<char*>(__FILE__));
}
}
namespace perlbind {
interpreter::interpreter()
: m_is_owner(true)
{
const char* argv[] = { "", "-ew", "0", nullptr };
constexpr int argc = (sizeof(argv) / sizeof(*argv)) - 1;
init(argc, argv);
}
interpreter::interpreter(int argc, const char** argv)
: m_is_owner(true)
{
init(argc, argv);
}
void interpreter::init(int argc, const char** argv)
{
char** argvs = const_cast<char**>(argv);
char** env = { nullptr };
// PERL_SYS_INIT3 and PERL_SYS_TERM should only be called once per program
PERL_SYS_INIT3(&argc, &argvs, &env);
my_perl = perl_alloc();
PERL_SET_CONTEXT(my_perl);
PL_perl_destruct_level = 1;
perl_construct(my_perl);
perl_parse(my_perl, xs_init, argc, argvs, nullptr);
perl_run(my_perl);
}
interpreter::~interpreter()
{
if (m_is_owner)
{
PL_perl_destruct_level = 1;
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SYS_TERM();
}
}
void interpreter::load_script(std::string packagename, std::string filename)
{
struct stat st{};
if (stat(filename.c_str(), &st) != 0)
{
throw std::runtime_error("Unable to read perl file '" + filename + "'");
}
std::ifstream ifs(filename);
std::stringstream buffer;
buffer << "package " << packagename << "; " << ifs.rdbuf();
try
{
eval(buffer.str().c_str());
}
catch (std::exception& e)
{
throw std::runtime_error("Error loading script '" + filename + "':\n " + e.what());
}
}
void interpreter::eval(const char* str)
{
SV* sv = eval_pv(str, 0);
if (sv == &PL_sv_undef)
{
SV* err = get_sv("@", 0);
if (err && err->sv_u.svu_pv[0])
{
throw std::runtime_error(err->sv_u.svu_pv);
}
throw std::runtime_error("unknown error in eval()");
}
}
} // namespace perlbind

88
libs/perlbind/src/package.cpp Normal file
View File

@ -0,0 +1,88 @@
#include <perlbind/perlbind.h>
namespace perlbind {
namespace detail {
extern "C" void xsub(PerlInterpreter* my_perl, CV* cv);
} // namespace detail
void package::add_impl(const char* name, detail::function_base* function)
{
std::string export_name = m_name + "::" + name;
// the sv is assigned a magic metamethod table to delete the function
// object when perl frees the sv
SV* sv = newSViv(PTR2IV(function));
sv_magicext(sv, nullptr, PERL_MAGIC_ext, &detail::function_base::mgvtbl, nullptr, 0);
CV* cv = get_cv(export_name.c_str(), 0);
if (!cv)
{
cv = newXS(export_name.c_str(), &detail::xsub, __FILE__);
CvXSUBANY(cv).any_ptr = function;
}
else // function exists, remove target to search overloads when called
{
CvXSUBANY(cv).any_ptr = nullptr;
}
// create an array with same name to store overloads in the CV's GV
AV* av = GvAV(CvGV(cv));
if (!av)
{
av = get_av(export_name.c_str(), GV_ADD);
}
array overloads = reinterpret_cast<AV*>(SvREFCNT_inc(av));
overloads.push_back(sv); // giving only ref to GV array
}
extern "C" void detail::xsub(PerlInterpreter* my_perl, CV* cv)
{
// croak does not unwind so inner calls throw exceptions to prevent leaks
try
{
detail::xsub_stack stack(my_perl, cv);
auto target = static_cast<detail::function_base*>(CvXSUBANY(cv).any_ptr);
if (target)
{
return target->call(stack);
}
// find first compatible overload
AV* av = GvAV(CvGV(cv));
array functions = reinterpret_cast<AV*>(SvREFCNT_inc(av));
for (const auto& function : functions)
{
auto func = INT2PTR(detail::function_base*, SvIV(function.sv()));
if (func->is_compatible(stack))
{
return func->call(stack);
}
}
SV* err = newSVpvf("no overload of '%s' matched the %d argument(s):\n (%s)\ncandidates:\n ",
stack.name().c_str(), stack.size(), stack.types().c_str());
for (const auto& function : functions)
{
auto func = INT2PTR(detail::function_base*, SvIV(function.sv()));
Perl_sv_catpvf(aTHX_ err, "%s\n ", func->get_signature().c_str());
}
err = sv_2mortal(err);
throw std::runtime_error(SvPV_nolen(err));
}
catch (std::exception& e)
{
Perl_croak(aTHX_ "%s", e.what());
}
catch (...)
{
Perl_croak(aTHX_ "unhandled exception");
}
}
} // namespace perlbind

112
libs/perlbind/src/perlbind.natvis Normal file
View File

@ -0,0 +1,112 @@
<?xml version="1.0" encoding="utf-8"?>
<AutoVisualizer xmlns="http://schemas.microsoft.com/vstudio/debugger/natvis/2010">
<Type Name="perlbind::scalar">
<AlternativeType Name="perlbind::reference" />
<DisplayString>{{ m_sv={(void*)m_sv} refcnt={m_sv->sv_refcnt,d} type={(svtype)(m_sv->sv_flags &amp; 0xff),d} }}</DisplayString>
<Expand>
<ExpandedItem>m_sv</ExpandedItem>
</Expand>
</Type>
<Type Name="perlbind::array">
<DisplayString Condition="m_av != nullptr">{{ size={(m_av->sv_any)->xav_fill + 1,d} refcnt={m_av->sv_refcnt,d} }</DisplayString>
<Expand>
<ExpandedItem>m_av</ExpandedItem>
</Expand>
</Type>
<Type Name="perlbind::hash">
<DisplayString Condition="m_hv != nullptr">{{ size={(m_hv->sv_any)->xhv_keys,d} refcnt={m_hv->sv_refcnt,d} }}</DisplayString>
<Expand>
<ExpandedItem>m_hv</ExpandedItem>
</Expand>
</Type>
<Type Name="sv">
<AlternativeType Name="cv" />
<DisplayString>{{ refcnt={sv_refcnt,d} type={(svtype)(sv_flags &amp; 0xff),d} }}</DisplayString>
<Expand>
<Item Name="[refcnt]">sv_refcnt,d</Item>
<Item Name="[type]">(svtype)(sv_flags &amp; 0xff),d</Item>
<Item Name="[reference]" Condition="(sv_flags &amp; 0x00000800)">sv_u.svu_rv</Item>
<!-- SVt_PVAV -->
<Item Name="[array]" Condition="((svtype)(sv_flags &amp; 0xff)) == 11">(av*)this</Item>
<!-- SVt_PVHV -->
<Item Name="[hash]" Condition="((svtype)(sv_flags &amp; 0xff)) == 12">(hv*)this</Item>
<!-- SVt_PVGV -->
<Item Name="[glob]" Condition="((svtype)(sv_flags &amp; 0xff)) == 9">(gv*)this</Item>
<!-- SVt_PVMG -->
<Item Name="[magic]" Condition="((svtype)(sv_flags &amp; 0xff)) == 7">((XPVMG*)(sv_any))</Item>
<!--<ExpandedItem>sv_u</ExpandedItem>-->
<Item Name="svu_pv">sv_u.svu_pv,na</Item>
<Item Name="svu_iv">sv_u.svu_iv,i</Item>
<Item Name="svu_uv">sv_u.svu_uv</Item>
<Item Name="svu_nv">sv_u.svu_nv,f</Item>
<Item Name="svu_rv">sv_u.svu_rv</Item>
</Expand>
</Type>
<Type Name="av">
<!--
These might be dependent on perl version
#define AvARRAY(av) ((av)->sv_u.svu_array)
#define AvALLOC(av) ((XPVAV*) SvANY(av))->xav_alloc
#define AvMAX(av) ((XPVAV*) SvANY(av))->xav_max
#define AvFILLp(av) ((XPVAV*) SvANY(av))->xav_fill
-->
<DisplayString>{{ size={(sv_any)->xav_fill + 1,d} refcnt={sv_refcnt,d} type={(svtype)(sv_flags &amp; 0xff),d} }</DisplayString>
<Expand>
<Item Name="[refcnt]">sv_refcnt,d</Item>
<Item Name="[size]">(sv_any)->xav_fill + 1</Item>
<Item Name="[capacity]">(sv_any)->xav_max</Item>
<ArrayItems>
<Size>(sv_any)->xav_fill + 1</Size>
<ValuePointer>(sv_u).svu_array</ValuePointer>
</ArrayItems>
</Expand>
</Type>
<Type Name="hv">
<!--
These might be dependent on perl version
SvANY(hv): (m_hv->sv_any)
HvMAX(hv): ((m_hv->sv_any)->xhv_max
HvARRAY(hv): ((m_hv->sv_u).svu_hash
HvAUX(hv): (xpvhv_aux*)&(((m_hv->sv_u)->svu_hash)[((m_hv->sv_any)->xhv_max + 1]
-->
<DisplayString>{{ size={(sv_any)->xhv_keys,d} refcnt={sv_refcnt,d} type={(svtype)(sv_flags &amp; 0xff),d} }}</DisplayString>
<Expand>
<Item Name="[refcnt]">sv_refcnt,d</Item>
<Item Name="[size]">(sv_any)->xhv_keys</Item>
<Item Name="[capacity]">(sv_any)->xhv_max</Item>
<CustomListItems MaxItemsPerView="5000">
<Variable Name="index" InitialValue="0"/>
<Variable Name="bucket_inc" InitialValue="0"/>
<Variable Name="max_index" InitialValue="(sv_any)->xhv_max"/>
<Variable Name="bucket_array" InitialValue="(sv_u).svu_hash"/>
<Variable Name="entry" InitialValue="(sv_u).svu_hash[0]"/>
<Loop>
<If Condition="entry == nullptr">
<Exec>index++</Exec>
<Exec>bucket_inc = __findnonnull(bucket_array + index, max_index - index)</Exec>
<Break Condition="bucket_inc == -1" />
<Exec>index += bucket_inc</Exec>
<Exec>entry = bucket_array[index]</Exec>
</If>
<Item Name="[{ (entry->hent_hek)->hek_key,na }]">(entry->he_valu).hent_val</Item>
<Exec>entry = entry->hent_next</Exec>
</Loop>
</CustomListItems>
</Expand>
</Type>
<Type Name="gv">
<DisplayString>{{ refcnt={sv_refcnt,d} type={(svtype)(sv_flags &amp; 0xff),d} }}</DisplayString>
<Expand>
<Item Name="[refcnt]">sv_refcnt,d</Item>
<Item Name="[type]">(svtype)(sv_flags &amp; 0xff),d</Item>
<Item Name="[sv]" Condition="(sv_u.svu_gp)->gp_sv != nullptr">(sv_u.svu_gp)->gp_sv</Item>
<Item Name="[cv]" Condition="(sv_u.svu_gp)->gp_cv != nullptr">(sv_u.svu_gp)->gp_cv</Item>
<Item Name="[array]" Condition="(sv_u.svu_gp)->gp_av != nullptr">(sv_u.svu_gp)->gp_av</Item>
<Item Name="[hash]" Condition="(sv_u.svu_gp)->gp_hv != nullptr">(sv_u.svu_gp)->gp_hv</Item>
<Item Name="svu_gp">(sv_u.svu_gp)</Item>
</Expand>
</Type>
</AutoVisualizer>