git.rot13.org Git - vrDialog/blob - dialog.pl

   1 #!/usr/bin/perl
   2 use warnings;
   3 use strict;
   4
   5 use Data::Dump qw(dump);
   6 my $debug = $ENV{DEBUG} || 0;
   7
   8 =for serial_port
   9
  10 use Device::SerialPort qw(:STAT);
  11
  12 my $port = Device::SerialPort->new('/dev/ttyUSB0');
  13 die "can't open serial port" unless $port;
  14 $port->baudrate(9600);
  15 $port->databits(8);
  16 $port->parity('none');
  17 $port->stopbits(1);
  18 $port->handshake('none');
  19
  20 $port->read_char_time(500);
  21 $port->read_const_time(1000);
  22
  23 sub read_serial {
  24         my $len = shift;
  25         return $port->read( $len );
  26 }
  27
  28 sub write_serial {
  29         my $bytes = shift;
  30         return $port->write( $bytes );
  31 }
  32
  33 =cut
  34
  35 # TODO: implement remote serial port
  36 # remserial -x 2 -p 23000 -s "9600 raw" /dev/ttyUSB0
  37
  38 use IO::Socket::INET;
  39
  40 my $sock = IO::Socket::INET->new(
  41         PeerAddr => '192.168.1.148',
  42         PeerPort => '23000',
  43         Proto    => 'tcp'
  44 );
  45 die "can't connect" unless $sock;
  46
  47 sub read_serial {
  48         my $len = shift;
  49         my $buffer;
  50         eval {
  51                 local $SIG{ALRM} = sub { die "read timeout" };
  52                 alarm 3;
  53
  54                 warn "## read_serial $len" if $debug;
  55                 $sock->read( $buffer, $len );
  56                 warn "## read $len ",as_hex($buffer) if $debug;
  57         };
  58         alarm 0;
  59         warn "ERROR: $@" if $@;
  60         return $buffer;
  61 }
  62
  63 sub write_serial {
  64         my $bytes = shift;
  65         return $sock->print( $bytes );
  66 }
  67
  68
  69 sub as_hex {
  70         my @out;
  71         foreach my $str ( @_ ) {
  72                 my $hex = uc unpack( 'H*', $str );
  73                 $hex =~ s/(..)/$1 /g if length( $str ) > 2;
  74                 $hex =~ s/\s+$//;
  75                 push @out, $hex;
  76         }
  77         return join(' | ', @out);
  78 }
  79
  80 sub hex2bytes {
  81         my $bytes;
  82         $bytes .= pack('C', hex('0x' . $_)) foreach split(/\s+/,join(' ',@_));
  83         return $bytes;
  84 }
  85
  86 sub crc {
  87         my $data = shift;
  88         my $crc = 0;
  89         for my $i ( 0 .. length($data) - 2 ) {
  90                 if ( $crc & 0x80 ) {
  91                         $crc = ( $crc << 1 ) ^ 25;
  92                 } else {
  93                         $crc = $crc << 1;
  94                 }
  95                 $crc = $crc & 0xff;
  96                 my $byte = ord(substr($data,$i,1));
  97                 $crc = $crc ^ $byte;
  98 #               warn "## ", as_hex(chr($byte)), " crc = ", $crc, " ", as_hex(chr($crc));
  99         }
 100         # ignore checksum errors for FF, we will calulate them!
 101         if ( chr($crc) ne substr($data,-1,1) && substr($data,-1,1) ne "\xFF" ) {
 102                 warn "CRC error for ",as_hex($data), " calulated ", as_hex(chr($crc));
 103         }
 104
 105         return substr($data,0,-1) . chr($crc);
 106 }
 107
 108 sub v_bytes {
 109         my ($bytes,$desc) = @_;
 110         warn "# $desc\n";
 111 retry:
 112         warn ">> ",as_hex( $bytes );
 113         crc( $bytes );
 114         write_serial( $bytes );
 115
 116         my $data = read_serial(1);
 117         warn "<< len: ",ord($data) if $debug;
 118
 119         goto retry if ord($data) == 0;
 120
 121         $data .= read_serial(ord($data) - 1);
 122         crc($data);
 123         warn "<< ",as_hex($data);
 124
 125         my $o = 2;
 126         while ( $o < length($data) - 2 ) {
 127                 my $n = unpack('n', substr($data,$o,2));
 128                 $n = -( 0xffff - $n ) if $n & 0x8000;
 129                 warn "## $o = ",$n, "\t",$n / 16,"\n";
 130                 $o += 2;
 131         }
 132
 133         while ( $o < length($data) - 1 ) {
 134                 my $n = unpack('c', substr($data,$o,1));
 135                 warn "## $o = ", $n, "\n";
 136                 $o += 1;
 137         }
 138
 139         return $data;
 140 }
 141
 142 sub v {
 143         my ($hex,$desc) = @_;
 144         v_bytes( hex2bytes( $hex ), $desc );
 145 }
 146
 147 if ( ! @ARGV ) {
 148         v '07 02 00 00 00 04 C4', "hardware version";
 149
 150         v '07 0A 00 00 00 04 44', 'software version';
 151
 152         v '07 00 01 00 06 0E EA', 'temperatures';
 153
 154         v '07 00 00 00 26 0A A6', 'last errros';
 155 }
 156
 157 #v '07 00 00 00 26 00 AC', 'last errros (with invalid length)';
 158
 159 foreach my $reg ( @ARGV ) {
 160         warn "# send user $reg\n";
 161         v_bytes(
 162                 crc( hex2bytes( "07 00 00 00 $reg 01 FF" ) )
 163         ,"user: $reg");
 164 }