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