1#!./perl -w 2 3BEGIN { 4 $| = 1; 5 chdir 't' if -d 't'; 6 @INC = '../lib'; 7} 8 9print "1..20\n"; 10 11my $t = 1; 12tie my $c => 'Tie::Monitor'; 13 14sub 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 29sub ok_undef { ok(!defined($_[0]), shift, "undef", @_) } 30sub ok_numeric { ok($_[0] == $_[1], @_) } 31sub ok_string { ok($_[0] eq $_[1], @_) } 32 33my($r, $s); 34# the thing itself 35ok_numeric($r = $c + 0, 0, 1, 0); 36ok_string($r = "$c", '0', 1, 0); 37 38# concat 39ok_string($c . 'x', '0x', 1, 0); 40ok_string('x' . $c, 'x0', 1, 0); 41$s = $c . $c; 42ok_string($s, '00', 2, 0); 43$r = 'x'; 44$s = $c = $r . 'y'; 45ok_string($s, 'xy', 1, 1); 46$s = $c = $c . 'x'; 47ok_string($s, '0x', 2, 1); 48$s = $c = 'x' . $c; 49ok_string($s, 'x0', 2, 1); 50$s = $c = $c . $c; 51ok_string($s, '00', 3, 1); 52 53# multiple magic in core functions 54$s = chop($c); 55ok_string($s, '0', 1, 1); 56 57# adapted from Tie::Counter by Abigail 58package Tie::Monitor; 59 60sub TIESCALAR { 61 my($class, $value) = @_; 62 bless { 63 read => 0, 64 write => 0, 65 values => [ 0 ], 66 }; 67} 68 69sub FETCH { 70 my $self = shift; 71 ++$self->{read}; 72 $self->{values}[$#{ $self->{values} }]; 73} 74 75sub STORE { 76 my($self, $value) = @_; 77 ++$self->{write}; 78 push @{ $self->{values} }, $value; 79} 80 81sub 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} 88