8 use IO::Select; |
21 use IO::Select; |
9 use Carp; |
22 use Carp; |
10 |
23 |
11 my %Objects = (); |
24 my %Objects = (); |
12 |
25 |
|
26 sub sigiohandler($); |
|
27 |
13 if (defined $SIG{IO}) { |
28 if (defined $SIG{IO}) { |
14 die "SIG IO is already defined. Since we won't disturb your application\n" |
29 die "SIG IO is already defined. Since we won't disturb your application\n" |
15 . "we decied to refuse loading this module. Sorry\n"; |
30 . "we decided to refuse loading this module. Sorry\n"; |
16 } |
31 } |
17 |
32 |
18 # If an interrupt occurs, we've to search for the file descriptor(s) |
33 my $gotSignal = 0; |
19 # that caused the interrupt. This is done by a lookup in the module global |
34 $SIG{IO} = \&sigiohandler; |
20 # %Objects hash. ("fd" -> { fd => XXX, object => XXXX }) |
|
21 |
|
22 $SIG{IO} = sub { |
|
23 my $val; |
|
24 warn "Got signal $_[0]\n"; |
|
25 |
|
26 # I do some magic(?) here, since the key isn't usable a a refence |
|
27 # anymore, we stored the reference itself behind the key, as well |
|
28 # as the object reference... |
|
29 |
|
30 |
|
31 # Now a race condition might occur. It's possible that an other |
|
32 # select() runs too (called in the read() method). |
|
33 my $select = new IO::Select(map { $Objects{$_}->{fd} } keys %Objects); |
|
34 my @ready = $select->can_read(0); |
|
35 |
|
36 print "May read on fds: @ready\n"; |
|
37 |
|
38 foreach (@ready) { |
|
39 my $object = $Objects{$_}->{object}; |
|
40 my $fd = $Objects{$_}->{fd}; |
|
41 $object->_read($fd); |
|
42 } |
|
43 |
|
44 warn "done signal\n"; |
|
45 |
|
46 }; |
|
47 |
35 |
48 # Create a new object. Open all the named devices (read only) |
36 # Create a new object. Open all the named devices (read only) |
49 # and read the current values (as the driver guarantees the |
37 # and read the current values (as the driver guarantees the |
50 # very first read to succeed). |
38 # very first read to succeed). |
51 # The order depends on the order the device names are passed |
39 # The order depends on the order the device names are passed |
57 bless $self, $class; |
45 bless $self, $class; |
58 |
46 |
59 my (@fds, @inputs); |
47 my (@fds, @inputs); |
60 my %idx = (); |
48 my %idx = (); |
61 my $idx = 0; |
49 my $idx = 0; |
|
50 my $inputBits = ""; |
|
51 |
62 foreach my $device (@_) { |
52 foreach my $device (@_) { |
63 my ($flags, $val); |
53 my ($flags, $val); |
64 my $fd = new IO::File($device, "r") |
54 my $fd = new IO::File($device, "r") |
65 or croak("open($device): $!\n"); |
55 or croak("open($device): $!\n"); |
66 |
56 |
67 fcntl($fd, F_SETOWN, $$) or croak "Can't set owner: $!\n"; |
57 fcntl($fd, F_SETOWN, $$) or croak "Can't set owner: $!\n"; |
68 $flags = fcntl($fd, F_GETFL, 0) or croak "Can't get flags: $!\n"; |
58 $flags = fcntl($fd, F_GETFL, 0) or croak "Can't get flags: $!\n"; |
69 fcntl($fd, F_SETFL, $flags | O_ASYNC) or croak "Can't set flags: $!\n"; |
59 fcntl($fd, F_SETFL, $flags | O_ASYNC) or croak "Can't set flags: $!\n"; |
70 |
60 |
71 $fd->sysread($val, 2); |
|
72 |
|
73 $Objects{$fd} = { object => $self, fd => $fd }; |
61 $Objects{$fd} = { object => $self, fd => $fd }; |
74 $idx{$fd} = $idx; |
62 $idx{$fd} = $idx; |
75 push @inputs, $val; |
63 vec($inputBits, $idx, 16) = 0x0; |
76 push @fds, $fd; |
64 push @fds, $fd; |
77 |
65 |
78 ++$idx; |
66 ++$idx; |
79 } |
67 } |
80 |
68 |
81 $self->{idx} = {%idx}; # fd -> index in input word array |
69 $self->{idx} = {%idx}; # fd -> index in input word array |
82 $self->{fds} = [@fds]; # list of fds |
70 $self->{fds} = [@fds]; # list of fds |
83 $self->{inputs} = [@inputs]; # array of input words |
|
84 $self->{select} = new IO::Select(@fds); |
71 $self->{select} = new IO::Select(@fds); |
|
72 |
|
73 $self->{inputBits} = $inputBits; |
|
74 $self->{oldBits} = ""; |
|
75 $self->{changedBits} = ""; |
|
76 |
|
77 $self->{changed} = undef; |
85 |
78 |
86 return $self; |
79 return $self; |
87 } |
80 } |
88 |
81 |
|
82 # Read *really* from the board and store the result at the proper |
|
83 # element of our @inputs array. |
89 sub _read { |
84 sub _read { |
90 my ($self, $fd) = @_; |
85 my ($self, @fds) = @_; |
91 my $val; |
86 my $val; # bit0-7 bit8-15 |
92 |
87 |
93 my $idx = $self->{idx}->{$fd}; |
88 foreach my $fd (@fds) { |
94 $self->{fds}->[$idx]->sysread($val, 2) or carp("sysread(): $!\n"); |
89 my $idx = $self->{idx}->{$fd}; |
95 $self->{inputs}->[$idx] = $val; |
90 $self->{fds}->[$idx]->sysread($val, 2) or carp("sysread(): $!\n"); |
|
91 vec($self->{inputBits}, $idx, 16) = unpack("n2", $val); |
|
92 } |
|
93 |
|
94 # Now get the difference between the old bits and the current values... |
|
95 # and then add these values to the array containing the change counters |
|
96 my $changedBits = $self->{inputBits} ^ $self->{oldBits}; |
|
97 my @changed = split //, unpack("b*", $changedBits); |
|
98 |
|
99 $self->{changedBits} |= $changedBits; |
|
100 for (my $i = 0; $i < $#changed; ++$i) { |
|
101 $self->{changed}->[$i] += $changed[$i]; |
|
102 } |
|
103 |
96 } |
104 } |
97 |
105 |
|
106 # This functions should read a set of values from the board. But: a race |
|
107 # condition might occur: while we're waiting for the select() to complete, |
|
108 # the SIGIO might be catched. Both, SIGIO as well as the suddenly succeeding |
|
109 # select() indicate a possible successful read... But only one of them will |
|
110 # be successful! |
98 sub read { |
111 sub read { |
99 my ($self, $timeout) = @_; |
112 my ($self, $timeout) = @_; |
100 |
113 |
101 local $SIG{IO} = sub { warn "*** SIG $_[0] diverted\n" }; |
114 { |
102 my @ready = $self->{select}->can_read($timeout); |
115 local $SIG{IO} = sub { $gotSignal = $_[0] }; |
|
116 my @ready = $self->{select}->can_read($timeout); |
103 |
117 |
104 if (!@ready) { |
118 if (!@ready) { |
105 warn "select() returned nothing: $!\n"; |
119 warn "select() returned nothing: $!\n"; |
106 return undef; |
120 return undef; |
|
121 } |
|
122 |
|
123 $self->_read(@ready); |
107 } |
124 } |
108 |
125 |
|
126 $gotSignal and sigiohandler($gotSignal); |
|
127 $self->{oldBits} = $self->{inputBits}; |
|
128 return split //, unpack("b*", $self->{inputBits}); |
|
129 } |
|
130 |
|
131 sub status { |
|
132 my $self = shift; |
|
133 return split //, unpack("b*", $self->{inputBits}); |
|
134 } |
|
135 |
|
136 # If an interrupt occurs, we've to search for the file descriptor(s) |
|
137 # that caused the interrupt. This is done by a lookup in the module global |
|
138 # %Objects hash. ("fd" -> { fd => XXX, object => XXXX }) |
|
139 sub sigiohandler($) { |
|
140 my $signal = shift; |
|
141 |
|
142 # I do some magic(?) here, since the key isn't usable a a refence |
|
143 # anymore, we stored the reference itself behind the key, as well |
|
144 # as the object reference... |
|
145 |
|
146 |
|
147 # Now a race condition might occur. It's possible that an other |
|
148 # select() runs too (called in the read() method). |
|
149 my $select = new IO::Select(map { $Objects{$_}->{fd} } keys %Objects); |
|
150 my @ready = $select->can_read(0); |
|
151 |
109 foreach (@ready) { |
152 foreach (@ready) { |
110 $self->_read($_); |
153 my $object = $Objects{$_}->{object}; |
|
154 my $fd = $Objects{$_}->{fd}; |
|
155 $object->_read($fd); |
111 } |
156 } |
|
157 $gotSignal = 0; |
|
158 }; |
112 |
159 |
113 return split //, unpack("b*", join("", @{$self->{inputs}})); |
160 sub changed { |
|
161 my $self = shift; |
|
162 return @{$self->{changed}} if wantarray; |
|
163 |
|
164 my $r; |
|
165 foreach (@{$self->{changed}}) { |
|
166 $r += $_; |
|
167 } |
|
168 return $r; |
114 } |
169 } |
115 |
170 |
116 sub DESTROY |
171 sub DESTROY |
117 { |
172 { |
118 my $self = shift; |
173 my $self = shift; |