Peek.xs

   1 /*  Copyright (c) 2008-2008 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 #include "ppport.h"
  13 #ifdef __cplusplus
  14 }
  15 #endif
  16
  17 SV *_DDump (SV *sv)
  18 {
  19     int   err[3], n;
  20     char  buf[128];
  21     SV   *dd;
  22     dTHX;
  23
  24     if (pipe (err)) return (NULL);
  25
  26     dd = sv_newmortal ();
  27     err[2] = dup (2);
  28     close (2);
  29     if (dup (err[1]) == 2)
  30         Perl_sv_dump (aTHX_ sv);
  31     close (err[1]);
  32     close (2);
  33     err[1] = dup (err[2]);
  34     close (err[2]);
  35
  36     Perl_sv_setpvn (aTHX_ dd, "", 0);
  37     while ((n = read (err[0], buf, 128)) > 0)
  38 #if PERL_VERSION >= 8
  39         /* perl 5.8.0 did not export Perl_sv_catpvn */
  40         Perl_sv_catpvn_flags (aTHX_ dd, buf, n, SV_GMAGIC);
  41 #else
  42         Perl_sv_catpvn       (aTHX_ dd, buf, n);
  43 #endif
  44     return (dd);
  45     } /* _DDump */
  46
  47 MODULE = Data::Peek             PACKAGE = Data::Peek
  48
  49 #ifdef NO_SV_PEEK
  50
  51 void
  52 DPeek (...)
  53   PROTOTYPE: ;$
  54   PPCODE:
  55     ST (0) = newSVpv ("Your perl did not export Perl_sv_peek ()", 0);
  56     XSRETURN (1);
  57     /* XS DPeek */
  58
  59 #else
  60
  61 void
  62 DPeek (...)
  63   PROTOTYPE: ;$
  64   PPCODE:
  65     ST (0) = newSVpv (Perl_sv_peek (aTHX_ items ? ST (0) : DEFSV), 0);
  66     XSRETURN (1);
  67     /* XS DPeek */
  68
  69 #endif
  70
  71 void
  72 DDisplay (...)
  73   PROTOTYPE: ;$
  74   PPCODE:
  75     SV *sv  = items ? ST (0) : DEFSV;
  76     SV *dsp = newSVpv ("", 0);
  77     if (SvPOK (sv) || SvPOKp (sv))
  78         Perl_pv_pretty (aTHX_ dsp, SvPVX (sv), SvCUR (sv), NULL,
  79             NULL, NULL,
  80             (PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT));
  81     ST (0) = dsp;
  82     XSRETURN (1);
  83     /* XS DDisplay */
  84
  85 void
  86 DDual (sv, ...)
  87     SV   *sv
  88
  89   PROTOTYPE: $;$
  90   PPCODE:
  91     if (items > 1 && SvGMAGICAL (sv) && SvTRUE (ST (1)))
  92         mg_get (sv);
  93
  94     if (SvPOK (sv) || SvPOKp (sv)) {
  95         SV *xv = newSVpv (SvPVX (sv), 0);
  96         if (SvUTF8 (sv)) SvUTF8_on (xv);
  97         mPUSHs (xv);
  98         }
  99     else
 100         PUSHs (&PL_sv_undef);
 101
 102     if (SvIOK (sv) || SvIOKp (sv))
 103         mPUSHi (SvIV (sv));
 104     else
 105         PUSHs (&PL_sv_undef);
 106
 107     if (SvNOK (sv) || SvNOKp (sv))
 108         mPUSHn (SvNV (sv));
 109     else
 110         PUSHs (&PL_sv_undef);
 111
 112     if (SvROK (sv)) {
 113         SV *xv = newSVsv (SvRV (sv));
 114         mPUSHs (xv);
 115         }
 116     else
 117         PUSHs (&PL_sv_undef);
 118
 119     mPUSHi (SvMAGICAL (sv) >> 21);
 120     /* XS DDual */
 121
 122 void
 123 DDump_XS (sv)
 124     SV   *sv
 125
 126   PROTOTYPE: $
 127   PPCODE:
 128     SV   *dd = _DDump (sv);
 129
 130     if (dd) {
 131         ST (0) = dd;
 132         XSRETURN (1);
 133         }
 134
 135     XSRETURN (0);
 136     /* XS DDump */
 137
 138 #if PERL_VERSION >= 8
 139
 140 void
 141 DDump_IO (io, sv, level)
 142     PerlIO *io
 143     SV     *sv
 144     IV      level
 145
 146   PPCODE:
 147     Perl_do_sv_dump (aTHX_ 0, io, sv, 1, level, 1, 0);
 148     XSRETURN (1);
 149     /* XS DDump */
 150
 151 #endif