#!/usr/bin/perl # Program to control a Nortek AS Paradopp product (specifically, a Vector # unit, in my case). # by Chris MacGregor # Cybermato Consulting # See http://www.cybermato.com/projects/vectorcontrol for latest version. # Paid for by the Oceanography Dept. of the University of Washington # (http://www.ocean.washington.edu), Seattle, WA, USA. # Started July 2007, based on my stepit.pl program to control an Advanced # Micro Systems SAX/DAX stepper motor controller (single axis). # TODO: better error checking and reporting (both for user input errors and # errors from the device); chunk-based data downloading. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . $version = "0.5.0 1-22-08"; $versioninfo = "vectorControl.pl Version $version"; use Time::HiRes "usleep"; use Time::Local; use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); use Errno; # constants: $acknak_len = 2; $ack = "\x06"; $ackack = $ack x $acknak_len; $nak = "\x15"; $naknak = $nak x $acknak_len; $clock_data_bytes = 6; $inquiry_response_bytes = 2; $battery_voltage_bytes = 2; $get_id_bytes = 14; $deployment_config_bytes = 512; $hardware_config_bytes = 48; $head_config_bytes = 224; $all_config_bytes = ($deployment_config_bytes + $hardware_config_bytes + $head_config_bytes); $fat_entry_bytes = 16; $fat_entry_count = 32; $fat_total_bytes = $fat_entry_bytes * $fat_entry_count; # $download_blocksize = 16384; # 9600 bps = ~ 960 Bps = ~ 17 sec for 16kB $download_blocksize = 1024; # variables (constants that can be overridden on the command line): $commdev = "unknown"; @devices_to_try = ( "/dev/ttyUSB0", "/dev/ttyS0" ); foreach $dev (@devices_to_try) { next if ! -e $dev; $commdev = $dev; last; } $breaktype = "soft"; $data_file = "vector_data.vec"; $bps = 9600; # $bps = 115200; $usage = < -reset (immediate version of "-do reset") -abort (immediate version of "-do abort") -power_down (immediate version of "-do power_down") -break (immediate version of "-do break") Command: any of the following: reset Send a sequence that should get control no matter what abort Send a sequence that should stop data collection and prepare the device for further commands power_down Tell the device to power down; use break to wake it up break Send break flush Discard any leftover input; implied by abort and reset command_mode Tell the device to expect commands; should not normally be needed, as it is implied by reset and abort (above) read_config TYPE FILE where TYPE is one of: head hardware deployment all Read the specified config info from the device and write it to FILE configure FILE Send the deployment config file FILE to the device. This should be a 512-byte *.pcf file (NOT a .dep file!) generated by running 'Vector.exe -cu' and saving the deployment file. read_clock Display the device's idea of the current date & time; note that the date is shown in European format (day/month/year) set_clock Set the device's idea of the current date & time to what the PC thinks is the current date & time (you ARE using NTP, aren't you?) battery_voltage Show the current voltage of the internal battery, in millivolts get_id Show the device's identification of itself inquiry Show the device's answer regarding its current state list_data Show the list of 'files' of recorded data currently stored on the device download_data NAME [DEST_FILE] download_data INDEX [DEST_FILE] Download data from the file with name NAME or index INDEX (either as shown by list_data) into DEST_FILE. If DEST_FILE is not specified, the name will be the name of the file on the device, with .vec appended, and a date-time stamp appended as well if necessary to avoid a collision with an existing file; e.g., if the file on the device is foo, then the default DEST_FILE is foo.vec or foo.vec.080122-2119 (at 21:19 on 22 January 2008). data_file FILE Specify FILE as the file to which collected data (see collect_data and record_data, below) should be appended. If you want to erase any data already in the file, use "exec rm FILE" first. collect_data TIME [TIME...] collect_data until ABSTIME collect_data NUM samples record_data TIME [TIME...] record_data until ABSTIME record_data NUM samples record_data_quietly TIME [TIME...] record_data_quietly until ABSTIME collect_data tells the device to send the data to the serial port only (device command ST). record_data (device command SR) does the same but also records to the device's onboard memory. record_data_quietly (device command SD) records to the device's onboard memory but does not output to the serial port, and so no data is written to the data file. In the collect_data and record_data commands, the data sent to the serial port is stored in the data file (see data_file command, above). For each command, three forms are available: measuring until a specified amount of time (e.g., 3 minutes) has passed; measuring until an absolute time is reached; measuring for a specified number of samples (which should be equivalent to a specified amount of time, except that one or the other may be more intuitive, depending on the situation). The exception is record_data_quietly, which is only time-based, because with no data coming from the device, there is no reliable way to know when the desired number of samples have been taken. See the sleep command, below, for the syntax of the TIME and ABSTIME parameters. Note that if you specify a TIME or ABSTIME, the effect is to stop after the first data packet is received following the specified time; thus, the actual time may be longer than you requested. sleep TIME [TIME...] Sleep for TIME, where TIME is one or more of: Wd W days Xh X hours Ym Y minutes Zs Z seconds ex. "sleep 20m" or "sleep 1h 37m 29s" or "sleep 7d" sleep until ABSTIME Sleep until the specified absolute time, where ABSTIME is in one of the following forms: YYYY-MM-DD HH:MM:SS YYYY-MM-DD HH:MM:SS am YYYY-MM-DD HH:MM:SS pm DD-MM-YYYY HH:MM:SS DD-MM-YYYY HH:MM:SS am DD-MM-YYYY HH:MM:SS pm YYYY/MM/DD HH:MM:SS YYYY/MM/DD HH:MM:SS am YYYY/MM/DD HH:MM:SS pm DD/MM/YYYY HH:MM:SS DD/MM/YYYY HH:MM:SS am DD/MM/YYYY HH:MM:SS pm HH:MM:SS HH:MM:SS am HH:MM:SS pm ex. "sleep until 2004/06/14 13:02:51" or "sleep until 1:03 pm" *** IMPORTANT NOTES: *** * Dates are in the European format: (day first followed by month followed by year, or year first followed by month followed by day), NOT the US format (month first followed by day followed by year). Putting the year first (followed by month and then day) is the safest way to minimize confusion. * If no date is specified, then either the current or next day is assumed, as follows: If the time specified has already passed for the current day, then it is assumed to refer to the next day; otherwise, the current day is assumed. * You may use a 24-hour clock (00:00 - 23:59) OR am/pm. Specify a time like "14:02 pm" at your own risk. include FILE Read and execute commands from FILE and then continue send CMD Send literal CMD to the device directly with no interpretation or modification ex. "send PD" exec UNIXCMD Execute literal UNIXCMD by passing it to the system shell ex. "exec dvgrab -frames 100000000000000000000000001" ENDUSAGE ; # this isn't syntactically necessary but it placates emacs' perl-mode # !########################################################################## # \fn void getargs (void) # \brief Process command line arguments, setting various global variables # (which are documented individually). # !########################################################################## sub getargs { while (@ARGV) { $arg = shift @ARGV; if ($arg =~ /^-?-debug(w?)(\d*)$/) { # ! \var int $debug \brief is set to 1 or greater by -debug to # generate various forms and levels of debugging output. $debug += $2 || 1; } elsif ($arg =~ /^(?:-v|-?-verbose)?(\d*)$/) { # ! \var int $verbose \brief is set to 1 or greater by -verbose to # generate various forms and levels of information about what # the program is doing. $verbose += $1 || 1; } elsif ($arg =~ /^-?-comm(dev)?$/) { $commdev = shift @ARGV; } elsif ($arg =~ /^-?-bps$/) { $bps = shift @ARGV; } elsif ($arg =~ /^-?-really-please-delete-all-the-data-on-the-device$/) { $reallydeletedata = 1; } elsif ($arg =~ /^-?-do$/) { push (@cmds, shift @ARGV); } elsif ($arg =~ /^-?-set_(default_)?bps$/) { my $newbps = shift @ARGV; set_bps ($newbps, $1 ne ""); print "Exiting!\n"; exit 0; } elsif ($arg =~ /^-?-(reset|abort|break|power_down|command_mode|flush|inquiry|format)$/) { opencomm (); execute_command ($1); $didsomething = 1; } elsif ($arg =~ /^-?-skipsleep(?:=([\d\.]+))?$/) { $skipsleep = 1; # only useful for debugging $sleepytime = $1 || 1; } elsif ($arg =~ /^-?-nowait$/) { $nowait = 1; } elsif ($arg =~ /^-?-noexec$/) { $noexec = 1; } elsif ($arg =~ /^-?-notreally$/ || $arg eq "-n") { $notreally = 1; $noexec = 1; $commdev = "none"; $skipsleep = 1; $sleepytime = 5; } elsif ($arg !~ /^-/) { push (@cmds, "include $arg"); } elsif ($arg =~ /^(--|-|\/)(\?|h(elp)?|usage)$/) { print $usage; exit 1; } else { print "$usage\nUnrecognized option \"$arg\"\n"; exit 1; } } $verbose = 1 if $debug && !$verbose; $| = 1 if $verbose || 1; } ############################################################################# ############################################################################# ####################### General Utility Functions ######################### ############################################################################# ############################################################################# # !########################################################################## # \fn string getdate (void) # \brief Return the current date and time, formatted like "Wed Feb 19 2003 # 12:40:09". # !########################################################################## sub getdate { my ($when) = @_; $when = time if !defined ($when); my ($sec, $min, $hour, $mday, $mon, $year, $wday) = localtime ($when); my ($date) = sprintf ("%s %s %2d %d %02d:%02d:%02d", ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat") [$wday], ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec") [$mon], $mday, $year + 1900, $hour, $min, $sec); return $date; } # !########################################################################## # \fn string getshortdate (void) # \brief Return the current date and time, formatted like " 5-Jul-2003 12:40:09". # !########################################################################## sub getshortdate { my ($when) = @_; $when = time if !defined ($when); my ($sec, $min, $hour, $mday, $mon, $year, $wday) = localtime ($when); my ($date) = sprintf ("%2d-%s-%d %02d:%02d:%02d", $mday, ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec") [$mon], $year + 1900, $hour, $min, $sec); return $date; } # !########################################################################## # \fn string getveryshortdate (void) # \brief Return the current date and time, formatted like "080129-1240". # !########################################################################## sub getveryshortdate { my ($when) = @_; $when = time if !defined ($when); my ($sec, $min, $hour, $mday, $mon, $year, $wday) = localtime ($when); my ($date) = sprintf ("%02d%02d%02d-%02d%02d", $year - 100, $mon + 1, $mday, $hour, $min); return $date; } # !########################################################################## # \fn void opencomm (void) # \brief Prepare for communications with the device, without sending anything # yet. # !########################################################################## sub opencomm { if ($commopen eq $commdev) { print "Comm on $commdev already open\n" if $verbose >= 2 || $debug; return; } print "Initializing communications on $commdev at $bps bps...\n" if $verbose; if ($commdev eq "none") { print "DEBUG MODE: sending no data\n"; return; } print "Opening $commdev...\n" if $verbose; my $sttycmd = "stty -F $commdev $bps -parenb cs8 cread clocal -crtscts " . "ignpar -parmrk -inpck -istrip -inlcr -igncr -icrnl -ixon -ixoff " . "-opost -ocrnl -onlcr -onocr -onlret -isig -icanon -iexten -echo " . "-echoe -echok -echoctl -echoke ignbrk -hupcl time 5"; print "Running \"$sttycmd\"...\n" if $debug >= 2; system ($sttycmd); die "\"$sttycmd\" returned $?" if $?; open (COMM, "+< $commdev") || die "Can't open $commdev: $!"; binmode (COMM, ":raw"); $commopen = $commdev; } sub closecomm { $commopen = undef; close (COMM); } # just send something sub sendcmdnowait { my ($cmd) = @_; print "Sending \"", escapestring ($cmd), "\"...\n" if $verbose >= 2 || ($verbose && length ($cmd) < 70); return if $commdev eq "none"; syswrite (COMM, "$cmd") || die "Write failed!!!"; } sub setblocking { my ($blocking) = @_; my $flags = fcntl (COMM, F_GETFL, 0) or die "Can't get flags for $commdev: $!\n"; if ($blocking) { $flags = $flags & ~O_NONBLOCK; } else { # inexplicably, '$flags |= O_NONBLOCK;' gets unrecognized character # \xE2. !?!? $flags = $flags | O_NONBLOCK; } $flags = fcntl (COMM, F_SETFL, $flags) or die "Can't set flags for $commdev: $!\n"; } sub escapestring { my ($string) = @_; for (my $i = length ($string) - 1; $i >= 0; $i--) { my $char = ord (substr ($string, $i, 1)); substr ($string, $i, 1) = sprintf ('\x%02x', $char) if $char < 32 || $char >= 127; } return $string; } sub dump_data { my ($data) = @_; my $string; my $offset; while (length ($data)) { my $chunk = substr ($data, 0, 16); $data = substr ($data, 16); $string .= sprintf ("0x%04x ", $offset); for (my $i = 0; $i < length ($chunk); $i++) { $string .= " " if $i == 8; $string .= sprintf (" %02x", ord (substr ($chunk, $i, 1))); } $string .= "\n"; $offset += length ($chunk); } return $string; } sub flushinput { my ($quietly) = @_; setblocking (0); my $string; while (1) { my $buffer; my $sysret = sysread (COMM, $buffer, 100000); die "sysread for flush: $! (" . int ($!) . ")" if !defined ($sysret) && ! $!{EAGAIN}; last if length ($buffer) == 0; $string .= $buffer; $buffer = escapestring ($buffer); print "Discarding lost input: \"$buffer\"\n" if !$quietly; } setblocking (1); return $string; } # $res = check_acknak (acknak, force, msg) # if msg is defined, will complain about NAK or unknown # if force is defined, unknown forced to that with complaint # else returns either "ACK", "NAK", or undef sub check_acknak { my ($acknak, $force, $msg) = @_; if ($acknak eq $ackack) { return "ACK"; } if ($acknak eq $naknak) { print "$msg FAILED\n" if defined ($msg); return "NAK"; } elsif (defined ($force)) { printf ("$msg got neither ACK nor NAK: '%s' (calling it $force)\n", escapestring ($acknak)); return $force; } return undef; } # send a command and wait for a response ending with ACK ACK or NAK NAK; # return an array: [0] = any chars preceding the ACK ACK or NAK NAK, and # [1] = "ACK" or "NAK" (NOT $ack or $nak). sub sendcmd { my ($cmd, $showresponse) = @_; sendcmdnowait ($cmd); return ("FAKE", "ACK") if $commdev eq "none"; print "Waiting for ACK or NAK...\n" if $debug || $verbose >= 2; my $response; my $acknak; my $char; usleep (50 * 1000); $weird0reads = 0; while (length ($acknak) < $acknak_len) { my $sysret = sysread (COMM, $char, 1); if ($sysret < 1) { warn "sysread returned \"$sysret\": $! (" . int ($!) . ")"; # All handling of this condition is a HACK! (Because I don't # understand why this might happen...) setblocking (1); if (++$weird0reads > 20) { warn "resending command \"" . escapestring ($cmd) . "\"\n"; flushinput(); sendcmdnowait ($cmd); } else { sleep (1); } next; } else { $weird0reads = 0; } if ($debug >= 2) { my $dchar = $char; if ($dchar eq "\r") { $dchar = "<\\r>"; } elsif ($dchar eq "\n") { $dchar = "<\\n>"; } elsif (ord ($dchar) < 32) { $dchar = sprintf ("<0x%02x>", ord ($dchar)); } print "received \"$dchar\"\n"; } if ($char eq $ack || $char eq $nak) { if (length ($acknak) > 0 && $acknak ne $char) { printf ("Uh oh, got 0x%02x followed by 0x%02x!?! " . "Treating as 0x%02x%02x\n", ord ($acknak), ord ($char), ord ($char), ord ($char)); $acknak = $char x $acknak_len; } else { $acknak .= $char; } } else { $response .= $char; } } my $validated = check_acknak ($acknak); if ($validated) { $acknak = $validated; } else { die "Internal botch: \$acknak neither ackack nor naknak: " . escapestring ($acknak); } my @response = ($response, $acknak); if ($showresponse || $verbose) { $response = escapestring ($response); print "Received: \"$response\" $acknak\n"; } return @response; } sub read_data { my ($len_wanted) = @_; if ($commdev eq "none") { print "Pretending to receive $len_wanted 00 bytes\n"; return "\0" x $len_wanted; } my $data; print "read_data: want $len_wanted bytes\n" if $debug >= 1; while ($len_wanted > 0) { my $buffer; my $sysret = sysread (COMM, $buffer, $len_wanted); die "sysread for read_data: $! (" . int ($!) . ")" if !defined ($sysret) && ! $!{EAGAIN}; $data .= $buffer; my $len = length ($buffer); die "sysread returned $sysret but data length = $len" if $len != $sysret; $len_wanted -= $len; print ("read_data: got $len bytes (", length ($data), " total), $len_wanted remaining\n") if $debug >= 1; } return $data; } sub sendinquiry { my @response = sendcmd ("II"); if ($response [1] eq "NAK") { print "inquiry NAK'd\n"; return; } my $response = $response [0]; warn "inquiry response length is " . length ($response) if length ($response) != $inquiry_response_bytes; $response = unpack ("v", $response); my $state = ("Firmware upgrade", "Measurement", "Command", "Data retrieval", "Confirmation")[$response]; $state = " ($state mode)" if $state ne ""; printf ("Inquiry says mode is 0x%04x$state\n", $response); } sub sendbreak { my ($times_called_already) = @_; my $breaksleep = 0.5; usleep ($breaksleep * 1000000); flushinput (!$verbose); if ($breaktype eq "hard") { die "hard break NYI - should set & hold break state for 500 ms"; } elsif ($breaktype eq "soft") { sendcmdnowait ("@@@@@@"); usleep (100 * 1000); sendcmdnowait ('K1W%!Q'); } else { die "Unknown break type \"$breaktype\""; } usleep ($breaksleep * 2 * 1000000); # HERE: maybe we should wait for the "Confirm:" string (or the "Command # mode" string, in case we're not in measurement mode) BEFORE sending MC, # to avoid this: # # (collecting data) # 15-Jul-2007 15:51:52 Command: abort # Sending "@@@@@@"... # Sending "K1W%!Q"... # Break got neither ACK nor NAK: '' (calling it ???) # Break response is "" ??? # Sending "MC"... # Received: "\x0a\x0dConfirm:" ACK # Sending "II"... # Received: "\x05\x00" ACK # Inquiry says mode is 0x0005 # 15-Jul-2007 15:51:57 Command: power_down # Sending "PD"... # Received: "" NAK # # But for now, we're increased the delay before we expect a response, # and we retry 9 more times if we didn't get one. my $response = flushinput (1); # flush quietly if (length ($response) == 0) { die "Sent $times_called_already Breaks with no response - " . "device is not responding!" if $times_called_already > 10; print (getshortdate(), " No response from $commdev - ", "re-sending break...\n"); return sendbreak ($times_called_already + 1); } else { my $acknak = substr ($response, -$acknak_len); $acknak = check_acknak ($acknak, "???", "Break"); $response = escapestring (substr ($response, 0, -$acknak_len)); print "Break response is \"$response\" $acknak\n" if $showresponse || $verbose; } } my %timeconv = ( "d" => 60 * 60 * 24, "h" => 60 * 60, "m" => 60, "s" => 1 ); sub fmttime { my ($hour, $min, $sec) = @_; return sprintf ("%02d:%02d:%02d", $hour, $min, $sec); } sub convtime { my ($what, @parts) = @_; my $time = 0; if ($parts [0] eq "until") { my ($date, $day, $month, $year, $hour, $minute, $second); shift @parts; foreach $part (@parts) { if ($part =~ /^(\d+)(\/|-)(\d+)\2(\d+)$/) { die "Syntax error in $what until: \"$part\": date was already" . " specified as $date\n" if $date ne ""; if (length ($4) == 4) { ($day, $month, $year) = ($1, $3, $4); } elsif (length ($1) == 4) { ($year, $month, $day) = ($1, $3, $4); } else { die "Syntax error in $what until: \"$part\": year " . "($1 or $4) must be 4 digits\n"; } if ($month > 12) { die "Syntax error in $what until: \"$part\": month " . "($month) must be 1-12 (maybe you meant to write " . "\"$month/$day/$year\"?)\n"; } $date = $part; } elsif ($part =~ /^(\d+):(\d\d)(?::(\d\d))?(am|pm)?$/i) { my ($newhour, $newminute, $newsecond, $ampm) = ($1, $2, $3, $4); die "Syntax error in $what until: \"$part\": time was already" . " specified as " . fmttime ($hour, $minute, $second) . "\n" if "$hour$minute$second" ne ""; $newsecond = "00" if $newsecond eq ""; ($hour, $minute, $second) = ($newhour, $newminute, $newsecond); push (@parts, $ampm) if $ampm ne ""; } elsif ($part =~ /^(am|pm)$/i) { if (lc $part eq "pm") { if ($hour > 12) { warn "What do you mean by $hour:$minute:$second pm??\n"; } elsif ($hour < 12) { $hour += 12; } } else # am { if ($hour > 12) { warn "What do you mean by $hour:$minute:$second am??\n"; } elsif ($hour == 12) { $hour = 0; } } } else { die "Syntax error in $what until: \"$part\": not recognized " . "as a date or time\n"; } } die "Error in $what until @parts: time not specified\n" if "$hour$minute$second" eq ""; my ($nowsec, $nowmin, $nowhour, $nowmday, $nowmon, $nowyear) = localtime (time); my $boost = 0; if ($day eq "") { $boost = 24 * 60 * 60 if (fmttime ($nowhour, $nowmin, $nowsec) > fmttime ($hour, $minute, $second)); ($day, $month, $year) = ($nowmday, $nowmon + 1, $nowyear + 1900); } my $abstime = timelocal ($second, $minute, $hour, $day, $month - 1, $year - 1900); my ($chksec, $chkmin, $chkhour, $chkmday, $chkmon, $chkyear) = localtime ($abstime); die "oops: ($chksec,$chkmin,$chkhour, $chkmday,$chkMon,$chkyear) " . "returned for ($second,$minute,$hour, $day," . ($month-1) . "," . ($year - 1900) . ")\n" if ($chksec != $second || $chkhour != $hour || $chkmin != $minute || $chkmon + 1 != $month || $chkmday != $day || $chkyear + 1900 != $year); $abstime += $boost; $time = $abstime - time; if ($time < 0) { warn "*** You asked to $what until " . getshortdate ($abstime) . ", but that time has already " . "passed;\n it is currently " . getshortdate (time) . "! Ignoring and continuing...\n"; $time = 0; } } else { foreach $part (@parts) { if ($part =~ /^([\d\.]+)([dhms])$/) { $time += $1 * $timeconv {$2}; } else { die "Syntax error in $what: \"$part\": must be " . "one or more of Xd, Xh, Xm, Xs where X is a number\n"; } } if ($time <= 0) { warn "*** Did you really want to $what for $time seconds? " . "(I'm ignoring this!)\n"; $time = 0; } } return $time; } sub check_packet { my ($data, $magic, $name, $size) = @_; my $okay = 1; if (defined ($magic) && substr ($data, 0, length ($magic)) ne $magic) { my $badmagic = escapestring (substr ($data, 0, length ($magic))); $magic = escapestring ($magic); print "check_packet: $name: magic mismatch: exp. $magic, " . "got $badmagic\n"; $okay = 0; } if ($size <= 0) { my $internalsize = 2 * unpack ("v", substr ($data, 2, 2)); if ($size < 0) { $size = -$size; if ($internalsize != $size) { print "check_packet: $name: bad size: exp. $size, internal size = " . "$internalsize\n"; $okay = 0; $size = $internalsize; } } else { $size = $internalsize; } } if (length ($data) != $size) { print "check_packet: $name: bad size: exp. $size, got " . length ($data) . "\n"; $okay = 0; } my $checksum = (unpack ("%16v*", substr ($data, 0, -2)) + 0xb58c) % 65536; my $expsum = unpack ("v", substr ($data, -2)); if ($checksum != $expsum) { printf ("check_packet: %s: bad checksum: exp. 0x%04x, got 0x%04x\n", $name, $expsum, $checksum); $okay = 0; } print "$name packet okay\n" if $okay && $verbose; return $okay; } sub execute_command { my ($cmd) = @_; my $cmd2 = $cmd; $cmd2 =~ s/\#.*$//; # drop comments $cmd2 =~ s,\/\/.*$,,; # drop comments $cmd2 =~ s/^\s+//; $cmd2 =~ s/\s+$//; return if $cmd2 eq ""; my @parts = split (" ", $cmd2); print getshortdate(), " Command: ", join (" ", @parts), "\n"; my $keyword = shift @parts; if ($keyword eq "reset") { sendbreak(); sendcmd ("MC"); sleep (2); sendcmd ("MC"); sleep (2); flushinput (!$verbose); sendinquiry(); sendinquiry(); sleep (2); flushinput (1); } elsif ($keyword eq "abort") { sendbreak(); sendcmd ("MC"); sleep (2); flushinput (!$verbose); sendinquiry(); sleep (1); flushinput (!$verbose); } elsif ($keyword eq "break") { sendbreak(); } elsif ($keyword eq "power_down") { sendcmd ("PD"); usleep (500 * 1000); } elsif ($keyword eq "flush") { usleep (500 * 1000); flushinput(); } elsif ($keyword eq "command_mode") { sendcmd ("MC"); sleep (2); } elsif ($keyword eq "read_clock") { # We used to use sendcmd() here, but it gets confused if the clock # data happens to include a 15 or a 06 (e.g., at 6:xx am or July 15th # or ...). Duh... # my @response = sendcmd ("RC"); sendcmdnowait ("RC"); my $response = read_data ($clock_data_bytes); my $acknak = check_acknak (read_data ($acknak_len), "???", $keyword); return if ($acknak ne "ACK"); print ">", join ("< >", unpack ("H2" x 6, $response)), "<\n" if $debug >= 5; my ($min, $sec, $day, $hour, $year, $month) = unpack ("H2" x 6, $response); printf ("Device clock: %2d/%02d/%02d %2d:%02d:%02d\n", $day, $month, $year, $hour, $min, $sec); } elsif ($keyword eq "set_clock") { my ($sec, $min, $hour, $day, $month, $year) = localtime (time); my $clockdata = pack ("H*", sprintf ("%02d" x 6, $min, $sec + 1, $day, $hour, $year - 100, $month + 1)); print ">", join ("< >", unpack ("H2" x 6, $clockdata)), "<\n" if $debug >= 5; ($min, $sec, $day, $hour, $year, $month) = unpack ("H2" x 6, $clockdata); printf ("Setting clock: %2d/%02d/%02d %2d:%02d:%02d\n", $day, $month, $year, $hour, $min, $sec) if $verbose; my @response = sendcmd ("SC" . $clockdata); if ($response [1] ne "ACK" || length ($response [0]) != 0) { print "$keyword failed.\n"; return; } } elsif ($keyword eq "read_config") { my ($type, $outfile) = @parts; my %cfgtype = ( deployment => [ "GC", $deployment_config_bytes ], hardware => [ "GP", $hardware_config_bytes ], head => [ "GH", $head_config_bytes ], all => [ "GA", $all_config_bytes ] ); if (!exists ($cfgtype {$type})) { die "Invalid $keyword type \"$type\": should be one of: " . join (" ", sort keys %cfgtype) . "\n"; } my ($outcmd, $expsize) = @{$cfgtype {$type}}; sendcmdnowait ($outcmd); my $data = read_data ($expsize); my $acknak = check_acknak (read_data ($acknak_len), "???", "$keyword $type"); if ($acknak eq "ACK") { open (CFGOUT, "> $outfile") || die "Can't open $outfile for writing: $!\n"; binmode (CFGOUT, ":raw"); print CFGOUT $data; close (CFGOUT); } } elsif ($keyword eq "configure") { my $cfgfile = shift @parts; open (CFGIN, "< $cfgfile") || die "Can't open $cfgfile for reading: $!\n"; binmode (CFGIN, ":raw"); my $cfgdatalen = 512; my $cfgdata; my $len = sysread (CFGIN, $cfgdata, $cfgdatalen); die "Failed to read config data from $cfgfile (got $len): $!" if $len != $cfgdatalen; close (CFGIN); my @response = sendcmd ("CC" . $cfgdata); if ($response [1] ne "ACK") { print "$keyword failed.\n"; return; } } elsif ($keyword eq "battery_voltage") { # We used to use sendcmd() here, but I think it will get confused if # the encoded battery voltage data happens to include a 15 or a 06. # my @response = sendcmd ("BV"); sendcmdnowait ("BV"); my $response = read_data ($battery_voltage_bytes); my $acknak = check_acknak (read_data ($acknak_len), "???", $keyword); return if ($acknak ne "ACK"); $response = unpack ("v", $response); printf ("Current battery voltage is %d mV\n", $response); } elsif ($keyword eq "get_id") { my @response = sendcmd ("ID"); if ($response [1] ne "ACK" || length ($response [0]) != $get_id_bytes) { print "$keyword failed.\n"; return; } printf ("Device ID is \"%s\"\n", $response [0]); } elsif ($keyword eq "send") { my @response = sendcmd ($parts [0]); if ($response [1] ne "ACK") { print "$keyword @parts failed.\n"; return; } printf ("Response to $parts[0] is \"%s\"\n", escapestring ($response [0])); } elsif ($keyword =~ /^(collect|record)_data(_quietly)?$/) { my ($record, $quietly) = ($1, $2); my $outcmd; if ($record eq "collect") { die "$keyword is not a valid command (did you mean collect_data " . "or record_data_quietly?)\n" if $quietly ne ""; $outcmd = "ST"; # start, output to serial port, no recording } elsif ($quietly eq "") { $outcmd = "SR"; # start, output to serial port, and record } else { $outcmd = "SD"; # start, record only, no output } my $samplecount = 0; my $until = 0; if (@parts == 2 && $parts [1] eq "samples" || $parts [0] =~ /^\d+$/) { if ($outcmd eq "SD") { print "$keyword is only valid with a time parameter, not a " . "sample count.\n"; return; } $samplecount = $parts [0]; die "sample count ($samplecount) should be at least one!" if $samplecount < 1; } else { my $time = convtime ($keyword, @parts); my $howlong = format_time_duration ($time); print "$keyword for $howlong...\n"; return if $time <= 0; $until = time + $time; } my @response = sendcmd ($outcmd); if ($response [1] ne "ACK") { print "$keyword @parts failed.\n"; return; } last if $notreally; # HERE: in theory, the SD command should produce no output. However, # on our Nortek Vector with firmware version 1.15, it does... # Nonetheless, this code does the right thing and does not attempt to # collect any output. if ($outcmd eq "SD") { sleep ($until - time); last; } open (DATAOUT, ">> $data_file") || die "Can't open $data_file to append: $!"; binmode (DATAOUT, ":raw"); my $data; my $vector_system_data_magic = 0xa511; my $vector_system_data_size = 28; my $vector_velocity_data_header_magic = 0xa512; my $vector_velocity_data_header_size = 42; my $vector_velocity_data_magic = 0xa510; my $vector_velocity_data_size = 24; while ($until ? (time < $until) : ($samplecount > 0)) { $data = read_data (4); my ($magic, $size) = unpack ("nv", $data); $size *= 2; if ($magic == $vector_velocity_data_magic) { $data .= read_data ($vector_velocity_data_size - 4); check_packet ($data, undef, "velocity data", $vector_velocity_data_size); --$samplecount; } elsif ($magic == $vector_velocity_data_header_magic) { $data .= read_data ($size - 4); my ($min, $sec, $day, $hour, $year, $month) = unpack ("H2" x 6, substr ($data, 4, 6)); printf (" @ %2d/%02d/%02d %2d:%02d:%02d ", $day, $month, $year, $hour, $min, $sec); check_packet ($data, undef, "velocity data header", -$vector_velocity_data_header_size); my $nrecords = unpack ("v", substr ($data, 10, 2)); print "nrecords = $nrecords\n"; } elsif ($magic == $vector_system_data_magic) { $data .= read_data ($size - 4); check_packet ($data, undef, "vector system data", -$vector_system_data_size); } else { printf ("Unknown packet type 0x%04x, size %d!!!\n", $magic, $size); die if $size > 100; $data .= read_data ($size - 4); } print dump_data ($data) if $debug >= 20; print DATAOUT $data; } close (DATAOUT); } elsif ($keyword eq "inquiry") { # HERE: syntax checking sendinquiry(); } elsif ($keyword eq "data_file") { $data_file = shift @parts; # HERE: syntax checking print "Data will be written to $data_file\n" if $verbose; } elsif ($keyword eq "list_data") { # HERE: syntax checking # We could theoretically use sendcmd() here, but I think it will get # confused if the encoded file info happens to include a 15 or a 06, # which is bound to happen sooner or later. # my @response = sendcmd ("RF"); sendcmdnowait ("RF"); my $response = read_data ($fat_total_bytes); my $acknak = check_acknak (read_data ($acknak_len), "???", $keyword); return if ($acknak ne "ACK"); print dump_data ($response) if $debug >= 20; my $files_found = 0; # We use $fat_entry_count - 1 because the docs say the last entry is # not used. for (my $i = 0; $i < $fat_entry_count - 1; $i++) { my $fat_entry = substr ($response, $i * $fat_entry_bytes, $fat_entry_bytes); my ($name, $status, $start, $end) = unpack ("Z7CVV", $fat_entry); if ($status) { if ($status & ~3) { $status = sprintf ("0x%02x", $status); } else { $status = (($status & 2) ? "W" : "-") . (($status & 1) ? "w" : "-"); } } else { $status = "--"; } my $len = $end - $start; if ($len > 9 * 1024 * 1024 * 1024) { $len = sprintf ("%.1f GB", $len / (1024 * 1024 * 1024)); } elsif ($len > 9 * 1024 * 1024) { $len = sprintf ("%.1f MB", $len / (1024 * 1024)); } elsif ($len > 99 * 1024) { $len = sprintf ("%.1f kB", $len / 1024); } else { $len = "$len B"; } next if $name eq "" && !$start && !$end && $status eq "--"; ++$files_found; printf ("%2d: %-7s %s 0x%08x - 0x%08x (%s)\n", $i, $name, $status, $start, $end, $len); } print "No recorded data is currently stored on the device.\n" if !$files_found; } elsif ($keyword eq "download_data") { my $from = shift @parts; my $to = shift @parts; # HERE: syntax checking if ($from eq "") { print "Please specify either a name or an index into the file " . "list on the device (try list_data to see the list).\n"; return; } # We could theoretically use sendcmd() here, but I think it will get # confused if the encoded file info happens to include a 15 or a 06, # which is bound to happen sooner or later. # my @response = sendcmd ("RF"); sendcmdnowait ("RF"); my $data = read_data ($fat_total_bytes); my $acknak = check_acknak (read_data ($acknak_len), "???", $keyword); return if ($acknak ne "ACK"); print dump_data ($data) if $debug >= 20; my $files_found = 0; my @starts = (); my @ends = (); my %byname = (); for (my $i = 0; $i < $fat_entry_count; $i++) { my $fat_entry = substr ($data, $i * $fat_entry_bytes, $fat_entry_bytes); my ($name, $status, $start, $end) = unpack ("Z7CVV", $fat_entry); next if $name eq "" && !$start && !$end; ++$files_found; $names [$i] = $name; $starts [$i] = $start; $ends [$i] = $end; $byname {$name} = defined ($byname {$name}) ? "multiple" : $i; } if (!$files_found) { print "No recorded data is currently stored on the device.\n"; return; } my ($start, $end, $index); if ($from eq "0" || ($from >= 1 && $from <= $fat_entry_count)) { $index = $from; $from = $names [$index]; if (!defined ($from)) { print "No file at index $index\n"; return; } } else { $index = $byname {$from}; if ($index eq "multiple") { print "More than one data file has the name \"$from\" - try " . "using list_data and specifying a number.\n"; return; } elsif ($index eq "") { print "No data file has the name \"$from\" - try list_data\n"; return; } } $start = $starts [$index]; $end = $ends [$index]; if ($to eq "") { if ($from eq "") { print "File at index $index has no name - using \"data\".\n"; $to = "data.vec"; } else { $to = "$from.vec"; } $to .= "." . getveryshortdate() if -e $to; } my $len = $end - $start; printf ("Copying configuration (%d bytes) plus %d data bytes from " . "file %d \"%s\" (0x%x - 0x%x) to \"%s\".\n", $all_config_bytes, $len, $index, $from, $start, $end, $to) if $verbose; printf ("Estimated time for %d bytes at about %d bytes/sec: %s\n", $len, $bps / 10, format_time_duration ($len * 10 / $bps)) if $verbose; # Just in case someone goofed up, append to the file rather than # overwriting it. They can always use "exec rm filename" if they want # to nuke an existing one, and this way the data can be recovered if # there is a mixup. open (DATAOUT, ">> $to") || die "Can't open $to to append: $!"; binmode (DATAOUT, ":raw"); # First, download the configuration that was active when this data was # recorded. sendcmdnowait ("FC" . pack ("v", $index)); $data = read_data ($all_config_bytes); $acknak = check_acknak (read_data ($acknak_len), "???", "$keyword $type"); return if ($acknak ne "ACK"); print DATAOUT $data; # And now download the actual data. # HERE: An improvement would be to fetch the data in chunks of # something like 16kB or 64kB (rather than the whole file even if it's # many megabytes) and for each chunk, check the CRC and re-request the # chunk if it doesn't match. As it stands, we CRC the whole file, and # then it's up to the user to notice if the CRC's don't match and to # initiate a re-download, and if it's a large file they're going to be # waiting a long time, even if only one bit was off in the whole # thing. Plus, the more data the CRC is applied to at once, the more # chance there is of multiple errors cancelling each other out. Also, # there seems to be no way to abort the sending of data once it # starts, so if you request a really large file, you're stuck for a # while no matter what. my @response = sendcmd ("DC" . pack ("VV", $start, $end)); if ($response [1] ne "ACK") { if ($len == 0) { print "No data to download (empty file on device).\n"; } else { print "Failed to initiate download.\n"; } close (DATAOUT); return; } my $start_time = time; my $count = 0; my $remaining = $len; my $crc = 0; while ($remaining > 0) { my $subrem = ($remaining > $download_blocksize) ? $download_blocksize : $remaining; $remaining -= $subrem; my $data = read_data ($subrem); print DATAOUT $data; $count += length ($data); $crc = calcCRC ($crc, $data); printf ("\r%3d%% = %d bytes", ($count / $len) * 100, $count) if $verbose; } my $total_time = time - $start_time; $total_time = 1 if !$total_time; # don't divide by 0! close (DATAOUT); printf (" in %d seconds = %d bytes/sec.\n", $total_time, $len / $total_time) if $verbose; my $theircrc = unpack ("v", read_data (2)); printf ("their crc = 0x%04x, my crc = 0x%04x\n", $theircrc, $crc) if $debug >= 1 || $crc != $theircrc; if ($crc == $theircrc) { print "CRC verified - data downloaded successfully!\n" if $verbose; } else { print "**************** CRC mismatch!!\n"; } my $acknak = check_acknak (read_data ($acknak_len), "???", $keyword); return if ($acknak ne "ACK"); } elsif ($keyword eq "format") { die "If you really and truly want all the data deleted from the " . "device, run $0 again and also specify the magic parameter " . "--really-please-delete-all-the-data-on-the-device\n" if !$reallydeletedata; my @response = sendcmd ("FO\x12\xd4\x1e\xef"); if ($response [1] ne "ACK") { print "$keyword failed.\n"; return; } else { print "$keyword successful. All data deleted from device. " . "Hope you meant to do that...\n"; } } elsif ($keyword eq "include") { $filename = shift @parts; $linenum = 0; # HERE: syntax checking open (IN, "< $filename") || die "Can't open $filename: $!"; my @morecmds = ; close (IN); print "Reading commands from $filename...\n"; unshift (@cmds, @morecmds, "endinclude"); } elsif ($keyword eq "endinclude") { print "End of commands from $filename.\n"; $filename = ""; $linenum = 0; # HERE: syntax checking } elsif ($keyword eq "sleep") { my $time = convtime ($keyword, @parts); my $howlong = format_time_duration ($time); if ($skipsleep) { print "Would sleep for $howlong..."; sleep ($sleepytime); print "and then continue.\n"; } else { print "Sleeping for $howlong...\n"; sleep ($time); } } elsif ($keyword eq "exec") { $cmd2 =~ s/^$keyword\s*//; if ($noexec) { print "Would execute \"$cmd2\"\n"; } else { system ($cmd2); my $ret = $?; $ret /= 256 if ($ret >= 0 && ($ret % 256) == 0); print "**** Command returned $ret!\n" if $ret; } } else { die "Command \"$keyword\" not recognized\n"; } } sub set_bps { my ($newbps, $make_default) = @_; %bps_code = ( 300 => "00", 600 => "11", 1200 => "22", 2400 => "33", 4800 => "44", 9600 => "55", 19200 => "66", 38400 => "77", 57600 => "88", 115200 => "99" ); my $newbpscode = $bps_code {$newbps}; die "Don't know how to set the device to $newbps bps! Try one of these: " . join (" ", sort { $a <=> $b } keys %bps_code) . "\n" if $newbpscode eq ""; opencomm (); print "\nPreparing to change from $bps bps to $newbps bps.\n" . "First, resetting device, just to be safe...\n\n"; sendbreak(); sendcmd ("MC"); sleep (2); sendcmd ("MC"); sleep (2); flushinput (!$verbose); sendinquiry(); sendinquiry(); sleep (2); flushinput (1); $verbose = 1 if !$verbose; print "\nOkay, here we go...setting new bit rate ($newbps bps)...\n\n"; my @response = sendcmd ("BR$newbpscode"); die "FAILED to set new bit rate!" if $response [1] ne "ACK"; print "\nNext, switching to $newbps bps on our end...\n\n"; closecomm(); $bps = $newbps; sleep (1); opencomm(); sleep (1); sendinquiry(); if (!$make_default) { print "\nOkay, if no errors above, bit rate change succeeded!\n" . "HOWEVER: device will return to its default bit rate when it\n" . "powers down OR receives a break signal!!\n\n"; return; } print "\nNow, attempting to make $newbps bps the default...\n\n"; my $tries_left = 3; while (--$tries_left >= 0) { @response = sendcmd ("SB3GA2"); last if $response [1] eq "ACK"; print "Hmmm, let's give that another shot...\n"; } die "FAILED to set default bps rate!" if $tries_left < 0; print "\nWoo hoo! It appears that we have successfully set the device's " . "default\nto $newbps bps! Testing is recommended, of course...\n"; } # This is based on the following code supplied by Nortek. # unsigned short CPdComm::CRC(unsigned short hCRC,char *pcBuf,int nLen) # { # int i; # while (nLen--) { # hCRC ^= (unsigned short) (*pcBuf++)<<8; # for (i=0; i<8; ++i) { # if (hCRC & 0x8000) # hCRC = (hCRC << 1) ^ 0x1021; # else # hCRC <<= 1; # } # } # return hCRC; # } sub calcCRC { my ($crc, $data) = @_; use integer; for (my $byte = 0; $byte < length ($data); ++$byte) { $crc ^= ord (substr ($data, $byte, 1)) << 8; for (my $i = 0; $i < 8; ++$i) { if ($crc & 0x8000) { $crc = ($crc << 1) ^ 0x1021; } else { $crc <<= 1; } } $crc &= 0xffff; # keep to an unsigned short worth of bits } return $crc; } sub format_time_duration_simplistic { my ($secs) = @_; if ($secs > 60 * 60) { return sprintf ("%d:%02d:%02d", $secs / (60 * 60), ($secs / 60) % 60, $secs % 60); } else { return sprintf ("%d:%02d", $secs / 60, $secs % 60); } } sub format_time_duration { my ($time) = @_; my $howlong = "$time second"; $howlong .= "s" if $time != 1; $howlong .= " ("; if ($time > 60) { my $timeleft = $time; if ($timeleft > 60 * 60) { if ($timeleft > 60 * 60 * 24) { my $days = int ($timeleft / (60 * 60 * 24)); $timeleft -= $days * 60 * 60 * 24; $howlong .= "$days/"; } my $hours = int ($timeleft / (60 * 60)); $timeleft -= $hours * 60 * 60; $howlong .= "0" if $hours < 10 && $howlong !~ /\($/; $howlong .= "$hours:"; } my $minutes = int ($timeleft / 60); $timeleft -= $minutes * 60; $howlong .= "0" if $minutes < 10 && $howlong !~ /\($/; $howlong .= sprintf ("%d:%02d = ", $minutes, $timeleft); } $howlong .= "until " . getshortdate (time + $time) . ")"; return $howlong; } # main program starts here getargs (); if (@cmds == 0) { exit 0 if $didsomething; die "$usage\nNeed something to do!\n"; } print $versioninfo, "\n"; print "Running in -notreally (script testing) mode...\n" if $notreally; opencomm (); $linenum = 0; $filename = ""; while (@cmds) { $cmd = shift @cmds; $linenum++; execute_command ($cmd); } close (COMM);