8 use IO::Select; |
8 use IO::Select; |
9 use Carp; |
9 use Carp; |
10 |
10 |
11 my %Objects = (); |
11 my %Objects = (); |
12 |
12 |
|
13 if (defined $SIG{IO}) { |
|
14 die "SIG IO is already defined. Since we won't disturb your application\n" |
|
15 . "we decied to refuse loading this module. Sorry\n"; |
|
16 } |
|
17 |
13 # If an interrupt occurs, we've to search for the file descriptor(s) |
18 # If an interrupt occurs, we've to search for the file descriptor(s) |
14 # that caused the interrupt. The file descriptor(s) should in turn |
19 # that caused the interrupt. This is done by a lookup in the module global |
15 # point us the the proper me8100 object ... |
20 # %Objects hash. ("fd" -> { fd => XXX, object => XXXX }) |
16 # |
21 |
17 $SIG{IO} = sub { |
22 $SIG{IO} = sub { |
18 my $val; |
23 my $val; |
19 warn "Got signal $_[0]\n"; |
24 warn "Got signal $_[0]\n"; |
20 |
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). |
21 my $select = new IO::Select(map { $Objects{$_}->{fd} } keys %Objects); |
33 my $select = new IO::Select(map { $Objects{$_}->{fd} } keys %Objects); |
22 my @ready = $select->can_read(0); |
34 my @ready = $select->can_read(0); |
23 |
35 |
24 foreach my $fd (@ready) { |
36 print "May read on fds: @ready\n"; |
25 my $current = $Objects{$fd}; |
|
26 my $idx = $current->{idx}; |
|
27 my $object = $current->{object}; |
|
28 |
37 |
29 #$object->_read($fd); |
38 foreach (@ready) { |
30 |
39 my $object = $Objects{$_}->{object}; |
31 warn "read ", $fd->fileno(), "\n"; |
40 my $fd = $Objects{$_}->{fd}; |
32 |
41 $object->_read($fd); |
33 my $val; |
|
34 $fd->sysread($val, 2) or carp("sysread(): $!\n"); |
|
35 $object->{inputs}->[$idx] = $val; |
|
36 $object->{changed} = 1; |
|
37 } |
42 } |
38 |
43 |
39 #kill("ALRM", $$); |
|
40 warn "done signal\n"; |
44 warn "done signal\n"; |
41 |
45 |
42 }; |
46 }; |
43 |
|
44 sub _read { |
|
45 my $self = shift; |
|
46 my $fd = shift; |
|
47 warn "read from ", $fd->fileno(), "\n"; |
|
48 } |
|
49 |
|
50 |
|
51 |
47 |
52 # Create a new object. Open all the named devices (read only) |
48 # Create a new object. Open all the named devices (read only) |
53 # and read the current values (as the driver guarantees the |
49 # and read the current values (as the driver guarantees the |
54 # very first read to succeed). |
50 # very first read to succeed). |
55 # The order depends on the order the device names are passed |
51 # The order depends on the order the device names are passed |
59 my $self = {}; |
55 my $self = {}; |
60 my $class = shift; |
56 my $class = shift; |
61 bless $self, $class; |
57 bless $self, $class; |
62 |
58 |
63 my (@fds, @inputs); |
59 my (@fds, @inputs); |
|
60 my %idx = (); |
64 my $idx = 0; |
61 my $idx = 0; |
65 foreach my $device (@_) { |
62 foreach my $device (@_) { |
66 my ($flags, $val); |
63 my ($flags, $val); |
67 my $fd = new IO::File($device, "r") |
64 my $fd = new IO::File($device, "r") |
68 or croak("open($device): $!\n"); |
65 or croak("open($device): $!\n"); |
69 |
66 |
70 fcntl($fd, F_SETOWN, $$) or croak "Can't set owner: $!\n"; |
67 fcntl($fd, F_SETOWN, $$) or croak "Can't set owner: $!\n"; |
71 $flags = fcntl($fd, F_GETFL, 0) or croak "Can't get flags: $!\n"; |
68 $flags = fcntl($fd, F_GETFL, 0) or croak "Can't get flags: $!\n"; |
72 fcntl($fd, F_SETFL, $flags | O_ASYNC) or croak "Can't set flags: $!\n"; |
69 fcntl($fd, F_SETFL, $flags | O_ASYNC) or croak "Can't set flags: $!\n"; |
73 |
70 |
74 $Objects{$fd} = { fd => $fd, idx => $idx, object => $self }; |
|
75 $fd->sysread($val, 2); |
71 $fd->sysread($val, 2); |
76 |
72 |
|
73 $Objects{$fd} = { object => $self, fd => $fd }; |
|
74 $idx{$fd} = $idx; |
77 push @inputs, $val; |
75 push @inputs, $val; |
78 push @fds, $fd; |
76 push @fds, $fd; |
79 |
77 |
80 ++$idx; |
78 ++$idx; |
81 } |
79 } |
82 |
80 |
83 $self->{fds} = [@fds]; |
81 $self->{idx} = {%idx}; # fd -> index in input word array |
84 $self->{inputs} = [@inputs]; |
82 $self->{fds} = [@fds]; # list of fds |
|
83 $self->{inputs} = [@inputs]; # array of input words |
85 $self->{select} = new IO::Select(@fds); |
84 $self->{select} = new IO::Select(@fds); |
86 $self->{changed} = 1; |
|
87 |
85 |
88 return $self; |
86 return $self; |
89 } |
87 } |
90 |
88 |
|
89 sub _read { |
|
90 my ($self, $fd) = @_; |
|
91 my $val; |
|
92 |
|
93 my $idx = $self->{idx}->{$fd}; |
|
94 $self->{fds}->[$idx]->sysread($val, 2) or carp("sysread(): $!\n"); |
|
95 $self->{inputs}->[$idx] = $val; |
|
96 } |
|
97 |
91 sub read { |
98 sub read { |
92 my $self = shift; |
99 my ($self, $timeout) = @_; |
93 my $timeout = shift; |
100 |
|
101 local $SIG{IO} = sub { warn "*** SIG $_[0] diverted\n" }; |
|
102 my @ready = $self->{select}->can_read($timeout); |
|
103 |
|
104 if (!@ready) { |
|
105 warn "select() returned nothing: $!\n"; |
|
106 return undef; |
|
107 } |
|
108 |
|
109 foreach (@ready) { |
|
110 $self->_read($_); |
|
111 } |
94 |
112 |
95 return split //, unpack("b*", join("", @{$self->{inputs}})); |
113 return split //, unpack("b*", join("", @{$self->{inputs}})); |
96 } |
|
97 |
|
98 sub changed { |
|
99 my $self; |
|
100 return $self->{changed}; |
|
101 } |
114 } |
102 |
115 |
103 sub DESTROY |
116 sub DESTROY |
104 { |
117 { |
105 my $self = shift; |
118 my $self = shift; |