From a2c6252c58d0875246316c5ab06e61148b94d8bb Mon Sep 17 00:00:00 2001 From: hg <4683435+hgtw@users.noreply.github.com> Date: Sat, 9 Apr 2022 19:54:38 -0400 Subject: [PATCH] Add perlbind library --- CMakeLists.txt | 2 +- libs/CMakeLists.txt | 4 + libs/perlbind/.gitignore | 21 ++ libs/perlbind/CMakeLists.txt | 64 +++++ libs/perlbind/LICENSE | 19 ++ libs/perlbind/include/perlbind/array.h | 119 +++++++++ libs/perlbind/include/perlbind/forward.h | 22 ++ libs/perlbind/include/perlbind/function.h | 144 ++++++++++ libs/perlbind/include/perlbind/hash.h | 124 +++++++++ libs/perlbind/include/perlbind/interpreter.h | 63 +++++ libs/perlbind/include/perlbind/iterator.h | 100 +++++++ libs/perlbind/include/perlbind/package.h | 59 ++++ libs/perlbind/include/perlbind/perlbind.h | 55 ++++ libs/perlbind/include/perlbind/scalar.h | 254 ++++++++++++++++++ libs/perlbind/include/perlbind/stack.h | 137 ++++++++++ libs/perlbind/include/perlbind/stack_push.h | 118 ++++++++ libs/perlbind/include/perlbind/stack_read.h | 266 +++++++++++++++++++ libs/perlbind/include/perlbind/subcaller.h | 78 ++++++ libs/perlbind/include/perlbind/traits.h | 33 +++ libs/perlbind/include/perlbind/typemap.h | 45 ++++ libs/perlbind/include/perlbind/types.h | 25 ++ libs/perlbind/include/perlbind/util.h | 50 ++++ libs/perlbind/include/perlbind/version.h | 10 + libs/perlbind/src/function.cpp | 15 ++ libs/perlbind/src/hash.cpp | 107 ++++++++ libs/perlbind/src/interpreter.cpp | 98 +++++++ libs/perlbind/src/package.cpp | 88 ++++++ libs/perlbind/src/perlbind.natvis | 112 ++++++++ 28 files changed, 2231 insertions(+), 1 deletion(-) create mode 100644 libs/perlbind/.gitignore create mode 100644 libs/perlbind/CMakeLists.txt create mode 100644 libs/perlbind/LICENSE create mode 100644 libs/perlbind/include/perlbind/array.h create mode 100644 libs/perlbind/include/perlbind/forward.h create mode 100644 libs/perlbind/include/perlbind/function.h create mode 100644 libs/perlbind/include/perlbind/hash.h create mode 100644 libs/perlbind/include/perlbind/interpreter.h create mode 100644 libs/perlbind/include/perlbind/iterator.h create mode 100644 libs/perlbind/include/perlbind/package.h create mode 100644 libs/perlbind/include/perlbind/perlbind.h create mode 100644 libs/perlbind/include/perlbind/scalar.h create mode 100644 libs/perlbind/include/perlbind/stack.h create mode 100644 libs/perlbind/include/perlbind/stack_push.h create mode 100644 libs/perlbind/include/perlbind/stack_read.h create mode 100644 libs/perlbind/include/perlbind/subcaller.h create mode 100644 libs/perlbind/include/perlbind/traits.h create mode 100644 libs/perlbind/include/perlbind/typemap.h create mode 100644 libs/perlbind/include/perlbind/types.h create mode 100644 libs/perlbind/include/perlbind/util.h create mode 100644 libs/perlbind/include/perlbind/version.h create mode 100644 libs/perlbind/src/function.cpp create mode 100644 libs/perlbind/src/hash.cpp create mode 100644 libs/perlbind/src/interpreter.cpp create mode 100644 libs/perlbind/src/package.cpp create mode 100644 libs/perlbind/src/perlbind.natvis diff --git a/CMakeLists.txt b/CMakeLists.txt index 407b1a221..30afb1324 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -373,7 +373,7 @@ ENDIF() IF(PERL_LIBRARY_ENABLED) OPTION(EQEMU_BUILD_PERL "Build Perl parser." ON) 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}") ADD_DEFINITIONS(-DEMBPERL) ADD_DEFINITIONS(-DEMBPERL_PLUGIN) diff --git a/libs/CMakeLists.txt b/libs/CMakeLists.txt index f454d164a..d5b325aec 100644 --- a/libs/CMakeLists.txt +++ b/libs/CMakeLists.txt @@ -1,3 +1,7 @@ IF(EQEMU_BUILD_LUA) ADD_SUBDIRECTORY(luabind) ENDIF(EQEMU_BUILD_LUA) + +IF(EQEMU_BUILD_PERL) + ADD_SUBDIRECTORY(perlbind) +ENDIF(EQEMU_BUILD_PERL) diff --git a/libs/perlbind/.gitignore b/libs/perlbind/.gitignore new file mode 100644 index 000000000..af66ff704 --- /dev/null +++ b/libs/perlbind/.gitignore @@ -0,0 +1,21 @@ +* +!.gitignore +!.editorconfig +!CMakeLists.txt +!LICENSE +!README.md + +!.github/ +!.github/** + +!doc/ +!doc/** + +!include/ +!include/** + +!src/ +!src/* + +!test/ +!test/* diff --git a/libs/perlbind/CMakeLists.txt b/libs/perlbind/CMakeLists.txt new file mode 100644 index 000000000..c03dd8e3a --- /dev/null +++ b/libs/perlbind/CMakeLists.txt @@ -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} + $ + $) + +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() diff --git a/libs/perlbind/LICENSE b/libs/perlbind/LICENSE new file mode 100644 index 000000000..37bca4200 --- /dev/null +++ b/libs/perlbind/LICENSE @@ -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. diff --git a/libs/perlbind/include/perlbind/array.h b/libs/perlbind/include/perlbind/array.h new file mode 100644 index 000000000..be9b7781a --- /dev/null +++ b/libs/perlbind/include/perlbind/array.h @@ -0,0 +1,119 @@ +#pragma once + +#include "types.h" +#include "iterator.h" +#include + +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(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(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(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 diff --git a/libs/perlbind/include/perlbind/forward.h b/libs/perlbind/include/perlbind/forward.h new file mode 100644 index 000000000..9757eb19c --- /dev/null +++ b/libs/perlbind/include/perlbind/forward.h @@ -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 diff --git a/libs/perlbind/include/perlbind/function.h b/libs/perlbind/include/perlbind/function.h new file mode 100644 index 000000000..2d4455a9b --- /dev/null +++ b/libs/perlbind/include/perlbind/function.h @@ -0,0 +1,144 @@ +#pragma once + +namespace perlbind { namespace detail { + +// traits for function and class method exports +template +struct base_traits +{ + using return_t = Ret; + using sig_t = util::type_name; + using stack_tuple = std::conditional_t::value, + std::tuple, + std::tuple>; + static constexpr int arity = sizeof...(Args); + static constexpr int stack_arity = sizeof...(Args) + (std::is_void::value ? 0 : 1); + static constexpr int vararg_count = count_of::value + + count_of::value; + static constexpr bool is_vararg = vararg_count > 0; + static constexpr bool is_vararg_last = is_last::value || + is_last::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 ::value> +struct function_traits : public function_traits {}; + +template +struct function_traits : base_traits +{ + using type = Ret(*)(Args...); +}; + +template +struct function_traits : base_traits +{ + using type = Ret(Class::*)(Args...); +}; + +template +struct function_traits : base_traits +{ + using type = Ret(Class::*)(Args...) const; +}; + +template +struct function_traits : base_traits +{ + 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 +struct function : public function_base, function_traits +{ + 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::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::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()); + } + +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 + auto call_func(F func, Tuple&& t, std::index_sequence) const + { + return func(std::get(std::forward(t))...); + } + + template + auto call_member(F method, Tuple&& t, std::index_sequence) const + { + return (std::get<0>(t)->*method)(std::get(std::forward(t))...); + } + + template ::value, bool> = true> + auto apply(F func, Tuple&& t) const + { + using make_sequence = std::make_index_sequence::value>; + return call_func(func, std::forward(t), make_sequence{}); + } + + template ::value, bool> = true> + auto apply(F func, Tuple&& t) const + { + using make_sequence = std::make_index_sequence::value - 1>; + return call_member(func, std::forward(t), make_sequence{}); + } + + PerlInterpreter* my_perl = nullptr; + T m_func; +}; + +} // namespace detail +} // namespace perlbind diff --git a/libs/perlbind/include/perlbind/hash.h b/libs/perlbind/include/perlbind/hash.h new file mode 100644 index 000000000..28bf72d53 --- /dev/null +++ b/libs/perlbind/include/perlbind/hash.h @@ -0,0 +1,124 @@ +#pragma once + +#include "types.h" +#include + +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(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(strlen(key))); + } + bool exists(const std::string& key) const + { + return hv_exists(m_hv, key.c_str(), static_cast(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(strlen(key)), 0); + } + void remove(const std::string& key) + { + hv_delete(m_hv, key.c_str(), static_cast(key.size()), 0); + } + size_t size() const { return HvTOTALKEYS(m_hv); } + SV* sv() const { return reinterpret_cast(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 diff --git a/libs/perlbind/include/perlbind/interpreter.h b/libs/perlbind/include/perlbind/interpreter.h new file mode 100644 index 000000000..5d4f03caf --- /dev/null +++ b/libs/perlbind/include/perlbind/interpreter.h @@ -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 + T call_sub(const char* subname, Args&&... args) const + { + detail::sub_caller caller(my_perl); + return caller.call_sub(subname, std::forward(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 + class_ new_class(const char* name) + { + static_assert(!std::is_pointer::value && !std::is_reference::value, + "new_class 'T' should not be a pointer or reference"); + + auto typemap = detail::typemap::get(my_perl); + auto type_id = detail::usertype::id(); + typemap[type_id] = name; + + return class_(my_perl, name); + } + + // helper to bind functions in default main:: package + template + void add(const char* name, T&& func) + { + new_package("main").add(name, std::forward(func)); + } + +private: + void init(int argc, const char** argv); + + bool m_is_owner = false; + PerlInterpreter* my_perl = nullptr; +}; + +} // namespace perlbind diff --git a/libs/perlbind/include/perlbind/iterator.h b/libs/perlbind/include/perlbind/iterator.h new file mode 100644 index 000000000..c53174129 --- /dev/null +++ b/libs/perlbind/include/perlbind/iterator.h @@ -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* operator->() + { + return &m_pair; + } + + std::pair& 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 m_pair; +}; + +} // namespace detail +} // namespace perlbind diff --git a/libs/perlbind/include/perlbind/package.h b/libs/perlbind/include/perlbind/package.h new file mode 100644 index 000000000..3e8238662 --- /dev/null +++ b/libs/perlbind/include/perlbind/package.h @@ -0,0 +1,59 @@ +#pragma once + +#include + +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 + void add(const char* name, T func) + { + // ownership of function object is given to perl + auto function = new detail::function(my_perl, func); + add_impl(name, static_cast(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(SvREFCNT_inc(av)); + isa_array.push_back(name); + } + + // add a constant value to this package namespace + template + 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 +struct class_ : public package +{ + using package::package; +}; + +} // namespace perlbind diff --git a/libs/perlbind/include/perlbind/perlbind.h b/libs/perlbind/include/perlbind/perlbind.h new file mode 100644 index 000000000..7e1a7830e --- /dev/null +++ b/libs/perlbind/include/perlbind/perlbind.h @@ -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 +#endif +#endif + +#include +#include +#include + +// short name perl macros that cause issues +#undef Move +#undef Copy +#undef Zero +#undef list +#undef seed +#undef do_open +#undef do_close + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include diff --git a/libs/perlbind/include/perlbind/scalar.h b/libs/perlbind/include/perlbind/scalar.h new file mode 100644 index 000000000..ea2d97ade --- /dev/null +++ b/libs/perlbind/include/perlbind/scalar.h @@ -0,0 +1,254 @@ +#pragma once + +#include "types.h" +#include +#include + +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 ::value, bool> = true> + scalar(T value) noexcept : type_base(), m_sv(newSViv(static_cast(value))) {} + + template ::value, bool> = true> + scalar(T value) noexcept : type_base(), m_sv(newSVuv(value)) {} + + template ::value, bool> = true> + scalar(T value) noexcept : type_base(), m_sv(newSVnv(value)) {} + + template ::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 ::value, bool> = true> + scalar& operator=(T value) noexcept + { + sv_setiv(m_sv, static_cast(value)); + return *this; + } + + template ::value, bool> = true> + scalar& operator=(T value) noexcept + { + sv_setuv(m_sv, value); + return *this; + } + + template ::value, bool> = true> + scalar& operator=(T value) noexcept + { + sv_setnv(m_sv, value); + return *this; + } + + template ::value, bool> = true> + scalar& operator=(T value) noexcept + { + // bless if it's in the typemap + const char* type_name = detail::typemap::template get_name(my_perl); + sv_setref_pv(m_sv, type_name, static_cast(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 ::value, bool> = true> + operator T() const { return static_cast(SvIV(m_sv)); } + template ::value, bool> = true> + operator T() const { return static_cast(SvUV(m_sv)); } + template ::value, bool> = true> + operator T() const { return static_cast(SvNV(m_sv)); } + template ::value, bool> = true> + operator T() const + { + const char* type_name = detail::typemap::template get_name(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 + T as() const { return static_cast(*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 ::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 ::value, bool> = true> + reference(T&& value) noexcept : scalar(value.my_perl, nullptr) { m_sv = newRV_inc(value); } + + template ::value, bool> = true> + reference(T& value) noexcept { reset(newRV_inc(reinterpret_cast(value))); } + + template ::value, bool> = true> + reference(T&& value) noexcept { reset(newRV_noinc(reinterpret_cast(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(m_value); } + + template + T as() const { return m_value.as(); } + + operator std::string() const { return m_value; } + + // copying value to supported conversion types (e.g. int val = arr[i]) + template ::value, bool> = true> + operator T() const + { + return static_cast(m_value); + } + + // taking a reference to the source SV (e.g. scalar val = arr[i]) + template ::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 diff --git a/libs/perlbind/include/perlbind/stack.h b/libs/perlbind/include/perlbind/stack.h new file mode 100644 index 000000000..64bdb2e04 --- /dev/null +++ b/libs/perlbind/include/perlbind/stack.h @@ -0,0 +1,137 @@ +#pragma once + +#include "stack_push.h" +#include "stack_read.h" +#include +#include +#include + +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 + void push_return(T&& value) + { + XSprePUSH; + push(std::forward(value)); + } + + // returns true if all perl stack arguments are compatible with expected native arg types + template + bool check_types(Tuple&& types) + { + static constexpr int count = std::tuple_size::value; + if (items != count) + return false; + else if (count == 0) + return true; + + using make_sequence = std::make_index_sequence; + return check_stack(std::forward(types), make_sequence()); + } + + // returns tuple of converted perl stack arguments, throws on an incompatible type + template + auto convert_stack(Tuple&& types) + { + using make_sequence = std::make_index_sequence::value>; + return get_stack(std::forward(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 ""; + 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 + bool check_index(T t, size_t index) + { + return stack::read_as::check(my_perl, static_cast(index), ax, items); + } + + // return true if perl stack matches all expected argument types in tuple + template + bool check_stack(Tuple&& t, std::index_sequence) + { + // lists compatibility of each expected arg type (no short-circuit) + std::initializer_list res = { + check_index(std::get(std::forward(t)), I)... }; + + return std::all_of(res.begin(), res.end(), [](bool same) { return same; }); + } + + template + T get_stack_index(T t, size_t index) + { + return stack::read_as::get(my_perl, static_cast(index), ax, items); + } + + template + auto get_stack(Tuple&& t, std::index_sequence) + { + return Tuple{ get_stack_index(std::get(std::forward(t)), I)... }; + } +}; + +} // namespace detail +} // namespace perlbind diff --git a/libs/perlbind/include/perlbind/stack_push.h b/libs/perlbind/include/perlbind/stack_push.h new file mode 100644 index 000000000..819b0767b --- /dev/null +++ b/libs/perlbind/include/perlbind/stack_push.h @@ -0,0 +1,118 @@ +#pragma once + +#include + +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(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 ::value, bool> = true> + void push(T value) { mPUSHi(static_cast(value)); ++m_pushed; } + + template ::value, bool> = true> + void push(T value) { mPUSHu(value); ++m_pushed; } + + template ::value, bool> = true> + void push(T value) { mPUSHn(value); ++m_pushed; } + + template ::value, bool> = true> + void push(T value) + { + const char* type_name = detail::typemap::get_name(my_perl); + if (!type_name) + { + throw std::runtime_error("cannot push unregistered pointer of type '" + util::type_name::str() + "'"); + } + + SV* sv = sv_newmortal(); + sv_setref_pv(sv, type_name, static_cast(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 + void push_args(Args&&... args) + { + EXTEND(sp, sizeof...(Args)); + push_args_impl(std::forward(args)...); + }; + +protected: + PerlInterpreter* my_perl = nullptr; + SV** sp = nullptr; + int m_pushed = 0; + +private: + template + void push_args_impl(Args&&... args) {} + + template + void push_args_impl(T&& value, Args&&... args) + { + push(std::forward(value)); + push_args(std::forward(args)...); + } +}; + +} // namespace stack +} // namespace perlbind diff --git a/libs/perlbind/include/perlbind/stack_read.h b/libs/perlbind/include/perlbind/stack_read.h new file mode 100644 index 000000000..fe5794124 --- /dev/null +++ b/libs/perlbind/include/perlbind/stack_read.h @@ -0,0 +1,266 @@ +#pragma once + +#include + +namespace perlbind { namespace stack { + +// perl stack reader to convert types, throws if perl stack value isn't type compatible +template +struct read_as; + +template +struct read_as::value || std::is_enum::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(SvIV(ST(i))); // unsigned and bools casted + } +}; + +template +struct read_as::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(SvNV(ST(i))); + } +}; + +template <> +struct read_as +{ + 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(SvPV_nolen(ST(i))); + } +}; + +template <> +struct read_as : read_as +{ +}; + +template <> +struct read_as +{ + 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 +struct read_as::value>> +{ + static bool check(PerlInterpreter* my_perl, int i, int ax, int items) + { + const char* type_name = detail::typemap::get_name(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(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 +struct read_as> +{ + static bool check(PerlInterpreter* my_perl, int i, int ax, int items) + { + return true; + } + + static nullable get(PerlInterpreter* my_perl, int i, int ax, int items) + { + if (sv_isobject(ST(i))) + { + const char* type_name = detail::typemap::get_name(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 +{ + 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 +{ + 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 +{ + 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 +{ + 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 +{ + 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 diff --git a/libs/perlbind/include/perlbind/subcaller.h b/libs/perlbind/include/perlbind/subcaller.h new file mode 100644 index 000000000..fb8c9d5c4 --- /dev/null +++ b/libs/perlbind/include/perlbind/subcaller.h @@ -0,0 +1,78 @@ +#pragma once + +#include + +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 ::value, bool> = true> + auto call_sub(const char* subname, Args&&... args) + { + call_sub_impl(subname, G_EVAL|G_VOID, std::forward(args)...); + } + + template ::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)...); + + if (count == 1) + { + SV* sv_result = pop(); + result = static_cast(SvIV(sv_result)); + } + } + catch (...) + { + pop(); // top of stack holds undef on error when called with these flags + throw; + } + + return result; + } + +private: + template + 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)...); + 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 diff --git a/libs/perlbind/include/perlbind/traits.h b/libs/perlbind/include/perlbind/traits.h new file mode 100644 index 000000000..e4f9da21e --- /dev/null +++ b/libs/perlbind/include/perlbind/traits.h @@ -0,0 +1,33 @@ +#pragma once + +namespace perlbind { namespace detail { + +template +struct is_any : std::false_type {}; +template +struct is_any : std::is_same {}; +template +struct is_any : std::integral_constant::value || is_any::value> {}; + +template +struct is_signed_integral : std::integral_constant::value && std::is_signed::value> {}; + +template +struct is_signed_integral_or_enum : std::integral_constant::value || std::is_enum::value> {}; + +template +struct count_of : std::integral_constant {}; +template +struct count_of : std::integral_constant::value ? 1 : 0> {}; +template +struct count_of : std::integral_constant::value + count_of::value> {}; + +template +struct is_last : std::false_type {}; +template +struct is_last : std::is_same {}; +template +struct is_last : std::integral_constant::value> {}; + +} // namespace detail +} // namespace perlbind diff --git a/libs/perlbind/include/perlbind/typemap.h b/libs/perlbind/include/perlbind/typemap.h new file mode 100644 index 000000000..c5a3e50d5 --- /dev/null +++ b/libs/perlbind/include/perlbind/typemap.h @@ -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 +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(SvREFCNT_inc(hv)); + } + + template + const char* get_name(PerlInterpreter* my_perl) + { + auto typemap = detail::typemap::get(my_perl); + auto type_id = detail::template usertype::id(); + + return typemap.exists(type_id) ? typemap[type_id].c_str() : nullptr; + } +} // namespace typemap + +} // namespace detail +} // namespace perlbind diff --git a/libs/perlbind/include/perlbind/types.h b/libs/perlbind/include/perlbind/types.h new file mode 100644 index 000000000..ed3916ab0 --- /dev/null +++ b/libs/perlbind/include/perlbind/types.h @@ -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 +struct nullable +{ + static_assert(std::is_pointer::value, "nullable 'T' must be pointer"); + + nullable() = default; + nullable(T ptr) : m_ptr(ptr) {} + T get() { return m_ptr; } +private: + T m_ptr = nullptr; +}; + +} // namespace perlbind diff --git a/libs/perlbind/include/perlbind/util.h b/libs/perlbind/include/perlbind/util.h new file mode 100644 index 000000000..8b1e306de --- /dev/null +++ b/libs/perlbind/include/perlbind/util.h @@ -0,0 +1,50 @@ +#pragma once + +#include +#include +#ifndef _MSC_VER +#include +#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 ""; +#else + return name; +#endif +} + +template +struct type_name; + +template <> +struct type_name<> +{ + static std::string str() { return "void"; } +}; + +template +struct type_name +{ + static std::string str() { return demangle(typeid(T).name()); } +}; + +template +struct type_name +{ + static std::string str() { return type_name::str() + "," + type_name::str(); } +}; + +} // namespace util +} // namespace perlbind diff --git a/libs/perlbind/include/perlbind/version.h b/libs/perlbind/include/perlbind/version.h new file mode 100644 index 000000000..bc6f6e3d8 --- /dev/null +++ b/libs/perlbind/include/perlbind/version.h @@ -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; +} diff --git a/libs/perlbind/src/function.cpp b/libs/perlbind/src/function.cpp new file mode 100644 index 000000000..3143b39b0 --- /dev/null +++ b/libs/perlbind/src/function.cpp @@ -0,0 +1,15 @@ +#include + +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 diff --git a/libs/perlbind/src/hash.cpp b/libs/perlbind/src/hash.cpp new file mode 100644 index 000000000..96cdaa2d7 --- /dev/null +++ b/libs/perlbind/src/hash.cpp @@ -0,0 +1,107 @@ +#include +#include +#include + +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(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(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(strlen(key))); +} + +hash::iterator hash::find(const std::string& key) +{ + return find(key.c_str(), static_cast(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(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(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(key_size), value, HeHASH(entry))) + { + SvREFCNT_dec(value); + } + } + + return hv; +} + +} // namespace perlbind diff --git a/libs/perlbind/src/interpreter.cpp b/libs/perlbind/src/interpreter.cpp new file mode 100644 index 000000000..2a10df4f0 --- /dev/null +++ b/libs/perlbind/src/interpreter.cpp @@ -0,0 +1,98 @@ +#include + +#include +#include +#include + +EXTERN_C +{ + void boot_DynaLoader(pTHX_ CV* cv); + static void xs_init(pTHX) + { + newXS(const_cast("DynaLoader::boot_DynaLoader"), boot_DynaLoader, const_cast(__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(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 diff --git a/libs/perlbind/src/package.cpp b/libs/perlbind/src/package.cpp new file mode 100644 index 000000000..3531265df --- /dev/null +++ b/libs/perlbind/src/package.cpp @@ -0,0 +1,88 @@ +#include + +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(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(CvXSUBANY(cv).any_ptr); + if (target) + { + return target->call(stack); + } + + // find first compatible overload + AV* av = GvAV(CvGV(cv)); + + array functions = reinterpret_cast(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 diff --git a/libs/perlbind/src/perlbind.natvis b/libs/perlbind/src/perlbind.natvis new file mode 100644 index 000000000..11e30d724 --- /dev/null +++ b/libs/perlbind/src/perlbind.natvis @@ -0,0 +1,112 @@ + + + + + {{ m_sv={(void*)m_sv} refcnt={m_sv->sv_refcnt,d} type={(svtype)(m_sv->sv_flags & 0xff),d} }} + + m_sv + + + + {{ size={(m_av->sv_any)->xav_fill + 1,d} refcnt={m_av->sv_refcnt,d} } + + m_av + + + + {{ size={(m_hv->sv_any)->xhv_keys,d} refcnt={m_hv->sv_refcnt,d} }} + + m_hv + + + + + + {{ refcnt={sv_refcnt,d} type={(svtype)(sv_flags & 0xff),d} }} + + sv_refcnt,d + (svtype)(sv_flags & 0xff),d + sv_u.svu_rv + + (av*)this + + (hv*)this + + (gv*)this + + ((XPVMG*)(sv_any)) + + sv_u.svu_pv,na + sv_u.svu_iv,i + sv_u.svu_uv + sv_u.svu_nv,f + sv_u.svu_rv + + + + + {{ size={(sv_any)->xav_fill + 1,d} refcnt={sv_refcnt,d} type={(svtype)(sv_flags & 0xff),d} } + + sv_refcnt,d + (sv_any)->xav_fill + 1 + (sv_any)->xav_max + + (sv_any)->xav_fill + 1 + (sv_u).svu_array + + + + + + {{ size={(sv_any)->xhv_keys,d} refcnt={sv_refcnt,d} type={(svtype)(sv_flags & 0xff),d} }} + + sv_refcnt,d + (sv_any)->xhv_keys + (sv_any)->xhv_max + + + + + + + + + + index++ + bucket_inc = __findnonnull(bucket_array + index, max_index - index) + + index += bucket_inc + entry = bucket_array[index] + + (entry->he_valu).hent_val + entry = entry->hent_next + + + + + + + {{ refcnt={sv_refcnt,d} type={(svtype)(sv_flags & 0xff),d} }} + + sv_refcnt,d + (svtype)(sv_flags & 0xff),d + (sv_u.svu_gp)->gp_sv + (sv_u.svu_gp)->gp_cv + (sv_u.svu_gp)->gp_av + (sv_u.svu_gp)->gp_hv + (sv_u.svu_gp) + + +