dist/Devel-PPPort/t/Sv_set.t

   1 ################################################################################
   2 #
   3 #            !!!!!   Do NOT edit this file directly!   !!!!!
   4 #
   5 #            Edit mktests.PL and/or parts/inc/Sv_set instead.
   6 #
   7 #  This file was automatically generated from the definition files in the
   8 #  parts/inc/ subdirectory by mktests.PL. To learn more about how all this
   9 #  works, please read the F<HACKERS> file that came with this distribution.
  10 #
  11 ################################################################################
  12
  13 use FindBin ();
  14
  15 BEGIN {
  16   if ($ENV{'PERL_CORE'}) {
  17     chdir 't' if -d 't';
  18     unshift @INC, '../lib' if -d '../lib' && -d '../ext';
  19     require Config; import Config;
  20     use vars '%Config';
  21     if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) {
  22       print "1..0 # Skip -- Perl configured without Devel::PPPort module\n";
  23       exit 0;
  24     }
  25   }
  26
  27   use lib "$FindBin::Bin";
  28   use lib "$FindBin::Bin/../parts/inc";
  29
  30   die qq[Cannot find "$FindBin::Bin/../parts/inc"] unless -d "$FindBin::Bin/../parts/inc";
  31
  32   sub load {
  33     require 'testutil.pl';
  34     require 'inctools';
  35   }
  36
  37   if (15) {
  38     load();
  39     plan(tests => 15);
  40   }
  41 }
  42
  43 use Devel::PPPort;
  44 use strict;
  45 BEGIN { $^W = 1; }
  46
  47 package Devel::PPPort;
  48 use vars '@ISA';
  49 require DynaLoader;
  50 @ISA = qw(DynaLoader);
  51 bootstrap Devel::PPPort;
  52
  53 package main;
  54
  55 my $foo = 5;
  56 ok(&Devel::PPPort::TestSvUV_set($foo, 12345), 42);
  57 ok(&Devel::PPPort::TestSvPVX_const("mhx"), 43);
  58 ok(&Devel::PPPort::TestSvPVX_mutable("mhx"), 44);
  59
  60 my $bar = [];
  61
  62 bless $bar, 'foo';
  63 ok($bar->x(), 'foobar');
  64
  65 Devel::PPPort::TestSvSTASH_set($bar, 'bar');
  66 ok($bar->x(), 'hacker');
  67
  68 if ( "$]" < '5.007003' ) {
  69     for (1..10) {
  70         skip 'skip: no SV_NOSTEAL support', 0;
  71     }
  72 } else {
  73     ok(Devel::PPPort::Test_sv_setsv_SV_NOSTEAL());
  74
  75     tie my $scalar, 'TieScalarCounter', 'string';
  76
  77     ok tied($scalar)->{fetch}, 0;
  78     ok tied($scalar)->{store}, 0;
  79     my $copy = Devel::PPPort::newSVsv_nomg($scalar);
  80     ok tied($scalar)->{fetch}, 0;
  81     ok tied($scalar)->{store}, 0;
  82
  83     my $fetch = $scalar;
  84     ok tied($scalar)->{fetch}, 1;
  85     ok tied($scalar)->{store}, 0;
  86     my $copy2 = Devel::PPPort::newSVsv_nomg($scalar);
  87     ok tied($scalar)->{fetch}, 1;
  88     ok tied($scalar)->{store}, 0;
  89     ok $copy2, 'string';
  90 }
  91
  92 package TieScalarCounter;
  93
  94 sub TIESCALAR {
  95     my ($class, $value) = @_;
  96     return bless { fetch => 0, store => 0, value => $value }, $class;
  97 }
  98
  99 sub FETCH {
 100     my ($self) = @_;
 101     $self->{fetch}++;
 102     return $self->{value};
 103 }
 104
 105 sub STORE {
 106     my ($self, $value) = @_;
 107     $self->{store}++;
 108     $self->{value} = $value;
 109 }
 110
 111 package foo;
 112
 113 sub x { 'foobar' }
 114
 115 package bar;
 116
 117 sub x { 'hacker' }
 118