Haiku Port

Message-Id: <20081029022544.413.1@knochen-vm.localdomain>

p4raw-id: //depot/perl@34630

1 files changed, 137 insertions, 0 deletions

diff --git a/haiku/Haiku/Haiku.xs b/haiku/Haiku/Haiku.xs
new file mode 100644
index 0000000000..c5a121dad1
--- /dev/null
+++ b/haiku/Haiku/Haiku.xs
@@ -0,0 +1,137 @@
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <stdarg.h>
+
+#include <OS.h>
+
+static void
+haiku_do_debugger(const char* format,...)
+{
+    char buffer[1024];
+    va_list args;
+    va_start(args, format);
+    my_vsnprintf(buffer, sizeof(buffer), format, args);
+    va_end(args);
+
+    debugger(buffer);
+}
+
+static void
+haiku_do_debug_printf(pTHX_ register SV *sv,
+    void (*printfFunc)(const char*,...))
+{
+    dVAR;
+
+    if (!sv)
+	return;
+    if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) {
+	assert(!SvGMAGICAL(sv));
+	if (SvIsUV(sv))
+	    (*printfFunc)("%"UVuf, (UV)SvUVX(sv));
+	else
+	    (*printfFunc)("%"IVdf, (IV)SvIVX(sv));
+	return;
+    }
+    else {
+	STRLEN len;
+	/* Do this first to trigger any overloading.  */
+	const char *tmps = SvPV_const(sv, len);
+	U8 *tmpbuf = NULL;
+
+	if (!SvUTF8(sv)) {
+	    /* We don't modify the original scalar.  */
+	    tmpbuf = bytes_to_utf8((const U8*) tmps, &len);
+	    tmps = (char *) tmpbuf;
+	}
+
+	if (len)
+	    (*printfFunc)("%.*s", (int)len, tmps);
+	Safefree(tmpbuf);
+    }
+}
+
+XS(haiku_debug_printf)
+{
+    dVAR;
+    dXSARGS;
+    dORIGMARK;
+    SV *sv;
+
+    if (items < 1)
+	Perl_croak(aTHX_ "usage: Haiku::debug_printf($format,...)");
+
+    sv = newSV(0);
+
+    if (SvTAINTED(MARK[1]))
+	TAINT_PROPER("debug_printf");
+    do_sprintf(sv, SP - MARK, MARK + 1);
+
+    haiku_do_debug_printf(sv, &debug_printf);
+
+    SvREFCNT_dec(sv);
+    SP = ORIGMARK;
+    PUSHs(&PL_sv_yes);
+}
+
+XS(haiku_ktrace_printf)
+{
+    dVAR;
+    dXSARGS;
+    dORIGMARK;
+    SV *sv;
+
+    if (items < 1)
+	Perl_croak(aTHX_ "usage: Haiku::debug_printf($format,...)");
+
+    sv = newSV(0);
+
+    if (SvTAINTED(MARK[1]))
+	TAINT_PROPER("ktrace_printf");
+    do_sprintf(sv, SP - MARK, MARK + 1);
+
+    haiku_do_debug_printf(sv, &ktrace_printf);
+
+    SvREFCNT_dec(sv);
+    SP = ORIGMARK;
+    PUSHs(&PL_sv_yes);
+}
+
+XS(haiku_debugger)
+{
+    dVAR;
+    dXSARGS;
+    dORIGMARK;
+    SV *sv;
+
+    if (items < 1)
+	Perl_croak(aTHX_ "usage: Haiku::debugger($format,...)");
+
+    sv = newSV(0);
+
+    if (SvTAINTED(MARK[1]))
+	TAINT_PROPER("debugger");
+    do_sprintf(sv, SP - MARK, MARK + 1);
+
+    haiku_do_debug_printf(sv, &haiku_do_debugger);
+
+    SvREFCNT_dec(sv);
+    SP = ORIGMARK;
+    PUSHs(&PL_sv_yes);
+}
+
+MODULE = Haiku            PACKAGE = Haiku
+
+PROTOTYPES: DISABLE
+
+BOOT:
+{
+    char *file = __FILE__;
+
+    newXS("Haiku::debug_printf", haiku_debug_printf, file);
+    newXS("Haiku::ktrace_printf", haiku_ktrace_printf, file);
+    newXS("Haiku::debugger", haiku_debugger, file);
+    XSRETURN_YES;
+}