#!perl -w
#
# this script tries to talk ppp over a serial line
#
# see rfc1661 + rfc1662
#
use strict;
use threads;
use Device::Modem;

# todo: create packet construction framework
#
# http://search.cpan.org/~cosimo/Device-Modem-1.47/docs/Modem.pod
# http://search.cpan.org/~bbirth/Win32-SerialPort-0.19/lib/Win32API/CommPort.pm
# http://search.cpan.org/~bbirth/Win32-SerialPort-0.19/lib/Win32/SerialPort.pm

# general flow : 

# receiveframe -> ppp_unescape -> ppp_deframe -> decodeframe
#  read            7d(.)          7e .... 7e     c021/c023/8021
#
#     c021   LCP
#     c023   PAP
#     8021   IPCP



$|=1;
$Device::Modem::TIMEOUT  = 100;

my $modem = new Device::Modem( port => "COM10" );


if( ! $modem->connect(baudrate => 115200) ) {
    die "could not connect to modem\n";
}
print "modem connect\n";

sleep(5);
$modem->attention();
#$modem->atsend("ATI1\r");
#print $modem->answer(200);

$modem->dial("*99#");
print "modem dialed\n";

my $ppp= PPP->new(port=>$modem->port);

my $frame = $ppp->receiveframe();
print "frame received\n";
my $uframe= $ppp->ppp_unescape($frame);
my $dframe= $ppp->ppp_deframe ($uframe);

my $pkt = $ppp->decodeframe($dframe);

use Dumpvalue;
my $d= new Dumpvalue;
$d->dumpValue($pkt);

#$ppp->sendframe(PPP::LCP::ConfAck($pkt->lcp->confreq->{options}));

exit(0);

package FCSCalc;
use integer;

our @EXPORT=qw(pppfcs16);

my @fcs16tab;
INIT {
    print("func FCSCalc::INIT\n");
    my $poly= 0x8408;
    for (my $b=0 ; $b<256 ; $b++) {
        my $v= $b;
        my $i= 8;
        while ($i--) {
            $v = $v&1 ? ($v>>1)^$poly : $v>>1;
        }
        push @fcs16tab, $v&0xffff;
    }
}

sub pppfcs16 {
    my $fcs= @_>1 ? $_[1] : 0xffff;
    printf("func FCSCalc::pppfcs16\n");
    $fcs = ($fcs>>8) ^ $fcs16tab[($fcs^ord(substr($_[0],$_,1)))&0xff] for (0..length($_[0])-1);
    return $fcs;
}
package PPP;
use strict;
#use FCSCalc;

my %protocols;
my %lcpcodes;
my %lcpoptions;

BEGIN {

# http://www.iana.org/assignments/ppp-numbers
%protocols= (
    0xc021=> { decoder=>\&lcp_decoder,  name=>"LCP" },
    0xc023=> { decoder=>\&pap_decoder,  name=>"PAP" },
    0x8021=> { decoder=>\&ipcp_decoder, name=>"IPCP" },
);
%lcpcodes= (
    1=>{decoder=>\&lcp_confreq, name=>"ConfReq" },
    2=>{decoder=>\&lcp_confack, name=>"ConfAck" },
    3=>{decoder=>\&lcp_confnak, name=>"ConfNak" },
    4=>{decoder=>\&lcp_confrej, name=>"ConfRej" },
    5=>{ name=>"TermReq" },
    6=>{ name=>"TermAck" },
    7=>{ name=>"CodeRej" },
    8=>{ name=>"ProtRej" },
    9=>{ name=>"EchoReq" },
   10=>{ name=>"EchoRep" },
   11=>{ name=>"DiscReq" },
   12=>{ name=>"Ident" },
   13=>{ name=>"TimeRem" },
   14=>{ name=>"RstReq" },
   15=>{ name=>"RstRep" },
);
%lcpoptions= (
   1=>{decoder=>\&lcpopt_mru, name=>"MRU" },  # Maximum-Receive-Unit
   2=>{decoder=>\&lcpopt_asyncmap, name=>"Asyncmap" },  # Async-Control-Character-Map
   3=>{decoder=>\&lcpopt_auth, name=>"Auth" },  # Authentication-Protocol
   4=>{ name=>"Quality" },  # Quality-Protocol
   5=>{ name=>"MagicNr" },  # Magic-Number
#   6=>{decoder=>\&lcpopt_, name=>"" },  # DEPRECATED (Quality-Protocol)
   7=>{ name=>"ProtComp" },  # Protocol-Field-Compression
   8=>{ name=>"AdrCtlComp" },  # Address-and-Control-Field-Compression
   9=>{ name=>"FCSAlt" },  # FCS-Alternatives				[RFC1570]
  10=>{ name=>"SelfPad" },  # Self-Describing-Pad				[RFC1570]
  11=>{ name=>"Numbered" },  # Numbered-Mode				[RFC1663]
#  12=>{decoder=>\&lcpopt_, name=>"" },  # DEPRECATED (Multi-Link-Procedure)
  13=>{ name=>"Callback" },  # Callback					[RFC1570]
#  14=>{decoder=>\&lcpopt_, name=>"" },  # DEPRECATED (Connect-Time)
#  15=>{decoder=>\&lcpopt_, name=>"" },  # DEPRECATED (Compound-Frames)
#  16=>{decoder=>\&lcpopt_, name=>"" },  # DEPRECATED (Nominal-Data-Encapsulation)
#  17=>{decoder=>\&lcpopt_, name=>"" },  # Multilink-MRRU                              [RFC1717]
#  18=>{decoder=>\&lcpopt_, name=>"" },  # Multilink-Short-Sequence-Number-Header      [RFC1717]
#  19=>{decoder=>\&lcpopt_, name=>"" },  # Multilink-Endpoint-Discriminator            [RFC1717]
#  20=>{decoder=>\&lcpopt_, name=>"" },  # Proprietary                                     [KEN]
#  21=>{decoder=>\&lcpopt_, name=>"" },  # DCE-Identifier                            [SCHNEIDER]
#  22=>{decoder=>\&lcpopt_, name=>"" },  # Multi-Link-Plus-Procedure                     [Smith]
#  23=>{decoder=>\&lcpopt_, name=>"" },  # Link Discriminator for BACP                 [RFC2125]
  24=>{ name=>"LCPAuth" },  # LCP-Authentication-Option                   [Culbert]
# 25=>{decoder=>\&lcpopt_, name=>"" },  # Consistent Overhead Byte Stuffing (COBS)    [Carlson],

# 26=>{decoder=>\&lcpopt_, name=>"" },  # Prefix elision                              [Bormann]
# 27=>{decoder=>\&lcpopt_, name=>"" },  # Multilink header format                     [Bormann]
# 28=>{decoder=>\&lcpopt_, name=>"" },  # Internationalization			       [RFC2484]	
# 29=>{decoder=>\&lcpopt_, name=>"" },  # Simple Data Link on SONET/SDH               [Carlson]
# 30=>{decoder=>\&lcpopt_, name=>"" },  # Reserved until 14-Oct-2002                     [CFox]
);
}
sub new {
    my ($class, %params)= @_;
    my $self= bless \%params, $class;

    $self->{previousread}= "";
    $self->set_charmap(0xffffffff);

    return $self;
}
sub set_charmap {
    my ($self, $bitmap)= @_;
    $self->{charmap}= "}~".join("", map { chr($_) } grep { $bitmap & (1<<$_) } (0..31));
}

sub receiveframe {
    my ($self)= @_;
    printf("func PPP::receiveframe\n");

    my $frame= $self->{previousread};
    while ($frame !~ /\x7e.*?\x7e/) {
        $frame .= $self->{port}->read(1024);
    }

    if ($frame =~ /\x7e.*?\x7e/gs) {
        my $pos= pos($frame);
        $self->{previousread}= substr($frame, $pos);

        if ($pos && $pos > length($&)) {
            push @{$self->{discarded}}, substr($frame, 0, $pos-length($&));
            printf("discarded: %s\n", unpack("H*", substr($frame, 0, $pos-length($&))));
        }

        $frame = substr($frame, $pos-length($&), length($&));
    }

    return $frame;
}

# calculate FCS, as detailed in rfc1662.txt appendix C.
sub calc_fcs { 
    return FCSCalc::pppfcs16(@_);
}

# decode rfc1662.txt section 3.1 frame
sub ppp_deframe {
    my ($self, $data)= @_;
    printf("func PPP::ppp_deframe(%s)\n", unpack("H*", $data));
    if ($data =~ /^\x7e\xff\x03(.*?)(..)\x7e$/s) {
        my ($frame, $lcs)= ($1, unpack("n", $2));

        my $calcfcs= calc_fcs(substr($data,1,length($data)-2));

        if ($calcfcs != 0xf0b8 ) {
            printf("frame check error fcs(%s) = %04x\n", unpack("H*", substr($data,1,length($data)-2)), $calcfcs);
            return;
        }

        return $frame;
    }
    else {
        printf("invalid frame: %02x %02x %02x ... %02x\n", ord(substr($data,0,1)), ord(substr($data,1,1)), ord(substr($data,2,1)), ord(substr($data,-1,1)));
    }
}

# handle rfc1662.txt section 4.2 - transparency
sub ppp_unescape {
    my ($self, $data)= @_;
    $data =~ s/\x7d(.)/$1^' '/egs;

    return $data;
}
sub ppp_escape {
    my ($self, $data)= @_;
    $data =~ s/[$self->{charmap}]/"\x7d".($1^' ')/egs;

    return $data;
}

sub decodeframe {
    my ($self, $frame)= @_;
    printf("func PPP::decodeframe(%s)\n", unpack("H*", $frame));
    my ($proto, $data)= unpack("na*", $frame);

    my %info = (
        proto => $proto,
    );
    if (exists $protocols{$proto}) { 
        $info{name} = $protocols{$proto}{name};
        if (exists $protocols{$proto}{decoder}) {
            $info{decoded} = $protocols{$proto}{decoder}->($self, $data);
        }
    }

    return \%info;
}
sub lcp_decoder {
    my ($self, $frame)= @_;
    printf("func PPP::lcp_decoder(%s)\n", unpack("H*", $frame));

    my ($code, $ident, $len, $data)= unpack("CCna*", $frame);
    my %info= (
        code=>$code,
        ident=>$ident,
    );

    if ($len-4 < length($data) ) {
        printf("extra data in lcp packet: %s\n", unpack("H*", substr($data, $len-4)));
    }
    elsif ($len-4 > length($data) ) {
        printf("lcp packet too short %d > %d : %s\n", $len-4, length($data), unpack("H*", $data));
    }
    if (exists $lcpcodes{$code}) {
        $info{name} = $lcpcodes{$code}{name};
        if (exists $lcpcodes{$code}{decoder}) {
            $info{decoded}= $lcpcodes{$code}{decoder}->($self, $data);
        }
    }
}
sub parse_lcp_options {
    my ($self, $frame)= @_;
    printf("func PPP::parse_lcp_options (%s)\n", unpack("H*", $frame));
    my $ofs= 0;
    my @options;
    while ($ofs<length($frame)) {
        my ($option, $len)= unpack("CC", substr($frame, $ofs,2));
        if ($ofs+$len>length($frame)) {
            printf("option longer than frame\n");
        }
        my $optiondata= substr($frame, $ofs+2, $len-2);

        my %info= (
            option=>$option,
        );
        if (exists $lcpoptions{$option}) {
            $info{name}= $lcpoptions{$option}{name};
            if (exists $lcpoptions{$option}{decoder}) {
                $info{decoded}= $lcpoptions{$option}{decoder}->($self, $optiondata);
            }
        }

        push @options, \%info;


        $ofs += $len;
    }
    return \@options;
}
sub lcp_confreq {
    printf("func PPP::lcp_confreq\n");
    return parse_lcp_options(@_);
}
sub lcp_confack {
    printf("func PPP::lcp_confack\n");
    return parse_lcp_options(@_);
}
sub lcp_confnak {
    printf("func PPP::lcp_confnak\n");
    return parse_lcp_options(@_);
}
sub lcp_confrej {
    printf("func PPP::lcp_confrej\n");
    return parse_lcp_options(@_);
}
# sub lcp_termreq {
#     return "";
# }
# sub lcp_termack {
#     return "";
# }
# sub lcp_coderej {
#     return "";
# }
# sub lcp_protrej {
#     return "";
# }
# sub lcp_echoreq {
#     return "";
# }
# sub lcp_echorep {
#     return "";
# }
# sub lcp_discreq {
#     return "";
# }
# sub lcp_ident {
#     return "";
# }  
# sub lcp_timerem {
#     return "";
# }
# sub lcp_rstreq {
#     return "";
# } 
# sub lcp_rstrep {
#     return "";
# } 



# sub pap_decoder {
#     my ($frame)= @_;
#     return "";
# }
# sub ipcp_decoder {
#     my ($frame)= @_;
#     return "";
# }
sub lcpopt_mru {
    my ($self, $data)= @_;
    if (length($data)!=2) {
        printf("lcpopt_mru - data!=short : %s\n", unpack("H*", $data));
    }
    return unpack("n", $data);
}
sub lcpopt_asyncmap {
    my ($self, $data)= @_;
    if (length($data)!=4) {
        printf("lcpopt_asyncmap - data!=long : %s\n", unpack("H*", $data));
    }
    $self->set_charmap(unpack("N", $data));
    return unpack("N", $data);
}
sub lcpopt_auth {
    my ($self, $data)= @_;
    if (length($data)!=2) {
        printf("lcpopt_auth - data!=short : %s\n", unpack("H*", $data));
    }
    return unpack("n", $data);
}