This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b34658892ffff2aa85e4b357dfa7278a883e9499
[perl5.git] / ext / XS / APItest / APItest.xs
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5
6 MODULE = XS::APItest:Hash               PACKAGE = XS::APItest::Hash
7
8 bool
9 exists(hash, key_sv)
10         PREINIT:
11         STRLEN len;
12         const char *key;
13         INPUT:
14         HV *hash
15         SV *key_sv
16         CODE:
17         key = SvPV(key_sv, len);
18         RETVAL = hv_exists(hash, key, SvUTF8(key_sv) ? -len : len);
19         OUTPUT:
20         RETVAL
21
22 SV *
23 delete(hash, key_sv)
24         PREINIT:
25         STRLEN len;
26         const char *key;
27         INPUT:
28         HV *hash
29         SV *key_sv
30         CODE:
31         key = SvPV(key_sv, len);
32         /* It's already mortal, so need to increase reference count.  */
33         RETVAL = SvREFCNT_inc(hv_delete(hash, key,
34                                         SvUTF8(key_sv) ? -len : len, 0));
35         OUTPUT:
36         RETVAL
37
38 SV *
39 store(hash, key_sv, value)
40         PREINIT:
41         STRLEN len;
42         const char *key;
43         SV *copy;
44         SV **result;
45         INPUT:
46         HV *hash
47         SV *key_sv
48         SV *value
49         CODE:
50         key = SvPV(key_sv, len);
51         copy = newSV(0);
52         result = hv_store(hash, key, SvUTF8(key_sv) ? -len : len, copy, 0);
53         SvSetMagicSV(*result, value);
54         if (!result) {
55             SvREFCNT_dec(copy);
56             XSRETURN_EMPTY;
57         }
58         /* It's about to become mortal, so need to increase reference count.
59          */
60         RETVAL = SvREFCNT_inc(*result);
61         OUTPUT:
62         RETVAL
63
64
65 SV *
66 fetch(hash, key_sv)
67         PREINIT:
68         STRLEN len;
69         const char *key;
70         SV **result;
71         INPUT:
72         HV *hash
73         SV *key_sv
74         CODE:
75         key = SvPV(key_sv, len);
76         result = hv_fetch(hash, key, SvUTF8(key_sv) ? -len : len, 0);
77         if (!result) {
78             XSRETURN_EMPTY;
79         }
80         /* Force mg_get  */
81         RETVAL = newSVsv(*result);
82         OUTPUT:
83         RETVAL
84
85 =pod
86
87 sub TIEHASH  { bless {}, $_[0] }
88 sub STORE    { $_[0]->{$_[1]} = $_[2] }
89 sub FETCH    { $_[0]->{$_[1]} }
90 sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
91 sub NEXTKEY  { each %{$_[0]} }
92 sub EXISTS   { exists $_[0]->{$_[1]} }
93 sub DELETE   { delete $_[0]->{$_[1]} }
94 sub CLEAR    { %{$_[0]} = () }
95
96 =cut
97
98 MODULE = XS::APItest            PACKAGE = XS::APItest
99
100 PROTOTYPES: DISABLE
101
102 void
103 print_double(val)
104         double val
105         CODE:
106         printf("%5.3f\n",val);
107
108 int
109 have_long_double()
110         CODE:
111 #ifdef HAS_LONG_DOUBLE
112         RETVAL = 1;
113 #else
114         RETVAL = 0;
115 #endif
116         OUTPUT:
117         RETVAL
118
119 void
120 print_long_double()
121         CODE:
122 #ifdef HAS_LONG_DOUBLE
123 #   if defined(PERL_PRIfldbl) && (LONG_DOUBLESIZE > DOUBLESIZE)
124         long double val = 7.0;
125         printf("%5.3" PERL_PRIfldbl "\n",val);
126 #   else
127         double val = 7.0;
128         printf("%5.3f\n",val);
129 #   endif
130 #endif
131
132 void
133 print_int(val)
134         int val
135         CODE:
136         printf("%d\n",val);
137
138 void
139 print_long(val)
140         long val
141         CODE:
142         printf("%ld\n",val);
143
144 void
145 print_float(val)
146         float val
147         CODE:
148         printf("%5.3f\n",val);
149         
150 void
151 print_flush()
152         CODE:
153         fflush(stdout);