This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Devel::PPPort 3.06.
[perl5.git] / ext / Devel / PPPort / parts / inc / misc
1 ################################################################################
2 ##
3 ##  $Revision: 20 $
4 ##  $Author: mhx $
5 ##  $Date: 2005/02/02 19:17:33 +0100 $
6 ##
7 ################################################################################
8 ##
9 ##  Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
10 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
11 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
12 ##
13 ##  This program is free software; you can redistribute it and/or
14 ##  modify it under the same terms as Perl itself.
15 ##
16 ################################################################################
17
18 =provides
19
20 __UNDEFINED__
21 PERL_UNUSED_DECL
22 PERL_GCC_BRACE_GROUPS_FORBIDDEN
23 NVTYPE
24 INT2PTR
25 PTRV
26 NUM2PTR
27 PTR2IV
28 PTR2UV
29 PTR2NV
30 PTR2ul
31 START_EXTERN_C
32 END_EXTERN_C
33 EXTERN_C
34 STMT_START
35 STMT_END
36 /PL_\w+/
37
38 =implementation
39
40 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
41 /* Replace: 1 */
42 #  define PL_DBsingle               DBsingle
43 #  define PL_DBsub                  DBsub
44 #  define PL_Sv                     Sv
45 #  define PL_compiling              compiling
46 #  define PL_copline                copline
47 #  define PL_curcop                 curcop
48 #  define PL_curstash               curstash
49 #  define PL_debstash               debstash
50 #  define PL_defgv                  defgv
51 #  define PL_diehook                diehook
52 #  define PL_dirty                  dirty
53 #  define PL_dowarn                 dowarn
54 #  define PL_errgv                  errgv
55 #  define PL_hexdigit               hexdigit
56 #  define PL_hints                  hints
57 #  define PL_na                     na
58 #  define PL_no_modify              no_modify
59 #  define PL_perl_destruct_level    perl_destruct_level
60 #  define PL_perldb                 perldb
61 #  define PL_ppaddr                 ppaddr
62 #  define PL_rsfp_filters           rsfp_filters
63 #  define PL_rsfp                   rsfp
64 #  define PL_stack_base             stack_base
65 #  define PL_stack_sp               stack_sp
66 #  define PL_stdingv                stdingv
67 #  define PL_sv_arenaroot           sv_arenaroot
68 #  define PL_sv_no                  sv_no
69 #  define PL_sv_undef               sv_undef
70 #  define PL_sv_yes                 sv_yes
71 #  define PL_tainted                tainted
72 #  define PL_tainting               tainting
73 /* Replace: 0 */
74 #endif
75
76 #ifdef HASATTRIBUTE
77 #  if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
78 #    define PERL_UNUSED_DECL
79 #  else
80 #    define PERL_UNUSED_DECL __attribute__((unused))
81 #  endif
82 #else
83 #  define PERL_UNUSED_DECL
84 #endif
85
86 __UNDEFINED__  NOOP          (void)0
87 __UNDEFINED__  dNOOP         extern int Perl___notused PERL_UNUSED_DECL
88
89 #ifndef NVTYPE
90 #  if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
91 #    define NVTYPE long double
92 #  else
93 #    define NVTYPE double
94 #  endif
95 typedef NVTYPE NV;
96 #endif
97
98 #ifndef INT2PTR
99
100 #  if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
101 #    define PTRV                  UV
102 #    define INT2PTR(any,d)        (any)(d)
103 #  else
104 #    if PTRSIZE == LONGSIZE
105 #      define PTRV                unsigned long
106 #    else
107 #      define PTRV                unsigned
108 #    endif
109 #    define INT2PTR(any,d)        (any)(PTRV)(d)
110 #  endif
111
112 #  define NUM2PTR(any,d)  (any)(PTRV)(d)
113 #  define PTR2IV(p)       INT2PTR(IV,p)
114 #  define PTR2UV(p)       INT2PTR(UV,p)
115 #  define PTR2NV(p)       NUM2PTR(NV,p)
116
117 #  if PTRSIZE == LONGSIZE
118 #    define PTR2ul(p)     (unsigned long)(p)
119 #  else
120 #    define PTR2ul(p)     INT2PTR(unsigned long,p)        
121 #  endif
122
123 #endif /* !INT2PTR */
124
125 #undef START_EXTERN_C
126 #undef END_EXTERN_C
127 #undef EXTERN_C
128 #ifdef __cplusplus
129 #  define START_EXTERN_C extern "C" {
130 #  define END_EXTERN_C }
131 #  define EXTERN_C extern "C"
132 #else
133 #  define START_EXTERN_C
134 #  define END_EXTERN_C
135 #  define EXTERN_C extern
136 #endif
137
138 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
139 #  if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
140 #    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
141 #  endif
142 #endif
143
144 #undef STMT_START
145 #undef STMT_END
146 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
147 #  define STMT_START    (void)( /* gcc supports ``({ STATEMENTS; })'' */
148 #  define STMT_END      )
149 #else
150 #  if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
151 #    define STMT_START  if (1)
152 #    define STMT_END    else (void)0
153 #  else
154 #    define STMT_START  do
155 #    define STMT_END    while (0)
156 #  endif
157 #endif
158
159 __UNDEFINED__  boolSV(b)    ((b) ? &PL_sv_yes : &PL_sv_no)
160
161 /* DEFSV appears first in 5.004_56 */
162 __UNDEFINED__  DEFSV        GvSV(PL_defgv)
163 __UNDEFINED__  SAVE_DEFSV   SAVESPTR(GvSV(PL_defgv))
164
165 /* Older perls (<=5.003) lack AvFILLp */
166 __UNDEFINED__  AvFILLp      AvFILL
167
168 __UNDEFINED__  ERRSV        get_sv("@",FALSE)
169
170 __UNDEFINED__  newSVpvn(data,len)  ((data)                                              \
171                                     ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
172                                     : newSV(0))
173
174 /* Hint: gv_stashpvn
175  * This function's backport doesn't support the length parameter, but
176  * rather ignores it. Portability can only be ensured if the length
177  * parameter is used for speed reasons, but the length can always be
178  * correctly computed from the string argument.
179  */
180
181 __UNDEFINED__  gv_stashpvn(str,len,create)  gv_stashpv(str,create)
182
183 /* Replace: 1 */
184 __UNDEFINED__  get_cv          perl_get_cv
185 __UNDEFINED__  get_sv          perl_get_sv
186 __UNDEFINED__  get_av          perl_get_av
187 __UNDEFINED__  get_hv          perl_get_hv
188 /* Replace: 0 */
189
190 #ifdef HAS_MEMCMP
191 __UNDEFINED__  memNE(s1,s2,l)  (memcmp(s1,s2,l))
192 __UNDEFINED__  memEQ(s1,s2,l)  (!memcmp(s1,s2,l))
193 #else
194 __UNDEFINED__  memNE(s1,s2,l)  (bcmp(s1,s2,l))
195 __UNDEFINED__  memEQ(s1,s2,l)  (!bcmp(s1,s2,l))
196 #endif
197
198 __UNDEFINED__  MoveD(s,d,n,t)  memmove((char*)(d),(char*)(s), (n) * sizeof(t))
199 __UNDEFINED__  CopyD(s,d,n,t)  memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
200 #ifdef HAS_MEMSET
201 __UNDEFINED__  ZeroD(d,n,t)    memzero((char*)(d), (n) * sizeof(t))
202 #else
203 __UNDEFINED__  ZeroD(d,n,t)    ((void)memzero((char*)(d), (n) * sizeof(t)),d)
204 #endif
205
206 __UNDEFINED__  Poison(d,n,t)   (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
207
208 __UNDEFINED__  dUNDERBAR       dNOOP
209 __UNDEFINED__  UNDERBAR        DEFSV
210
211 __UNDEFINED__  dAX             I32 ax = MARK - PL_stack_base + 1
212 __UNDEFINED__  dITEMS          I32 items = SP - MARK
213
214 __UNDEFINED__  dXSTARG         SV * targ = sv_newmortal()
215
216 =xsmisc
217
218 XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
219 XS(XS_Devel__PPPort_dXSTARG)
220 {
221   dXSARGS;
222   dXSTARG;
223   IV iv;
224   SP -= items;
225   iv = SvIV(ST(0)) + 1;
226   PUSHi(iv);
227   XSRETURN(1);
228 }
229
230 =xsboot
231
232 newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, file);
233
234 =xsubs
235
236 int
237 gv_stashpvn(name, create)
238         char *name
239         I32 create
240         CODE:
241                 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
242         OUTPUT:
243                 RETVAL
244
245 int
246 get_sv(name, create)
247         char *name
248         I32 create
249         CODE:
250                 RETVAL = get_sv(name, create) != NULL;
251         OUTPUT:
252                 RETVAL
253
254 int
255 get_av(name, create)
256         char *name
257         I32 create
258         CODE:
259                 RETVAL = get_av(name, create) != NULL;
260         OUTPUT:
261                 RETVAL
262
263 int
264 get_hv(name, create)
265         char *name
266         I32 create
267         CODE:
268                 RETVAL = get_hv(name, create) != NULL;
269         OUTPUT:
270                 RETVAL
271
272 int
273 get_cv(name, create)
274         char *name
275         I32 create
276         CODE:
277                 RETVAL = get_cv(name, create) != NULL;
278         OUTPUT:
279                 RETVAL
280
281 void
282 newSVpvn()
283         PPCODE:
284                 XPUSHs(newSVpvn("test", 4));
285                 XPUSHs(newSVpvn("test", 2));
286                 XPUSHs(newSVpvn("test", 0));
287                 XPUSHs(newSVpvn(NULL, 2));
288                 XPUSHs(newSVpvn(NULL, 0));
289                 XSRETURN(5);
290
291 SV *
292 PL_sv_undef()
293         CODE:
294                 RETVAL = newSVsv(&PL_sv_undef);
295         OUTPUT:
296                 RETVAL
297
298 SV *
299 PL_sv_yes()
300         CODE:
301                 RETVAL = newSVsv(&PL_sv_yes);
302         OUTPUT:
303                 RETVAL
304
305 SV *
306 PL_sv_no()
307         CODE:
308                 RETVAL = newSVsv(&PL_sv_no);
309         OUTPUT:
310                 RETVAL
311
312 int
313 PL_na(string)
314         char *string
315         CODE:
316                 PL_na = strlen(string);
317                 RETVAL = PL_na;
318         OUTPUT:
319                 RETVAL
320
321 SV*
322 boolSV(value)
323         int value
324         CODE:
325                 RETVAL = newSVsv(boolSV(value));
326         OUTPUT:
327                 RETVAL
328
329 SV*
330 DEFSV()
331         CODE:
332                 RETVAL = newSVsv(DEFSV);
333         OUTPUT:
334                 RETVAL
335
336 int
337 ERRSV()
338         CODE:
339                 RETVAL = SvTRUE(ERRSV);
340         OUTPUT:
341                 RETVAL
342
343 SV*
344 UNDERBAR()
345         CODE:
346                 {
347                   dUNDERBAR;
348                   RETVAL = newSVsv(UNDERBAR);
349                 }
350         OUTPUT:
351                 RETVAL
352
353 =tests plan => 32
354
355 use vars qw($my_sv @my_av %my_hv);
356
357 my @s = &Devel::PPPort::newSVpvn();
358 ok(@s == 5);
359 ok($s[0], "test");
360 ok($s[1], "te");
361 ok($s[2], "");
362 ok(!defined($s[3]));
363 ok(!defined($s[4]));
364
365 ok(!defined(&Devel::PPPort::PL_sv_undef()));
366 ok(&Devel::PPPort::PL_sv_yes());
367 ok(!&Devel::PPPort::PL_sv_no());
368 ok(&Devel::PPPort::PL_na("abcd"), 4);
369
370 ok(&Devel::PPPort::boolSV(1));
371 ok(!&Devel::PPPort::boolSV(0));
372
373 $_ = "Fred";
374 ok(&Devel::PPPort::DEFSV(), "Fred");
375 ok(&Devel::PPPort::UNDERBAR(), "Fred");
376
377 eval { 1 };
378 ok(!&Devel::PPPort::ERRSV());
379 eval { cannot_call_this_one() };
380 ok(&Devel::PPPort::ERRSV());
381
382 ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
383 ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
384 ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
385
386 $my_sv = 1;
387 ok(&Devel::PPPort::get_sv('my_sv', 0));
388 ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
389 ok(&Devel::PPPort::get_sv('not_my_sv', 1));
390
391 @my_av = (1);
392 ok(&Devel::PPPort::get_av('my_av', 0));
393 ok(!&Devel::PPPort::get_av('not_my_av', 0));
394 ok(&Devel::PPPort::get_av('not_my_av', 1));
395
396 %my_hv = (a=>1);
397 ok(&Devel::PPPort::get_hv('my_hv', 0));
398 ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
399 ok(&Devel::PPPort::get_hv('not_my_hv', 1));
400
401 sub my_cv { 1 };
402 ok(&Devel::PPPort::get_cv('my_cv', 0));
403 ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
404 ok(&Devel::PPPort::get_cv('not_my_cv', 1));
405
406 ok(Devel::PPPort::dXSTARG(42), 43);
407