| Commit | Line | Data |
|---|
| df00ff3b |
1 | #define PERL_NO_GET_CONTEXT |
| 2 | #include "EXTERN.h" |
| 3 | #include "perl.h" |
| 4 | #include "XSUB.h" |
| 5 | |
| 6 | #include <stdarg.h> |
| 7 | |
| 8 | #include <OS.h> |
| 9 | |
| 10 | static void |
| 11 | haiku_do_debugger(const char* format,...) |
| 12 | { |
| 13 | char buffer[1024]; |
| 14 | va_list args; |
| 15 | va_start(args, format); |
| 16 | my_vsnprintf(buffer, sizeof(buffer), format, args); |
| 17 | va_end(args); |
| 18 | |
| 19 | debugger(buffer); |
| 20 | } |
| 21 | |
| 22 | static void |
| 23 | haiku_do_debug_printf(pTHX_ register SV *sv, |
| 24 | void (*printfFunc)(const char*,...)) |
| 25 | { |
| 26 | dVAR; |
| 27 | |
| 28 | if (!sv) |
| 29 | return; |
| 30 | if (SvTYPE(sv) == SVt_IV && SvIOK(sv)) { |
| 31 | assert(!SvGMAGICAL(sv)); |
| 32 | if (SvIsUV(sv)) |
| 33 | (*printfFunc)("%"UVuf, (UV)SvUVX(sv)); |
| 34 | else |
| 35 | (*printfFunc)("%"IVdf, (IV)SvIVX(sv)); |
| 36 | return; |
| 37 | } |
| 38 | else { |
| 39 | STRLEN len; |
| 40 | /* Do this first to trigger any overloading. */ |
| 41 | const char *tmps = SvPV_const(sv, len); |
| 42 | U8 *tmpbuf = NULL; |
| 43 | |
| 44 | if (!SvUTF8(sv)) { |
| 45 | /* We don't modify the original scalar. */ |
| 46 | tmpbuf = bytes_to_utf8((const U8*) tmps, &len); |
| 47 | tmps = (char *) tmpbuf; |
| 48 | } |
| 49 | |
| 50 | if (len) |
| 51 | (*printfFunc)("%.*s", (int)len, tmps); |
| 52 | Safefree(tmpbuf); |
| 53 | } |
| 54 | } |
| 55 | |
| 56 | XS(haiku_debug_printf) |
| 57 | { |
| 58 | dVAR; |
| 59 | dXSARGS; |
| 60 | dORIGMARK; |
| 61 | SV *sv; |
| 62 | |
| 63 | if (items < 1) |
| 64 | Perl_croak(aTHX_ "usage: Haiku::debug_printf($format,...)"); |
| 65 | |
| 66 | sv = newSV(0); |
| 67 | |
| 68 | if (SvTAINTED(MARK[1])) |
| 69 | TAINT_PROPER("debug_printf"); |
| 70 | do_sprintf(sv, SP - MARK, MARK + 1); |
| 71 | |
| 72 | haiku_do_debug_printf(sv, &debug_printf); |
| 73 | |
| 74 | SvREFCNT_dec(sv); |
| 75 | SP = ORIGMARK; |
| 76 | PUSHs(&PL_sv_yes); |
| 77 | } |
| 78 | |
| 79 | XS(haiku_ktrace_printf) |
| 80 | { |
| 81 | dVAR; |
| 82 | dXSARGS; |
| 83 | dORIGMARK; |
| 84 | SV *sv; |
| 85 | |
| 86 | if (items < 1) |
| 87 | Perl_croak(aTHX_ "usage: Haiku::debug_printf($format,...)"); |
| 88 | |
| 89 | sv = newSV(0); |
| 90 | |
| 91 | if (SvTAINTED(MARK[1])) |
| 92 | TAINT_PROPER("ktrace_printf"); |
| 93 | do_sprintf(sv, SP - MARK, MARK + 1); |
| 94 | |
| 95 | haiku_do_debug_printf(sv, &ktrace_printf); |
| 96 | |
| 97 | SvREFCNT_dec(sv); |
| 98 | SP = ORIGMARK; |
| 99 | PUSHs(&PL_sv_yes); |
| 100 | } |
| 101 | |
| 102 | XS(haiku_debugger) |
| 103 | { |
| 104 | dVAR; |
| 105 | dXSARGS; |
| 106 | dORIGMARK; |
| 107 | SV *sv; |
| 108 | |
| 109 | if (items < 1) |
| 110 | Perl_croak(aTHX_ "usage: Haiku::debugger($format,...)"); |
| 111 | |
| 112 | sv = newSV(0); |
| 113 | |
| 114 | if (SvTAINTED(MARK[1])) |
| 115 | TAINT_PROPER("debugger"); |
| 116 | do_sprintf(sv, SP - MARK, MARK + 1); |
| 117 | |
| 118 | haiku_do_debug_printf(sv, &haiku_do_debugger); |
| 119 | |
| 120 | SvREFCNT_dec(sv); |
| 121 | SP = ORIGMARK; |
| 122 | PUSHs(&PL_sv_yes); |
| 123 | } |
| 124 | |
| 125 | MODULE = Haiku PACKAGE = Haiku |
| 126 | |
| 127 | PROTOTYPES: DISABLE |
| 128 | |
| 129 | BOOT: |
| 130 | { |
| 131 | char *file = __FILE__; |
| 132 | |
| 133 | newXS("Haiku::debug_printf", haiku_debug_printf, file); |
| 134 | newXS("Haiku::ktrace_printf", haiku_ktrace_printf, file); |
| 135 | newXS("Haiku::debugger", haiku_debugger, file); |
| 136 | XSRETURN_YES; |
| 137 | } |
projects / p5sagit/p5-mst-13.2.git / blame