t/28-uvar.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Config qw/%Config/;
   7
   8 use Test::More;
   9
  10 use Variable::Magic qw/wizard cast dispell VMG_UVAR/;
  11
  12 if (VMG_UVAR) {
  13  plan tests => 2 * 9 + 7 + 12 + 1;
  14 } else {
  15  plan skip_all => 'No nice uvar magic for this perl';
  16 }
  17
  18 use lib 't/lib';
  19 use Variable::Magic::TestWatcher;
  20
  21 my $wiz = init [ qw/fetch store exists delete/ ], 'uvar';
  22
  23 my %h = (a => 1, b => 2, c => 3);
  24
  25 my $res = check { cast %h, $wiz } { }, 'cast';
  26 ok $res, 'uvar: cast succeeded';
  27
  28 my $x;
  29
  30 check { $x = $h{a} } { fetch => 1 }, 'fetch directly';
  31 is $x, 1, 'uvar: fetch directly correctly';
  32
  33 check { $x = "$h{b}" } { fetch => 1 }, 'fetch by interpolation';
  34 is $x, 2, 'uvar: fetch by interpolation correctly';
  35
  36 check { $h{c} = 4 } { store => 1 }, 'store directly';
  37
  38 check { $x = $h{c} = 5 } { store => 1 }, 'fetch and store';
  39 is $x, 5, 'uvar: fetch and store correctly';
  40
  41 check { $x = exists $h{c} } { exists => 1 }, 'exists';
  42 ok $x, 'uvar: exists correctly';
  43
  44 check { $x = delete $h{c} } { delete => 1 }, 'delete existing key';
  45 is $x, 5, 'uvar: delete existing key correctly';
  46
  47 check { $x = delete $h{z} } { delete => 1 }, 'delete non-existing key';
  48 ok !defined $x, 'uvar: delete non-existing key correctly';
  49
  50 my $wiz2 = wizard fetch => sub { 0 };
  51 my %h2 = (a => 37, b => 2, c => 3);
  52 cast %h2, $wiz2;
  53
  54 eval {
  55  local $SIG{__WARN__} = sub { die };
  56  $x = $h2{a};
  57 };
  58 is $@, '', 'uvar: fetch with incomplete magic doesn\'t croak';
  59 is $x, 37, 'uvar: fetch with incomplete magic correctly';
  60
  61 eval {
  62  local $SIG{__WARN__} = sub { die };
  63  $h2{a} = 73;
  64 };
  65 is $@, '',     'uvar: store with incomplete magic doesn\'t croak';
  66 is $h2{a}, 73, 'uvar: store with incomplete magic correctly';
  67
  68 my $wiz3 = wizard store => sub { ++$_[2]; 0 };
  69 my %h3 = (a => 3);
  70 cast %h3, $wiz3;
  71
  72 for my $i (1 .. 2) {
  73  eval { my $key = 'a'; $h3{$key} = 3 + $i };
  74  is        $@,   '',  "uvar: change key in store doesn't croak ($i)";
  75  is_deeply \%h3, { a => 3, b => 3 + $i },
  76                       "uvar: change key in store correcty ($i)";
  77 }
  78
  79 my $ro_bare_hk = $] >= 5.010 && $Config{useithreads};
  80 diag 'This perl has readonly bare hash keys' if $ro_bare_hk;
  81
  82 for my $i (1 .. 2) {
  83  eval { $h3{b} = 5 + $i };
  84  if ($ro_bare_hk) {
  85   like $@, qr/Modification\s+of\s+a\s+read-only\s+value/,
  86                                "uvar: change readonly key in store croaks ($i)";
  87   is_deeply \%h3, { a => 3, b => 5 },
  88                              "uvar: change readonly key in store correcty ($i)";
  89  } else {
  90   is $@, '',                   "uvar: change readonly key in store croaks ($i)";
  91   is_deeply \%h3, { a => 3, b => 5, c => 6, (d => 7) x ($i >= 2) },
  92                              "uvar: change readonly key in store correcty ($i)";
  93  }
  94 }
  95