Commit | Line | Data |
8d6d96c1 |
1 | #!./perl -w |
2 | |
3 | BEGIN { |
4 | $| = 1; |
5 | chdir 't' if -d 't'; |
6 | @INC = '../lib'; |
7 | } |
8 | |
1e968d83 |
9 | print "1..20\n"; |
8d6d96c1 |
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 | |
1e968d83 |
53 | # multiple magic in core functions |
54 | $s = chop($c); |
55 | ok_string($s, '0', 1, 1); |
56 | |
8d6d96c1 |
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 | } |