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 void
  50 DPeek (...)
  51   PROTOTYPE: ;$
  52   PPCODE:
  53     ST (0) = newSVpv (Perl_sv_peek (aTHX_ items ? ST (0) : DEFSV), 0);
  54     XSRETURN (1);
  55     /* XS DPeek */
  56
  57 void
  58 DDual (sv, ...)
  59     SV   *sv
  60
  61   PROTOTYPE: $;$
  62   PPCODE:
  63     if (items > 1 && SvGMAGICAL (sv) && SvTRUE (ST (1)))
  64         mg_get (sv);
  65
  66     if (SvPOK (sv) || SvPOKp (sv)) {
  67         SV *xv = newSVpv (SvPVX (sv), 0);
  68         if (SvUTF8 (sv)) SvUTF8_on (xv);
  69         mPUSHs (xv);
  70         }
  71     else
  72         PUSHs (&PL_sv_undef);
  73
  74     if (SvIOK (sv) || SvIOKp (sv))
  75         mPUSHi (SvIV (sv));
  76     else
  77         PUSHs (&PL_sv_undef);
  78
  79     if (SvNOK (sv) || SvNOKp (sv))
  80         mPUSHn (SvNV (sv));
  81     else
  82         PUSHs (&PL_sv_undef);
  83
  84     if (SvROK (sv)) {
  85         SV *xv = newSVsv (SvRV (sv));
  86         mPUSHs (xv);
  87         }
  88     else
  89         PUSHs (&PL_sv_undef);
  90
  91     mPUSHi (SvMAGICAL (sv) >> 21);
  92     /* XS DDual */
  93
  94 void
  95 DDump_XS (sv)
  96     SV   *sv
  97
  98   PROTOTYPE: $
  99   PPCODE:
 100     SV   *dd = _DDump (sv);
 101
 102     if (dd) {
 103         ST (0) = dd;
 104         XSRETURN (1);
 105         }
 106
 107     XSRETURN (0);
 108     /* XS DDump */
 109
 110 #if PERL_VERSION >= 8
 111
 112 void
 113 DDump_IO (io, sv, level)
 114     PerlIO *io
 115     SV     *sv
 116     IV      level
 117
 118   PPCODE:
 119     Perl_do_sv_dump (aTHX_ 0, io, sv, 1, level, 1, 0);
 120     XSRETURN (1);
 121     /* XS DDump */
 122
 123 #endif