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