1################################################################################
2##
3##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
4##  Version 2.x, Copyright (C) 2001, Paul Marquess.
5##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
6##
7##  This program is free software; you can redistribute it and/or
8##  modify it under the same terms as Perl itself.
9##
10################################################################################
11
12=provides
13
14__UNDEFINED__
15
16=implementation
17
18/* concatenating with "" ensures that only literal strings are accepted as argument
19 * note that STR_WITH_LEN() can't be used as argument to macros or functions that
20 * under some configurations might be macros
21 */
22
23__UNDEFINED__  STR_WITH_LEN(s)             (s ""), (sizeof(s)-1)
24
25__UNDEFINED__  newSVpvs(str)               newSVpvn(str "", sizeof(str) - 1)
26__UNDEFINED__  newSVpvs_flags(str, flags)  newSVpvn_flags(str "", sizeof(str) - 1, flags)
27__UNDEFINED__  newSVpvs_share(str)         newSVpvn_share(str "", sizeof(str) - 1, 0)
28__UNDEFINED__  sv_catpvs(sv, str)          sv_catpvn(sv, str "", sizeof(str) - 1)
29__UNDEFINED__  sv_setpvs(sv, str)          sv_setpvn(sv, str "", sizeof(str) - 1)
30__UNDEFINED__  hv_fetchs(hv, key, lval)    hv_fetch(hv, key "", sizeof(key) - 1, lval)
31__UNDEFINED__  hv_stores(hv, key, val)     hv_store(hv, key "", sizeof(key) - 1, val, 0)
32
33__UNDEFINED__  gv_fetchpvs(name, flags, svt)            gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt)
34__UNDEFINED__  gv_stashpvs(name, flags)                 gv_stashpvn(name "", sizeof(name) - 1, flags)
35
36__UNDEFINED__  get_cvs(name, flags)                     get_cvn_flags(name "", sizeof(name)-1, flags)
37
38=xsinit
39
40#define NEED_newSVpvn_share
41
42=xsubs
43
44void
45newSVpvs()
46        PPCODE:
47                mXPUSHs(newSVpvs("newSVpvs"));
48                XSRETURN(1);
49
50void
51newSVpvs_flags()
52        PPCODE:
53                XPUSHs(newSVpvs_flags("newSVpvs_flags", SVs_TEMP));
54                XSRETURN(1);
55
56int
57newSVpvs_share()
58        PREINIT:
59                SV *sv;
60                U32 hash;
61        CODE:
62                RETVAL = 0;
63                PERL_HASH(hash, "pvs", 3);
64                sv = newSVpvs_share("pvs");
65                RETVAL += strEQ(SvPV_nolen_const(sv), "pvs");
66                RETVAL += SvCUR(sv) == 3;
67                RETVAL += SvSHARED_HASH(sv) == hash;
68                SvREFCNT_dec(sv);
69        OUTPUT:
70                RETVAL
71
72void
73sv_catpvs(sv)
74        SV *sv
75        PPCODE:
76                sv_catpvs(sv, "sv_catpvs");
77
78void
79sv_setpvs(sv)
80        SV *sv
81        PPCODE:
82                sv_setpvs(sv, "sv_setpvs");
83
84void
85hv_fetchs(hv)
86        SV *hv
87        PREINIT:
88                SV **s;
89        PPCODE:
90                s = hv_fetchs((HV *) SvRV(hv), "hv_fetchs", 0);
91                XPUSHs(sv_mortalcopy(*s));
92                XSRETURN(1);
93
94void
95hv_stores(hv, sv)
96        SV *hv
97        SV *sv
98        PPCODE:
99                (void) hv_stores((HV *) SvRV(hv), "hv_stores", SvREFCNT_inc_simple(sv));
100
101SV*
102gv_fetchpvs()
103        CODE:
104                RETVAL = newRV_inc((SV*)gv_fetchpvs("Devel::PPPort::VERSION", 0, SVt_PV));
105        OUTPUT:
106                RETVAL
107
108SV*
109gv_stashpvs()
110        CODE:
111                RETVAL = newRV_inc((SV*)gv_stashpvs("Devel::PPPort", 0));
112        OUTPUT:
113                RETVAL
114
115int
116get_cvs()
117        PREINIT:
118                CV* xv;
119        CODE:
120                RETVAL = 0;
121                xv = get_cvs("Devel::PPPort::foobar", 0);
122                if(xv == NULL) RETVAL++;
123                xv = get_cvs("Devel::PPPort::foobar", GV_ADDMULTI);
124                if(xv && SvTYPE(xv) == SVt_PVCV) RETVAL++;
125                xv = get_cvs("Devel::PPPort::get_cvs", 0);
126                if(xv && SvTYPE(xv) == SVt_PVCV) RETVAL++;
127OUTPUT:
128        RETVAL
129
130
131=tests plan => 12
132
133my $x = 'foo';
134
135ok(Devel::PPPort::newSVpvs(), "newSVpvs");
136ok(Devel::PPPort::newSVpvs_flags(), "newSVpvs_flags");
137ok(Devel::PPPort::newSVpvs_share(), 3);
138
139Devel::PPPort::sv_catpvs($x);
140ok($x, "foosv_catpvs");
141
142Devel::PPPort::sv_setpvs($x);
143ok($x, "sv_setpvs");
144
145my %h = ('hv_fetchs' => 42);
146Devel::PPPort::hv_stores(\%h, 4711);
147ok(scalar keys %h, 2);
148ok(exists $h{'hv_stores'});
149ok($h{'hv_stores'}, 4711);
150ok(Devel::PPPort::hv_fetchs(\%h), 42);
151ok(Devel::PPPort::gv_fetchpvs(), \*Devel::PPPort::VERSION);
152ok(Devel::PPPort::gv_stashpvs(), \%Devel::PPPort::);
153
154ok(Devel::PPPort::get_cvs(), 3);
155