# -*- mode:perl; tab-width:4; c-basic-offset:4; c-indent-level:4; indent-tabs-mode:nil;  -*-
# Copyright (C) 2009, Bret McDanel <trixter AT 0xdecafbad.com>  
#    
# Version: MPL 1.1   
#    
# The contents of this file are subject to the Mozilla Public License Version
# 1.1 (the "License"); you may not use this file except in compliance with  
# the License. You may obtain a copy of the License at 
# http://www.mozilla.org/MPL/   
#    
# Software distributed under the License is distributed on an "AS IS" basis, 
# WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License  
# for the specific language governing rights and limitations under the 
# License.    
#    
# The Original Code is Yaesu CAT EEPROM alignment configuration backup tool 
#    
# The Initial Developer of the Original Code is  
# Bret McDanel <trixter AT 0xdecafbad.com>   
# Portions created by the Initial Developer are Copyright (C)  
# the Initial Developer. All Rights Reserved.   
#    
# Contributor(s):   
#    
# Bret McDanel <trixter AT 0xdecafbad.com>   

package FT8xxCAT;


BEGIN {
    use Exporter ();
    use vars qw($VERSION $DEBUG %OPMODES %TONEMODES $LASTERR $UNDOCUMENTED);
    
    $VERSION = '0.1';
    $DEBUG=0;
    $UNDOCUMENTED=0;
    
    
    %OPMODES = (LSB => 0x00, USB => 0x01, CW => 0x02,
                CWR => 0x03, AM => 0x04, FM => 0x08,
                DIG => 0x0A, PKT => 0x0C, FMN => 0x88
                
        );
    
    %TONEMODES = ('OFF' => 0x8a, 'DCS_ON' => 0x0a, 'DCS_DECODE' => 0x0b,
                  'DCS_ENCODE' => 0x0c, 'CTCSS_ON' => 0x2a,
                  'CTCSS_DECODE' => 0x3a, 'CTCSS_ENCODE' => 0x4a
        );
    $LASTERR=undef;
    
    if( $^O eq "MSWin32") {
        require Win32::SerialPort;
        import Win32::SerialPort;
    } else {
        require Device::SerialPort;
        import Device::SerialPort;
    }
    
}


use strict;

use constant (MAX_RESPONSE => 5);


sub new {
    my($proto,%options) = @_;  # Get reference to object
    # Options of object
    my $class = ref($proto) || $proto;  # Get reference to class
    
    
    $options{'bpsrate'} ||= 9600;
    
    
    if(! defined $options{'serialdev'}) {
        print "You must specify a serial device\n";
        return undef;
    }
    
    my $me = bless \%options, $class;  # Instance $class object
    
    $me->{'port'} = ( ($^O eq "MSWin32") ?
                      (new Win32::SerialPort ($options{'serialdev'})) :
                      (new Device::SerialPort ($options{'serialdev'})) )
        || die "Can't open '/dev/ttyUSB0': $!\n";
    
    
    # Check connection
    unless( ref $me->{'port'} ) {
        return undef;
    }
    
    # Set communication options
    $me->{'port'}->baudrate ( $options{'bpsrate'} );
    $me->{'port'}->databits (8);
    $me->{'port'}->stopbits (2);
    $me->{'port'}->parity  ("none");
    $me->{'port'}->read_char_time(0); # dont wait for each character  
    $me->{'port'}->read_const_time(1000); # 1 second per unfulfilled "read" call 
    return $me;
}


##########
# gets the error 
sub getError {
    my $self = shift;
    return $LASTERR;
}

##########
# clear error
sub clearError {
    my $self = shift;
    my $err = $LASTERR;
    $LASTERR=undef;
    return $err;
}


##########
# sets the debug value
sub setDebug {
    my $self = shift;
    my $debug = shift;
    
    if(defined $debug) {
        $DEBUG = $debug;
    }
    
    return $DEBUG;
    
}

##########
# sets the use of undocumented commands
sub setUndocumented {
    my $self = shift;
    my $undocumented = shift;
    
    if(defined $undocumented) {
        $UNDOCUMENTED = $undocumented;
    }
    return $UNDOCUMENTED;
}


##########
# internal logging function
sub _log {
    my $self = shift;
    my $message = shift;
    
    if($DEBUG) {
        print "[DEBUG] $message\n";
    }
}


##################
# Sends the raw argument straight to the serial port
sub _Send {
    my $self  = shift;
    my $data1 = shift;
    my $data2 = shift;
    my $data3 = shift;
    my $data4 = shift;
    my $opcode = shift;
    
    if(! defined $opcode) {
        return "Send: Invalid arguments!";
    }
 
    # sanity checking
    if ($data1>255 || $data2>255 ||$data3>255 ||$data4>255) {
        return "invalid input!";
    }
   
    $self->_log(sprintf "Sending: %02x %02x %02x %02x %02x",
                $data1, $data2, $data3, $data4, $opcode);
    
    my $count_out = $self->{'port'}->write(chr($data1).chr($data2).chr($data3).chr($data4).chr($opcode));
    return "write failed: $!" unless ($count_out);
    return "write incomplete" if ($count_out != 5);
    return undef;
}


#############
# Receives data from the serial port.
sub _Receive {
    my $self = shift;
    my $bytes = shift;
    
    if(! defined $bytes) {
        $bytes = MAX_RESPONSE;
    }
    
    my ($count_in, $buf) = $self->{'port'}->read($bytes);
    
    my $dbg= "Received: ";
    for (my $i=0; $i<$count_in;$i++) {
        $dbg.=sprintf "%s ", unpack("H*", substr($buf,$i,1));
    }
    $self->_log($dbg);
    
    return $buf;
}



############
# locks the knob
# returns 0xf0 if already locked 0 if unlocked
sub lock {
    my $self = shift;
    
    my $resp = $self->_Send(0x00,0x00,0x00,0x00,0x00);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}

##########
# unlocks the knob
# returns 0xf0 if already unlocked 0 if locked
sub unlock {
    my $self = shift;
    
    my $resp = $self->_Send(0x00,0x00,0x00,0x00,0x80);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}

##########
# presses the PTT
# returns 0xf0 if ptt already pressed, 0 if not pressed
sub pressPTT {
    my $self = shift;
    
    my $resp = $self->_Send(0x00,0x00,0x00,0x00,0x08);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}

##########
# releases the PTT
# returns 0xf0 if ptt already released, 0 if pressed
sub releasePTT {
    my $self = shift;
    
    my $resp = $self->_Send(0x00,0x00,0x00,0x00,0x88);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}


##########
# tunes the active VFO in hz
# returns 0xf0 if freq is invalid, 0 if valid
sub setFrequency {
    my $self = shift;
    my $freq = shift;
    
    if(! defined $freq || $freq =~ m/\D/) {
        return "You must specify a valid frequency";
    }
    
    my $p4 = hex(substr($freq,-3,2)) | 0;
    my $p3 = hex(substr($freq,-5,2)) | 0;
    my $p2 = hex(substr($freq,-7,2)) | 0;
    my $p1 = hex(substr($freq,-9,2)) | 0;
    
    my $resp = $self->_Send($p1,$p2,$p3,$p4,0x01);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}



##########
# sets the operating mode
# returns 0
sub setMode {
    my $self = shift;
    my $mode = shift;
    
    if(!defined $mode || !defined $OPMODES{uc($mode)}) {
        return "You must specify a valid mode";
    }
    
    my $resp = $self->_Send($OPMODES{uc($mode)},0,0,0,0x07);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}

##########
# enables the clarifier
# returns 0xf0 if already set 0 otherwise
sub enableClarifier {
    my $self = shift;
    
    my $resp = $self->_Send(0,0,0,0,0x05);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}

##########
# disables the clarifier
# returns 0xf0 if already disabled 0 otherwise
sub disableClarifier {
    my $self = shift;
    
    my $resp = $self->_Send(0,0,0,0,0x85);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}

##########
# sets the clarifier frequency
# returns 0xf0 if freq out of range 0 on success
sub setClarifier {
    my $self = shift;
    my $freq = shift;
    
    if(! defined $freq || $freq =~ m/^[^\+\-\D]/) {
        $LASTERR = "You must specify a valid offset and sign";
        return 0xf0;
    }
    
    $freq =~ m/^([\+-])(\d+)$/;
    
    my $freq = $2;
    my $p4 = hex(substr($freq,-2,2)) | 0;
    my $p3 = hex(substr($freq,-4,2)) | 0;
    
    my $p1 = ($1 eq "+" ? 0:1);
    
    my $resp = $self->_Send($p1,0x00,$p3,$p4,0xF5);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}

##########
# VFO Toggle
# returns nothing
sub toggleVFO {
    my $self = shift;
    
    my $resp = $self->_Send(0,0,0,0,0x81);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    $self->_Receive(1);
    return undef;
}


##########
# Enable Split
# returns 0xf0 if already enabled 0 otherwise
sub enableSplit {
    my $self=shift;
    my $resp = $self->_Send(0,0,0,0,0x02);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}

##########
# Disable Split
# returns 0xf0 if already enabled 0 otherwise
sub disableSplit {
    my $self=shift;
    my $resp = $self->_Send(0,0,0,0,0x82);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}

##########
# Set repeater offset direction (+-simp)
# returns 0xf0 on error
sub repeaterOffset {
    my $self=shift;
    my $mode=shift;
    
    if($mode eq "-") {
        $mode = 0x09;
    } elsif ($mode eq "+") {
        $mode = 0x49;
    } elsif ($mode eq "0") {
        $mode = 0x89;
    } else {
        return "You must enter a valid mode";
    }
    
    my $resp = $self->_Send($mode,0,0,0,0x09);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    $self->_Receive(1);
    return undef;
}


##########
# Set repeater offset frequency in hz
# returns nothing
sub repeaterOffsetFrequency {
    my $self=shift;
    my $freq=shift;
    
    if(! defined $freq || $freq =~ m/\D/) {
        return "You must specify a valid frequency";
    }
    
    my $p4 = hex(substr($freq,-3,2)) | 0;
    my $p3 = hex(substr($freq,-5,2)) | 0;
    my $p2 = hex(substr($freq,-7,2)) | 0;
    my $p1 = hex(substr($freq,-9,2)) | 0;
    
    my $resp = $self->_Send($p1,$p2,$p3,$p4,0xF9);
    return $resp if $resp;
    $self->_Receive(1);
    return undef;
}

##########
# Sets the tone encoding/decoding scheme
# returns 0xf0 on error
sub toneMode {
    my $self=shift;
    my $mode=shift;
    
    if(!defined $mode || !defined $TONEMODES{uc($mode)}) {
        $LASTERR= "You must specify a valid mode";
        return 0xf0;
    }
    
    
    my $resp = $self->_Send($TONEMODES{uc($mode)},0,0,0,0x0a);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    $self->_Receive(1);
    return undef;
}


##########
# Set the CTCSS tone for Tx/Rx
# returns 0xff0 if tone is invalid 0 otherwise
sub setCTCSSTone {
    my $self=shift;
    my $txtone=shift;
    my $rxtone=shift;
    
    if (!defined $txtone || !defined $rxtone || 
        $txtone =~ /\D/ || $rxtone =~ /\D/) {
        $LASTERR= "You must specify a valid tone";
        return 0xf0
    }
    
    my $p4 = hex(substr($rxtone,-2,2)) | 0;
    my $p3 = hex(substr($rxtone,-4,2)) | 0;
    my $p2 = hex(substr($txtone,-2,2)) | 0;
    my $p1 = hex(substr($txtone,-4,2)) | 0;
    
    my $resp = $self->_Send($p1,$p2,$p3,$p4,0x0b);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}

##########
# Set the DCS tone for Tx/Rx
# returns 0xf0 if tone is invalid 0 otherwise
sub setDCSTone {
    my $self=shift;
    my $txtone=shift;
    my $rxtone=shift;
    
    if (!defined $txtone || !defined $rxtone || 
        $txtone =~ /\D/ || $rxtone =~ /\D/) {
        $LASTERR= "You must specify a valid tone";
        return 0xf0;
    }
    
    my $p4 = hex(substr($rxtone,-2,2)) | 0;
    my $p3 = hex(substr($rxtone,-4,2)) | 0;
    my $p2 = hex(substr($txtone,-2,2)) | 0;
    my $p1 = hex(substr($txtone,-4,2)) | 0;
    
    my $resp = $self->_Send($p1,$p2,$p3,$p4,0x0c);
    if($resp) {
        $LASTERR=$resp;
        return 0xf0;
    }
    return ord($self->_Receive(1));
}



##########
# Rx status
# return hash of values
sub getRxStatus {
    my $self=shift;
    my $resp = $self->_Send(0,0,0,0,0xe7);
    if($resp) {
        $LASTERR=$resp;
        return undef;
    }
    $resp = ord($self->_Receive(1));
    
    my %data = ( # bit 5 is dummy data
                 squelch => ($resp & 0b10000000 ? 1:0),
                 tone => ($resp & 0b01000000 ? 1:0),
                 discriminator => ($resp & 0b00100000 ? 1:0),
                 smeter => ($resp & 0b00001111)
        );
    # The S meter is 0x01 for S1 ... 0x09 for S9, 0x0A for 10dB over S9,
    # 0x0B for 20dB over S9 ... to 0x0F
    
    return %data;
}



##########
# Tx status
# return hash of values
sub getTxStatus {
    my $self=shift;
    my $resp = $self->_Send(0,0,0,0,0xf7);
    
    if($resp) {
        $LASTERR=$resp;
        return undef;
    }
    $resp = ord($self->_Receive(1));
    
    if($resp == 0xff) {
        return undef;
    }
    
    my %data = ( # bit 5 is dummy data
                 # ministry of truth says 0 is on 1 is off
                 ptt => ($resp & 0b10000000 ? 0:1),
                 hi_swr => ($resp & 0b01000000 ? 1:0),
                 # freedom is slavery
                 split => ($resp & 0b00100000 ? 0:1),
                 po_meter => ($resp & 0b00001111)
        );
    return %data;
}


##########
# get other Rx status
# return hash of data
sub getFrequency {
    my $self=shift;
    my $resp = $self->_Send(0,0,0,0,0x03);
    if($resp) {
        $LASTERR=$resp;
        return undef;
    }
    $resp = $self->_Receive(5);
    
    my %freq = (
        frequency => "",
        mode => ord(substr($resp,4,1))
        );
    
    my $i;
    for($i=0;$i<4;$i++) {
        $freq{'frequency'}.=sprintf "%s", unpack("H*", substr($resp,$i,1));
    }
    
    foreach my $key (keys %OPMODES) {
        if ($OPMODES{$key} eq $freq{'mode'}) {
            $freq{'mode'} = $key;
            last;
        }
    }
    
    return %freq;
    
}


##########
# UNDOCUMENTED - get Tx state
# returns 0 if unkeyed 0xf0 if keyed
# does not appear to work on the FT-897, use getTxStatus
sub getTxState {
    my $self=shift;
    if($UNDOCUMENTED!=0) {
        my $resp = $self->_Send(0,0,0,0,0x10);
        if($resp) {
            $LASTERR=$resp;
            return undef;
        }
        $resp= $self->_Receive(1);
        return ord($resp);
    } else {
        $LASTERR="Disabled";
        return undef;
    }
    
}

##########
# UNDOCUMENTED - reads 2 bytes from the eeprom,
sub readEeprom {
    my $self=shift;
    my $msb=shift;
    my $lsb=shift;
    if($UNDOCUMENTED!=0) {
        if(!defined $lsb || !defined $msb) {
            $LASTERR="You must set a valid address";
            return undef;
        }
        my $resp = $self->_Send($msb,$lsb,0,0,0xBB);
        if($resp) {
            $LASTERR=$resp;
            return undef;
        }
        $resp= $self->_Receive(2);
        return $resp;
    } else {
        $LASTERR="Disabled";
        return undef;
    }
}

##########
# UNDOCUMENTED - reads 2 bytes from the eeprom,
# USE EXTREME CAUTION
sub writeEeprom {
    my $self=shift;
    my $msb=shift;
    my $lsb=shift;
    my $data1=shift;
    my $data2=shift;
    if($UNDOCUMENTED!=0) {
        if(!defined $lsb || !defined $msb) {
            $LASTERR="You must set a valid address";
            return undef;
        }
        my $resp = $self->_Send($msb,$lsb,$data1,$data2,0xBC);
        if($resp) {
            $LASTERR=$resp;
            return undef;
        }
        $resp= $self->_Receive(1);
        return ord($resp);
    } else {
        $LASTERR="Disabled";
        return undef;
    }
}

##########
# UNDOCUMENTED - gets radio config
sub getRadioConfig {
    my $self=shift;
    if($UNDOCUMENTED!=0) {
        my $resp = $self->_Send(0,0,0,0,0xa7);
        if($resp) {
            $LASTERR=$resp;
            return undef;
        }
        return $self->_Receive(9);
    } else {
        $LASTERR="Disabled";
        return undef;
    }
}


##########
# UNDOCUMENTED - get Tx metering
sub getTxMetering {
    my $self=shift;
    if($UNDOCUMENTED!=0) {
        my $resp = $self->_Send(0,0,0,0,0xbd);
        if($resp) {
            $LASTERR=$resp;
            return undef;
        }
        my $resp = $self->_Receive(2);
        if (length $resp != 2) {
            return undef;
        }
        
        $resp = unpack("H*",$resp);
        my $nyb1=ord(pack("h",substr($resp,0,1)));
        my $nyb2=ord(pack("h",substr($resp,1,1)));
        my $nyb3=ord(pack("h",substr($resp,2,1)));
        my $nyb4=ord(pack("h",substr($resp,3,1)));
        
        my %data = (
            pwr => $nyb1,
            vswr => $nyb2,
            alc => $nyb3,
            mod => $nyb4
            );
        return %data;
    } else {
        $LASTERR="Disabled";
        return undef;
    }
    
}


##########
# UNDOCUMENTED - reset to pre-alignment factory defaults
# “Luke: What's in there?
# Yoda: Only what you take with you.”
# IF YOU DO NOT HAVE A BACKUP OF YOUR CALIBRATION SETTINGS
# YOU WILL NOT HAVE A CALIBRATED RADIO. IT WILL UNDERPERFORM
# YOU HAVE BEEN WARNED - THERE IS PROBABLY NO REASON TO EVER USE THIS
sub factoryResetandEraseAlignment {
    my $self=shift;
    if($UNDOCUMENTED!=0) {
        my $resp = $self->_Send(0,0,0,0,0xbe);
        if($resp) {
            $LASTERR=$resp;
            return undef;
        }
        return $self->_Receive(1);
    } else {
        $LASTERR="Disabled";
        return undef;
    }
}


1;