5 # Quancom. |
5 # Quancom. |
6 |
6 |
7 use strict; |
7 use strict; |
8 use warnings; |
8 use warnings; |
9 use Carp; |
9 use Carp; |
10 use IO::Socket::UNIX; |
10 use IO::Socket; |
11 use IO::Select; |
11 use IO::Select; |
12 |
12 |
13 my $STX = "\x02"; |
13 my $STX = "\x02"; |
14 |
14 |
15 sub new { |
15 sub new { |
16 my $class = ref $_ ? ref shift : shift; |
16 my $class = ref $_ ? ref shift : shift; |
17 |
17 |
18 my $self = bless {} => $class; |
18 my $self = bless {} => $class; |
|
19 my $addr = shift or croak "need socket address"; |
19 |
20 |
20 # if there's a filename passed, then we assume it as |
21 $self->{debug} = 0; |
21 # the UNIX socket for communication, otherwise we communicate |
22 |
22 # via STDIN/STDOUT |
23 # if there's a parameter passed we understand it as |
23 if (@_) { |
24 # a socket address for communication |
24 $self->{fifo} = shift; |
25 if ($addr eq "-") { |
25 $self->{socket} = new IO::Socket::UNIX( |
26 warn "listening on: stdio\n"; |
26 Listen => 1, |
|
27 Local => $self->{fifo} |
|
28 ) or croak "Can't create IO::Socket::UNIX: $!\n"; |
|
29 warn "listening on: $self->{fifo}\n"; |
|
30 } |
27 } |
31 else { |
28 else { |
32 warn "listening on: stdio\n"; |
29 if ($addr =~ /\//) { |
|
30 $self->{file} = $addr; |
|
31 $self->{socket} = new IO::Socket::UNIX( |
|
32 Listen => 1, |
|
33 Local => $self->{file} |
|
34 ) or croak "Can't create IO::Socket::UNIX: $!\n"; |
|
35 } |
|
36 else { |
|
37 $addr = "127.0.0.1:$1" if $addr =~ /^:?(\d+)/; |
|
38 |
|
39 $self->{socket} = new IO::Socket::INET( |
|
40 Listen => 1, |
|
41 ReuseAddr => 1, |
|
42 LocalAddr => $addr |
|
43 ) or croak "Can't create IO::Socket::INET: $!\n"; |
|
44 } |
|
45 |
|
46 warn "listening on: $addr\n"; |
33 } |
47 } |
34 |
48 |
35 # we can't use 64bit as Vector (vec()), since not all platforms support it |
49 # we can't use 64bit as Vector (vec()), since not all platforms support it |
|
50 # with this length |
|
51 |
36 @{ $self->{outputs} } = map { pack "c", $_ } (0, 0, 0, 0, 0, 0, 0, 0); |
52 @{ $self->{outputs} } = map { pack "c", $_ } (0, 0, 0, 0, 0, 0, 0, 0); |
37 $self->show; |
53 $self->show; |
38 |
54 |
39 return $self; |
55 return $self; |
40 } |
56 } |
69 |
85 |
70 # create a new connection or process incoming |
86 # create a new connection or process incoming |
71 # data |
87 # data |
72 |
88 |
73 if ($c == $self->{socket}) { |
89 if ($c == $self->{socket}) { |
74 my $n = $self->{socket}->accept; |
90 my $n = $self->{socket}->accept; |
75 $n->autoflush(1); |
91 $n->autoflush(1); |
76 $s->add($n); |
92 $s->add($n); |
77 next; |
93 next; |
78 } |
94 } |
79 |
95 |
80 local $/ = "\r"; # quancom sends CR as line terminator |
96 local $/ = "\r"; # quancom sends CR as line terminator |
81 my $l = <$c>; |
97 my $l = <$c>; |
82 $s->remove($c), next if not defined $l; |
98 $s->remove($c), next if not defined $l; |
83 chomp $l; |
99 chomp $l; |
84 $l = $self->_process($l); |
100 $l = $self->_process($l); |
85 warn "sending $l\n"; |
101 $c->print($l . "\r"); |
86 $self->{socket}->print($l . "\r"); |
|
87 warn "done\n"; |
|
88 } |
102 } |
89 } |
103 } |
90 return; |
104 return; |
91 } |
105 } |
92 |
106 |
104 |
118 |
105 # some fixups |
119 # some fixups |
106 $line =~ s/^$STX//; # cut STX, if any |
120 $line =~ s/^$STX//; # cut STX, if any |
107 $line =~ s/(..)$//; # cut checksum |
121 $line =~ s/(..)$//; # cut checksum |
108 |
122 |
109 warn "got: <STX>$line($1)\n"; |
123 warn "got: <STX>$line($1)\n" if $self->{debug}; |
110 |
124 |
111 return pack("ac", "E", 1) # checksum error |
125 return pack("ac", "E", 1) # checksum error |
112 if $1 ne ".." and hex($1) != unpack("%8C*", "$STX$line"); |
126 if $1 ne ".." and hex($1) != unpack("%8C*", "$STX$line"); |
113 |
127 |
114 my ($jid, $cmd, $width, $addr, $data) = ( |
128 my ($jid, $cmd, $width, $addr, $data) = ( |
135 return pack("ac", "E", 3) # width error |
149 return pack("ac", "E", 3) # width error |
136 if @data != $width; |
150 if @data != $width; |
137 |
151 |
138 my $offset = $addr - 0x100; |
152 my $offset = $addr - 0x100; |
139 |
153 |
140 warn "@data\n"; |
|
141 |
|
142 $self->show; |
|
143 @{ $self->{outputs} }[ $offset .. $offset + $width - 1 ] = |
154 @{ $self->{outputs} }[ $offset .. $offset + $width - 1 ] = |
144 map { pack "C", hex($_) } @data; |
155 map { pack "C", hex($_) } @data; |
145 $self->show; |
156 $self->show; |
146 |
157 |
147 $retval = "O$jid"; |
158 $retval = "O$jid"; |
148 } |
159 } |
149 else { |
160 else { |
150 warn "command \"$cmd\" not supported\n"; |
161 warn "command \"$cmd\" not supported\n"; |
151 $retval = pack("ac", "E", 2); |
162 $retval = pack("ac", "E", 2); |
152 } |
163 } |
153 |
164 |
154 return $retval . sprintf("%02x", unpack("%8C*", $retval)); |
165 return $retval . sprintf("%02x", unpack("%8C*", $retval)); |
155 } |
166 } |
156 |
167 |