projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Try to demangle the mess created by 34667 (the "resubmittal" was actually
[p5sagit/p5-mst-13.2.git] / ext / Devel / PPPort / parts / inc / misc
CommitLineData
adfe19db 1################################################################################
2##
fd7af155 3## $Revision: 47 $
adfe19db 4## $Author: mhx $
fd7af155 5## $Date: 2008/10/21 23:14:09 +0200 $
adfe19db 6##
7################################################################################
8##
c1a049cb 9## Version 3.x, Copyright (C) 2004-2008, 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
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 116# endif
117
118#endif /* !INT2PTR */
119
a745474a 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 133#if defined(PERL_GCC_PEDANTIC)
134# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
a745474a 135# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
136# endif
137#endif
138
c07deaaf 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 145#undef STMT_START
146#undef STMT_END
c07deaaf 147#ifdef PERL_USE_GCC_BRACE_GROUPS
a745474a 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 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))
165
166/* Older perls (<=5.003) lack AvFILLp */
167__UNDEFINED__ AvFILLp AvFILL
168
169__UNDEFINED__ ERRSV get_sv("@",FALSE)
170
adfe19db 171/* Hint: gv_stashpvn
172 * This function's backport doesn't support the length parameter, but
173 * rather ignores it. Portability can only be ensured if the length
174 * parameter is used for speed reasons, but the length can always be
175 * correctly computed from the string argument.
176 */
177
178__UNDEFINED__ gv_stashpvn(str,len,create) gv_stashpv(str,create)
179
180/* Replace: 1 */
181__UNDEFINED__ get_cv perl_get_cv
182__UNDEFINED__ get_sv perl_get_sv
183__UNDEFINED__ get_av perl_get_av
184__UNDEFINED__ get_hv perl_get_hv
185/* Replace: 0 */
186
adfe19db 187__UNDEFINED__ dUNDERBAR dNOOP
188__UNDEFINED__ UNDERBAR DEFSV
189
190__UNDEFINED__ dAX I32 ax = MARK - PL_stack_base + 1
191__UNDEFINED__ dITEMS I32 items = SP - MARK
192
9132e1a3 193__UNDEFINED__ dXSTARG SV * targ = sv_newmortal()
194
0d0f8426 195__UNDEFINED__ dAXMARK I32 ax = POPMARK; \
196 register SV ** const mark = PL_stack_base + ax++
197
198
199__UNDEFINED__ XSprePUSH (sp = PL_stack_base + ax - 1)
200
201#if { VERSION < 5.005 }
202# undef XSRETURN
203# define XSRETURN(off) \
204 STMT_START { \
205 PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
206 return; \
207 } STMT_END
208#endif
209
f2ab5a41 210__UNDEFINED__ PERL_ABS(x) ((x) < 0 ? -(x) : (x))
211
212__UNDEFINED__ dVAR dNOOP
213
214__UNDEFINED__ SVf "_"
215
c83e6f19 216__UNDEFINED__ UTF8_MAXBYTES UTF8_MAXLEN
217
fd7af155 218__UNDEFINED__ CPERLscope(x) x
219
c83e6f19 220__UNDEFINED__ PERL_HASH(hash,str,len) \
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; \
228 } STMT_END
679ad62d 229
9c0a17a0 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 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
9132e1a3 253=xsmisc
254
255XS(XS_Devel__PPPort_dXSTARG); /* prototype */
256XS(XS_Devel__PPPort_dXSTARG)
257{
258 dXSARGS;
259 dXSTARG;
2dd69576 260 IV iv;
9132e1a3 261 SP -= items;
2dd69576 262 iv = SvIV(ST(0)) + 1;
9132e1a3 263 PUSHi(iv);
264 XSRETURN(1);
265}
266
0d0f8426 267XS(XS_Devel__PPPort_dAXMARK); /* prototype */
268XS(XS_Devel__PPPort_dAXMARK)
269{
270 dSP;
271 dAXMARK;
272 dITEMS;
273 IV iv;
274 SP -= items;
275 iv = SvIV(ST(0)) - 1;
c1a049cb 276 mPUSHi(iv);
0d0f8426 277 XSRETURN(1);
278}
279
9132e1a3 280=xsboot
281
282newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, file);
0d0f8426 283newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
9132e1a3 284
adfe19db 285=xsubs
286
287int
288gv_stashpvn(name, create)
289 char *name
290 I32 create
291 CODE:
292 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
293 OUTPUT:
294 RETVAL
295
296int
297get_sv(name, create)
298 char *name
299 I32 create
300 CODE:
301 RETVAL = get_sv(name, create) != NULL;
302 OUTPUT:
303 RETVAL
304
305int
306get_av(name, create)
307 char *name
308 I32 create
309 CODE:
310 RETVAL = get_av(name, create) != NULL;
311 OUTPUT:
312 RETVAL
313
314int
315get_hv(name, create)
316 char *name
317 I32 create
318 CODE:
319 RETVAL = get_hv(name, create) != NULL;
320 OUTPUT:
321 RETVAL
322
323int
324get_cv(name, create)
325 char *name
326 I32 create
327 CODE:
328 RETVAL = get_cv(name, create) != NULL;
329 OUTPUT:
330 RETVAL
331
332void
0d0f8426 333xsreturn(two)
334 int two
335 PPCODE:
c1a049cb 336 mXPUSHp("test1", 5);
0d0f8426 337 if (two)
c1a049cb 338 mXPUSHp("test2", 5);
0d0f8426 339 if (two)
340 XSRETURN(2);
341 else
342 XSRETURN(1);
343
adfe19db 344SV*
345boolSV(value)
346 int value
347 CODE:
348 RETVAL = newSVsv(boolSV(value));
349 OUTPUT:
350 RETVAL
351
352SV*
353DEFSV()
354 CODE:
355 RETVAL = newSVsv(DEFSV);
356 OUTPUT:
357 RETVAL
358
359int
360ERRSV()
361 CODE:
362 RETVAL = SvTRUE(ERRSV);
363 OUTPUT:
364 RETVAL
365
366SV*
367UNDERBAR()
368 CODE:
369 {
370 dUNDERBAR;
371 RETVAL = newSVsv(UNDERBAR);
372 }
373 OUTPUT:
374 RETVAL
375
0d0f8426 376void
377prepush()
378 CODE:
379 {
380 dXSTARG;
381 XSprePUSH;
1d175cda 382 PUSHi(42);
0d0f8426 383 XSRETURN(1);
384 }
385
f2ab5a41 386int
387PERL_ABS(a)
388 int a
389
390void
391SVf(x)
392 SV *x
393 PPCODE:
394#if { VERSION >= 5.004 }
c1a049cb 395 x = sv_2mortal(newSVpvf("[%"SVf"]", x));
f2ab5a41 396#endif
397 XPUSHs(x);
398 XSRETURN(1);
399
fd7af155 400void
401Perl_ppaddr_t(string)
402 char *string
403 PREINIT:
404 Perl_ppaddr_t lower;
405 PPCODE:
406 lower = PL_ppaddr[OP_LC];
407 PUSHMARK(SP);
408 mXPUSHs(newSVpv(string, 0));
409 PUTBACK;
410 ENTER;
411 (void)*(lower)(aTHXR);
412 SPAGAIN;
413 LEAVE;
414 XSRETURN(1);
415
416=tests plan => 33
adfe19db 417
418use vars qw($my_sv @my_av %my_hv);
419
adfe19db 420ok(&Devel::PPPort::boolSV(1));
421ok(!&Devel::PPPort::boolSV(0));
422
423$_ = "Fred";
424ok(&Devel::PPPort::DEFSV(), "Fred");
425ok(&Devel::PPPort::UNDERBAR(), "Fred");
426
0d0f8426 427if ($] >= 5.009002) {
428 eval q{
429 my $_ = "Tony";
430 ok(&Devel::PPPort::DEFSV(), "Fred");
431 ok(&Devel::PPPort::UNDERBAR(), "Tony");
432 };
433}
434else {
435 ok(1);
436 ok(1);
437}
438
adfe19db 439eval { 1 };
440ok(!&Devel::PPPort::ERRSV());
441eval { cannot_call_this_one() };
442ok(&Devel::PPPort::ERRSV());
443
444ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
445ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
446ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
447
448$my_sv = 1;
449ok(&Devel::PPPort::get_sv('my_sv', 0));
450ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
451ok(&Devel::PPPort::get_sv('not_my_sv', 1));
452
453@my_av = (1);
454ok(&Devel::PPPort::get_av('my_av', 0));
455ok(!&Devel::PPPort::get_av('not_my_av', 0));
456ok(&Devel::PPPort::get_av('not_my_av', 1));
457
458%my_hv = (a=>1);
459ok(&Devel::PPPort::get_hv('my_hv', 0));
460ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
461ok(&Devel::PPPort::get_hv('not_my_hv', 1));
462
463sub my_cv { 1 };
464ok(&Devel::PPPort::get_cv('my_cv', 0));
465ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
466ok(&Devel::PPPort::get_cv('not_my_cv', 1));
467
9132e1a3 468ok(Devel::PPPort::dXSTARG(42), 43);
0d0f8426 469ok(Devel::PPPort::dAXMARK(4711), 4710);
470
471ok(Devel::PPPort::prepush(), 42);
9132e1a3 472
0d0f8426 473ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
474ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
f2ab5a41 475
476ok(Devel::PPPort::PERL_ABS(42), 42);
477ok(Devel::PPPort::PERL_ABS(-13), 13);
478
479ok(Devel::PPPort::SVf(42), $] >= 5.004 ? '[42]' : '42');
480ok(Devel::PPPort::SVf('abc'), $] >= 5.004 ? '[abc]' : 'abc');
481
fd7af155 482ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
483
Unnamed repository; edit this file to name it for gitweb.