Old(er) perls (e.g. 5.8.0) do not like \my $x, more
[Data-Peek.git] / Peek.xs
blob55a1806ead0aa08f520f2260c51873b24d5f7c04
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  */
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
18 #endif
20 SV *_DDump (pTHX_ SV *sv)
22     int   err[3], n;
23     char  buf[128];
24     SV   *dd;
26     if (pipe (err)) return (NULL);
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]);
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 */
49 SV *_DPeek (pTHX_ int items, SV *sv)
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 */
58 void _Dump_Dual (pTHX_ SV *sv, SV *pv, SV *iv, SV *nv, SV *rv)
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 */
66 MODULE = Data::Peek             PACKAGE = Data::Peek
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 */
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 */
92 void
93 triplevar (pv, iv, nv)
94     SV  *pv
95     SV  *iv
96     SV  *nv
98   PROTOTYPE: $$$
99   PPCODE:
100     SV  *tv = newSVpvs ("");
101     SvUPGRADE (tv, SVt_PVNV);
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);
110     if (SvNOK (nv) || SvNOKp (nv)) {
111         SvNV_set (tv, SvNV (nv));
112         SvNOK_on (tv);
113         }
115     if (SvIOK (iv) || SvIOKp (iv)) {
116         SvIV_set (tv, SvIV (iv));
117         SvIOK_on (tv);
118         }
120     ST (0) = tv;
121     XSRETURN (1);
122     /* XS triplevar */
124 void
125 DDual (sv, ...)
126     SV   *sv
128   PROTOTYPE: $;$
129   PPCODE:
130     I32 gimme = GIMME_V;
132     if (items > 1 && SvGMAGICAL (sv) && SvTRUE (ST (1)))
133         mg_get (sv);
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);
143     if (SvIOK (sv) || SvIOKp (sv))
144         mPUSHi (SvIV (sv));
145     else
146         PUSHs (&PL_sv_undef);
148     if (SvNOK (sv) || SvNOKp (sv))
149         mPUSHn (SvNV (sv));
150     else
151         PUSHs (&PL_sv_undef);
153     if (SvROK (sv)) {
154         SV *xv = newSVsv (SvRV (sv));
155         mPUSHs (xv);
156         }
157     else
158         PUSHs (&PL_sv_undef);
160     mPUSHi (SvMAGICAL (sv) >> 21);
162     if (gimme == G_VOID) _Dump_Dual (aTHX_ sv, ST (0), ST (1), ST (2), ST (3));
163     /* XS DDual */
165 void
166 DGrow (sv, size)
167     SV     *sv
168     IV      size
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 */
180 void
181 DDump_XS (sv)
182     SV   *sv
184   PROTOTYPE: $
185   PPCODE:
186     SV   *dd = _DDump (aTHX_ sv);
188     if (dd) {
189         ST (0) = dd;
190         XSRETURN (1);
191         }
193     XSRETURN (0);
194     /* XS DDump */
196 #if PERL_VERSION >= 8
198 void
199 DDump_IO (io, sv, level)
200     PerlIO *io
201     SV     *sv
202     IV      level
204   PPCODE:
205     do_sv_dump (0, io, sv, 1, level, 1, 0);
206     XSRETURN (1);
207     /* XS DDump */
209 #endif