1 package ME8100; |
1 package ME8100; |
2 # (c) 2002 Heiko Schlittermann |
2 # (c) 2002 Heiko Schlittermann |
3 |
3 # For POD documentation see the end of this file. |
4 =head1 NAME |
|
5 |
|
6 ME8100 - a perl interface to the me8100 driver (Meilhaus Digital I/O) |
|
7 |
|
8 =head1 SYNOPSIS |
|
9 |
|
10 use ME8100; |
|
11 $me8100 = new ME8100 qw(/dev/me8100_0a /dev/me8100_0b); |
|
12 @bits = $me8100->read(); |
|
13 @bits = $me8100->status(); |
|
14 |
|
15 =head1 DESCRIPTION |
|
16 |
|
17 This module is an interface to the me8100 driver talking with the Meilhaus |
|
18 D I/O board ME8100. |
|
19 |
|
20 =cut |
|
21 |
4 |
22 use strict; |
5 use strict; |
23 use Fcntl; |
6 use Fcntl; |
24 use IO::File; |
7 use IO::File; |
25 use IO::Select; |
8 use IO::Select; |
26 use Carp; |
9 use Carp; |
27 |
10 |
28 my %Objects = (); |
11 my %Objects = (); |
29 |
|
30 sub sigiohandler($); |
|
31 |
|
32 if (defined $SIG{IO}) { |
|
33 die "SIG IO is already defined. Since we won't disturb your application\n" |
|
34 . "we decided to refuse loading this module. Sorry\n"; |
|
35 } |
|
36 |
|
37 my $gotSignal = 0; |
12 my $gotSignal = 0; |
38 $SIG{IO} = \&sigiohandler; |
13 my $opt_async = 0; |
39 |
14 |
40 =over 4 |
15 sub iohandler($); |
41 |
16 sub import { $opt_async = grep { /^:async/ } @_; } |
42 =item new(I<device, ...>); |
17 |
43 |
18 # Install the signal handler only if we have passed the ':async' tag |
44 The C<new()> function creates a new ME8100 object connected to the |
19 # to the module... |
45 passed devices. |
20 INIT { $SIG{IO} = \&iohandler if $opt_async; } |
46 |
|
47 =cut |
|
48 |
21 |
49 # Create a new object. Open all the named devices (read only) |
22 # Create a new object. Open all the named devices (read only) |
50 # and read the current values (as the driver guarantees the |
23 # and read the current values (as the driver guarantees the |
51 # very first read to succeed). |
24 # very first read to succeed). |
52 # The order depends on the order the device names are passed |
25 # The order depends on the order the device names are passed |
64 foreach my $device (@_) { |
37 foreach my $device (@_) { |
65 my ($flags, $val); |
38 my ($flags, $val); |
66 my $fd = new IO::File($device, "r") |
39 my $fd = new IO::File($device, "r") |
67 or croak("open($device): $!\n"); |
40 or croak("open($device): $!\n"); |
68 |
41 |
69 fcntl($fd, F_SETOWN, $$) or croak "Can't set owner: $!\n"; |
42 if ($opt_async) { |
70 $flags = fcntl($fd, F_GETFL, 0) or croak "Can't get flags: $!\n"; |
43 fcntl($fd, F_SETOWN, $$) or croak "Can't set owner: $!\n"; |
71 fcntl($fd, F_SETFL, $flags | O_ASYNC) or croak "Can't set flags: $!\n"; |
44 $flags = fcntl($fd, F_GETFL, 0) or croak "Can't get flags: $!\n"; |
|
45 fcntl($fd, F_SETFL, $flags | O_ASYNC) or croak "Can't set flags: $!\n"; |
|
46 } |
72 |
47 |
73 $Objects{$fd} = { object => $self, fd => $fd }; |
48 $Objects{$fd} = { object => $self, fd => $fd }; |
74 $idx{$fd} = $idx; |
49 $idx{$fd} = $idx; |
75 vec($inputBits, $idx, 16) = 0x0; |
50 vec($inputBits, $idx, 16) = 0x0; |
76 push @fds, $fd; |
51 push @fds, $fd; |
80 |
55 |
81 $self->{idx} = {%idx}; # fd -> index in input word array |
56 $self->{idx} = {%idx}; # fd -> index in input word array |
82 $self->{fds} = [@fds]; # list of fds |
57 $self->{fds} = [@fds]; # list of fds |
83 $self->{select} = new IO::Select(@fds); |
58 $self->{select} = new IO::Select(@fds); |
84 |
59 |
|
60 $self->{bits} = $idx * 16; |
85 $self->{inputBits} = $inputBits; |
61 $self->{inputBits} = $inputBits; |
86 $self->{oldBits} = ""; |
62 $self->{oldBits} = ""; |
87 $self->{changedBits} = ""; |
63 $self->{changedBits} = ""; |
88 |
64 |
89 $self->{changed} = undef; |
65 $self->{changed} = [split //, "0" x $self->{bits} ]; |
90 |
|
91 return $self; |
66 return $self; |
92 } |
67 } |
93 |
|
94 =item read([I<timeout>]) |
|
95 |
|
96 Read the input from the devices. This call is guaranteed to succeede |
|
97 on the first run, but every following call will block until the status |
|
98 of the input changed. (This behaviour is due to the driver.) |
|
99 |
|
100 A timeout may be passed. |
|
101 |
|
102 On success an array of the input bits is returned, otherwise undef. |
|
103 |
|
104 =cut |
|
105 |
68 |
106 sub read { |
69 sub read { |
107 # This functions should read a set of values from the board. But: a |
70 # This functions should read a set of values from the board. But: a |
108 # race condition might occur: while we're waiting for the select() |
71 # race condition might occur: while we're waiting for the select() |
109 # to complete, the SIGIO might be catched. Both, SIGIO as well as |
72 # to complete, the SIGIO might be catched. Both, SIGIO as well as |
111 # read... But only one of them will be successful! |
74 # read... But only one of them will be successful! |
112 |
75 |
113 my ($self, $timeout) = @_; |
76 my ($self, $timeout) = @_; |
114 |
77 |
115 { |
78 { |
116 local $SIG{IO} = sub { $gotSignal = $_[0] }; |
79 local $SIG{IO} = sub { $gotSignal = $_[0] } if $opt_async; |
117 my @ready = $self->{select}->can_read($timeout); |
80 my @ready = $self->{select}->can_read($timeout); |
118 |
81 |
119 if (!@ready) { |
82 if (!@ready) { |
120 warn "select() returned nothing: $!\n"; |
83 warn "select() returned nothing: $!\n"; |
121 return undef; |
84 return undef; |
122 } |
85 } |
123 |
86 |
124 $self->_read(@ready); |
87 $self->_read(@ready); |
125 } |
88 } |
126 |
89 |
127 $gotSignal and sigiohandler($gotSignal); |
90 $gotSignal and iohandler($gotSignal); |
128 $self->{oldBits} = $self->{inputBits}; |
91 $self->{changedBits} = ""; |
|
92 $self->{changed} = [ split //, "0" x $self->{bits} ]; |
129 return split //, unpack("b*", $self->{inputBits}); |
93 return split //, unpack("b*", $self->{inputBits}); |
130 } |
94 } |
131 |
95 |
132 sub status { |
96 sub status { |
133 my $self = shift; |
97 my $self = shift; |
134 return split //, unpack("b*", $self->{inputBits}); |
98 return split //, unpack("b*", $self->{inputBits}); |
135 } |
99 } |
136 |
|
137 |
100 |
138 # Read *really* from the board and store the result at the proper |
101 # Read *really* from the board and store the result at the proper |
139 # element of our @inputs array. |
102 # element of our @inputs array. |
140 sub _read { |
103 sub _read { |
141 my ($self, @fds) = @_; |
104 my ($self, @fds) = @_; |
147 vec($self->{inputBits}, $idx, 16) = unpack("n2", $val); |
110 vec($self->{inputBits}, $idx, 16) = unpack("n2", $val); |
148 } |
111 } |
149 |
112 |
150 # Now get the difference between the old bits and the current values... |
113 # Now get the difference between the old bits and the current values... |
151 # and then add these values to the array containing the change counters |
114 # and then add these values to the array containing the change counters |
|
115 |
152 my $changedBits = $self->{inputBits} ^ $self->{oldBits}; |
116 my $changedBits = $self->{inputBits} ^ $self->{oldBits}; |
|
117 |
153 my @changed = split //, unpack("b*", $changedBits); |
118 my @changed = split //, unpack("b*", $changedBits); |
154 |
119 #print STDERR "o: ", unpack("b*", $self->{oldBits}), "\n"; |
155 $self->{changedBits} |= $changedBits; |
120 #print STDERR "n: ", unpack("b*", $self->{inputBits}), "\n"; |
|
121 #print STDERR "=: ", @changed, "\n\n"; |
|
122 |
156 for (my $i = 0; $i < $#changed; ++$i) { |
123 for (my $i = 0; $i < $#changed; ++$i) { |
157 $self->{changed}->[$i] += $changed[$i]; |
124 $self->{changed}->[$i] += $changed[$i]; |
158 } |
125 } |
159 |
126 |
160 } |
127 $self->{changedBits} |= $changedBits; |
161 |
128 $self->{oldBits} = $self->{inputBits}; |
162 # If an interrupt occurs, we've to search for the file descriptor(s) |
129 } |
163 # that caused the interrupt. This is done by a lookup in the module global |
130 |
164 # %Objects hash. ("fd" -> { fd => XXX, object => XXXX }) |
131 sub iohandler($) { |
165 sub sigiohandler($) { |
132 # If an interrupt occurs, we've to search for the file descriptor(s) |
|
133 # that caused the interrupt. This is done by a lookup in the module global |
|
134 # %Objects hash. ("fd" -> { fd => XXX, object => XXXX }) |
|
135 |
166 my $signal = shift; |
136 my $signal = shift; |
167 |
137 |
168 # I do some magic(?) here, since the key isn't usable a a refence |
138 # I do some magic(?) here, since the key isn't usable a a refence |
169 # anymore, we stored the reference itself behind the key, as well |
139 # anymore, we stored the reference itself behind the key, as well |
170 # as the object reference... |
140 # as the object reference... |
198 { |
169 { |
199 my $self = shift; |
170 my $self = shift; |
200 delete @Objects{ @{$self->{fds}} }; |
171 delete @Objects{ @{$self->{fds}} }; |
201 } |
172 } |
202 |
173 |
|
174 |
|
175 #-- Documenation follows |
|
176 |
|
177 =head1 NAME |
|
178 |
|
179 ME8100 - a perl interface to the me8100 driver (Meilhaus Digital I/O) |
|
180 |
|
181 =head1 SYNOPSIS |
|
182 |
|
183 use ME8100; |
|
184 or |
|
185 use ME8100 qw/:async/; |
|
186 |
|
187 $me8100 = new ME8100 qw(/dev/me8100_0a /dev/me8100_0b); |
|
188 @bits = $me8100->read(); |
|
189 @bits = $me8100->status(); |
|
190 |
|
191 =head1 DESCRIPTION |
|
192 |
|
193 This module is an interface to the me8100 driver talking with the Meilhaus |
|
194 D I/O board ME8100. |
|
195 |
|
196 =over 4 |
|
197 |
|
198 =item new(I<device>,...) |
|
199 |
|
200 Creates a new ME8100 object connected to all the listed devices. |
|
201 |
|
202 =item read([I<timeout>]) |
|
203 |
|
204 Read the input from the devices. This call is guaranteed to succeede |
|
205 on the first run, but every following call will block until the status |
|
206 of the input changed. (This behaviour is due to the driver.) |
|
207 |
|
208 A timeout may be passed. |
|
209 |
|
210 Every read() resets the register for obtaining the changed bits. |
|
211 |
|
212 On success an array of the input bits is returned, otherwise undef. |
|
213 |
|
214 =item status() |
|
215 |
|
216 Returns an array with the current status of all input bits. |
|
217 Never blocks. |
|
218 |
|
219 =item changed() |
|
220 |
|
221 Returns an array containing the number of detected changes per input |
|
222 bit. |
|
223 |
|
224 =item iohandler(I<signal>) |
|
225 |
|
226 For internal use only. |
|
227 |
|
228 =item _read() |
|
229 |
|
230 For internal use only. |
|
231 |
|
232 =item DESTROY() |
|
233 |
|
234 For internal use only. |
|
235 |
203 =head1 AUTHOR |
236 =head1 AUTHOR |
204 |
237 |
205 Heiko Schlittermann <hs@schlittermann.de> |
238 Heiko Schlittermann <hs@schlittermann.de> |
206 |
239 |
207 =head1 COPYRIGHT |
240 =head1 COPYRIGHT |