t/op/gmagic.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     $| = 1;
   5     chdir 't' if -d 't';
   6     @INC = '../lib';
   7 }
   8
   9 print "1..20\n";
  10
  11 my $t = 1;
  12 tie my $c => 'Tie::Monitor';
  13
  14 sub ok {
  15     my($ok, $got, $exp, $rexp, $wexp) = @_;
  16     my($rgot, $wgot) = (tied $c)->init(0);
  17     print $ok ? "ok $t\n" : "# expected $exp, got $got\nnot ok $t\n";
  18     ++$t;
  19     if ($rexp == $rgot && $wexp == $wgot) {
  20         print "ok $t\n";
  21     } else {
  22         print "# read $rgot expecting $rexp\n" if $rgot != $rexp;
  23         print "# wrote $wgot expecting $wexp\n" if $wgot != $wexp;
  24         print "not ok $t\n";
  25     }
  26     ++$t;
  27 }
  28
  29 sub ok_undef { ok(!defined($_[0]), shift, "undef", @_) }
  30 sub ok_numeric { ok($_[0] == $_[1], @_) }
  31 sub ok_string { ok($_[0] eq $_[1], @_) }
  32
  33 my($r, $s);
  34 # the thing itself
  35 ok_numeric($r = $c + 0, 0, 1, 0);
  36 ok_string($r = "$c", '0', 1, 0);
  37
  38 # concat
  39 ok_string($c . 'x', '0x', 1, 0);
  40 ok_string('x' . $c, 'x0', 1, 0);
  41 $s = $c . $c;
  42 ok_string($s, '00', 2, 0);
  43 $r = 'x';
  44 $s = $c = $r . 'y';
  45 ok_string($s, 'xy', 1, 1);
  46 $s = $c = $c . 'x';
  47 ok_string($s, '0x', 2, 1);
  48 $s = $c = 'x' . $c;
  49 ok_string($s, 'x0', 2, 1);
  50 $s = $c = $c . $c;
  51 ok_string($s, '00', 3, 1);
  52
  53 # multiple magic in core functions
  54 $s = chop($c);
  55 ok_string($s, '0', 1, 1);
  56
  57 # adapted from Tie::Counter by Abigail
  58 package Tie::Monitor;
  59
  60 sub TIESCALAR {
  61     my($class, $value) = @_;
  62     bless {
  63         read => 0,
  64         write => 0,
  65         values => [ 0 ],
  66     };
  67 }
  68
  69 sub FETCH {
  70     my $self = shift;
  71     ++$self->{read};
  72     $self->{values}[$#{ $self->{values} }];
  73 }
  74
  75 sub STORE {
  76     my($self, $value) = @_;
  77     ++$self->{write};
  78     push @{ $self->{values} }, $value;
  79 }
  80
  81 sub init {
  82     my $self = shift;
  83     my @results = ($self->{read}, $self->{write});
  84     $self->{read} = $self->{write} = 0;
  85     $self->{values} = [ 0 ];
  86     @results;
  87 }