ext/Devel/PPPort/parts/inc/newCONSTSUB

   1 ################################################################################
   2 ##
   3 ##  $Revision: 7 $
   4 ##  $Author: mhx $
   5 ##  $Date: 2004/08/13 12:45:55 +0200 $
   6 ##
   7 ################################################################################
   8 ##
   9 ##  Version 3.x, Copyright (C) 2004, 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 void
  34 newCONSTSUB(HV *stash, char *name, SV *sv)
  35 {
  36         U32 oldhints = PL_hints;
  37         HV *old_cop_stash = PL_curcop->cop_stash;
  38         HV *old_curstash = PL_curstash;
  39         line_t oldline = PL_curcop->cop_line;
  40         PL_curcop->cop_line = PL_copline;
  41
  42         PL_hints &= ~HINT_BLOCK_SCOPE;
  43         if (stash)
  44                 PL_curstash = PL_curcop->cop_stash = stash;
  45
  46         newSUB(
  47
  48 #if   { VERSION <  5.003_22 }
  49                 start_subparse(),
  50 #elif { VERSION == 5.003_22 }
  51                 start_subparse(0),
  52 #else  /* 5.003_23  onwards */
  53                 start_subparse(FALSE, 0),
  54 #endif
  55
  56                 newSVOP(OP_CONST, 0, newSVpv(name,0)),
  57                 newSVOP(OP_CONST, 0, &PL_sv_no),   /* SvPV(&PL_sv_no) == "" -- GMB */
  58                 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
  59         );
  60
  61         PL_hints = oldhints;
  62         PL_curcop->cop_stash = old_cop_stash;
  63         PL_curstash = old_curstash;
  64         PL_curcop->cop_line = oldline;
  65 }
  66 #endif
  67 #endif
  68
  69 =xsinit
  70
  71 #define NEED_newCONSTSUB
  72
  73 =xsmisc
  74
  75 void call_newCONSTSUB_1(void)
  76 {
  77 #ifdef PERL_NO_GET_CONTEXT
  78         dTHX;
  79 #endif
  80         newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1));
  81 }
  82
  83 extern void call_newCONSTSUB_2(void);
  84 extern void call_newCONSTSUB_3(void);
  85
  86 =xsubs
  87
  88 void
  89 call_newCONSTSUB_1()
  90
  91 void
  92 call_newCONSTSUB_2()
  93
  94 void
  95 call_newCONSTSUB_3()
  96
  97 =tests plan => 3
  98
  99 &Devel::PPPort::call_newCONSTSUB_1();
 100 ok(&Devel::PPPort::test_value_1(), 1);
 101
 102 &Devel::PPPort::call_newCONSTSUB_2();
 103 ok(&Devel::PPPort::test_value_2(), 2);
 104
 105 &Devel::PPPort::call_newCONSTSUB_3();
 106 ok(&Devel::PPPort::test_value_3(), 3);
 107