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