# HG changeset patch # User heiko # Date 1012253035 -3600 # Node ID 33280ad0f4b2a78b8bcc129b50c787ae80b8d0ec # Parent 4e4d4b59a0af687e271973327cf37b94f4bd66de hm - so leidlich diff -r 4e4d4b59a0af -r 33280ad0f4b2 me8100_test_perl/ME8100.pm --- a/me8100_test_perl/ME8100.pm Mon Jan 28 17:18:06 2002 +0100 +++ b/me8100_test_perl/ME8100.pm Mon Jan 28 22:23:55 2002 +0100 @@ -1,23 +1,6 @@ package ME8100; # (c) 2002 Heiko Schlittermann - -=head1 NAME - - ME8100 - a perl interface to the me8100 driver (Meilhaus Digital I/O) - -=head1 SYNOPSIS - - use ME8100; - $me8100 = new ME8100 qw(/dev/me8100_0a /dev/me8100_0b); - @bits = $me8100->read(); - @bits = $me8100->status(); - -=head1 DESCRIPTION - -This module is an interface to the me8100 driver talking with the Meilhaus -D I/O board ME8100. - -=cut +# For POD documentation see the end of this file. use strict; use Fcntl; @@ -26,25 +9,15 @@ use Carp; my %Objects = (); - -sub sigiohandler($); - -if (defined $SIG{IO}) { - die "SIG IO is already defined. Since we won't disturb your application\n" - . "we decided to refuse loading this module. Sorry\n"; -} +my $gotSignal = 0; +my $opt_async = 0; -my $gotSignal = 0; -$SIG{IO} = \&sigiohandler; - -=over 4 +sub iohandler($); +sub import { $opt_async = grep { /^:async/ } @_; } -=item new(I); - -The C function creates a new ME8100 object connected to the -passed devices. - -=cut +# Install the signal handler only if we have passed the ':async' tag +# to the module... +INIT { $SIG{IO} = \&iohandler if $opt_async; } # Create a new object. Open all the named devices (read only) # and read the current values (as the driver guarantees the @@ -66,9 +39,11 @@ my $fd = new IO::File($device, "r") or croak("open($device): $!\n"); - fcntl($fd, F_SETOWN, $$) or croak "Can't set owner: $!\n"; - $flags = fcntl($fd, F_GETFL, 0) or croak "Can't get flags: $!\n"; - fcntl($fd, F_SETFL, $flags | O_ASYNC) or croak "Can't set flags: $!\n"; + if ($opt_async) { + fcntl($fd, F_SETOWN, $$) or croak "Can't set owner: $!\n"; + $flags = fcntl($fd, F_GETFL, 0) or croak "Can't get flags: $!\n"; + fcntl($fd, F_SETFL, $flags | O_ASYNC) or croak "Can't set flags: $!\n"; + } $Objects{$fd} = { object => $self, fd => $fd }; $idx{$fd} = $idx; @@ -82,27 +57,15 @@ $self->{fds} = [@fds]; # list of fds $self->{select} = new IO::Select(@fds); + $self->{bits} = $idx * 16; $self->{inputBits} = $inputBits; $self->{oldBits} = ""; $self->{changedBits} = ""; - $self->{changed} = undef; - + $self->{changed} = [split //, "0" x $self->{bits} ]; return $self; } -=item read([I]) - -Read the input from the devices. This call is guaranteed to succeede -on the first run, but every following call will block until the status -of the input changed. (This behaviour is due to the driver.) - -A timeout may be passed. - -On success an array of the input bits is returned, otherwise undef. - -=cut - sub read { # This functions should read a set of values from the board. But: a # race condition might occur: while we're waiting for the select() @@ -113,7 +76,7 @@ my ($self, $timeout) = @_; { - local $SIG{IO} = sub { $gotSignal = $_[0] }; + local $SIG{IO} = sub { $gotSignal = $_[0] } if $opt_async; my @ready = $self->{select}->can_read($timeout); if (!@ready) { @@ -124,8 +87,9 @@ $self->_read(@ready); } - $gotSignal and sigiohandler($gotSignal); - $self->{oldBits} = $self->{inputBits}; + $gotSignal and iohandler($gotSignal); + $self->{changedBits} = ""; + $self->{changed} = [ split //, "0" x $self->{bits} ]; return split //, unpack("b*", $self->{inputBits}); } @@ -134,7 +98,6 @@ return split //, unpack("b*", $self->{inputBits}); } - # Read *really* from the board and store the result at the proper # element of our @inputs array. sub _read { @@ -149,20 +112,27 @@ # Now get the difference between the old bits and the current values... # and then add these values to the array containing the change counters + my $changedBits = $self->{inputBits} ^ $self->{oldBits}; + my @changed = split //, unpack("b*", $changedBits); + #print STDERR "o: ", unpack("b*", $self->{oldBits}), "\n"; + #print STDERR "n: ", unpack("b*", $self->{inputBits}), "\n"; + #print STDERR "=: ", @changed, "\n\n"; - $self->{changedBits} |= $changedBits; for (my $i = 0; $i < $#changed; ++$i) { $self->{changed}->[$i] += $changed[$i]; } + $self->{changedBits} |= $changedBits; + $self->{oldBits} = $self->{inputBits}; } -# If an interrupt occurs, we've to search for the file descriptor(s) -# that caused the interrupt. This is done by a lookup in the module global -# %Objects hash. ("fd" -> { fd => XXX, object => XXXX }) -sub sigiohandler($) { +sub iohandler($) { + # If an interrupt occurs, we've to search for the file descriptor(s) + # that caused the interrupt. This is done by a lookup in the module global + # %Objects hash. ("fd" -> { fd => XXX, object => XXXX }) + my $signal = shift; # I do some magic(?) here, since the key isn't usable a a refence @@ -183,11 +153,12 @@ $gotSignal = 0; }; + sub changed { my $self = shift; - return @{$self->{changed}} if wantarray; + my $r = 0; - my $r; + wantarray and return @{$self->{changed}}; foreach (@{$self->{changed}}) { $r += $_; } @@ -200,6 +171,68 @@ delete @Objects{ @{$self->{fds}} }; } + +#-- Documenation follows + +=head1 NAME + + ME8100 - a perl interface to the me8100 driver (Meilhaus Digital I/O) + +=head1 SYNOPSIS + + use ME8100; +or + use ME8100 qw/:async/; + + $me8100 = new ME8100 qw(/dev/me8100_0a /dev/me8100_0b); + @bits = $me8100->read(); + @bits = $me8100->status(); + +=head1 DESCRIPTION + +This module is an interface to the me8100 driver talking with the Meilhaus +D I/O board ME8100. + +=over 4 + +=item new(I,...) + +Creates a new ME8100 object connected to all the listed devices. + +=item read([I]) + +Read the input from the devices. This call is guaranteed to succeede +on the first run, but every following call will block until the status +of the input changed. (This behaviour is due to the driver.) + +A timeout may be passed. + +Every read() resets the register for obtaining the changed bits. + +On success an array of the input bits is returned, otherwise undef. + +=item status() + +Returns an array with the current status of all input bits. +Never blocks. + +=item changed() + +Returns an array containing the number of detected changes per input +bit. + +=item iohandler(I) + +For internal use only. + +=item _read() + +For internal use only. + +=item DESTROY() + +For internal use only. + =head1 AUTHOR Heiko Schlittermann diff -r 4e4d4b59a0af -r 33280ad0f4b2 me8100_test_perl/test.pl --- a/me8100_test_perl/test.pl Mon Jan 28 17:18:06 2002 +0100 +++ b/me8100_test_perl/test.pl Mon Jan 28 22:23:55 2002 +0100 @@ -1,25 +1,48 @@ #! /usr/bin/perl -w -use ME8100; +use ME8100 qw/:async/; my @DEVICES = qw(/dev/me8100_0a /dev/me8100_0b); my @INPUTS = qw(Tür1 Tür2 Feuerlöscher); +sub _sleep($); + MAIN: { my $me8100 = new ME8100(@DEVICES); - my %inputs; + my (%inputs, %changed); # first read will be always go through @inputs{@INPUTS} = $me8100->read(); + print "Read:\n"; print map { sprintf "%20s: %d\n", $_, $inputs{$_} } @INPUTS; + _sleep(10); + @inputs{@INPUTS} = $me8100->status(); - print "Status:\n"; + print "Status2:\n"; print map { sprintf "%20s: %d\n", $_, $inputs{$_} } @INPUTS; + @inputs{@INPUTS} = $me8100->changed(); + print "Changed:\n"; + print map { sprintf "%20s: %d\n", $_, $inputs{$_} } @INPUTS; + + # and now block 'til the next change... + @inputs{@INPUTS} = $me8100->read(); + @changed{@INPUTS} = $me8100->changed(); + print "Finally:\n"; + print map { sprintf "%20s: %d (%d)\n", $_, $inputs{$_}, $changed{$_} } @INPUTS; } +# Sleep replacement, since the standard sleep +# gets awoken on every signal +sub _sleep($) { + my $timeout = shift; + while ($timeout > 0) { + $timeout -= sleep($timeout); + } +} + # vim:sts=4 sw=4 aw ai sm: