Peek.xs

   1 /*  Copyright (c) 2008-2009 H.Merijn Brand.  All rights reserved.
   2  *  This program is free software; you can redistribute it and/or
   3  *  modify it under the same terms as Perl itself.
   4  */
   5
   6 #ifdef __cplusplus
   7 extern "C" {
   8 #endif
   9 #include <EXTERN.h>
  10 #include <perl.h>
  11 #include <XSUB.h>
  12 #define NEED_pv_pretty
  13 #define NEED_pv_escape
  14 #define NEED_my_snprintf
  15 #include "ppport.h"
  16 #ifdef __cplusplus
  17 }
  18 #endif
  19
  20 SV *_DDump (SV *sv)
  21 {
  22     int   err[3], n;
  23     char  buf[128];
  24     SV   *dd;
  25     dTHX;
  26
  27     if (pipe (err)) return (NULL);
  28
  29     dd = sv_newmortal ();
  30     err[2] = dup (2);
  31     close (2);
  32     if (dup (err[1]) == 2)
  33         Perl_sv_dump (aTHX_ sv);
  34     close (err[1]);
  35     close (2);
  36     err[1] = dup (err[2]);
  37     close (err[2]);
  38
  39     Perl_sv_setpvn (aTHX_ dd, "", 0);
  40     while ((n = read (err[0], buf, 128)) > 0)
  41 #if PERL_VERSION >= 8
  42         /* perl 5.8.0 did not export Perl_sv_catpvn */
  43         Perl_sv_catpvn_flags (aTHX_ dd, buf, n, SV_GMAGIC);
  44 #else
  45         Perl_sv_catpvn       (aTHX_ dd, buf, n);
  46 #endif
  47     return (dd);
  48     } /* _DDump */
  49
  50 MODULE = Data::Peek             PACKAGE = Data::Peek
  51
  52 #ifdef NO_SV_PEEK
  53
  54 void
  55 DPeek (...)
  56   PROTOTYPE: ;$
  57   PPCODE:
  58     ST (0) = newSVpv ("Your perl did not export Perl_sv_peek ()", 0);
  59     XSRETURN (1);
  60     /* XS DPeek */
  61
  62 #else
  63
  64 void
  65 DPeek (...)
  66   PROTOTYPE: ;$
  67   PPCODE:
  68     ST (0) = newSVpv (Perl_sv_peek (aTHX_ items ? ST (0) : DEFSV), 0);
  69     XSRETURN (1);
  70     /* XS DPeek */
  71
  72 #endif
  73
  74 void
  75 DDisplay (...)
  76   PROTOTYPE: ;$
  77   PPCODE:
  78     SV *sv  = items ? ST (0) : DEFSV;
  79     SV *dsp = newSVpv ("", 0);
  80     if (SvPOK (sv) || SvPOKp (sv))
  81         Perl_pv_pretty (aTHX_ dsp, SvPVX (sv), SvCUR (sv), 0,
  82             NULL, NULL,
  83             (PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT));
  84     ST (0) = dsp;
  85     XSRETURN (1);
  86     /* XS DDisplay */
  87
  88 void
  89 triplevar (pv, iv, nv)
  90     SV  *pv
  91     SV  *iv
  92     SV  *nv
  93
  94   PROTOTYPE: $$$
  95   PPCODE:
  96     SV  *tv = newSVpvs ("");
  97     SvUPGRADE (tv, SVt_PVNV);
  98
  99     if (SvPOK (pv) || SvPOKp (pv)) {
 100         sv_setpvn (tv, SvPVX (pv), SvCUR (pv));
 101         if (SvUTF8 (pv)) SvUTF8_on (tv);
 102         }
 103     else
 104         sv_setpvn (tv, NULL, 0);
 105
 106     if (SvNOK (nv) || SvNOKp (nv)) {
 107         SvNV_set (tv, SvNV (nv));
 108         SvNOK_on (tv);
 109         }
 110
 111     if (SvIOK (iv) || SvIOKp (iv)) {
 112         SvIV_set (tv, SvIV (iv));
 113         SvIOK_on (tv);
 114         }
 115
 116     ST (0) = tv;
 117     XSRETURN (1);
 118     /* XS triplevar */
 119
 120 void
 121 DDual (sv, ...)
 122     SV   *sv
 123
 124   PROTOTYPE: $;$
 125   PPCODE:
 126     if (items > 1 && SvGMAGICAL (sv) && SvTRUE (ST (1)))
 127         mg_get (sv);
 128
 129     if (SvPOK (sv) || SvPOKp (sv)) {
 130         SV *xv = newSVpv (SvPVX (sv), 0);
 131         if (SvUTF8 (sv)) SvUTF8_on (xv);
 132         mPUSHs (xv);
 133         }
 134     else
 135         PUSHs (&PL_sv_undef);
 136
 137     if (SvIOK (sv) || SvIOKp (sv))
 138         mPUSHi (SvIV (sv));
 139     else
 140         PUSHs (&PL_sv_undef);
 141
 142     if (SvNOK (sv) || SvNOKp (sv))
 143         mPUSHn (SvNV (sv));
 144     else
 145         PUSHs (&PL_sv_undef);
 146
 147     if (SvROK (sv)) {
 148         SV *xv = newSVsv (SvRV (sv));
 149         mPUSHs (xv);
 150         }
 151     else
 152         PUSHs (&PL_sv_undef);
 153
 154     mPUSHi (SvMAGICAL (sv) >> 21);
 155     /* XS DDual */
 156
 157 void
 158 DDump_XS (sv)
 159     SV   *sv
 160
 161   PROTOTYPE: $
 162   PPCODE:
 163     SV   *dd = _DDump (sv);
 164
 165     if (dd) {
 166         ST (0) = dd;
 167         XSRETURN (1);
 168         }
 169
 170     XSRETURN (0);
 171     /* XS DDump */
 172
 173 #if PERL_VERSION >= 8
 174
 175 void
 176 DDump_IO (io, sv, level)
 177     PerlIO *io
 178     SV     *sv
 179     IV      level
 180
 181   PPCODE:
 182     Perl_do_sv_dump (aTHX_ 0, io, sv, 1, level, 1, 0);
 183     XSRETURN (1);
 184     /* XS DDump */
 185
 186 #endif