[aprssig] Field station

[Arne Stahre]

  This is how I did KISS in Perl (Linux). Maybe it still works...

  73 de SM6VYF/Arne

#!/usr/bin/perl -w
# SM6VYF 26-28.X.02
# From C to Common Lisp to Perl...

use strict;

#### - - - - - BEGIN AX.25 code - - - - -
####AX.25 constants
my $FEND =      0xC0;
my $FESC =      0xDB;
my $TFEND =     0xDC;
my $TFESC =     0xDD;
my $KISS_DATA = 0x00;

my $AXALEN =       7;
my $SSID =      0x1E;		#Bitmask
my $CONTROL =   0x03;		#UI
my $PID =       0xF0;		#No layer three

my @rx_buffer = ();
my $index = 0;

my $state = 'SYNCH';

sub change_state {
   my ($new_state) = @_;

   $state = $new_state;
}

sub clear_buffer {
   @rx_buffer = ();
   $index = 0;
}

sub select_buffer {
}

sub to_buffer {
   my ($byte) = @_;

   $rx_buffer[$index++] = $byte;
}

sub reset_kiss {
   clear_buffer();
   change_state('SYNCH');
}

sub call_char {
   my ($str_ref, $index) = @_;

   my $c = chr(($$str_ref[$index] >> 1) & 0x7F);
   return $c ne ' ' ? $c : '';
}

sub pull_call {
   my ($str_ref, $offset) = @_;

   my $ssid_byte = $$str_ref[$offset + ($AXALEN - 1)];
   my $ssid = ($ssid_byte & $SSID) >> 1;

   return (sprintf("%s%s%s%s%s%s%s",
		  call_char($str_ref, $offset + 0),
		  call_char($str_ref, $offset + 1),
		  call_char($str_ref, $offset + 2),
		  call_char($str_ref, $offset + 3),
		  call_char($str_ref, $offset + 4),
		  call_char($str_ref, $offset + 5),
		  $ssid ? "-$ssid" : ''),
	  $ssid_byte & 0x80,	#digid or C bit
	  ! ($ssid_byte & 0x1)); #more
}

sub pull_digis {
   my ($str_ref, $offset) = @_;

   my ($call, $more, $n, $digid, @digi_list);

   $more = 1;
   $n = 0;

   while ($more) {
     ($call, $digid, $more) = pull_call($str_ref, $offset);
     push(@digi_list, $digid ? "$call*" : $call);
     $n += 1 if ($digid);
     $offset += $AXALEN;
   }
   return (@digi_list);
}

sub disp_digis {
   my ($list_ref) = @_;

   return join('', map sprintf(",%s", $_), (@$list_ref));
}

sub extract_frame {

   my ($dest, $source, $digid, $more, @digi_list, $n);

   ($dest, $digid, $more) = pull_call(\@rx_buffer, 0);
   ($source, $digid, $more) = pull_call(\@rx_buffer, $AXALEN);
   if ($more) {
     @digi_list = pull_digis(\@rx_buffer, $AXALEN * 2);
   }

   my $control_byte_index = ($#digi_list + 3) * $AXALEN;
   if (($rx_buffer[$control_byte_index] & 0xCF) == 3) {
    return sprintf("%s>%s%s:%s",
		  $source,
		  $dest,
		  disp_digis(\@digi_list),
		  join('',
		       map(chr($_),
			   splice(@rx_buffer, $control_byte_index + 2))));
   } else {
     return 'OTHER FRAME';
   }
}

sub build_kiss_frame {
   my ($byte) = @_;

   my $ret = 'NO FRAME';

   if ($state eq 'SYNCH') {
      if ($byte eq $FEND) {	#beginning of frame
        change_state('COMMAND');
      }
   } elsif ($state eq 'COMMAND') {
     if ($byte eq $FEND) {	#new beginning of frame
     } elsif (($byte & 0xF) == $KISS_DATA) {
       select_buffer(($byte & 0xF0) >> 4);
       clear_buffer();
       change_state('NORMAL');	#clear buffer
     } else {
       change_state('SYNCH');
     }
   } elsif ($state eq 'NORMAL') {
     if ($byte eq $FEND)	{	#end of frame
       $ret = extract_frame();
       change_state('SYNCH');
     } elsif ($byte eq $FESC) {
       change_state('ESCAPED');
     } else {
       to_buffer($byte);
     }
   } elsif ($state eq 'ESCAPED') {
     if ($byte eq $FEND) {	#end of frame
       $ret = extract_frame();
       change_state('SYNCH');
     } elsif ($byte eq $TFEND) {
       to_buffer($FEND);
       change_state('NORMAL');
     } elsif ($byte eq $TFESC) {
       to_buffer($FESC);
       change_state('NORMAL');
     } else {
       to_buffer($byte);
     }
   }
   return $ret;
}

###Below is the code needed to send KISS-data
sub send_kiss {
   my (@s) = @_;

   write_byte($FEND);
   write_byte($KISS_DATA);
   foreach my $byte (@s) {
     if ($byte eq $FEND) {
       write_byte($FESC);
       write_byte($TFEND);
     } elsif ($byte eq $FESC) {
       write_byte($FESC);
       write_byte($TFESC);
     } else {
       write_byte($byte);
     }
   }
   write_byte($FEND);
}

sub make_call {
   my ($call, $ssid, $more) = @_;

   my @str = split(//, uc($call . '      ')); # ???
   return (ord($str[0]) << 1,
	  ord($str[1]) << 1,
	  ord($str[2]) << 1,
	  ord($str[3]) << 1,
	  ord($str[4]) << 1,
	  ord($str[5]) << 1,
	  ($ssid << 1) | ($more ? 0x0 : 0x1));
}

sub ax25_addr {
   my ($call, $more) = @_;

   if ($call =~ /([A-Z0-9]+)\-(\d+)/) {
     return make_call($1, $2, $more);
   } else {
     return make_call($call, 0, $more);
   }
}

sub write_kiss_frame {
   my ($dest, $source, $path_ref, $message) = @_;

   my @tx_buffer;

   ##Destination
   push(@tx_buffer, ax25_addr($dest, 1));
   ##Source
   push(@tx_buffer, ax25_addr($source, $#$path_ref >= 0));
   ##Digipeaters
   foreach my $i (0 .. $#$path_ref) {
     push(@tx_buffer, ax25_addr($$path_ref[$i], $i != $#$path_ref));
   }
   ##Control & PID
   push(@tx_buffer, $CONTROL);
   push(@tx_buffer, $PID);
   ##Message
   push(@tx_buffer, map(ord($_), split(//, $message)));
   ##TX
   send_kiss(@tx_buffer);
}

#### - - - - - END AX.25 code - - - - -
sub write_byte {
   my ($byte) = @_;

   syswrite(TNC, chr($byte), 1);
}

sub disp_frame {
   my ($str) = @_;

   my $oldfh = select(STDOUT);
   $| = 1;
   print "$str\n";
   select($oldfh);
   $| = 1;
}

my $tty = '/dev/ttyS0';
my ($rin, $rout) = ('', '');
my ($win, $wout) = ('', '');
my ($byte, $c) = ('', '');

reset_kiss();

system("stty 19200 -echo -cstopb raw < $tty");

open(TNC, "+<$tty") or die("Open error: $1");
binmode(TNC);
select(TNC);
$|=1;

vec($rin, fileno(TNC), 1) = 1;
vec($win, fileno(STDIN), 1) = 1;

while (select(undef, $wout=$win, undef, 1)) {
#  write_kiss_frame('APRS', 'SM6VYF-13', ['WIDE2-2'],
#		   '!5743.60N/01146.43E.Perl KISS interface test');

   while (select($rout=$rin, undef, undef, 1)) { # $wout=$win
     sysread(TNC, $byte, 1);
     $c = build_kiss_frame(ord($byte));
     last if ($c ne 'NO FRAME');
   }
   disp_frame($c);# if ($c ne 'OTHER FRAME');
}

close(TNC);