ext/Devel/PPPort/parts/inc/newCONSTSUB

   1 ################################################################################
   2 ##
   3 ##  $Revision: 15 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2009/01/18 14:10:55 +0100 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004-2009, Marcus Holland-Moritz.
  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
  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
  37 void
  38 newCONSTSUB(HV *stash, const char *name, SV *sv)
  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;
  44         PL_curcop->cop_line = D_PPP_PL_copline;
  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
  60                 newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
  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
 103 &Devel::PPPort::call_newCONSTSUB_1();
 104 ok(&Devel::PPPort::test_value_1(), 1);
 105
 106 &Devel::PPPort::call_newCONSTSUB_2();
 107 ok(&Devel::PPPort::test_value_2(), 2);
 108
 109 &Devel::PPPort::call_newCONSTSUB_3();
 110 ok(&Devel::PPPort::test_value_3(), 3);
 111