projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Move Devel::PPPort from ext/ to cpan/
[p5sagit/p5-mst-13.2.git] / cpan / Devel-PPPort / parts / inc / misc
CommitLineData
adfe19db 1################################################################################
2##
8565c31a 3## $Revision: 53 $
adfe19db 4## $Author: mhx $
8565c31a 5## $Date: 2009/03/31 23:05:55 +0200 $
adfe19db 6##
7################################################################################
8##
51d6c659 9## Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
adfe19db 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 22PERL_UNUSED_ARG
23PERL_UNUSED_VAR
24PERL_UNUSED_CONTEXT
a745474a 25PERL_GCC_BRACE_GROUPS_FORBIDDEN
c07deaaf 26PERL_USE_GCC_BRACE_GROUPS
9c0a17a0 27PERLIO_FUNCS_DECL
28PERLIO_FUNCS_CAST
adfe19db 29NVTYPE
30INT2PTR
31PTRV
32NUM2PTR
c83e6f19 33PERL_HASH
adfe19db 34PTR2IV
35PTR2UV
36PTR2NV
37PTR2ul
a745474a 38START_EXTERN_C
39END_EXTERN_C
40EXTERN_C
41STMT_START
42STMT_END
679ad62d 43UTF8_MAXBYTES
0d0f8426 44XSRETURN
adfe19db 45
46=implementation
47
62093c1c 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 58#endif
59
f2ab5a41 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 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 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 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 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 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 134#if defined(PERL_GCC_PEDANTIC)
135# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
a745474a 136# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
137# endif
138#endif
139
c07deaaf 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 146#undef STMT_START
147#undef STMT_END
c07deaaf 148#ifdef PERL_USE_GCC_BRACE_GROUPS
a745474a 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 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 167
168/* Older perls (<=5.003) lack AvFILLp */
169__UNDEFINED__ AvFILLp AvFILL
170
171__UNDEFINED__ ERRSV get_sv("@",FALSE)
172
adfe19db 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 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 195__UNDEFINED__ dXSTARG SV * targ = sv_newmortal()
196
0d0f8426 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
8565c31a 212__UNDEFINED__ XSPROTO(name) void name(pTHX_ CV* cv)
213__UNDEFINED__ SVfARG(p) ((void*)(p))
214
f2ab5a41 215__UNDEFINED__ PERL_ABS(x) ((x) < 0 ? -(x) : (x))
216
217__UNDEFINED__ dVAR dNOOP
218
219__UNDEFINED__ SVf "_"
220
c83e6f19 221__UNDEFINED__ UTF8_MAXBYTES UTF8_MAXLEN
222
fd7af155 223__UNDEFINED__ CPERLscope(x) x
224
c83e6f19 225__UNDEFINED__ PERL_HASH(hash,str,len) \
226 STMT_START { \
227 const char *s_PeRlHaSh = str; \
228 I32 i_PeRlHaSh = len; \
229 U32 hash_PeRlHaSh = 0; \
230 while (i_PeRlHaSh--) \
231 hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
232 (hash) = hash_PeRlHaSh; \
233 } STMT_END
679ad62d 234
9c0a17a0 235#ifndef PERLIO_FUNCS_DECL
236# ifdef PERLIO_FUNCS_CONST
237# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
238# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
239# else
240# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
241# define PERLIO_FUNCS_CAST(funcs) (funcs)
242# endif
243#endif
244
fd7af155 245/* provide these typedefs for older perls */
246#if { VERSION < 5.9.3 }
247
248# ifdef ARGSproto
249typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
250# else
251typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
252# endif
253
254typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
255
256#endif
257
db42c902 258__UNDEFINED__ isPSXSPC(c) (isSPACE(c) || (c) == '\v')
259__UNDEFINED__ isBLANK(c) ((c) == ' ' || (c) == '\t')
260#ifdef EBCDIC
261__UNDEFINED__ isALNUMC(c) isalnum(c)
262__UNDEFINED__ isASCII(c) isascii(c)
263__UNDEFINED__ isCNTRL(c) iscntrl(c)
264__UNDEFINED__ isGRAPH(c) isgraph(c)
265__UNDEFINED__ isPRINT(c) isprint(c)
266__UNDEFINED__ isPUNCT(c) ispunct(c)
267__UNDEFINED__ isXDIGIT(c) isxdigit(c)
268#else
269# if { VERSION < 5.10.0 }
270/* Hint: isPRINT
271 * The implementation in older perl versions includes all of the
272 * isSPACE() characters, which is wrong. The version provided by
273 * Devel::PPPort always overrides a present buggy version.
274 */
275# undef isPRINT
276# endif
277__UNDEFINED__ isALNUMC(c) (isALPHA(c) || isDIGIT(c))
278__UNDEFINED__ isASCII(c) ((c) <= 127)
279__UNDEFINED__ isCNTRL(c) ((c) < ' ' || (c) == 127)
280__UNDEFINED__ isGRAPH(c) (isALNUM(c) || isPUNCT(c))
281__UNDEFINED__ isPRINT(c) (((c) >= 32 && (c) < 127))
282__UNDEFINED__ isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
283__UNDEFINED__ isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
284#endif
285
9132e1a3 286=xsmisc
287
8565c31a 288typedef XSPROTO(XSPROTO_test_t);
289typedef XSPROTO_test_t *XSPROTO_test_t_ptr;
290
9132e1a3 291XS(XS_Devel__PPPort_dXSTARG); /* prototype */
292XS(XS_Devel__PPPort_dXSTARG)
293{
294 dXSARGS;
295 dXSTARG;
2dd69576 296 IV iv;
9132e1a3 297 SP -= items;
2dd69576 298 iv = SvIV(ST(0)) + 1;
9132e1a3 299 PUSHi(iv);
300 XSRETURN(1);
301}
302
0d0f8426 303XS(XS_Devel__PPPort_dAXMARK); /* prototype */
304XS(XS_Devel__PPPort_dAXMARK)
305{
306 dSP;
307 dAXMARK;
308 dITEMS;
309 IV iv;
310 SP -= items;
311 iv = SvIV(ST(0)) - 1;
c1a049cb 312 mPUSHi(iv);
0d0f8426 313 XSRETURN(1);
314}
315
9132e1a3 316=xsboot
317
8565c31a 318{
319 XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG;
320 newXS("Devel::PPPort::dXSTARG", *p, file);
321}
0d0f8426 322newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
9132e1a3 323
adfe19db 324=xsubs
325
326int
7bb03b24 327ptrtests()
328 PREINIT:
329 int var, *p = &var;
330
331 CODE:
332 RETVAL = 0;
333 RETVAL += PTR2nat(p) != 0 ? 1 : 0;
334 RETVAL += PTR2ul(p) != 0UL ? 2 : 0;
335 RETVAL += PTR2UV(p) != (UV) 0 ? 4 : 0;
336 RETVAL += PTR2IV(p) != (IV) 0 ? 8 : 0;
337 RETVAL += PTR2NV(p) != (NV) 0 ? 16 : 0;
338 RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0;
339
340 OUTPUT:
341 RETVAL
342
343int
adfe19db 344gv_stashpvn(name, create)
345 char *name
346 I32 create
347 CODE:
348 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
349 OUTPUT:
350 RETVAL
351
352int
353get_sv(name, create)
354 char *name
355 I32 create
356 CODE:
357 RETVAL = get_sv(name, create) != NULL;
358 OUTPUT:
359 RETVAL
360
361int
362get_av(name, create)
363 char *name
364 I32 create
365 CODE:
366 RETVAL = get_av(name, create) != NULL;
367 OUTPUT:
368 RETVAL
369
370int
371get_hv(name, create)
372 char *name
373 I32 create
374 CODE:
375 RETVAL = get_hv(name, create) != NULL;
376 OUTPUT:
377 RETVAL
378
379int
380get_cv(name, create)
381 char *name
382 I32 create
383 CODE:
384 RETVAL = get_cv(name, create) != NULL;
385 OUTPUT:
386 RETVAL
387
388void
0d0f8426 389xsreturn(two)
390 int two
391 PPCODE:
c1a049cb 392 mXPUSHp("test1", 5);
0d0f8426 393 if (two)
c1a049cb 394 mXPUSHp("test2", 5);
0d0f8426 395 if (two)
396 XSRETURN(2);
397 else
398 XSRETURN(1);
399
adfe19db 400SV*
401boolSV(value)
402 int value
403 CODE:
404 RETVAL = newSVsv(boolSV(value));
405 OUTPUT:
406 RETVAL
407
408SV*
409DEFSV()
410 CODE:
411 RETVAL = newSVsv(DEFSV);
412 OUTPUT:
413 RETVAL
414
51d6c659 415void
416DEFSV_modify()
417 PPCODE:
418 XPUSHs(sv_mortalcopy(DEFSV));
419 ENTER;
420 SAVE_DEFSV;
421 DEFSV_set(newSVpvs("DEFSV"));
422 XPUSHs(sv_mortalcopy(DEFSV));
ac2e3cea 423 /* Yes, this leaks the above scalar; 5.005 with threads for some reason */
424 /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */
425 /* sv_2mortal(DEFSV); */
51d6c659 426 LEAVE;
427 XPUSHs(sv_mortalcopy(DEFSV));
428 XSRETURN(3);
429
adfe19db 430int
431ERRSV()
432 CODE:
433 RETVAL = SvTRUE(ERRSV);
434 OUTPUT:
435 RETVAL
436
437SV*
438UNDERBAR()
439 CODE:
440 {
441 dUNDERBAR;
442 RETVAL = newSVsv(UNDERBAR);
443 }
444 OUTPUT:
445 RETVAL
446
0d0f8426 447void
448prepush()
449 CODE:
450 {
451 dXSTARG;
452 XSprePUSH;
1d175cda 453 PUSHi(42);
0d0f8426 454 XSRETURN(1);
455 }
456
f2ab5a41 457int
458PERL_ABS(a)
459 int a
460
461void
462SVf(x)
463 SV *x
464 PPCODE:
465#if { VERSION >= 5.004 }
8565c31a 466 x = sv_2mortal(newSVpvf("[%"SVf"]", SVfARG(x)));
f2ab5a41 467#endif
468 XPUSHs(x);
469 XSRETURN(1);
470
fd7af155 471void
472Perl_ppaddr_t(string)
473 char *string
474 PREINIT:
475 Perl_ppaddr_t lower;
476 PPCODE:
477 lower = PL_ppaddr[OP_LC];
478 PUSHMARK(SP);
479 mXPUSHs(newSVpv(string, 0));
480 PUTBACK;
481 ENTER;
482 (void)*(lower)(aTHXR);
483 SPAGAIN;
484 LEAVE;
485 XSRETURN(1);
486
7bb03b24 487=tests plan => 39
adfe19db 488
489use vars qw($my_sv @my_av %my_hv);
490
adfe19db 491ok(&Devel::PPPort::boolSV(1));
492ok(!&Devel::PPPort::boolSV(0));
493
494$_ = "Fred";
495ok(&Devel::PPPort::DEFSV(), "Fred");
496ok(&Devel::PPPort::UNDERBAR(), "Fred");
497
0d0f8426 498if ($] >= 5.009002) {
499 eval q{
500 my $_ = "Tony";
501 ok(&Devel::PPPort::DEFSV(), "Fred");
502 ok(&Devel::PPPort::UNDERBAR(), "Tony");
503 };
504}
505else {
506 ok(1);
507 ok(1);
508}
509
51d6c659 510my @r = &Devel::PPPort::DEFSV_modify();
511
512ok(@r == 3);
513ok($r[0], 'Fred');
514ok($r[1], 'DEFSV');
515ok($r[2], 'Fred');
516
517ok(&Devel::PPPort::DEFSV(), "Fred");
518
adfe19db 519eval { 1 };
520ok(!&Devel::PPPort::ERRSV());
521eval { cannot_call_this_one() };
522ok(&Devel::PPPort::ERRSV());
523
524ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
525ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
526ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
527
528$my_sv = 1;
529ok(&Devel::PPPort::get_sv('my_sv', 0));
530ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
531ok(&Devel::PPPort::get_sv('not_my_sv', 1));
532
533@my_av = (1);
534ok(&Devel::PPPort::get_av('my_av', 0));
535ok(!&Devel::PPPort::get_av('not_my_av', 0));
536ok(&Devel::PPPort::get_av('not_my_av', 1));
537
538%my_hv = (a=>1);
539ok(&Devel::PPPort::get_hv('my_hv', 0));
540ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
541ok(&Devel::PPPort::get_hv('not_my_hv', 1));
542
543sub my_cv { 1 };
544ok(&Devel::PPPort::get_cv('my_cv', 0));
545ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
546ok(&Devel::PPPort::get_cv('not_my_cv', 1));
547
9132e1a3 548ok(Devel::PPPort::dXSTARG(42), 43);
0d0f8426 549ok(Devel::PPPort::dAXMARK(4711), 4710);
550
551ok(Devel::PPPort::prepush(), 42);
9132e1a3 552
0d0f8426 553ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
554ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
f2ab5a41 555
556ok(Devel::PPPort::PERL_ABS(42), 42);
557ok(Devel::PPPort::PERL_ABS(-13), 13);
558
559ok(Devel::PPPort::SVf(42), $] >= 5.004 ? '[42]' : '42');
560ok(Devel::PPPort::SVf('abc'), $] >= 5.004 ? '[abc]' : 'abc');
561
fd7af155 562ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
563
7bb03b24 564ok(&Devel::PPPort::ptrtests(), 63);
565
Unnamed repository; edit this file to name it for gitweb.