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 DDual (sv, ...)
  73     SV   *sv
  74
  75   PROTOTYPE: $;$
  76   PPCODE:
  77     if (items > 1 && SvGMAGICAL (sv) && SvTRUE (ST (1)))
  78         mg_get (sv);
  79
  80     if (SvPOK (sv) || SvPOKp (sv)) {
  81         SV *xv = newSVpv (SvPVX (sv), 0);
  82         if (SvUTF8 (sv)) SvUTF8_on (xv);
  83         mPUSHs (xv);
  84         }
  85     else
  86         PUSHs (&PL_sv_undef);
  87
  88     if (SvIOK (sv) || SvIOKp (sv))
  89         mPUSHi (SvIV (sv));
  90     else
  91         PUSHs (&PL_sv_undef);
  92
  93     if (SvNOK (sv) || SvNOKp (sv))
  94         mPUSHn (SvNV (sv));
  95     else
  96         PUSHs (&PL_sv_undef);
  97
  98     if (SvROK (sv)) {
  99         SV *xv = newSVsv (SvRV (sv));
 100         mPUSHs (xv);
 101         }
 102     else
 103         PUSHs (&PL_sv_undef);
 104
 105     mPUSHi (SvMAGICAL (sv) >> 21);
 106     /* XS DDual */
 107
 108 void
 109 DDump_XS (sv)
 110     SV   *sv
 111
 112   PROTOTYPE: $
 113   PPCODE:
 114     SV   *dd = _DDump (sv);
 115
 116     if (dd) {
 117         ST (0) = dd;
 118         XSRETURN (1);
 119         }
 120
 121     XSRETURN (0);
 122     /* XS DDump */
 123
 124 #if PERL_VERSION >= 8
 125
 126 void
 127 DDump_IO (io, sv, level)
 128     PerlIO *io
 129     SV     *sv
 130     IV      level
 131
 132   PPCODE:
 133     Perl_do_sv_dump (aTHX_ 0, io, sv, 1, level, 1, 0);
 134     XSRETURN (1);
 135     /* XS DDump */
 136
 137 #endif