#!/usr/bin/perl
# TinyTrak Configuration Utility            V1.3                  04.01.09
#  Copyright (C) 2001-2009 Rolf Bleher   http://www.dk7in.de

#  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, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

#  see file COPYING for details

#--------------------------------------------------------------------------

# symbols file from XASTIR, change the path for your environment
$SYMBFILE = "/usr/share/xastir/symbols/symbols.dat";

# default port for TinyTrak device, you can change it here
#   or call the program with the device as parameter
$port = "/dev/ttyS0";

#--------------------------------------------------------------------------

# you need to have these modules installed on your system,
# you can find them on CPAN
use Tk;
use Tk::TFrame;
use Time::HiRes qw(sleep);
use Device::SerialPort;

END {
    if ($v24) {
      $v24->rts_active(0);
      $v24->close;
      undef $v24;
    }
}

#--------------------------------------------------------------------------

foreach $arg (@ARGV) {
  if ($arg =~ /\/dev\/ttyS/) {
    $port = $arg;
  }
}

#--------------------------------------------------------------------------
# Standard settings
$txdly1   = 200;
$bcrate1  = 60;
$interlv  = 3;
$squelch  = 2;
$symbol   = '>';
$table    = '/';
$txdly2   = 200;
$bcrate2  = 300;
$calib    = 63;
$mycall   = 'NOCALL';
$path     = 'RELAY,WIDE';
$info     = 'TinyTrak DK7IN V1.6';
$msgtype  = 1;     # message type   En Route       see @strmsg
$genpath  = 0;     # conventional path             see @strpath
#--------------------------------------------------------------------------
$baud     = 4800;                      # baudrate for serial interface
$ESC      = chr(0x1b);
$tone     = 0;
$inpstr   = '';
$parstr   = '';
%sympix = ();
%symtxt = ();
$lasttable  = $table;
$lastsymbol = $symbol;
$tablist = "/\\";
@strmsg   = ('Off Duty','En Route','In Service','Returning',
             'Committed','Special','Priority','Emergency');
@strpath  = ('Conventional','WIDE1-1','WIDE2-2','WIDE3-3','WIDE4-4',
             'WIDE5-5','WIDE6-6','WIDE7-7','North','South','East',
             'West','North + WIDE','South + WIDE','East  + WIDE',
             'West  + WIDE');
setuppics();
#storepics();    # store icons as XPM files

#--< window setup >--------------------------------------------------------
# +-APRS----------------------------+ +-Timing-------------------------------+
# | MyCall       DK7IN-2            | |        Beacon rate [s]  TxDelay [ms] |
# | Mic-E Path   Conventional       | | primary  ===60======   ====198====   |
# | Path         RELAY,WIDE5-5      | |                                      |
# +---------------------------------+ | second   ====300====   ====198====   |
# +-Info----------------------------+ |                                      |
# | Table   /    Symbol  >     ICON | | Quiet    =2=========  +-Test---------|
# | MIC-E Message   En Route        | |                       | 1200   2200  |
# | Info     Rolf, QRV DB0TA  Test  | | Calibr   ===63======  | Mixed  Stop  |
# | Info every  =3========= beacons | +--------------------------------------+
# +---------------------------------+
# +---------------------------------+       |Version|   |Read|   |Write|
# |            status line          |
# +---------------------------------+

$mw = MainWindow->new;
$mw->title('DK7IN  TinyTrak Configuration');
$status = $mw->Label(-textvariable => \$statusmsg, 
                     -borderwidth => 2,
                     -relief => 'groove');
#-------------
$aprs_f   = $mw->TFrame(-label => [ -text => 'APRS' ],
                        -relief => 'groove', 
                        -borderwidth => 2);

$mycl_l   = $aprs_f->Label(-text => 'MyCall');
$mycl_e   = $aprs_f->Entry(-textvariable => \$mycall);

$micep_l  = $aprs_f->Label(-text => "Mic-E Path");
$path_txt = $strpath[$genpath];
$micep_om = $aprs_f->Optionmenu(-variable => \$genpath,
                               -textvariable => \$path_txt,
                               -options  => [["Conventional", 0],
                                             ["WIDE1-1",      1],
                                             ["WIDE2-2",      2],
                                             ["WIDE3-3",      3],
                                             ["WIDE4-4",      4],
                                             ["WIDE5-5",      5],
                                             ["WIDE6-6",      6],
                                             ["WIDE7-7",      7],
                                             ["North",        8],
                                             ["South",	      9],
                                             ["East",	     10],
                                             ["West",	     11],
                                             ["North + WIDE",12],
                                             ["South + WIDE",13],
                                             ["East  + WIDE",14],
                                             ["West  + WIDE",15]]);

$path_l   = $aprs_f->Label(-text => 'Path');
$path_e   = $aprs_f->Entry(-textvariable => \$path);

$mycl_l->grid(  -row => 0, -column => 0, -sticky => "w",-padx => 4);
$mycl_e->grid(  -row => 0, -column => 1, -sticky => "w");
$micep_l->grid( -row => 1, -column => 0, -sticky => "w",-padx => 4);
$micep_om->grid(-row => 1, -column => 1, -sticky => "w");
$path_l->grid(  -row => 2, -column => 0, -sticky => "w",-padx => 4);
$path_e->grid(  -row => 2, -column => 1, -sticky => "w");
#-------------
$info_f   = $mw->TFrame(-label => [ -text => 'Info' ],
                        -relief => 'groove',
                        -borderwidth => 2);

$tabl_l   = $info_f->Label(-text => 'Table');
$tabl_e   = $info_f->Entry(-textvariable => \$table, -width => 3,
                           -justify => 'center', -insertontime => 0);
$tabl_e->bind("<KeyPress>", [\&settable, Ev('A')]);
$tabl_e->bind("<Up>", [\&tabinc]);
$tabl_e->bind("<Down>", [\&tabdec]);
$tabl_e->bind("<KP_Up>", [\&tabinc]);
$tabl_e->bind("<KP_Down>", [\&tabdec]);

$symb_l   = $info_f->Label(-text => 'Symbol');
$symb_e   = $info_f->Entry(-textvariable => \$symbol, -width => 3,
                           -justify => 'center', -insertontime => 0);
$symb_e->bind("<KeyPress>", [\&setsymbol, Ev('A')]);
$symb_e->bind("<Up>", [\&syminc]);
$symb_e->bind("<Down>", [\&symdec]);
$symb_e->bind("<KP_Up>", [\&syminc]);
$symb_e->bind("<KP_Down>", [\&symdec]);

$pix0     = $info_f->Pixmap(-data => getpic("  "));
$pix      = $info_f->Pixmap(-data => getpic($table.$symbol));
$pix_l    = $info_f->Label(-image => $pix);

$msgt_l   = $info_f->Label(-text => "Mic-E Msg");
$msgt_txt = $strmsg[$msgtype];
$msgt_om  = $info_f->Optionmenu(-variable => \$msgtype,
                                -textvariable => \$msgt_txt,
                                -options  => [["Off Duty",  0],
                                              ["En Route",  1],
                                              ["In Service",2],
                                              ["Returning", 3],
                                              ["Committed", 4],
                                              ["Special",   5],
                                              ["Priority",  6],
                                              ["Emergency", 7]]);

$info_l   = $info_f->Label(-text => 'Info');
$info_e   = $info_f->Entry(-textvariable => \$info);
$info_l->grid($info_e,'-','-');

$inft1_l = $info_f->Label(-text => 'Info every');
$inft_sc = $info_f->Scale(-from=>1,-to=>255,
                         -variable=>\$interlv,
                         -orient=>"horizontal",-sliderlength=>20);
$inft2_l = $info_f->Label(-text => 'Beacons');
$inft1_l->grid($inft_sc,$inft2_l,'-');

$tabl_l->grid(  -row => 0, -column => 0, -sticky => "w",-padx => 4);
$tabl_e->grid(  -row => 0, -column => 1, -sticky => "w");
$symb_l->grid(  -row => 0, -column => 2, -sticky => "w");
$symb_e->grid(  -row => 0, -column => 3, -sticky => "w");
$pix_l->grid(   -row => 0, -column => 4, -padx => 5);

$msgt_l->grid(  -row => 1, -column => 0, -sticky => "w",-padx => 4);
$msgt_om->grid( -row => 1, -column => 1, -sticky => "w", -columnspan => 4);
$info_l->grid(  -row => 2, -column => 0, -sticky => "w",-padx => 4);
$info_e->grid(  -row => 2, -column => 1, -sticky => "w", -columnspan => 4);
$inft1_l->grid( -row => 3, -column => 0, -sticky => "w",-padx => 4);
$inft_sc->grid( -row => 3, -column => 1, -sticky => "w", -columnspan => 2);
$inft2_l->grid( -row => 3, -column => 3, -sticky => "w", -columnspan => 2);

#----------
$time_f  = $mw->TFrame(-label => [ -text => 'Timing' ],
                       -relief => 'groove',
                       -borderwidth => 2);

$prim_l  = $time_f->Label(-text => "Primary\nTiming", -justify => 'left');
$brt1_sc = $time_f->Scale(-from=>10,-to=>2550,-resolution=>10,
                         -label=>'Beacon Rate [s]', -variable=>\$bcrate1,
                         -orient=>"horizontal",-sliderlength=>20);
$txd1_sc = $time_f->Scale(-from=>6.6,-to=>1689.6,-resolution=>6.6,
                         -label=>'TxDelay [ms]', -variable=>\$txdly1,
                         -orient=>"horizontal",-sliderlength=>20);

$scnd_l  = $time_f->Label(-text => "Secondary\nTiming", -justify => 'left');
$brt2_sc = $time_f->Scale(-from=>10,-to=>2550,-resolution=>10,
                         -variable=>\$bcrate2,
                         -orient=>"horizontal",-sliderlength=>20);
$txd2_sc = $time_f->Scale(-from=>6.6,-to=>1689.6,-resolution=>6.6,
                         -variable=>\$txdly2,
                         -orient=>"horizontal",-sliderlength=>20);

$quiet_l  = $time_f->Label(-text => 'Quiet Time [s]');
$quiet_sc = $time_f->Scale(-from=>1,-to=>255,
                         -variable=>\$squelch,
                         -orient=>"horizontal",-sliderlength=>20);

$calib_l  = $time_f->Label(-text => 'Calibration');
$calib_sc = $time_f->Scale(-from=>30,-to=>150,
                         -variable=>\$calib,
                         -orient=>"horizontal",-sliderlength=>20);
#----------
$serv_f = $time_f->TFrame(-label => [ -text => 'Test' ],
                          -relief => 'groove',
                          -borderwidth => 2);
$s1k2_b = $serv_f->Button(-text => '1200',  -width => 3, -height => 1, -activebackground => '#FFBB00', -state => "disabled", -command => \&set1200);
$s2k2_b = $serv_f->Button(-text => '2200',  -width => 3, -height => 1, -activebackground => '#FFBB00', -state => "disabled", -command => \&set2200);
$smix_b = $serv_f->Button(-text => 'Mixed', -width => 3, -height => 1, -activebackground => '#FFBB00', -state => "disabled", -command => \&setmixed);
$stop_b = $serv_f->Button(-text => 'Stop',  -width => 3, -height => 1, -activebackground => '#FFBB00', -state => "disabled", -command => \&stoptone);
$s1k2_b->grid($s2k2_b);
$smix_b->grid($stop_b);
#----------
$prim_l->grid(  -row => 0, -column => 0, -sticky => "w",-padx => 4);
$brt1_sc->grid( -row => 0, -column => 1, -sticky => "w");
$txd1_sc->grid( -row => 0, -column => 2, -sticky => "w");
$scnd_l->grid(  -row => 1, -column => 0, -sticky => "w",-padx => 4);
$brt2_sc->grid( -row => 1, -column => 1, -sticky => "w");
$txd2_sc->grid( -row => 1, -column => 2, -sticky => "w");
$quiet_l->grid( -row => 2, -column => 0, -sticky => "w",-padx => 4);
$quiet_sc->grid(-row => 2, -column => 1, -sticky => "w");
$serv_f->grid(  -row => 2, -column => 2, -rowspan => 2);
$calib_l->grid( -row => 3, -column => 0, -sticky => "w",-padx => 4);
$calib_sc->grid(-row => 3, -column => 1, -sticky => "w");

#----------
$pgm_f   = $mw->Frame();
$vers_b  = $pgm_f->Button(-text => 'Version', -width => 5, -height => 1, -activebackground => '#FFFF00', -state => "disabled", -command => \&version);
$read_b  = $pgm_f->Button(-text => 'Read',    -width => 5, -height => 1, -activebackground => '#FFFF00', -state => "disabled", -command => \&readpar);
$write_b = $pgm_f->Button(-text => 'Write',   -width => 5, -height => 1, -activebackground => '#FFFF00', -state => "disabled", -command => \&writepar);

$vers_b->grid( -row => 0, -column => 0, -padx => 10);
$read_b->grid( -row => 0, -column => 1, -padx => 10);
$write_b->grid(-row => 0, -column => 2, -padx => 10);

$aprs_f->grid(-row => 0, -column => 0, -sticky => "nsew",-padx => 2);
$info_f->grid(-row => 1, -column => 0, -rowspan => 2,-padx => 2);
$status->grid(-row => 3, -column => 0, -sticky => "ew",-padx => 2,-pady => 3);
$time_f->grid(-row => 0, -column => 1, -sticky => "n", -rowspan => 2,-padx => 2);
$pgm_f->grid( -row => 2, -column => 1, -sticky => "n", -rowspan => 2, -pady => 6);

$mw->resizable(0,0);
$statusmsg = 'initialising...';
$mw->update();

#--< start processing >----------------------------------------------------

if (initserial()) {                          # open V.24
  $mw->after(1000, sub { ttinit1() });       # continue init after 1 sec
  MainLoop();
  exit;
} else {
  $statusmsg = 'error opening '.$port;
  MainLoop();
  exit;
}

#--------------------------------------------------------------------------

#--------------------------------------------------------------------------

sub ttinit1 {
  $statusmsg = $port.' opened';
  $mw->update();
  $v24->rts_active(1);                       # power up TinyTrak
  $mw->after(2000, sub { ttinit2() });       # activate buttons after 2 sec
}

#--------------------------------------------------------------------------

sub ttinit2 {
  resync();
  $s1k2_b->configure( -state => "normal");     # enable all buttons
  $s2k2_b->configure( -state => "normal");
  $smix_b->configure( -state => "normal");
  $stop_b->configure( -state => "normal");
  $vers_b->configure( -state => "normal");
  $read_b->configure( -state => "normal");
  $write_b->configure(-state => "normal");
}

#--------------------------------------------------------------------------

sub setsymbol {
  my ($entry,$key) = @_;
  my $chg = 0;
  if ($key ne '') {
#    if (($key ge "#" && $key le "{")||($key eq "!" || $key eq "}")) {
    if ($key ge "!" && $key le "}") { $chg = 1 }
  }
  if ($chg) {
    $symbol = $key;
    $lastsymbol = $symbol;
    $pix_l->configure(-image => $pix0);
    $pix->configure(-data => getpic($table.$symbol));
    $pix_l->configure(-image => $pix);
  } else {
    $symbol = $lastsymbol;
  }
  $statusmsg = gettxt($table.$symbol);
  $status->update();
}

#--------------------------------------------------------------------------

sub syminc {
  my $sym = chr(ord($lastsymbol)+1);
  if ($sym gt "}") {
    $sym = "!";
    tabinc();
  }
  $symbol = $sym;
  $lastsymbol = $symbol;
  $pix_l->configure(-image => $pix0);
  $pix->configure(-data => getpic($table.$symbol));
  $pix_l->configure(-image => $pix);
  $statusmsg = gettxt($table.$symbol);
  $status->update();
}

#--------------------------------------------------------------------------

sub symdec {
  my $sym = chr(ord($lastsymbol)-1);
  if ($sym lt "!") { 
    $sym = "}";
    tabdec();
  }
  $symbol = $sym;
  $lastsymbol = $symbol;
  $pix_l->configure(-image => $pix0);
  $pix->configure(-data => getpic($table.$symbol));
  $pix_l->configure(-image => $pix);
  $statusmsg = gettxt($table.$symbol);
  $status->update();
}

#--------------------------------------------------------------------------

sub settable {    # / primary  \ alternate
  my ($entry,$key) = @_;
  my $chg = 0;
  if ($key ne '') {
    if ($key eq "/" || $key eq "\\") {
      $chg = 1;
    }
  }
  if ($chg) {
    $table = $key;
    $lasttable = $table;
    $pix_l->configure(-image => $pix0);
    $pix->configure(-data => getpic($table.$symbol));
    $pix_l->configure(-image => $pix);
  } else {
    $table = $lasttable;
  }
  $statusmsg = gettxt($table.$symbol);
  $status->update();
}

#--------------------------------------------------------------------------

sub tabinc {
  my $i;
  for ($i=0;$i<length($tablist);$i++) {
    last if ($lasttable eq substr($tablist,$i,1));
  }
  $i++;
  if ($i >= length($tablist)) { $i = 0 }
  $table = substr($tablist,$i,1);
  $lasttable = $table;
  $pix_l->configure(-image => $pix0);
  $pix->configure(-data => getpic($table.$symbol));
  $pix_l->configure(-image => $pix);
  $statusmsg = gettxt($table.$symbol);
  $status->update();
}

#--------------------------------------------------------------------------

sub tabdec {
  my $i;
  for ($i=0;$i<length($tablist);$i++) {
    last if ($lasttable eq substr($tablist,$i,1));
  }
  $i--;
  if ($i < 0) { $i = length($tablist)-1 }
  $table = substr($tablist,$i,1);
  $lasttable = $table;
  $pix_l->configure(-image => $pix0);
  $pix->configure(-data => getpic($table.$symbol));
  $pix_l->configure(-image => $pix);
  $statusmsg = gettxt($table.$symbol);
  $status->update();
}

#--------------------------------------------------------------------------

sub setuppics {
  my $table  = '';
  my $symbol = '';
  my $pixstr;
  my $str;
  my ($i,$j,$c);
  my $line;
  my $head;
  my $descr = 0;
  my $txt;
  if (-f $SYMBFILE) {
    if (open(FH, "<$SYMBFILE")) {
SYM:  while(<FH>) {
        last if (/DONE/);
        if (/TABLE (.)/) {
          $table = $1;
          if(length($_)>20) { $descr = 1 }
          next;
        }
        if (/APRS (.)/) {
          $symbol = $1;
          next if ($table ne '/' && $table ne '\\');   # ignore other
          $txt = "";
          if ($descr) {
            if(length($_)>20) {
                $txt = substr($_,20);
            }
            $txt =~ s/^\s*//;
            $txt =~ s/(\(.+\))*\s*$//;
          }
          my %col = ();
          $pixstr = '';
          for ($i=0;$i<20;$i++) {
            $line = <FH>;
            $line =~ s/\n//;
            $line =~ s/\r//;
            next SYM if (length($line) != 20);
            $pixstr .= "\"$line\"".(($i<19)?",\n":'');
            for ($j=0;$j<20;$j++) {
              $c = substr($line,$j,1);
              $col{$c} = $c;
            }
          }
          $pixstr .= "};\n";
          $head = ''; $j = 0;
          foreach $c (keys %col) {
            $head .= colstr($c);
            $j++;
          }
          $sympix{$table.$symbol} = "/* XPM */{\"20 20 $j 1 \",\n".$head.$pixstr;
          $symtxt{$table.$symbol} = $txt;
        }
      }
      close(FH);
    }
  }
  $str = "/* XPM */{\"20 20 1 1 \",\n"."\". c None\",\n";
  for ($i=0;$i<20;$i++) {
    $str .= "\"....................\",\n";
  }
  $sympix{"  "} = $str . "};\n";
}

#--------------------------------------------------------------------------

sub colstr {                                 # setup string for color
  my ($c) = @_;
  my @coltab = qw(FFFF00 CD6500 A020F0 CCCCCC CD0000 FF4040 CD3333 00008B 00BFFF 006400 EE0000 00CD00 0000CD FFFFFF 878787 5A5A5A 454545 000000 None);
  if ($c eq '#') {                           # Yellow
    $cidx = 0;
  } elsif ($c ge 'a' && $c le 'q') {
    $cidx = ord($c)-ord('a')+1;
  } else {
    return("\"$c c None\",\n");              # transparent
  }
  return("\"$c c #$coltab[$cidx]\",\n");
}

#--------------------------------------------------------------------------

sub getpic {
  my ($id) = @_;
  $str = $sympix{$id};
  if (! $str) {
    $str = $sympix{"  "};      # default
  }
  $str;
}

#--------------------------------------------------------------------------

sub gettxt {
  my ($id) = @_;
  $str = $symtxt{$id};
  if (! $str) {
    $str = "";      # default
  }
  $str;
}

#--------------------------------------------------------------------------

sub getpicfile {
  my ($id) = @_;
  $fname = "Icons/".sprintf("Aprs%2.2X%2.2X.xpm",ord(substr($id,0,1)),ord(substr($id,1,1)));
  if (! -f $fname) {
    $fname = "Icons/Aprs2020.xpm";
  }
  $fname;
}

#--------------------------------------------------------------------------

sub storepics {                              # extract all icons to files
  foreach $cc (keys %sympix) {
    $fname = sprintf("Aprs%2.2X%2.2X.xpm",ord(substr($cc,0,1)),ord(substr($cc,1,1)));
    if (open(FH,">$fname")) {
      printf(FH "%s",getpic($cc));
      close(FH);
    }
  }
}

#--------------------------------------------------------------------------

sub version() {                              # get and display version string
  if ($tone) { 
    stoptone();
  } else {
    resync();
  }
  $statusmsg = 'reading...';
  $status->update();
  $v24->write($ESC."V");
  sleep(1);
  ($cnt,$str) = $v24->read(30);            # read max 30 char
  if ($cnt > 11) {                         # original has 13 chr, mine 19
    $statusmsg = $str;
  } else {
    $statusmsg = 'error reading version';
    resync();
  }
}

#--------------------------------------------------------------------------

sub readpar {
  if ($tone) { stoptone() }
  $statusmsg = 'reading...';
  $status->update();
  $v24->write($ESC."U");                     # read parameter (upload) command
  sleep(1);                                  # wait for data coming in
  ($cnt,$inpstr) = $v24->read(70);           # read max 70 char
  if ($cnt == 64) {
    $ptr_path = ord(substr($inpstr,0,1));
    $txdly1   = ord(substr($inpstr,1,1))*6.6;
    $bcrate1  = ord(substr($inpstr,2,1))*10;
    $interlv  = ord(substr($inpstr,3,1));
    $ptr_msg  = ord(substr($inpstr,4,1));
    $squelch  = ord(substr($inpstr,5,1));     # quiet time in sec
    $msgtype  = ord(substr($inpstr,6,1));     # detination field bits
    $genpath  = ord(substr($inpstr,7,1));     # info field bits
    $symbol   = substr($inpstr,8,1);
    $lastsymbol = $symbol;
    $table    = substr($inpstr,9,1);
    $lasttable = $table;
    $txdly2   = ord(substr($inpstr,10,1))*6.6;
    $bcrate2  = ord(substr($inpstr,11,1))*10;
    $calib    = ord(substr($inpstr,12,1));
    $rawpath  = substr($inpstr,$ptr_path,$ptr_msg-$ptr_path);
    $info     = substr($inpstr,$ptr_msg,64-$ptr_msg);
    $info     =~ s/\x00.*$//;
    $path     = substr($rawpath,0,int(length($rawpath)/7)*7);
    $mycall   = mice2path(substr($path,0,7));
    $path     = mice2path(substr($path,7));
    $path_txt = $strpath[$genpath];
    $msgt_txt = $strmsg[$msgtype];
    $statusmsg = 'ok';
    $pix_l->configure(-image => $pix0);
    $pix->configure(-data => getpic($table.$symbol));
    $pix_l->configure(-image => $pix);
  } else {
    $statusmsg = 'error reading parameters';
  }
}

#--------------------------------------------------------------------------

sub writepar() {
  if ($tone) { stoptone() }
  $statusmsg = '';
  $status->update();
  $mycall  = uc($mycall);
  if ($mycall !~ /^[A-Z0-9]{2,6}(-((\d)|(1[0-5])))?$/) {
    $statusmsg = 'syntax error in MyCall';
    return();
  }
  $path    = uc($path);
  if ($path !~ /^[A-Z0-9]{2,6}(-((\d)|(1[0-5])))?(,[A-Z0-9]{2,6}(-((\d)|(1[0-5])))?)*$/) {
    $statusmsg = 'syntax error in Path';
    return();
  }
  $parstr  = chr(0x0d);                     # pointer to path string
  $addr    = path2mice($mycall).path2mice($path);  # setup path
  $pathlen = length($addr);
  $addr    = substr($addr,0,$pathlen-1).chr(ord(substr($addr,-1))+1);  # add 1 to last char
  $addr   .= chr(0x03).chr(0xf0).chr(0x00); # Control field, Protocol ID, EOL
  $parstr .= chr(int($txdly1/6.6+0.49));    # prim TxDelay
  $parstr .= chr(int($bcrate1/10));         # prim Beacon Rate
  $parstr .= chr($interlv);                 # Comment Interleave
  $parstr .= chr(0x0d+$pathlen+3);          # pointer to comment string
  $parstr .= chr($squelch);                 # Quiet Time
  $parstr .= chr($msgtype);                 # message type
  $parstr .= chr($genpath);                 # generic APRS path
  $parstr .= $symbol.$table;                # symbol and table
  $parstr .= chr(int($txdly2/6.6+0.49));    # scnd TxDelay
  $parstr .= chr(int($bcrate2/10));         # scnd Beacon Rate
  $parstr .= chr($calib);                   # calibration value
  $parstr .= $addr;                         # source / digipeater addresses
  $parstr .= $info;                         # comment
  $parstr = substr($parstr,0,63).chr(0x00);
  while (length($parstr) < 64) { $parstr .= $ESC }
  $outstr = $ESC.'D'.$parstr;
  $statusmsg = 'writing...';
  $status->update();
  for ($i=0;$i<length($outstr);$i++) {
    # this does not work anymore with newer Perl versions: ???
    # $v24->write(substr($outstr,$i,1));
    # this is working (thanks to DM2FCO):
    $v24->write(chr(ord(substr($outstr,$i,1))));
    sleep(0.02);                            # max 20ms for EEPROM programming
  }
  $v24->write($ESC."U");                    # reread data
  sleep(1);                                 # wait for data coming in
  ($cnt,$inpstr) = $v24->read(70);          # read max 70 char
  if ($inpstr eq $parstr) {
    $statusmsg = 'parameters written';
  } else {
    $statusmsg = 'error writing parameters';
  }
}

#--------------------------------------------------------------------------

sub resync {
  my $i;  
  for ($i=0;$i<10;$i++) {
    $v24->write($ESC);
  }
  $v24->write('X');
}

#--------------------------------------------------------------------------

sub set1200() {
  if ($tone) { stoptone() }
  $statusmsg = '1200 Hz tone';
  $status->update();
  $tone = 1;
  $v24->write($ESC."T0");
  $s1k2_b->configure(-background => '#FF0000',-activebackground => '#FF0000');
  $s1k2_b->update();
}

#--------------------------------------------------------------------------

sub set2200() {
  if ($tone) { stoptone() }
  $statusmsg = '2200 Hz tone';
  $status->update();
  $tone = 1;
  $v24->write($ESC."T1");
  $s2k2_b->configure(-background => '#FF0000',-activebackground => '#FF0000');
  $s2k2_b->update();
}

#--------------------------------------------------------------------------

sub setmixed() {
  if ($tone) { stoptone() }
  $statusmsg = 'mixed 1200/2200 Hz tone';
  $status->update();
  $tone = 1;
  $v24->write($ESC."TM");
  $smix_b->configure(-background => '#FF0000',-activebackground => '#FF0000');
  $smix_b->update();
}

#--------------------------------------------------------------------------

sub stoptone() {
  $statusmsg = 'cancel tone...';
  $status->update();
  $tone = 0;
  $s1k2_b->configure(-background => '#d9d9d9', -activebackground => '#FFBB00');
  $s2k2_b->configure(-background => '#d9d9d9', -activebackground => '#FFBB00');
  $smix_b->configure(-background => '#d9d9d9', -activebackground => '#FFBB00');
  $serv_f->update();
  $v24->write(chr(0x00).chr(0x00).chr(0x00).chr(0x00).chr(0x00).chr(0x00).chr(0x00));
  sleep(2);
  $statusmsg = '';
  $status->update();
  resync();
}

#--------------------------------------------------------------------------

sub initserial {
    $v24 = Device::SerialPort->new ($port);
    return(0) unless ($v24);
    $v24->baudrate($baud) || return(0);
    $v24->databits(8);
    $v24->parity("none");
    $v24->stopbits(1);
    $v24->handshake('none');
    $v24->rts_active(0);
    $v24->write_settings  || return(0);
    return(1);
}

#--------------------------------------------------------------------------

sub path2mice {                             # shift left every char
  my ($str) = @_;
  my $i;
  my @calls = split(',',$str);
  my $call;
  $str = '';
  foreach $call (@calls) {
    $str .= txt2p($call);
  }
  my $nstr = '';
  for ($i=0;$i<length($str);$i++) {
    $nstr .= chr(ord(substr($str,$i,1))*2); # shift every char to left
  }
  $nstr;
}

#--------------------------------------------------------------------------

sub txt2p {
  my ($str) = @_;
  my ($call,$ssid);
  if ($str =~ /(.*)-((\d)|(1[0-5]))/) {
    $call = $1;
    $ssid = $2+0;
  } else {
    $call = $str;
    $ssid = 0;
  }
  while (length($call) < 6) { $call .= ' ' }
  $call .= chr(ord('0') + $ssid);
  $call;
}

#--------------------------------------------------------------------------

sub mice2path {                             # shift right every char
  my ($str) = @_;
  my $i;
  my $nstr = '';
  for ($i=0;$i<length($str);$i++) {
    $nstr .= chr(int(ord(substr($str,$i,1))/2));  # shift every char to right
  }
  $str = '';
  while (length($nstr)>0) {
    if (length($str)>0) { $str .= ',' }
    $str .= p2txt(substr($nstr,0,7));
    $nstr = substr($nstr,7);
  }
  $str;
}

#--------------------------------------------------------------------------

sub p2txt {
  my ($str) = @_;
  my $ssid = ord(substr($str,6,1))-ord(0);
  if ($ssid==0) { 
    $ssid = '';
  } else {
    $ssid = sprintf("%d",$ssid);
  }
  my $call = substr($str,0,6);
  $call =~ s/\s//g;
  if ($ssid) { $call .= '-'.$ssid }
  $call;
}

#--------------------------------------------------------------------------
