| Commit | Line | Data |
|---|
| adfe19db |
1 | ################################################################################ |
| 2 | ## |
| 51d6c659 |
3 | ## $Revision: 15 $ |
| adfe19db |
4 | ## $Author: mhx $ |
| 51d6c659 |
5 | ## $Date: 2009/01/18 14:10:55 +0100 $ |
| 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 | newCONSTSUB |
| 21 | |
| 22 | =implementation |
| 23 | |
| 24 | /* Hint: newCONSTSUB |
| 25 | * Returns a CV* as of perl-5.7.1. This return value is not supported |
| 26 | * by Devel::PPPort. |
| 27 | */ |
| 28 | |
| 29 | /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ |
| 30 | #if { VERSION < 5.004_63 } && { VERSION != 5.004_05 } |
| 31 | #if { NEED newCONSTSUB } |
| 32 | |
| c01be2ce |
33 | /* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ |
| 34 | /* (There's no PL_parser in perl < 5.005, so this is completely safe) */ |
| 35 | #define D_PPP_PL_copline PL_copline |
| 36 | |
| adfe19db |
37 | void |
| aab9a3b6 |
38 | newCONSTSUB(HV *stash, const char *name, SV *sv) |
| adfe19db |
39 | { |
| 40 | U32 oldhints = PL_hints; |
| 41 | HV *old_cop_stash = PL_curcop->cop_stash; |
| 42 | HV *old_curstash = PL_curstash; |
| 43 | line_t oldline = PL_curcop->cop_line; |
| c01be2ce |
44 | PL_curcop->cop_line = D_PPP_PL_copline; |
| adfe19db |
45 | |
| 46 | PL_hints &= ~HINT_BLOCK_SCOPE; |
| 47 | if (stash) |
| 48 | PL_curstash = PL_curcop->cop_stash = stash; |
| 49 | |
| 50 | newSUB( |
| 51 | |
| 52 | #if { VERSION < 5.003_22 } |
| 53 | start_subparse(), |
| 54 | #elif { VERSION == 5.003_22 } |
| 55 | start_subparse(0), |
| 56 | #else /* 5.003_23 onwards */ |
| 57 | start_subparse(FALSE, 0), |
| 58 | #endif |
| 59 | |
| aab9a3b6 |
60 | newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), |
| adfe19db |
61 | newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ |
| 62 | newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) |
| 63 | ); |
| 64 | |
| 65 | PL_hints = oldhints; |
| 66 | PL_curcop->cop_stash = old_cop_stash; |
| 67 | PL_curstash = old_curstash; |
| 68 | PL_curcop->cop_line = oldline; |
| 69 | } |
| 70 | #endif |
| 71 | #endif |
| 72 | |
| 73 | =xsinit |
| 74 | |
| 75 | #define NEED_newCONSTSUB |
| 76 | |
| 77 | =xsmisc |
| 78 | |
| 79 | void call_newCONSTSUB_1(void) |
| 80 | { |
| 81 | #ifdef PERL_NO_GET_CONTEXT |
| 82 | dTHX; |
| 83 | #endif |
| 84 | newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1)); |
| 85 | } |
| 86 | |
| 87 | extern void call_newCONSTSUB_2(void); |
| 88 | extern void call_newCONSTSUB_3(void); |
| 89 | |
| 90 | =xsubs |
| 91 | |
| 92 | void |
| 93 | call_newCONSTSUB_1() |
| 94 | |
| 95 | void |
| 96 | call_newCONSTSUB_2() |
| 97 | |
| 98 | void |
| 99 | call_newCONSTSUB_3() |
| 100 | |
| 101 | =tests plan => 3 |
| 102 | |
| 4a582685 |
103 | &Devel::PPPort::call_newCONSTSUB_1(); |
| adfe19db |
104 | ok(&Devel::PPPort::test_value_1(), 1); |
| 105 | |
| 4a582685 |
106 | &Devel::PPPort::call_newCONSTSUB_2(); |
| adfe19db |
107 | ok(&Devel::PPPort::test_value_2(), 2); |
| 108 | |
| 4a582685 |
109 | &Devel::PPPort::call_newCONSTSUB_3(); |
| adfe19db |
110 | ok(&Devel::PPPort::test_value_3(), 3); |
| 111 | |
projects / p5sagit/p5-mst-13.2.git / blame