perlmod: magically call Drop handlers

magic classes now don't need to manually implement DESTROY
anymore

Signed-off-by: Wolfgang Bumiller <w.bumiller@proxmox.com>

perlmod-test/src/magic.rs

@@ -24,9 +24,4 @@ mod export {
         println!("Calling magic with content {:?}", this.content);
         Ok(())
     }
-
-    #[export(name = "DESTROY")]
-    fn destroy(#[raw] this: Value) {
-        perlmod::magic_destructor!(this: &MAGIC);
-    }
 }

perlmod/src/error.rs

@@ -70,6 +70,9 @@ impl fmt::Display for MagicError {
             MagicError::NotAReference(class) => {
                 write!(f, "value blessed into {} was not a reference", class)
             }
+            MagicError::NotFound("") => {
+                write!(f, "value did not contain the requested magic pointer")
+            }
             MagicError::NotFound(class) => write!(
                 f,
                 "value blessed into {} did not contain its declared magic pointer",

perlmod/src/ffi.rs

@@ -53,13 +53,131 @@ impl MAGIC {
     }
 }
 
-/// Struct big enough to fit perl's MGVTBL struct. We don't make the contents available for now.
+#[repr(C)]
+pub struct Unsupported {
+    _ffi: usize,
+}
+
+#[cfg(perlmod = "multiplicity")]
+#[repr(C)]
+pub struct Interpreter {
+    _ffi: usize,
+}
+
+#[cfg(perlmod = "multiplicity")]
+mod vtbl_types_impl {
+    use super::{Interpreter, MAGIC, SV};
+    use libc::c_int;
+
+    pub type Get = extern "C" fn(_perl: *const Interpreter, sv: *mut SV, mg: *mut MAGIC) -> c_int;
+    pub type Set = extern "C" fn(_perl: *const Interpreter, sv: *mut SV, mg: *mut MAGIC) -> c_int;
+    pub type Len = extern "C" fn(_perl: *const Interpreter, sv: *mut SV, mg: *mut MAGIC) -> u32;
+    pub type Clear = extern "C" fn(_perl: *const Interpreter, sv: *mut SV, mg: *mut MAGIC) -> c_int;
+    pub type Free = extern "C" fn(_perl: *const Interpreter, sv: *mut SV, mg: *mut MAGIC) -> c_int;
+    pub type Copy = extern "C" fn(
+        _perl: *const Interpreter,
+        sv: *mut SV,
+        mg: *mut MAGIC,
+        nsv: *mut SV,
+        name: *const libc::c_char,
+        namelen: i32,
+    ) -> c_int;
+    pub type Dup = extern "C" fn(
+        _perl: *const Interpreter,
+        sv: *mut SV,
+        mg: *mut MAGIC,
+        clone_parms: *mut super::Unsupported,
+    ) -> c_int;
+    pub type Local = extern "C" fn(_perl: *const Interpreter, sv: *mut SV, mg: *mut MAGIC) -> c_int;
+
+    #[macro_export]
+    macro_rules! perl_fn {
+        ($(
+            $(#[$attr:meta])*
+            extern "C" fn $name:ident ($($args:tt)*) $(-> $re:ty)? {
+                $($code:tt)*
+            }
+        )*) => {$(
+            $(#[$attr])*
+            extern "C" fn $name (_perl: *const $crate::ffi::Interpreter, $($args)*) $(-> $re)? {
+                $($code)*
+            }
+        )*};
+    }
+}
+
+#[cfg(not(perlmod = "multiplicity"))]
+mod vtbl_types_impl {
+    use super::{Interpreter, MAGIC, SV};
+    use libc::c_int;
+
+    pub type Get = extern "C" fn(sv: *mut SV, mg: *mut MAGIC) -> c_int;
+    pub type Set = extern "C" fn(sv: *mut SV, mg: *mut MAGIC) -> c_int;
+    pub type Len = extern "C" fn(sv: *mut SV, mg: *mut MAGIC) -> u32;
+    pub type Clear = extern "C" fn(sv: *mut SV, mg: *mut MAGIC) -> c_int;
+    pub type Free = extern "C" fn(sv: *mut SV, mg: *mut MAGIC) -> c_int;
+    pub type Copy = extern "C" fn(
+        sv: *mut SV,
+        mg: *mut MAGIC,
+        nsv: *mut SV,
+        name: *const libc::c_char,
+        namelen: i32,
+    ) -> c_int;
+    pub type Dup =
+        extern "C" fn(sv: *mut SV, mg: *mut MAGIC, clone_parms: *mut super::Unsupported) -> c_int;
+    pub type Local = extern "C" fn(sv: *mut SV, mg: *mut MAGIC) -> c_int;
+
+    #[macro_export]
+    macro_rules! perl_fn {
+        ($(
+            $(#[$attr:meta])*
+            extern "C" fn $name:ident ($($args:tt)*) $(-> $re:ty)? {
+                $($code:tt)*
+            }
+        )*) => {$(
+            $(#[$attr])*
+            extern "C" fn $name ($($args)*) $(-> $re)? {
+                $($code)*
+            }
+        )*};
+    }
+}
+
+/// The types in this module depend on the configuration of your perl installation.
+///
+/// If the perl interpreter has been compiled with `USEMULTIPLICITY`, these methods have an
+/// additional parameter.
+pub mod vtbl_types {
+    pub use super::vtbl_types_impl::*;
+}
+
+#[derive(Clone, Copy)]
 #[repr(C)]
 pub struct MGVTBL {
-    _funptrs: [usize; 8],
+    pub get: Option<vtbl_types::Get>,
+    pub set: Option<vtbl_types::Set>,
+    pub len: Option<vtbl_types::Len>,
+    pub clear: Option<vtbl_types::Clear>,
+    pub free: Option<vtbl_types::Free>,
+    pub copy: Option<vtbl_types::Copy>,
+    pub dup: Option<vtbl_types::Dup>,
+    pub local: Option<vtbl_types::Local>,
 }
 
 impl MGVTBL {
+    /// Let's not expose this directly, we need there to be distinct instances of these, so they
+    /// should be created via `MGVTBL::zero()`.
+    const EMPTY: Self = Self {
+        get: None,
+        set: None,
+        len: None,
+        clear: None,
+        free: None,
+        copy: None,
+        dup: None,
+        local: None,
+    };
+
     /// Create a new all-zeroes vtbl as perl docs suggest this is the safest way to
     /// make sure what a `PERL_MAGIC_ext` magic actually means, as the ptr value
     /// may be arbitrary.
@@ -69,7 +187,7 @@ impl MGVTBL {
     /// This must not be deallocated as long as it is attached to a perl value, so best use this as
     /// `const` variables, rather than dynamically allocating it.
     pub const fn zero() -> Self {
-        Self { _funptrs: [0; 8] }
+        *&Self::EMPTY
     }
 }
 

perlmod/src/lib.rs

@@ -27,8 +27,10 @@ pub use error::Error;
 #[macro_use]
 mod macros;
 
-pub mod de;
+#[macro_use]
 pub mod ffi;
+
+pub mod de;
 pub mod ser;
 
 #[doc(inline)]

perlmod/src/macros.rs

@@ -106,11 +106,15 @@ macro_rules! destructor {
 }
 
 /// Create a standard destructor for a value where a rust value has been attached via a
-/// [`MagicSpec`](crate::magic::MagicSpec).
+/// [`MagicSpec`]
 ///
 /// This assumes the type is a reference and calls [`dereference`](crate::Value::dereference()) on
 /// it.
 ///
+/// Note that this only makes sense if the used [`MagicSpec`] does not include a `free` method.
+/// This method *is* includded when using its `DEFAULT` or the [`declare_magic!`] macro, so this
+/// macro is only required when using custom magic with a custom `DESTROY` sub.
+///
 /// Due to compiler restrictions, the function itself needs to be written manually, only the
 /// contents can be generated using this macro. This also means that the `this` parameter needs to
 /// be passed to the macro.
@@ -137,7 +141,7 @@ macro_rules! destructor {
 /// ```ignore
 /// #[export(name = "DESTROY")]
 /// fn destroy(#[raw] this: Value) {
-///     match this.remove_magic_spec(&MyMagic) {
+///     match this.remove_magic(&MyMagic) {
 ///         Ok(_drpo) => (),
 ///         Err(err) => {
 ///             eprintln!("DESTROY called with an invalid pointer: {}", err);
@@ -145,6 +149,7 @@ macro_rules! destructor {
 ///     }
 /// }
 /// ```
+/// [`MagicSpec`]: crate::magic::MagicSpec
 #[macro_export]
 macro_rules! magic_destructor {
     ($this:ident: $spec:expr) => {
@@ -158,8 +163,9 @@ macro_rules! magic_destructor {
         match Value::dereference(&$this) {
             None => $on_ref_err,
             Some(value) => match $crate::ScalarRef::remove_magic(&value, $spec) {
-                Some(_drop) => (),
+                Ok(Some(_drop)) => (),
-                None => $on_type_err,
+                Ok(None) => (),
+                Err(_) => $on_type_err,
             }
         }
     };
@@ -173,13 +179,8 @@ macro_rules! magic_destructor {
 ///   [`add_magic`](crate::ScalarRef::add_magic()).
 /// * `impl TryFrom<&Value> for &Inner`: assuming the value is a reference (calling
 ///   [`dereference`](crate::Value::dereference()) on it) and then looking for the `MAGIC` pointer.
-///
+/// * Binds the `Drop` handler for to the magic value, so that a custom destructor for perl is not
-/// # Warning
+///   necessary.
-///
-/// This does *not* provide a destructor!
-///
-/// This is due to compiler limitations (the `#[export]` attribute cannot be applied from within
-/// this macro).
 ///
 /// ```
 /// struct MyThing {} // anything
@@ -192,10 +193,8 @@ macro_rules! magic_destructor {
 macro_rules! declare_magic {
     ($ty:ty : &$inner:ty as $class:literal) => {
         const CLASSNAME: &str = $class;
-        const MAGIC: $crate::MagicSpec<$ty> = unsafe {
+        const MAGIC: $crate::MagicSpec<$ty> =
-            const TAG: $crate::MagicTag = $crate::MagicTag::new();
+            unsafe { perlmod::MagicSpec::new_static(&$crate::MagicTag::<$ty>::DEFAULT) };
-            perlmod::MagicSpec::new_static(&TAG)
-        };
 
         impl<'a> ::std::convert::TryFrom<&'a $crate::Value> for &'a $inner {
             type Error = $crate::error::MagicError;

perlmod/src/magic.rs

@@ -68,7 +68,10 @@
 //! ```
 //!
 
+use std::marker::PhantomData;
+
 use crate::ffi;
+use crate::perl_fn;
 use crate::ScalarRef;
 
 /// Pointer-like types which can be leaked and reclaimed.
@@ -123,21 +126,52 @@ unsafe impl<T> Leakable for std::rc::Rc<T> {
 }
 
 /// A tag for perl magic, see [`MagicSpec`] for its usage.
-pub struct MagicTag(ffi::MGVTBL);
+pub struct MagicTag<T = ()>(ffi::MGVTBL, PhantomData<T>);
 
-impl MagicTag {
+impl<T> MagicTag<T> {
     /// Create a new tag. See [`MagicSpec`] for its usage.
     pub const fn new() -> Self {
-        Self(ffi::MGVTBL::zero())
+        Self(ffi::MGVTBL::zero(), PhantomData)
     }
 }
 
-impl AsRef<ffi::MGVTBL> for MagicTag {
+impl<T> AsRef<ffi::MGVTBL> for MagicTag<T> {
     fn as_ref(&self) -> &ffi::MGVTBL {
         &self.0
     }
 }
 
+impl<T: Leakable> MagicTag<T> {
+    perl_fn! {
+        extern "C" fn drop_handler(_sv: *mut ffi::SV, mg: *mut ffi::MAGIC) -> libc::c_int {
+            let mg = unsafe { &*mg };
+            match T::get_ref(mg.ptr()) {
+                Some(ptr) => {
+                    let _drop = unsafe { T::reclaim(ptr) };
+                }
+                None => eprintln!("Default magic drop handler called but pointer was NULL"),
+            }
+            0
+        }
+    }
+
+    /// The default tag, note that using this tag when creating perl values for *different* types
+    /// than `T` this *will* cause memory corruption!
+    pub const DEFAULT: Self = Self(
+        ffi::MGVTBL {
+            free: Some(Self::drop_handler),
+            get: None,
+            set: None,
+            len: None,
+            clear: None,
+            copy: None,
+            dup: None,
+            local: None,
+        },
+        PhantomData,
+    );
+}
+
 /// A tag for perl magic. Use this for blessed objects.
 ///
 /// When creating a blessed object is safer to attach the rust pointer via magic than by embedding
@@ -194,7 +228,7 @@ impl<T> MagicSpec<'static, 'static, T> {
     /// # Safety
     ///
     /// This should be safe as long as the [`MagicTag`] is only used for a single [`MagicSpec`].
-    pub const unsafe fn new_static(vtbl: &'static MagicTag) -> Self {
+    pub const unsafe fn new_static<TT>(vtbl: &'static MagicTag<TT>) -> Self {
         Self {
             obj: None,
             how: None,

perlmod/src/scalar.rs

@@ -6,6 +6,7 @@ use std::mem;
 
 use bitflags::bitflags;
 
+use crate::error::MagicError;
 use crate::ffi::{self, SV};
 use crate::magic::{Leakable, MagicSpec};
 use crate::raw_value;
@@ -475,14 +476,38 @@ impl ScalarRef {
     }
 
     /// Remove a magic tag from this value previously added via
-    /// [`add_magic`](ScalarRef::add_magic()) and reclaim the contained value of type `T`.
+    /// [`add_magic`](ScalarRef::add_magic()) and potentially reclaim the contained value of type
+    /// `T`.
+    ///
+    /// When using a "default" magic tag via [`MagicTag::DEFAULT`](crate::magic::MagicTag::DEFAULT)
+    /// such as when using the [`declare_magic!`](crate::declare_magic!) macro, removing the magic
+    /// implicitly causes perl call the `free` method, therefore in this case this method returns
+    /// `None`.
+    ///
+    /// In case the magic was not found, [`MagicError::NotFound("")`] is returned.
     ///
     /// This does not need to include the object and type information.
-    ///
+    pub fn remove_magic<T: Leakable>(
-    /// Use the [`spec`](MagicSpec::spec())` method in case you have additional information in your
+        &self,
-    /// magic tag.
+        spec: &MagicSpec<'static, 'static, T>,
-    pub fn remove_magic<T: Leakable>(&self, spec: &MagicSpec<'static, 'static, T>) -> Option<T> {
+    ) -> Result<Option<T>, MagicError> {
-        let this = self.find_magic(spec).map(|m| unsafe { T::reclaim(m) });
+        let this = match self.find_raw_magic(spec.how, Some(spec.vtbl)) {
+            None => Err(MagicError::NotFound("")),
+            Some(mg) => {
+                assert_eq!(
+                    mg.vtbl().map(|v| v as *const _),
+                    Some(spec.vtbl as *const _),
+                    "Perl_mg_findext misbehaved horribly",
+                );
+
+                Ok(match mg.vtbl() {
+                    // We assume that a 'free' callback takes care of reclaiming the value!
+                    Some(v) if v.free.is_some() => None,
+                    _ => T::get_ref(mg.ptr()).map(|m| unsafe { T::reclaim(m) }),
+                })
+            }
+        };
+
         unsafe {
             self.remove_raw_magic(spec.how, Some(spec.vtbl));
         }

test.pl

@@ -2,10 +2,12 @@
 
 use v5.28.0;
 
-# The nasty one:
-use Storable;
 use POSIX ();
 
+# The nasty ones:
+use Storable;
+use Clone;
+
 use lib '.';
 use RSPM::Bless;
 use RSPM::Foo142;
@@ -86,13 +88,20 @@ print($ref1->{x}, "\n");
 my $magic = RSPM::Magic->new('magic test');
 $magic->call();
 
-print("Testing unsafe dclone\n");
+sub test_unsafe_clone($) {
-my $bad = Storable::dclone($magic);
+    my ($bad) = @_;
     eval { $bad->call() };
     if (!$@) {
-    die "dclone'd object not properly detected!\n";
+        die "cloned object not properly detected!\n";
     } elsif ($@ ne "value blessed into RSPM::Magic did not contain its declared magic pointer\n") {
-    die "dclone'd object error message changed to: [$@]\n";
+        die "cloned object error message changed to: [$@]\n";
     }
     undef $bad;
-print("unsafe dclone dropped (error should have been printed)\n");
+    print("unsafe dclone dropped\n");
+}
+
+print("Testing unsafe dclone\n");
+test_unsafe_clone(Storable::dclone($magic));
+
+print("Testing unsafe clone\n");
+test_unsafe_clone(Clone::clone($magic));

test.pl.expected

@@ -34,6 +34,7 @@ x was stored
 x was changed
 Calling magic with content "magic test"
 Testing unsafe dclone
-DESTROY called on a value with no magic
+unsafe dclone dropped
-unsafe dclone dropped (error should have been printed)
+Testing unsafe clone
+unsafe dclone dropped
 Dropping blessed magic with content "magic test"