File Coverage

blib/lib/Game/Tibia/Cam.pm
Criterion Covered Total %
statement 101 118 85.5
branch 23 50 46.0
condition 6 17 35.2
subroutine 21 21 100.0
pod 8 8 100.0
total 159 214 74.3


line stmt bran cond sub pod time code
1 2     2   110983 use strict;
  2         4  
  2         59  
2 2     2   9 use warnings;
  2         4  
  2         126  
3             package Game::Tibia::Cam;
4              
5             # ABSTRACT: Read/Convert TibiCam .rec files to pcaps
6             our $VERSION = '0.003'; # VERSION
7              
8 2     2   11 use Carp;
  2         3  
  2         119  
9 2     2   548 use Game::Tibia::Packet::Login 0.006;
  2         34933  
  2         63  
10 2     2   574 use Net::PcapWriter;
  2         22334  
  2         59  
11 2     2   16 use Time::HiRes;
  2         4  
  2         13  
12 2     2   168 use Scalar::Util 'openhandle';
  2         4  
  2         1913  
13              
14             =pod
15              
16             =encoding utf8
17              
18             =head1 NAME
19              
20             Game::Tibia::Cam - Read/Convert TibiCam .rec files to pcaps
21              
22              
23             =head1 SYNOPSIS
24              
25             # cam2pcap script
26             use Game::Tibia::Cam;
27             local $/;
28             print Game::Tibia::Cam->new(rec => <>)->pcap;
29              
30              
31             =head1 DESCRIPTION
32              
33             With programs like TibiCam, Tibia game sessions can be saved to a custom format and replayed with a modified game client.
34              
35             This plugin allows conversion between some of these formats and the more main-stream pcap format.
36              
37             =head1 METHODS AND ARGUMENTS
38              
39             =over 4
40              
41             =item new(rec => $recording, [is_str => undef])
42              
43             Here, the [] indicate an optional parameter.
44              
45             Constructs a new C instance. C<$recording> is either a binary string
46             resulting from reading a recording in the C<*.rec> format or the filename of such a recording.
47              
48             When C<$is_str> is C, the type of C<$recording>'s contents is inferred from the first bytes.
49              
50             Function croaks if opening file fails.
51              
52             =cut
53              
54             sub new {
55 2     2 1 265 my $class = shift;
56              
57 2         10 my $self = {
58             @_
59             };
60              
61 2         17 $self->{sig} = unpack 'S>', $self->{rec};
62 2   33     17 $self->{is_str} //= _getversion($self->{sig});
63              
64 2 50       6 unless ($self->{is_str}) {
65 0         0 my $file = $self->{rec};
66 0 0 0     0 croak 'No file name provided' if !defined $file || $file eq '';
67              
68 0         0 local $/;
69 0 0       0 open(my $fh, '<:raw', $file) or croak "Failed to open file '$file' for reading: $!";
70              
71 0         0 my $self->{rec} = <$fh>;
72 0         0 close($fh);
73              
74 0 0       0 croak "Reading from '$file' returned undef" unless defined $self->{rec};
75             }
76              
77 2         7 $self->{sig} = unpack 'S>', $self->{rec};
78 2         6 ($self->{min_version}, $self->{max_version}) = _getversion($self->{sig});
79 2   33     7 $self->{max_version} //= $self->{min_version};
80              
81 2 50       9 croak "Not a valid TibiCam recording" unless defined $self->{min_version};
82 2 50       6 croak 'Encrypted TibiCam files not yet supported' if $self->{sig} >= 0x502;
83              
84             # https://github.com/gurka/OldSchoolTibia/blob/master/tools/libs/recording.py
85 2         8 $self->{ptotal} = unpack 'xx L<', $self->{rec};
86 2 50       9 $self->{ptotal} -= 57 if $self->{sig} >= 0x302;
87 2 50       12 (my $s, $self->{sizesize}) = $self->{sig} == 0x301 ? ('L', 4) : ('S', 2);
88 2         10 $self->{template} = "($s L X[L]X[$s] $s x[L] /a)<";
89              
90 2         4 bless $self, $class;
91 2         6 return $self;
92             };
93              
94             =item ptotal()
95              
96             Returns the total number of packets in the recording. This is C.
97              
98             =cut
99              
100             sub ptotal {
101 3     3 1 15 my $self = shift;
102 3         16 $self->{ptotal};
103             }
104              
105             =item version()
106              
107             Returns the recording's protocol version. If the version can't be precisely determined, return value should be interpreted as C<($min, $max)> instead. Otherwise, C<($ver, $ver)>.
108              
109             =cut
110              
111             sub _getversion {
112 4     4   7 my ($sig) = @_;
113              
114 4 50       12 $sig == 0x301 and return @{[721, 724]};
  4         18  
115 0 0       0 $sig == 0x302 and return @{[730, 760]};
  0         0  
116 0 0       0 $sig == 0x402 and return @{[770]};
  0         0  
117 0 0       0 $sig == 0x502 and return @{[770, 790]};
  0         0  
118 0 0       0 $sig == 0x602 and return @{[810]};
  0         0  
119              
120 0         0 return undef;
121             }
122              
123             sub version {
124 2     2 1 723 my $self = shift;
125              
126             return wantarray ? ($self->{min_version}, ($self->{max_version} // $self->{min_version}))
127 2 100 33     23 : $self->{min_version};
128             }
129              
130             =item pfirst()
131              
132             Returns the first packet in a capture
133              
134             =cut
135              
136             sub _reset {
137 8     8   14 my $self = shift;
138 8         15 my ($offset, $pnum) = @_;
139              
140 8         17 ($self->{offset}, $offset) = ($offset, $self->{offset});
141 8         16 ($self->{pnum}, $pnum) = ($pnum, $self->{pnum});
142 8   100     29 $self->{eof} = ($self->{pnum} // 0) == $self->{ptotal};
143              
144 8         17 return ($offset, $pnum);
145             }
146              
147             sub pfirst {
148 3     3 1 5 my $self = shift;
149              
150 3         12 $self->_reset(6, 0);
151             (undef, $self->{first_ts}, undef)
152 3         48 = unpack $self->{template}, substr($self->{rec}, $self->{offset});
153 3         16 return $self->pnext;
154             }
155              
156             =item pnum()
157              
158             Returns the number of the packet that has just been read by C
159             =cut
160              
161             sub pnum {
162 67     67 1 328 my $self = shift;
163 67         231 $self->{pnum};
164             }
165              
166             =item pnext()
167              
168             Returns the next packet in a capture
169              
170             =cut
171              
172             sub pnext {
173 204     204 1 25479 my $self = shift;
174              
175 204 100       466 return $self->pfirst unless defined $self->{offset};
176 201 100       387 return undef if $self->{eof};
177              
178             (my $len, $self->{last_ts}, my $data)
179 198         1118 = unpack $self->{template}, substr($self->{rec}, $self->{offset});
180             $len == length($data)
181 198 50       457 or croak "Packet length " . length($data) . " smaller than reported $len at offset " . $self->{offset} . "/" . length($self->{rec});
182              
183 198         297 $self->{offset} += $self->{sizesize} + 4 + $len;
184 198 100       388 if (++$self->{pnum} == $self->{ptotal}) {
185 3         5 $self->{eof} = 1;
186 3         10 $self->{duration} = ($self->{last_ts} - $self->{first_ts}) / 1000;
187             }
188              
189 198         751 return { timestamp => $self->{last_ts} / 1000, data => $data }
190             }
191              
192             =item duration()
193              
194             Returns the duration of the clip. This requires traversing all unparsed packets, so calling it after C returns C is preferable.
195              
196             =cut
197              
198             sub _forrest {
199 1     1   2 my $self = shift;
200 1         4 $self->_foreach(@_, $self->_reset);
201             }
202              
203             sub _foreach {
204 2     2   6 my ($self, $code, @off) = @_;
205              
206 2         9 my @pos = $self->_reset(@off); # save seek pointer
207              
208 2 100       6 if (defined $code) {
209 1         4 while (my $p = $self->pnext) { $code->($p); }
  66         95  
210             } else {
211 1         4 while (my $p = $self->pnext) { }
212             }
213              
214 2         11 $self->_reset(@pos); # restore seek pointer
215             }
216              
217              
218             sub duration {
219 2     2 1 277 my $self = shift;
220              
221 2 100       7 unless (defined $self->{duration}) {
222 1         3 $self->_forrest; # Does a lot of useless copies
223             }
224              
225 2         21 return $self->{duration};
226             }
227              
228             =item pcap([ file => undef, synthesize_login => 1])
229              
230             Either creates a new pcap file or append the data to a file handle if specified. In both cases, it returns a file handle for possible further appending. If C is C, which it is by default, a string with the contents is returned instead.
231              
232             Unless, C<< synthesize_login => 0 >>, a Tibia game server login packet is prepended to the pcap. This allows the pcap to be directly read into wireshark and dissected with the Tibia dissector, because otherwise Wireshark wouldn't know for sure what version and possibly XTEA key, the capture has.
233              
234             If RSA encryption is required, the OTServ RSA key is used.
235              
236             =cut
237              
238             sub pcap {
239 1     1 1 4 my $self = shift;
240 1         6 my %args = (
241             synthesize_login => 1,
242             @_
243             );
244              
245 1         12 my $fh = openhandle $args{file};
246              
247 1         4 my $pcap;
248              
249 1 50       7 unless ($fh) {
250 1 50       5 if (defined $args{file}) {
251 0 0       0 open($fh, '>:raw', $args{file}) or croak "Can't open '$args{file}' for pcap: $!";
252             } else {
253 1 50   1   54 open($fh, '>:raw', \$pcap) or croak "Can't open in-memory file for pcap: $!";
  1         14  
  1         3  
  1         11  
254             }
255             }
256              
257 1         1036 my $writer = Net::PcapWriter->new($fh);
258 1         56 my $conn = $writer->tcp_conn('127.0.0.1',57171 => '127.0.0.1',7171);
259              
260              
261 1 50       2879 if ($args{synthesize_login} == 1) {
262 1         6 my $login = Game::Tibia::Packet::Login->new(
263             version => scalar $self->version,
264             character => __PACKAGE__,
265             );
266              
267 1         68 $conn->write(0, $login->finalize);
268             }
269              
270              
271 1         562 my $basetime = Time::HiRes::gettimeofday;
272              
273 1         3 my $n = 0;
274             $self->_foreach(sub {
275 66     66   80 my ($p) = @_;
276 66         176 $conn->write(1, $p->{data}, $basetime + $p->{timestamp});
277 1         8 });
278 1         11 $conn->shutdown(0);
279              
280 1   33     179 return $pcap // $fh;
281             }
282              
283             1;
284             __END__