File Coverage

blib/lib/Cassandra/Client/Protocol.pm
Criterion Covered Total %
statement 40 187 21.3
branch 0 64 0.0
condition 0 24 0.0
subroutine 11 35 31.4
pod 0 24 0.0
total 51 334 15.2


line stmt bran cond sub pod time code
1             package Cassandra::Client::Protocol;
2             our $AUTHORITY = 'cpan:TVDW';
3             $Cassandra::Client::Protocol::VERSION = '0.13_004'; # TRIAL
4              
5 1     1   14 $Cassandra::Client::Protocol::VERSION = '0.13004';use 5.010;
  1         4  
6 1     1   4 use strict;
  1         2  
  1         16  
7 1     1   4 use warnings;
  1         1  
  1         20  
8              
9 1     1   390 use Encode;
  1         6947  
  1         83  
10              
11             require Exporter;
12             our @ISA= qw(Exporter);
13              
14 1     1   333 use Cassandra::Client::Error::Base;
  1         2  
  1         27  
15 1     1   263 use Cassandra::Client::Error::ReadTimeoutException;
  1         3  
  1         23  
16 1     1   256 use Cassandra::Client::Error::WriteTimeoutException;
  1         2  
  1         23  
17 1     1   251 use Cassandra::Client::Error::UnavailableException;
  1         3  
  1         55  
18              
19 1     1   6 use constant BIGINT_SUPPORTED => eval { unpack('q>', "\0\0\0\0\0\0\0\1") };
  1         9  
  1         2  
  1         76  
20 1     1   444 use if !BIGINT_SUPPORTED, 'Math::BigInt';
  1         11  
  1         4  
21              
22             our (@EXPORT_OK, %EXPORT_TAGS);
23             our (%consistency_lookup, %batch_type_lookup);
24             BEGIN {
25 1     1   277 my %constants= (
26             OPCODE_ERROR => 0,
27             OPCODE_STARTUP => 1,
28             OPCODE_READY => 2,
29             OPCODE_AUTHENTICATE => 3,
30             OPCODE_OPTIONS => 5,
31             OPCODE_SUPPORTED => 6,
32             OPCODE_QUERY => 7,
33             OPCODE_RESULT => 8,
34             OPCODE_PREPARE => 9,
35             OPCODE_EXECUTE => 10,
36             OPCODE_REGISTER => 11,
37             OPCODE_EVENT => 12,
38             OPCODE_BATCH => 13,
39             OPCODE_AUTH_CHALLENGE => 14,
40             OPCODE_AUTH_RESPONSE => 15,
41             OPCODE_AUTH_SUCCESS => 16,
42              
43             RESULT_VOID => 1,
44             RESULT_ROWS => 2,
45             RESULT_SET_KEYSPACE => 3,
46             RESULT_PREPARED => 4,
47             RESULT_SCHEMA_CHANGE => 5,
48              
49             CONSISTENCY_ANY => 0,
50             CONSISTENCY_ONE => 1,
51             CONSISTENCY_TWO => 2,
52             CONSISTENCY_THREE => 3,
53             CONSISTENCY_QUORUM => 4,
54             CONSISTENCY_ALL => 5,
55             CONSISTENCY_LOCAL_QUORUM => 6,
56             CONSISTENCY_EACH_QUORUM => 7,
57             CONSISTENCY_SERIAL => 8,
58             CONSISTENCY_LOCAL_SERIAL => 9,
59             CONSISTENCY_LOCAL_ONE => 10,
60              
61             TYPE_CUSTOM => 0x00,
62             TYPE_ASCII => 0x01,
63             TYPE_BIGINT => 0x02,
64             TYPE_BLOB => 0x03,
65             TYPE_BOOLEAN => 0x04,
66             TYPE_COUNTER => 0x05,
67             TYPE_DECIMAL => 0x06,
68             TYPE_DOUBLE => 0x07,
69             TYPE_FLOAT => 0x08,
70             TYPE_INT => 0x09,
71             TYPE_TEXT => 0x0A, # deprecated/removed
72             TYPE_TIMESTAMP => 0x0B,
73             TYPE_UUID => 0x0C,
74             TYPE_VARCHAR => 0x0D,
75             TYPE_VARINT => 0x0E,
76             TYPE_TIMEUUID => 0x0F,
77             TYPE_INET => 0x10,
78             TYPE_DATE => 0x11,
79             TYPE_TIME => 0x12,
80             TYPE_SMALLINT => 0x13,
81             TYPE_TINYINT => 0x14,
82             TYPE_LIST => 0x20,
83             TYPE_MAP => 0x21,
84             TYPE_SET => 0x22,
85             TYPE_UDT => 0x30,
86             TYPE_TUPLE => 0x31,
87             );
88              
89 1         14 @EXPORT_OK= (
90             keys %constants,
91             qw/
92             pack_int unpack_int
93             pack_long
94             pack_short unpack_short
95             pack_string unpack_string
96             pack_longstring
97             pack_stringlist unpack_stringlist
98             pack_bytes unpack_bytes
99             pack_shortbytes unpack_shortbytes
100             pack_option_type
101             pack_stringmap
102             pack_stringmultimap unpack_stringmultimap
103             unpack_inet
104             unpack_char
105              
106             pack_metadata unpack_metadata
107             unpack_errordata
108             pack_queryparameters
109              
110             %consistency_lookup
111             %batch_type_lookup
112              
113             BIGINT_SUPPORTED
114             /
115             );
116              
117 1         20 %EXPORT_TAGS= (
118             constants => [ keys %constants ],
119             all => [ @EXPORT_OK ]
120             );
121              
122             %consistency_lookup= map {
123 11         14 my $key= $_;
124 11         18 $key =~ s/CONSISTENCY_//;
125 11         34 (lc $key) => $constants{$_}
126 1         8 } grep { /CONSISTENCY/ } keys %constants;
  58         83  
127              
128 1         7 %batch_type_lookup= (
129             logged => 0,
130             unlogged => 1,
131             counter => 2,
132             );
133              
134 1         1807 constant->import( { %constants } );
135             }
136              
137             # TYPE: int
138             sub pack_int {
139 0     0 0   pack('l>', $_[0])
140             }
141              
142             sub unpack_int {
143 0     0 0   unpack('l>', substr $_[0], 0, 4, '')
144             }
145              
146             # TYPE: long
147             sub pack_long {
148 0     0 0   if (BIGINT_SUPPORTED) {
149 0           return pack('q>', $_[0]);
150             } else {
151             return bigint_to_bytes($_[0]);
152             }
153             }
154              
155             # TYPE: short
156             sub pack_short {
157 0     0 0   pack('n', $_[0])
158             }
159              
160             sub unpack_short {
161 0     0 0   unpack('n', substr $_[0], 0, 2, '')
162             }
163              
164             # TYPE: char
165             sub unpack_char {
166 0     0 0   unpack('c', substr $_[0], 0, 1, '')
167             }
168              
169             # TYPE: string
170             sub pack_string {
171 0 0   0 0   if (utf8::is_utf8($_[0])) {
172 0           my $str= $_[0]; # copy
173 0           utf8::encode $str;
174 0           return pack('n/a', $str);
175             }
176              
177 0           return pack('n/a', $_[0]);
178             }
179              
180             sub unpack_string {
181 0     0 0   my $length= &unpack_short;
182 0 0         if ($length > 0) {
183 0           my $string= substr($_[0], 0, $length, '');
184 0           utf8::decode $string;
185 0           return $string;
186             } else {
187 0           return '';
188             }
189             }
190              
191             # TYPE: longstring
192             sub pack_longstring {
193 0 0   0 0   if (utf8::is_utf8($_[0])) {
194 0           my $str= $_[0]; # copy
195 0           utf8::encode $str;
196 0           return pack('l>/a', $str);
197             }
198              
199 0           return pack('l>/a', $_[0]);
200             }
201              
202             # TYPE: stringlist
203             sub pack_stringlist {
204 0     0 0   pack_short(0+@{$_[0]}).join('', map { pack_string($_) } @{$_[0]})
  0            
  0            
  0            
205             }
206              
207             sub unpack_stringlist {
208 0     0 0   my $count= &unpack_short;
209 0           [ map &unpack_string, 1..$count ]
210             }
211              
212             # TYPE: bytes
213             sub pack_bytes {
214 0 0   0 0   if (utf8::is_utf8($_[0])) {
215 0           warn 'BUG: utf8 data passed to pack_bytes';
216 0           Encode::_utf8_off($_[0]);
217             }
218 0 0         defined $_[0] ? (pack_int(length($_[0])).$_[0]) : pack_int(-1)
219             }
220              
221             sub unpack_bytes {
222 0     0 0   my $len= &unpack_int;
223 0 0         if ($len > 0) {
    0          
224 0           return substr($_[0], 0, $len, '');
225              
226             } elsif ($len < 0) {
227 0           return undef;
228              
229             } else {
230 0           return '';
231             }
232             }
233              
234             # TYPE: shortbytes
235             sub pack_shortbytes {
236 0 0   0 0   if (utf8::is_utf8($_[0])) {
237 0           warn 'BUG: utf8 data passed to pack_shortbytes';
238 0           Encode::_utf8_off($_[0]);
239             }
240 0 0         defined $_[0] ? (pack_short(length($_[0])).$_[0]) : pack_short(-1)
241             }
242              
243             sub unpack_shortbytes {
244 0     0 0   my $len= &unpack_short;
245 0 0         if ($len > 0) {
    0          
246 0           return substr($_[0], 0, $len, '');
247              
248             } elsif ($len < 0) {
249 0           return undef;
250              
251             } else {
252 0           return '';
253             }
254             }
255              
256             # TYPE: inet
257             sub unpack_inet {
258 0     0 0   my $length= unpack('C', substr($_[0], 0, 1, ''));
259 0           my $tmp_val= substr($_[0], 0, $length, '');
260              
261 0           my $addr;
262 0 0         if ($length == 4) {
263 0           $addr= join('.', unpack('CCCC', $tmp_val));
264             } else {
265 0           $addr= join(':', unpack('(H4)[8]', $tmp_val));
266             # Simplify the V6 address
267 0           $addr =~ s/\b0+(\d+)\b/$1/g;
268 0           $addr =~ s/\b0(:0)+\b/:/;
269 0           $addr =~ s/:::/::/;
270             }
271 0           return $addr;
272             }
273              
274             # TYPE: option_type
275             sub pack_option_type {
276 0     0 0   my ($type)= @_;
277 0           my ($id, @value)= @$type;
278 0 0 0       if ($id == TYPE_CUSTOM) {
    0          
    0          
    0          
    0          
    0          
279 0           return pack_short($id).pack_string($value[0]);
280             } elsif ($id < 0x20) {
281 0           return pack_short($id);
282             } elsif ($id == TYPE_LIST || $id == TYPE_SET) {
283 0           return pack_short($id).pack_option_type($value[0]);
284             } elsif ($id == TYPE_MAP) {
285 0           return pack_short($id).pack_option_type($value[0]).pack_option_type($value[1]);
286             } elsif ($id == TYPE_UDT) {
287 0           my $out= pack_short($id).pack_string($value[0]).pack_string($value[1]);
288 0           my @fields= @{$value[2]};
  0            
289 0           $out .= pack_short(0+@fields);
290 0           for my $field (@fields) {
291 0           $out .= pack_string($field->[0]).pack_option_type($field->[1]);
292             }
293 0           return $out;
294             } elsif ($id == TYPE_TUPLE) {
295 0           my @fields= @{$value[0]};
  0            
296 0           my $out= pack_short($id).pack_short(0+@fields);
297 0           $out .= pack_option_type($_) for @fields;
298 0           return $out;
299             } else {
300 0           die 'Unable to pack_option_type for type '.$id;
301             }
302             }
303              
304             # TYPE: stringmap
305             sub pack_stringmap {
306 0     0 0   my $pairs= '';
307 0           my $count= 0;
308 0           for my $key (sort keys %{$_[0]}) {
  0            
309 0           $pairs .= pack_string($key).pack_string($_[0]{$key});
310 0           $count++;
311             }
312 0           return pack_short($count).$pairs;
313             }
314              
315             # TYPE: stringmultimap
316             sub pack_stringmultimap {
317 0     0 0   my $pairs= '';
318 0           my $count= 0;
319 0           for my $key (sort keys %{$_[0]}) {
  0            
320 0           $pairs .= pack_string($key).pack_stringlist($_[0]{$key});
321 0           $count++;
322             }
323 0           return pack_short($count).$pairs;
324             }
325              
326             sub unpack_stringmultimap {
327 0     0 0   my $count= &unpack_short;
328 0           my $result= {};
329 0           for (1..$count) {
330 0           my $key= &unpack_string;
331 0           $result->{$key}= &unpack_stringlist;
332             }
333 0           return $result;
334             }
335              
336             # Metadata
337             sub pack_metadata {
338 0     0 0   my ($metadata)= @_;
339 0           my $columns= $metadata->{columns};
340 0           my $paging_state= $metadata->{paging_state};
341              
342 0 0         my $flags= ($columns ? 0 : 4) | (defined($paging_state) ? 2 : 0);
    0          
343              
344 0           my $out= pack_int($flags);
345 0 0         $out .= pack_int($columns ? (0+@$columns) : 0);
346 0 0         $out .= pack_bytes($paging_state) if $flags & 2;
347 0 0         unless ($flags & 4) {
348 0           for my $column (@$columns) {
349 0           $out .= pack_string($column->[0]).pack_string($column->[1]);
350 0           $out .= pack_string($column->[2]).pack_option_type($column->[3]);
351             }
352             }
353              
354 0           return $out;
355             }
356              
357             # Query parameters
358             sub pack_queryparameters {
359 0     0 0   my ($consistency, $skip_metadata, $page_size, $paging_state, $timestamp, $row)= @_;
360              
361 0   0       my $has_row= defined($row) && length($row);
362 0   0       my $flags= (
      0        
      0        
      0        
      0        
363             0
364             | (($has_row && 0x01) || 0)
365             | (($skip_metadata && 0x02) || 0)
366             | (($page_size && 0x04) || 0)
367             | (($paging_state && 0x08) || 0)
368             | (($timestamp && 0x20) || 0)
369             );
370              
371             return (
372 0 0 0       pack('nC', $consistency, $flags)
    0          
    0          
373             . ($row || '')
374             . ($page_size ? pack('l>', $page_size) : '')
375             . ($paging_state ? pack('l>/a', $paging_state) : '')
376             . ($timestamp ? (BIGINT_SUPPORTED ? pack('q>', $timestamp) : bigint_to_bytes($timestamp)) : '')
377             );
378             }
379              
380             sub unpack_errordata {
381 0     0 0   my $code= &unpack_int;
382              
383 0           my %error;
384 0           $error{code}= $code;
385 0           $error{message}= &unpack_string;
386 0   0       $error{is_timeout}= ( $code == 0x1001 || $code == 0x1100 || $code == 0x1200 );
387              
388 0 0         if ($code == 0x1000) {
    0          
    0          
389             # Unavailable
390 0           $error{cl}= &unpack_short;
391 0           $error{required}= &unpack_int;
392 0           $error{alive}= &unpack_int;
393 0           return Cassandra::Client::Error::UnavailableException->new(%error);
394             } elsif ($code == 0x1100) {
395             # Write timeout
396 0           $error{cl}= &unpack_short;
397 0           $error{received}= &unpack_int;
398 0           $error{blockfor}= &unpack_int;
399 0           $error{write_type}= &unpack_string;
400 0           return Cassandra::Client::Error::WriteTimeoutException->new(%error);
401             } elsif ($code == 0x1200) {
402             # Read timeout
403 0           $error{cl}= &unpack_short;
404 0           $error{received}= &unpack_int;
405 0           $error{blockfor}= &unpack_int;
406 0           $error{data_present}= &unpack_char;
407 0           return Cassandra::Client::Error::ReadTimeoutException->new(%error);
408             }
409              
410 0           return Cassandra::Client::Error::Base->new(%error);
411             }
412              
413             # Support for 32bit perl
414             sub bigint_to_bytes {
415 0     0 0   my $mb= Math::BigInt->new($_[0]);
416 0 0         if ($_[0] !~ /^-?[0-9\.E]+$/i) { # Idk, approximate it
417 0           warn "Argument $_[0] isn't numeric";
418             }
419 0   0       my $negative= $mb->is_neg && $mb != 0;
420 0 0         if ($negative) {
421 0           $mb *= -1; # Flips the bits, adds one
422 0           $mb -= 1; # Removes that one
423             }
424              
425 0           my $hex= $mb->as_hex;
426 0           $hex =~ s/^0x//;
427 0           my $bytes= pack('H*', substr(("0"x16).$hex, -16));
428 0 0         if ($negative) {
429 0           $bytes= ~$bytes; # Flip those bits back
430             }
431              
432 0           return $bytes;
433             }
434              
435             1;
436              
437             __END__