ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/RCU/DevLirc/DevLirc.pm
Revision: 1.1
Committed: Sun Nov 6 17:24:32 2005 UTC (19 years, 1 month ago) by root
Branch: MAIN
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 =head1 NAME
2    
3     RCU::Lirc - RCU interface to linux-infrared-remote-control
4    
5     =head1 SYNOPSIS
6    
7     use RCU::Lirc;
8    
9     =head1 DESCRIPTION
10    
11     See L<RCU>.
12    
13     =over 4
14    
15     =cut
16    
17     package RCU::Lirc;
18    
19     use DynaLoader;
20     use Carp;
21     use POSIX ();
22     use Time::HiRes ();
23     use Errno ();
24     use Fcntl;
25    
26     use RCU;
27    
28     use base qw(RCU::Interface DynaLoader);
29    
30     BEGIN {
31     $VERSION = 0.01;
32     bootstrap RCU::Lirc $VERSION;
33     }
34    
35     =item new progname
36    
37     Create an interface to lircd using the configuration for program "progname".
38    
39     =cut
40    
41     sub new {
42     my $class = shift;
43     my $prog = shift || "perl";
44     my $self = $class->SUPER::new();
45     my $fh = local *LIRC_FH;
46    
47     $self->{fh} = $fh;
48    
49     $self->{pid} = open $fh, "-|";
50     if ($self->{pid} == 0) {
51     select STDOUT; $|=1;
52     eval {
53     $SIG{HUP} = sub { _exit };
54     lirc_init($prog) >= 0 or croak "unable to connect to lircd: $!";
55     lirc_readconfig();# == 0 or croak "unable to read lirc configuration for <$prog>: $!\n";
56     print "I\x00";
57     for(;;) {
58     my ($raw, $cooked) = _get_code;
59     print "=".Time::HiRes::time."\x01$raw\x01$cooked\x00";
60     }
61     };
62     if ($@) {
63     $@ =~ s/\x00/\x01/g;
64     print "E$@\x00";
65     }
66     #lirc_freeconfig;
67     #lirc_deinit;
68     POSIX::_exit(0);
69     } elsif (!defined $self->{pid}) {
70     die;
71     }
72    
73     $self->get; # wait for I packet
74    
75     $self;
76     }
77    
78     sub fd {
79     fileno $_[0]->{fh};
80     }
81    
82     sub _get {
83     my $self = shift;
84     my $fh = $self->{fh};
85     local $/ = "\x00";
86     $! = 0;
87     my $code = <$fh>;
88     if ("=" eq substr $code, 0, 1) {
89     split /\x01/, substr $code, 1, -1;
90     } elsif ($code =~ s/^E//) {
91     die substr $code, 0, -1;
92     } elsif ($code =~ /^I/) {
93     # NOP
94     ();
95     } elsif ($! != Errno::EAGAIN) {
96     delete $self->{fh}; # to make event stop
97     croak "lirc communication error ($!)";
98     } else {
99     ();
100     }
101     }
102    
103     sub get {
104     fcntl $_[0]->{fh}, F_SETFL, 0;
105     goto &_get;
106     }
107    
108     sub poll {
109     fcntl $_[0]->{fh}, F_SETFL, O_NONBLOCK;
110     goto &_get;
111     }
112    
113     1;
114    
115     =back
116    
117     =head1 AUTHOR
118    
119     This perl extension was written by Marc Lehmann <schmorp@schmorp.de>.
120    
121    
122    
123    
124