Removed the "Broken croak" support, which was useful on broken

64bit Strawberry perl only. We don't use Strawberry perl anymore,
so this has been removed for clarity.

Added a PerlCallback wrapper to call a Perl subroutine from a C++ code.

1 files changed, 84 insertions, 39 deletions

diff --git a/xs/src/libslic3r/utils.cpp b/xs/src/libslic3r/utils.cpp
index f2415ac07..2978783a6 100644
--- a/xs/src/libslic3r/utils.cpp
+++ b/xs/src/libslic3r/utils.cpp
@@ -1,3 +1,5 @@
+#include "Utils.hpp"
+
 #include <locale>
 #include <ctime>
 
@@ -135,44 +137,6 @@ const std::string& data_dir()
 
 } // namespace Slic3r
 
-#ifdef SLIC3R_HAS_BROKEN_CROAK
-
-// Some Strawberry Perl builds (mainly the latest 64bit builds) have a broken mechanism
-// for emiting Perl exception after handling a C++ exception. Perl interpreter
-// simply hangs. Better to show a message box in that case and stop the application.
-
-#include <stdarg.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-
-#ifdef WIN32
-#include <Windows.h>
-#endif
-
-void confess_at(const char *file, int line, const char *func, const char *format, ...)
-{
-    char dest[1024*8];
-    va_list argptr;
-    va_start(argptr, format);
-    vsprintf(dest, format, argptr);
-    va_end(argptr);
-
-    char filelinefunc[1024*8];
-    sprintf(filelinefunc, "\r\nin function: %s\r\nfile: %s\r\nline: %d\r\n", func, file, line);
-    strcat(dest, filelinefunc);
-    strcat(dest, "\r\n Closing the application.\r\n");
-    #ifdef WIN32
-    ::MessageBoxA(NULL, dest, "Slic3r Prusa Edition", MB_OK | MB_ICONERROR);
-    #endif
-
-    // Give up.
-    printf(dest);
-    exit(-1);
-}
-
-#else
-
 #include <xsinit.h>
 
 void
@@ -202,7 +166,88 @@ confess_at(const char *file, int line, const char *func,
     #endif
 }
 
-#endif
+void PerlCallback::register_callback(void *sv)
+{ 
+    if (! SvROK((SV*)sv) || SvTYPE(SvRV((SV*)sv)) != SVt_PVCV)
+        croak("Not a Callback %_ for PerlFunction", (SV*)sv);
+    if (m_callback)
+        SvSetSV((SV*)m_callback, (SV*)sv);
+    else
+        m_callback = newSVsv((SV*)sv);
+}
+
+void PerlCallback::deregister_callback()
+{
+	if (m_callback) {
+		sv_2mortal((SV*)m_callback);
+		m_callback = nullptr;
+	}
+}
+
+void PerlCallback::call()
+{
+    if (! m_callback)
+        return;
+    dSP;
+    ENTER;
+    SAVETMPS;
+    PUSHMARK(SP);
+    PUTBACK; 
+    perl_call_sv(SvRV((SV*)m_callback), G_DISCARD);
+    FREETMPS;
+    LEAVE;
+}
+
+void PerlCallback::call(int i)
+{
+    if (! m_callback)
+        return;
+    dSP;
+    ENTER;
+    SAVETMPS;
+    PUSHMARK(SP);
+    XPUSHs(sv_2mortal(newSViv(i)));
+    PUTBACK; 
+    perl_call_sv(SvRV((SV*)m_callback), G_DISCARD);
+    FREETMPS;
+    LEAVE;
+}
+
+void PerlCallback::call(int i, int j)
+{
+    if (! m_callback)
+        return;
+    dSP;
+    ENTER;
+    SAVETMPS;
+    PUSHMARK(SP);
+    XPUSHs(sv_2mortal(newSViv(i)));
+    XPUSHs(sv_2mortal(newSViv(j)));
+    PUTBACK; 
+    perl_call_sv(SvRV((SV*)m_callback), G_DISCARD);
+    FREETMPS;
+    LEAVE;
+}
+
+/*
+void PerlCallback::call(const std::vector<int> &ints)
+{
+    if (! m_callback)
+        return;
+    dSP;
+    ENTER;
+    SAVETMPS;
+    PUSHMARK(SP);
+    AV* av = newAV();
+    for (int i : ints)
+        av_push(av, newSViv(i));
+    XPUSHs(av);
+    PUTBACK;
+    perl_call_sv(SvRV((SV*)m_callback), G_DISCARD);
+    FREETMPS;
+    LEAVE;
+}
+*/
 
 #ifdef WIN32
     #ifndef NOMINMAX