view release on metacpan or  search on metacpan

lib/Acme/RFC4824.pm  view on Meta::CPAN

XEOF
    $self->{'ascii2art_map'}->{'Q'} = << 'XEOF';
__0/
  | 
 / \
XEOF
    $self->{'ascii2art_map'}->{'R'} = << 'XEOF';
__0__
  | 
 / \
XEOF
    $self->{'ascii2art_map'}->{'S'} = << 'XEOF';
__0 
  |\
 / \
XEOF
    $self->{'ascii2art_map'}->{'T'} = << 'XEOF';
\0|
 | 
/ \
XEOF
    $self->{'ascii2art_map'}->{'U'} = << 'XEOF';
\0/
 | 
/ \
XEOF
    $self->{'ascii2art_map'}->{'V'} = << 'XEOF';
|0 
 |\
/ \
XEOF
    $self->{'ascii2art_map'}->{'W'} = << 'XEOF';
 0/_
 | 
/ \
XEOF
    $self->{'ascii2art_map'}->{'X'} = << 'XEOF';
 0/
 |\
/ \
XEOF
    $self->{'ascii2art_map'}->{'Y'} = << 'XEOF';
\0__
 | 
/ \
XEOF
    $self->{'ascii2art_map'}->{'Z'} = << 'XEOF';
 0__
 |\
/ \
XEOF
    return 1;
}

sub decode {
    my $self    = shift;
    my $arg_ref = shift;

    my $frame   = $arg_ref->{FRAME};
    if (! defined $frame) {
        croak "You need to pass a frame to be decoded.";
    }
    my $last_frame_undo = rindex $frame, 'T';
    if ($last_frame_undo > 0) {
        # if a FUN was found, take everything to the right to be the
        # new frame.
        $frame = 'Q' . substr($frame, $last_frame_undo + 2);
    }
    while ($frame =~ m{ (.*) [^S]S (.*) }xms) {
        # delete the signal before a 'S' (SUN, signal undo)
        $frame = $1 . $2;
    }
    $frame =~ s/[U-Y]//g; # ignore ACK, KAL, NAK, RTR and RTT signals
    my ($header, $payload, $checksum) =
        ($frame =~ m{\A Q([A-E][A-B][A-P]{2}) ([A-P]+) ([A-P]{4})R \z}xms);
    if (! defined $header || ! defined $payload || ! defined $checksum) {
        croak "Invalid frame format.";
    }
    return $self->__pack($payload);
}

sub __pack {
    my $self  = shift;
    my $frame = shift;

    # convert from ASCII to hex
    $frame =~ tr/A-J/0-9/;
    $frame =~ tr/K-P/a-f/;
    return pack('H*', $frame);
}

sub __unpack {
    my $self = shift;
    my $data = shift;

    # unpack
    my $result = unpack('H*', $data);
    $result =~ tr/0-9/A-J/;
    $result =~ tr/a-f/K-P/;
    return $result;
}

sub encode {
    my $self    = shift;
    my $arg_ref = shift;

    my $sfs_frame = 'Q'; # Frame Start FST

    # type is ASCII or ASCII-ART
    my $type = 'ASCII';
    if (defined $arg_ref->{TYPE}) {
        $type = $arg_ref->{TYPE};
    }
    if ($type ne 'ASCII' && $type ne 'ASCII art') {
        croak "Invalid output type";
    }

    my $packet = $arg_ref->{PACKET};
    if (! defined $packet || ! length($packet)) {
        croak "You need to pass an IP packet";
    }