This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Devel::PPPort 3.18
[perl5.git] / ext / Devel-PPPort / parts / inc / misc
CommitLineData
adfe19db
MHM
1################################################################################
2##
7bb03b24 3## $Revision: 52 $
adfe19db 4## $Author: mhx $
7bb03b24 5## $Date: 2009/03/15 06:51:00 +0100 $
adfe19db
MHM
6##
7################################################################################
8##
51d6c659 9## Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
adfe19db
MHM
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__
21PERL_UNUSED_DECL
f2ab5a41
MHM
22PERL_UNUSED_ARG
23PERL_UNUSED_VAR
24PERL_UNUSED_CONTEXT
a745474a 25PERL_GCC_BRACE_GROUPS_FORBIDDEN
c07deaaf 26PERL_USE_GCC_BRACE_GROUPS
9c0a17a0
MHM
27PERLIO_FUNCS_DECL
28PERLIO_FUNCS_CAST
adfe19db
MHM
29NVTYPE
30INT2PTR
31PTRV
32NUM2PTR
c83e6f19 33PERL_HASH
adfe19db
MHM
34PTR2IV
35PTR2UV
36PTR2NV
37PTR2ul
a745474a
MHM
38START_EXTERN_C
39END_EXTERN_C
40EXTERN_C
41STMT_START
42STMT_END
679ad62d 43UTF8_MAXBYTES
0d0f8426 44XSRETURN
adfe19db
MHM
45
46=implementation
47
62093c1c
NC
48#ifndef PERL_UNUSED_DECL
49# ifdef HASATTRIBUTE
50# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
51# define PERL_UNUSED_DECL
52# else
53# define PERL_UNUSED_DECL __attribute__((unused))
54# endif
adfe19db 55# else
62093c1c 56# define PERL_UNUSED_DECL
adfe19db 57# endif
adfe19db
MHM
58#endif
59
f2ab5a41
MHM
60#ifndef PERL_UNUSED_ARG
61# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
62# include <note.h>
63# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
64# else
65# define PERL_UNUSED_ARG(x) ((void)x)
66# endif
67#endif
68
69#ifndef PERL_UNUSED_VAR
70# define PERL_UNUSED_VAR(x) ((void)x)
71#endif
72
73#ifndef PERL_UNUSED_CONTEXT
74# ifdef USE_ITHREADS
75# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
76# else
77# define PERL_UNUSED_CONTEXT
78# endif
79#endif
80
81__UNDEFINED__ NOOP /*EMPTY*/(void)0
82__UNDEFINED__ dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
adfe19db
MHM
83
84#ifndef NVTYPE
85# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
86# define NVTYPE long double
87# else
88# define NVTYPE double
89# endif
90typedef NVTYPE NV;
91#endif
92
93#ifndef INT2PTR
adfe19db
MHM
94# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
95# define PTRV UV
96# define INT2PTR(any,d) (any)(d)
97# else
98# if PTRSIZE == LONGSIZE
99# define PTRV unsigned long
100# else
101# define PTRV unsigned
102# endif
103# define INT2PTR(any,d) (any)(PTRV)(d)
104# endif
7bb03b24 105#endif
adfe19db 106
7bb03b24 107#ifndef PTR2ul
adfe19db
MHM
108# if PTRSIZE == LONGSIZE
109# define PTR2ul(p) (unsigned long)(p)
110# else
4a582685 111# define PTR2ul(p) INT2PTR(unsigned long,p)
adfe19db 112# endif
7bb03b24 113#endif
adfe19db 114
7bb03b24
MHM
115__UNDEFINED__ PTR2nat(p) (PTRV)(p)
116__UNDEFINED__ NUM2PTR(any,d) (any)PTR2nat(d)
117__UNDEFINED__ PTR2IV(p) INT2PTR(IV,p)
118__UNDEFINED__ PTR2UV(p) INT2PTR(UV,p)
119__UNDEFINED__ PTR2NV(p) NUM2PTR(NV,p)
adfe19db 120
a745474a
MHM
121#undef START_EXTERN_C
122#undef END_EXTERN_C
123#undef EXTERN_C
124#ifdef __cplusplus
125# define START_EXTERN_C extern "C" {
126# define END_EXTERN_C }
127# define EXTERN_C extern "C"
128#else
129# define START_EXTERN_C
130# define END_EXTERN_C
131# define EXTERN_C extern
132#endif
133
c07deaaf
MHM
134#if defined(PERL_GCC_PEDANTIC)
135# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
a745474a
MHM
136# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
137# endif
138#endif
139
c07deaaf
MHM
140#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
141# ifndef PERL_USE_GCC_BRACE_GROUPS
142# define PERL_USE_GCC_BRACE_GROUPS
143# endif
144#endif
145
a745474a
MHM
146#undef STMT_START
147#undef STMT_END
c07deaaf 148#ifdef PERL_USE_GCC_BRACE_GROUPS
a745474a
MHM
149# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
150# define STMT_END )
151#else
152# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
153# define STMT_START if (1)
154# define STMT_END else (void)0
155# else
156# define STMT_START do
157# define STMT_END while (0)
158# endif
159#endif
160
adfe19db
MHM
161__UNDEFINED__ boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
162
163/* DEFSV appears first in 5.004_56 */
164__UNDEFINED__ DEFSV GvSV(PL_defgv)
165__UNDEFINED__ SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
ac2e3cea 166__UNDEFINED__ DEFSV_set(sv) (DEFSV = (sv))
adfe19db
MHM
167
168/* Older perls (<=5.003) lack AvFILLp */
169__UNDEFINED__ AvFILLp AvFILL
170
171__UNDEFINED__ ERRSV get_sv("@",FALSE)
172
adfe19db
MHM
173/* Hint: gv_stashpvn
174 * This function's backport doesn't support the length parameter, but
175 * rather ignores it. Portability can only be ensured if the length
176 * parameter is used for speed reasons, but the length can always be
177 * correctly computed from the string argument.
178 */
179
180__UNDEFINED__ gv_stashpvn(str,len,create) gv_stashpv(str,create)
181
182/* Replace: 1 */
183__UNDEFINED__ get_cv perl_get_cv
184__UNDEFINED__ get_sv perl_get_sv
185__UNDEFINED__ get_av perl_get_av
186__UNDEFINED__ get_hv perl_get_hv
187/* Replace: 0 */
188
adfe19db
MHM
189__UNDEFINED__ dUNDERBAR dNOOP
190__UNDEFINED__ UNDERBAR DEFSV
191
192__UNDEFINED__ dAX I32 ax = MARK - PL_stack_base + 1
193__UNDEFINED__ dITEMS I32 items = SP - MARK
194
9132e1a3
MHM
195__UNDEFINED__ dXSTARG SV * targ = sv_newmortal()
196
0d0f8426
MHM
197__UNDEFINED__ dAXMARK I32 ax = POPMARK; \
198 register SV ** const mark = PL_stack_base + ax++
199
200
201__UNDEFINED__ XSprePUSH (sp = PL_stack_base + ax - 1)
202
203#if { VERSION < 5.005 }
204# undef XSRETURN
205# define XSRETURN(off) \
206 STMT_START { \
207 PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
208 return; \
209 } STMT_END
210#endif
211
f2ab5a41
MHM
212__UNDEFINED__ PERL_ABS(x) ((x) < 0 ? -(x) : (x))
213
214__UNDEFINED__ dVAR dNOOP
215
216__UNDEFINED__ SVf "_"
217
c83e6f19
MHM
218__UNDEFINED__ UTF8_MAXBYTES UTF8_MAXLEN
219
fd7af155
MHM
220__UNDEFINED__ CPERLscope(x) x
221
c83e6f19
MHM
222__UNDEFINED__ PERL_HASH(hash,str,len) \
223 STMT_START { \
224 const char *s_PeRlHaSh = str; \
225 I32 i_PeRlHaSh = len; \
226 U32 hash_PeRlHaSh = 0; \
227 while (i_PeRlHaSh--) \
228 hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
229 (hash) = hash_PeRlHaSh; \
230 } STMT_END
679ad62d 231
9c0a17a0
MHM
232#ifndef PERLIO_FUNCS_DECL
233# ifdef PERLIO_FUNCS_CONST
234# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
235# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
236# else
237# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
238# define PERLIO_FUNCS_CAST(funcs) (funcs)
239# endif
240#endif
241
fd7af155
MHM
242/* provide these typedefs for older perls */
243#if { VERSION < 5.9.3 }
244
245# ifdef ARGSproto
246typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
247# else
248typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
249# endif
250
251typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
252
253#endif
254
db42c902
MHM
255__UNDEFINED__ isPSXSPC(c) (isSPACE(c) || (c) == '\v')
256__UNDEFINED__ isBLANK(c) ((c) == ' ' || (c) == '\t')
257#ifdef EBCDIC
258__UNDEFINED__ isALNUMC(c) isalnum(c)
259__UNDEFINED__ isASCII(c) isascii(c)
260__UNDEFINED__ isCNTRL(c) iscntrl(c)
261__UNDEFINED__ isGRAPH(c) isgraph(c)
262__UNDEFINED__ isPRINT(c) isprint(c)
263__UNDEFINED__ isPUNCT(c) ispunct(c)
264__UNDEFINED__ isXDIGIT(c) isxdigit(c)
265#else
266# if { VERSION < 5.10.0 }
267/* Hint: isPRINT
268 * The implementation in older perl versions includes all of the
269 * isSPACE() characters, which is wrong. The version provided by
270 * Devel::PPPort always overrides a present buggy version.
271 */
272# undef isPRINT
273# endif
274__UNDEFINED__ isALNUMC(c) (isALPHA(c) || isDIGIT(c))
275__UNDEFINED__ isASCII(c) ((c) <= 127)
276__UNDEFINED__ isCNTRL(c) ((c) < ' ' || (c) == 127)
277__UNDEFINED__ isGRAPH(c) (isALNUM(c) || isPUNCT(c))
278__UNDEFINED__ isPRINT(c) (((c) >= 32 && (c) < 127))
279__UNDEFINED__ isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
280__UNDEFINED__ isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
281#endif
282
9132e1a3
MHM
283=xsmisc
284
285XS(XS_Devel__PPPort_dXSTARG); /* prototype */
286XS(XS_Devel__PPPort_dXSTARG)
287{
288 dXSARGS;
289 dXSTARG;
2dd69576 290 IV iv;
9132e1a3 291 SP -= items;
2dd69576 292 iv = SvIV(ST(0)) + 1;
9132e1a3
MHM
293 PUSHi(iv);
294 XSRETURN(1);
295}
296
0d0f8426
MHM
297XS(XS_Devel__PPPort_dAXMARK); /* prototype */
298XS(XS_Devel__PPPort_dAXMARK)
299{
300 dSP;
301 dAXMARK;
302 dITEMS;
303 IV iv;
304 SP -= items;
305 iv = SvIV(ST(0)) - 1;
c1a049cb 306 mPUSHi(iv);
0d0f8426
MHM
307 XSRETURN(1);
308}
309
9132e1a3
MHM
310=xsboot
311
312newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, file);
0d0f8426 313newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
9132e1a3 314
adfe19db
MHM
315=xsubs
316
317int
7bb03b24
MHM
318ptrtests()
319 PREINIT:
320 int var, *p = &var;
321
322 CODE:
323 RETVAL = 0;
324 RETVAL += PTR2nat(p) != 0 ? 1 : 0;
325 RETVAL += PTR2ul(p) != 0UL ? 2 : 0;
326 RETVAL += PTR2UV(p) != (UV) 0 ? 4 : 0;
327 RETVAL += PTR2IV(p) != (IV) 0 ? 8 : 0;
328 RETVAL += PTR2NV(p) != (NV) 0 ? 16 : 0;
329 RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0;
330
331 OUTPUT:
332 RETVAL
333
334int
adfe19db
MHM
335gv_stashpvn(name, create)
336 char *name
337 I32 create
338 CODE:
339 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
340 OUTPUT:
341 RETVAL
342
343int
344get_sv(name, create)
345 char *name
346 I32 create
347 CODE:
348 RETVAL = get_sv(name, create) != NULL;
349 OUTPUT:
350 RETVAL
351
352int
353get_av(name, create)
354 char *name
355 I32 create
356 CODE:
357 RETVAL = get_av(name, create) != NULL;
358 OUTPUT:
359 RETVAL
360
361int
362get_hv(name, create)
363 char *name
364 I32 create
365 CODE:
366 RETVAL = get_hv(name, create) != NULL;
367 OUTPUT:
368 RETVAL
369
370int
371get_cv(name, create)
372 char *name
373 I32 create
374 CODE:
375 RETVAL = get_cv(name, create) != NULL;
376 OUTPUT:
377 RETVAL
378
379void
0d0f8426
MHM
380xsreturn(two)
381 int two
382 PPCODE:
c1a049cb 383 mXPUSHp("test1", 5);
0d0f8426 384 if (two)
c1a049cb 385 mXPUSHp("test2", 5);
0d0f8426
MHM
386 if (two)
387 XSRETURN(2);
388 else
389 XSRETURN(1);
390
adfe19db
MHM
391SV*
392boolSV(value)
393 int value
394 CODE:
395 RETVAL = newSVsv(boolSV(value));
396 OUTPUT:
397 RETVAL
398
399SV*
400DEFSV()
401 CODE:
402 RETVAL = newSVsv(DEFSV);
403 OUTPUT:
404 RETVAL
405
51d6c659
MHM
406void
407DEFSV_modify()
408 PPCODE:
409 XPUSHs(sv_mortalcopy(DEFSV));
410 ENTER;
411 SAVE_DEFSV;
412 DEFSV_set(newSVpvs("DEFSV"));
413 XPUSHs(sv_mortalcopy(DEFSV));
ac2e3cea
MHM
414 /* Yes, this leaks the above scalar; 5.005 with threads for some reason */
415 /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */
416 /* sv_2mortal(DEFSV); */
51d6c659
MHM
417 LEAVE;
418 XPUSHs(sv_mortalcopy(DEFSV));
419 XSRETURN(3);
420
adfe19db
MHM
421int
422ERRSV()
423 CODE:
424 RETVAL = SvTRUE(ERRSV);
425 OUTPUT:
426 RETVAL
427
428SV*
429UNDERBAR()
430 CODE:
431 {
432 dUNDERBAR;
433 RETVAL = newSVsv(UNDERBAR);
434 }
435 OUTPUT:
436 RETVAL
437
0d0f8426
MHM
438void
439prepush()
440 CODE:
441 {
442 dXSTARG;
443 XSprePUSH;
1d175cda 444 PUSHi(42);
0d0f8426
MHM
445 XSRETURN(1);
446 }
447
f2ab5a41
MHM
448int
449PERL_ABS(a)
450 int a
451
452void
453SVf(x)
454 SV *x
455 PPCODE:
456#if { VERSION >= 5.004 }
c1a049cb 457 x = sv_2mortal(newSVpvf("[%"SVf"]", x));
f2ab5a41
MHM
458#endif
459 XPUSHs(x);
460 XSRETURN(1);
461
fd7af155
MHM
462void
463Perl_ppaddr_t(string)
464 char *string
465 PREINIT:
466 Perl_ppaddr_t lower;
467 PPCODE:
468 lower = PL_ppaddr[OP_LC];
469 PUSHMARK(SP);
470 mXPUSHs(newSVpv(string, 0));
471 PUTBACK;
472 ENTER;
473 (void)*(lower)(aTHXR);
474 SPAGAIN;
475 LEAVE;
476 XSRETURN(1);
477
7bb03b24 478=tests plan => 39
adfe19db
MHM
479
480use vars qw($my_sv @my_av %my_hv);
481
adfe19db
MHM
482ok(&Devel::PPPort::boolSV(1));
483ok(!&Devel::PPPort::boolSV(0));
484
485$_ = "Fred";
486ok(&Devel::PPPort::DEFSV(), "Fred");
487ok(&Devel::PPPort::UNDERBAR(), "Fred");
488
0d0f8426
MHM
489if ($] >= 5.009002) {
490 eval q{
491 my $_ = "Tony";
492 ok(&Devel::PPPort::DEFSV(), "Fred");
493 ok(&Devel::PPPort::UNDERBAR(), "Tony");
494 };
495}
496else {
497 ok(1);
498 ok(1);
499}
500
51d6c659
MHM
501my @r = &Devel::PPPort::DEFSV_modify();
502
503ok(@r == 3);
504ok($r[0], 'Fred');
505ok($r[1], 'DEFSV');
506ok($r[2], 'Fred');
507
508ok(&Devel::PPPort::DEFSV(), "Fred");
509
adfe19db
MHM
510eval { 1 };
511ok(!&Devel::PPPort::ERRSV());
512eval { cannot_call_this_one() };
513ok(&Devel::PPPort::ERRSV());
514
515ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
516ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
517ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
518
519$my_sv = 1;
520ok(&Devel::PPPort::get_sv('my_sv', 0));
521ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
522ok(&Devel::PPPort::get_sv('not_my_sv', 1));
523
524@my_av = (1);
525ok(&Devel::PPPort::get_av('my_av', 0));
526ok(!&Devel::PPPort::get_av('not_my_av', 0));
527ok(&Devel::PPPort::get_av('not_my_av', 1));
528
529%my_hv = (a=>1);
530ok(&Devel::PPPort::get_hv('my_hv', 0));
531ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
532ok(&Devel::PPPort::get_hv('not_my_hv', 1));
533
534sub my_cv { 1 };
535ok(&Devel::PPPort::get_cv('my_cv', 0));
536ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
537ok(&Devel::PPPort::get_cv('not_my_cv', 1));
538
9132e1a3 539ok(Devel::PPPort::dXSTARG(42), 43);
0d0f8426
MHM
540ok(Devel::PPPort::dAXMARK(4711), 4710);
541
542ok(Devel::PPPort::prepush(), 42);
9132e1a3 543
0d0f8426
MHM
544ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
545ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
f2ab5a41
MHM
546
547ok(Devel::PPPort::PERL_ABS(42), 42);
548ok(Devel::PPPort::PERL_ABS(-13), 13);
549
550ok(Devel::PPPort::SVf(42), $] >= 5.004 ? '[42]' : '42');
551ok(Devel::PPPort::SVf('abc'), $] >= 5.004 ? '[abc]' : 'abc');
552
fd7af155
MHM
553ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
554
7bb03b24
MHM
555ok(&Devel::PPPort::ptrtests(), 63);
556