File Coverage

blib/lib/Game/Tibia/Packet/Charlist.pm

Criterion	Covered	Total	%
statement	65	67	97.0
branch	11	22	50.0
condition	4	9	44.4
subroutine	11	11	100.0
pod	2	2	100.0
total	93	111	83.7

use strict;
use warnings;
use v5.16.0;
package Game::Tibia::Packet::Charlist;

# ABSTRACT: Character list packet support for the MMORPG Tibia
our $VERSION = '0.005'; # VERSION

use Carp;
use Game::Tibia::Packet;

use constant DLG_MOTD     => 0x14;
use constant DLG_INFO     => 0x15;
use constant DLG_ERROR    => 0x0a;
use constant DLG_CHARLIST => 0x64;

my $default = Game::Tibia::Packet::version(860);

=pod

=encoding utf8

=head1 NAME

Game::Tibia::Packet::Charlist - Character list packet support for the MMORPG Tibia


=head1 SYNOPSIS

    use Game::Tibia::Packet::Charlist;

    my $p = Game::Tibia::Packet::Charlist->new(
        packet => $packet,
        xtea    => $xtea,
        version => 830
    );

    $p->{premium_days} = 0xff;
    $sock->send($p->finalize);


=head1 DESCRIPTION

Decodes Tibia Login packets into hashes and vice versa.

=cut

=head1 METHODS AND ARGUMENTS

=over 4

=item new([packet => $packet, xtea => $xtea, version => 860])

Constructs a new Game::Tibia::Packet::Charlist instance. When C and C are specified, the supplied packet is decrypted and is then retrievable with the C subroutine.

=cut

sub new {
	my $class = shift;

	my $self = {
        packet => undef,
        xtea    => undef,
        version => $default,

        @_
    };

    croak "Packet was specified without XTEA key" if defined $self->{packet} && !defined $self->{xtea};
    $self->{version} = Game::Tibia::Packet::version $self->{version} unless ref $self->{version};

    if (defined $self->{packet}) {
        my $packet = Game::Tibia::Packet->new(
            packet  => $self->{packet},
            xtea    => $self->{xtea},
            version => $self->{version},
        );

        my $payload = $packet->payload;
        (my $type, $payload) = unpack 'Ca*', $payload;
        if      ($type eq DLG_MOTD) {
            ($self->{motd}, $payload) = unpack '(S/a)< a*', $payload;
        } elsif ($type eq DLG_INFO) {
            ($self->{info}, $payload) = unpack '(S/a)< a*', $payload;
        } elsif ($type eq DLG_ERROR) {
            ($self->{error}, $payload) = unpack '(S/a)< a*', $payload;
        }
        ($type, $payload) = unpack 'Ca*', $payload;
        if ($type eq DLG_CHARLIST) {
            (my $count, $payload) = unpack 'Ca*', $payload;
            $self->{characters} = undef;
            my @chars;
            while ($count--) {
                my $char;
                ($char->{name}, $char->{world}{name}, $char->{world}{ip}, $char->{world}{port}, $payload)
                = unpack '(S/a S/a a4 S)< a*', $payload;
                $char->{world}{ip} = join '.', unpack('C4', $char->{world}{ip});
                push @chars, $char;
            }
            $self->{characters} = \@chars;
        }
        $self->{premium_days} = unpack 'S<', $payload;
    }

	bless $self, $class;
	return $self;
}

=item finalize([$xtea]])

Finalizes the packet. encrypts with XTEA and prepends header

=cut


sub finalize {
	my $self = shift;
    my $xtea = shift // $self->{xtea};

    my $packet = Game::Tibia::Packet->new(version => $self->{version});
    $packet->payload .= pack '(C S/a)<', DLG_MOTD, $self->{motd} if defined $self->{motd};
    $packet->payload .= pack '(C S/a)<', DLG_INFO, $self->{info} if defined $self->{info};
    $packet->payload .= pack '(C S/a)<', DLG_ERROR, $self->{error} if defined $self->{error};
    if (defined $self->{characters} && @{$self->{characters}} > 0) {
    $packet->payload .= pack 'C C', DLG_CHARLIST, scalar @{$self->{characters}};
        foreach my $char (@{$self->{characters}}) {
            $packet->payload .= pack '(S/a S/a a4 S)<',
                $char->{name}, $char->{world}{name},
                pack("C4", split('\.', $char->{world}{ip})), $char->{world}{port};
        }
    }
    $packet->payload .= pack('S<', $self->{premium_days}); # pacc days
    return $packet->finalize($xtea);
}


1;
__END__