Peek.xs

   1 /*  Copyright (c) 2008-2014 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 (pTHX_ SV *sv)
  21 {
  22     int   err[3], n;
  23     char  buf[128];
  24     SV   *dd;
  25
  26     if (pipe (err)) return (NULL);
  27
  28     dd = sv_newmortal ();
  29     err[2] = dup (2);
  30     close (2);
  31     if (dup (err[1]) == 2)
  32         sv_dump (sv);
  33     close (err[1]);
  34     close (2);
  35     err[1] = dup (err[2]);
  36     close (err[2]);
  37
  38     sv_setpvn (dd, "", 0);
  39     while ((n = read (err[0], buf, 128)) > 0)
  40 #if PERL_VERSION >= 8
  41         /* perl 5.8.0 did not export Perl_sv_catpvn */
  42         sv_catpvn_flags (dd, buf, n, SV_GMAGIC);
  43 #else
  44         sv_catpvn       (dd, buf, n);
  45 #endif
  46     return (dd);
  47     } /* _DDump */
  48
  49 SV *_DPeek (pTHX_ int items, SV *sv)
  50 {
  51 #ifdef NO_SV_PEEK
  52     return newSVpv ("Your perl did not export Perl_sv_peek ()", 0);
  53 #else
  54     return newSVpv (sv_peek (items ? sv : DEFSV), 0);
  55 #endif
  56     } /* _DPeek */
  57
  58 void _Dump_Dual (pTHX_ SV *sv, SV *pv, SV *iv, SV *nv, SV *rv)
  59 {
  60 #ifndef NO_SV_PEEK
  61     warn ("%s\n  PV: %s\n  IV: %s\n  NV: %s\n  RV: %s\n",
  62         sv_peek (sv), sv_peek (pv), sv_peek (iv), sv_peek (nv), sv_peek (rv));
  63 #endif
  64     } /* _Dump_Dual */
  65
  66 MODULE = Data::Peek             PACKAGE = Data::Peek
  67
  68 void
  69 DPeek (...)
  70   PROTOTYPE: ;$
  71   PPCODE:
  72     I32 gimme = GIMME_V;
  73     ST (0) = _DPeek (aTHX_ items, ST (0));
  74     if (gimme == G_VOID) warn ("%s\n", SvPVX (ST (0)));
  75     XSRETURN (1);
  76     /* XS DPeek */
  77
  78 void
  79 DDisplay (...)
  80   PROTOTYPE: ;$
  81   PPCODE:
  82     SV *sv  = items ? ST (0) : DEFSV;
  83     SV *dsp = newSVpv ("", 0);
  84     if (SvPOK (sv) || SvPOKp (sv))
  85         pv_pretty (dsp, SvPVX (sv), SvCUR (sv), 0,
  86             NULL, NULL,
  87             (PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT));
  88     ST (0) = dsp;
  89     XSRETURN (1);
  90     /* XS DDisplay */
  91
  92 void
  93 triplevar (pv, iv, nv)
  94     SV  *pv
  95     SV  *iv
  96     SV  *nv
  97
  98   PROTOTYPE: $$$
  99   PPCODE:
 100     SV  *tv = newSVpvs ("");
 101     SvUPGRADE (tv, SVt_PVNV);
 102
 103     if (SvPOK (pv) || SvPOKp (pv)) {
 104         sv_setpvn (tv, SvPVX (pv), SvCUR (pv));
 105         if (SvUTF8 (pv)) SvUTF8_on (tv);
 106         }
 107     else
 108         sv_setpvn (tv, NULL, 0);
 109
 110     if (SvNOK (nv) || SvNOKp (nv)) {
 111         SvNV_set (tv, SvNV (nv));
 112         SvNOK_on (tv);
 113         }
 114
 115     if (SvIOK (iv) || SvIOKp (iv)) {
 116         SvIV_set (tv, SvIV (iv));
 117         SvIOK_on (tv);
 118         }
 119
 120     ST (0) = tv;
 121     XSRETURN (1);
 122     /* XS triplevar */
 123
 124 void
 125 DDual (sv, ...)
 126     SV   *sv
 127
 128   PROTOTYPE: $;$
 129   PPCODE:
 130     I32 gimme = GIMME_V;
 131
 132     if (items > 1 && SvGMAGICAL (sv) && SvTRUE (ST (1)))
 133         mg_get (sv);
 134
 135     if (SvPOK (sv) || SvPOKp (sv)) {
 136         SV *xv = newSVpv (SvPVX (sv), 0);
 137         if (SvUTF8 (sv)) SvUTF8_on (xv);
 138         mPUSHs (xv);
 139         }
 140     else
 141         PUSHs (&PL_sv_undef);
 142
 143     if (SvIOK (sv) || SvIOKp (sv))
 144         mPUSHi (SvIV (sv));
 145     else
 146         PUSHs (&PL_sv_undef);
 147
 148     if (SvNOK (sv) || SvNOKp (sv))
 149         mPUSHn (SvNV (sv));
 150     else
 151         PUSHs (&PL_sv_undef);
 152
 153     if (SvROK (sv)) {
 154         SV *xv = newSVsv (SvRV (sv));
 155         mPUSHs (xv);
 156         }
 157     else
 158         PUSHs (&PL_sv_undef);
 159
 160     mPUSHi (SvMAGICAL (sv) >> 21);
 161
 162     if (gimme == G_VOID) _Dump_Dual (aTHX_ sv, ST (0), ST (1), ST (2), ST (3));
 163     /* XS DDual */
 164
 165 void
 166 DGrow (sv, size)
 167     SV     *sv
 168     IV      size
 169
 170   PROTOTYPE: $$
 171   PPCODE:
 172     if (SvROK (sv))
 173         sv = SvRV (sv);
 174     if (!SvPOK (sv))
 175         sv_setpvn (sv, "", 0);
 176     SvGROW (sv, size);
 177     mPUSHi (SvLEN (sv));
 178     /* XS DGrow */
 179
 180 void
 181 DDump_XS (sv)
 182     SV   *sv
 183
 184   PROTOTYPE: $
 185   PPCODE:
 186     SV   *dd = _DDump (aTHX_ sv);
 187
 188     if (dd) {
 189         ST (0) = dd;
 190         XSRETURN (1);
 191         }
 192
 193     XSRETURN (0);
 194     /* XS DDump */
 195
 196 #if PERL_VERSION >= 8
 197
 198 void
 199 DDump_IO (io, sv, level)
 200     PerlIO *io
 201     SV     *sv
 202     IV      level
 203
 204   PPCODE:
 205     do_sv_dump (0, io, sv, 1, level, 1, 0);
 206     XSRETURN (1);
 207     /* XS DDump */
 208
 209 #endif