dist/Devel-PPPort/parts/inc/newCONSTSUB

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