9 use File
::KDBX
::Util
qw(:all);
11 use Scalar
::Util
qw(blessed);
14 can_ok
('File::KDBX::Util', qw{
29 simple_expression_query
38 subtest
'Emptiness' => sub {
41 ok empty
(@empty), 'Empty array should be empty';
42 ok
!nonempty
(@empty), 'Empty array should be !nonempty';
43 ok
!empty
(@nonempty), 'Array should be !empty';
44 ok nonempty
(@nonempty), 'Array should be nonempty';
47 my %nonempty = (a
=> 'b');
48 ok empty
(%empty), 'Empty hash should be empty';
49 ok
!nonempty
(%empty), 'Empty hash should be !nonempty';
50 ok
!empty
(%nonempty), 'Hash should be !empty';
51 ok nonempty
(%nonempty), 'Hash should be nonempty';
57 my $nref1 = \
$nonempty;
61 [0, $empty, 'Empty string'],
63 [0, \
undef, 'Reference to undef'],
64 [0, {}, 'Empty hashref'],
65 [0, [], 'Empty arrayref'],
66 [0, $eref1, 'Reference to empty string'],
67 [0, $eref2, 'Reference to reference to empty string'],
68 [0, \\\\\\\'', 'Deep reference to empty string
'],
69 [1, $nonempty, 'String
'],
73 [1, {a => 'b
'}, 'Hashref
'],
75 [1, $nref1, 'Reference to string
'],
76 [1, $nref2, 'Reference to reference to string
'],
77 [1, \\\\\\\'z', 'Deep reference to string'],
79 my ($expected, $thing, $note) = @$test;
81 ok
!empty
($thing), "$note should be !empty";
82 ok nonempty
($thing), "$note should be nonempty";
85 ok empty
($thing), "$note should be empty";
86 ok
!nonempty
($thing), "$note should be !nonempty";
91 subtest
'UUIDs' => sub {
92 my $uuid = "\x01\x23\x45\x67\x89\xab\xcd\xef\x01\x23\x45\x67\x89\xab\xcd\xef";
93 my $uuid1 = uuid
('01234567-89AB-CDEF-0123-456789ABCDEF');
94 my $uuid2 = uuid
('0123456789ABCDEF0123456789ABCDEF');
95 my $uuid3 = uuid
('012-3-4-56-789AB-CDEF---012-34567-89ABC-DEF');
97 is $uuid1, $uuid, 'Formatted UUID is packed';
98 is $uuid2, $uuid, 'Formatted UUID does not need dashes';
99 is $uuid2, $uuid, 'Formatted UUID can have weird dashes';
101 is format_uuid
($uuid), '0123456789ABCDEF0123456789ABCDEF', 'UUID unpacks to hex string';
102 is format_uuid
($uuid, '-'), '01234567-89AB-CDEF-0123-456789ABCDEF', 'Formatted UUID can be delimited';
104 my %uuid_set = ($uuid => 'whatever');
106 my $new_uuid = generate_uuid
(\
%uuid_set);
107 isnt
$new_uuid, $uuid, 'Generated UUID is not in set';
109 $new_uuid = generate_uuid
(sub { !$uuid_set{$_} });
110 isnt
$new_uuid, $uuid, 'Generated UUID passes a test function';
112 like generate_uuid
(print => 1), qr/^[A-Za-z0-9]+$/, 'Printable UUID is printable (1)';
113 like generate_uuid
(printable
=> 1), qr/^[A-Za-z0-9]+$/, 'Printable UUID is printable (2)';
116 subtest
'Snakification' => sub {
117 is snakify
('FooBar'), 'foo_bar', 'Basic snakification';
118 is snakify
('MyUUIDSet'), 'my_uuid_set', 'Acronym snakification';
119 is snakify
('Numbers123'), 'numbers_123', 'Snake case with numbers';
120 is snakify
('456Baz'), '456_baz', 'Prefixed numbers';
123 subtest
'Padding' => sub {
126 is pad_pkcs7
('foo', 2), "foo\x01", 'Pad one byte to fill the second block';
127 is pad_pkcs7
('foo', 4), "foo\x01", 'Pad one byte to fill one block';
128 is pad_pkcs7
('foo', 8), "foo\x05\x05\x05\x05\x05", 'Pad to fill one block';
129 is pad_pkcs7
('moof', 4), "moof\x04\x04\x04\x04", 'Add a whole block of padding';
130 is pad_pkcs7
('', 3), "\x03\x03\x03", 'Pad an empty string';
131 like exception
{ pad_pkcs7
(undef, 8) }, qr/must provide a string/i, 'String must be defined';
132 like exception
{ pad_pkcs7
('bar') }, qr/must provide block size/i, 'Size must defined';
133 like exception
{ pad_pkcs7
('bar', 0) }, qr/must provide block size/i, 'Size must be non-zero';
136 subtest
'64-bit packing' => sub {
139 ["\xfe\xff\xff\xff\xff\xff\xff\xff", -2],
140 ["\xff\xff\xff\xff\xff\xff\xff\xff", -1],
141 ["\x00\x00\x00\x00\x00\x00\x00\x00", 0],
142 ["\x01\x00\x00\x00\x00\x00\x00\x00", 1],
143 ["\x02\x00\x00\x00\x00\x00\x00\x00", 2],
144 ["\x01\x01\x00\x00\x00\x00\x00\x00", 257],
145 ["\xfe\xff\xff\xff\xff\xff\xff\xff", Math
::BigInt-
>new('-2')],
146 ["\xff\xff\xff\xff\xff\xff\xff\xff", Math
::BigInt-
>new('-1')],
147 ["\x00\x00\x00\x00\x00\x00\x00\x00", Math
::BigInt-
>new('0')],
148 ["\x01\x00\x00\x00\x00\x00\x00\x00", Math
::BigInt-
>new('1')],
149 ["\x02\x00\x00\x00\x00\x00\x00\x00", Math
::BigInt-
>new('2')],
150 ["\x01\x01\x00\x00\x00\x00\x00\x00", Math
::BigInt-
>new('257')],
151 ["\xfe\xff\xff\xff\xff\xff\xff\xff", Math
::BigInt-
>new('18446744073709551614')],
152 ["\xff\xff\xff\xff\xff\xff\xff\xff", Math
::BigInt-
>new('18446744073709551615')],
153 ["\xff\xff\xff\xff\xff\xff\xff\xff", Math
::BigInt-
>new('18446744073709551616')], # overflow
154 ["\x02\x00\x00\x00\x00\x00\x00\x80", Math
::BigInt-
>new('-9223372036854775806')],
155 ["\x01\x00\x00\x00\x00\x00\x00\x80", Math
::BigInt-
>new('-9223372036854775807')],
156 ["\x00\x00\x00\x00\x00\x00\x00\x80", Math
::BigInt-
>new('-9223372036854775808')],
157 ["\x00\x00\x00\x00\x00\x00\x00\x80", Math
::BigInt-
>new('-9223372036854775809')], # overflow
159 my ($bytes, $num) = @$test;
160 my $desc = sprintf('Pack %s => %s', $num, unpack('H*', $bytes));
161 $desc =~ s/^(Pack)/$1 bigint/ if blessed
$num;
162 my $p = pack_Ql
($num);
163 is $p, $bytes, $desc or diag
unpack('H*', $p);
167 # bytes, unsigned value, signed value
168 ["\x00\x00\x00\x00\x00\x00\x00\x00", 0, 0],
169 ["\x01\x00\x00\x00\x00\x00\x00\x00", 1, 1],
170 ["\x02\x00\x00\x00\x00\x00\x00\x00", 2, 2],
171 ["\xfe\xff\xff\xff\xff\xff\xff\xff", Math
::BigInt-
>new('18446744073709551614'), -2],
172 ["\xff\xff\xff\xff\xff\xff\xff\xff", Math
::BigInt-
>new('18446744073709551615'), -1],
173 ["\x02\x00\x00\x00\x00\x00\x00\x80", Math
::BigInt-
>new('9223372036854775810'),
174 Math
::BigInt-
>new('-9223372036854775806')],
175 ["\x01\x00\x00\x00\x00\x00\x00\x80", Math
::BigInt-
>new('9223372036854775809'),
176 Math
::BigInt-
>new('-9223372036854775807')],
177 ["\x00\x00\x00\x00\x00\x00\x00\x80", Math
::BigInt-
>new('9223372036854775808'),
178 Math
::BigInt-
>new('-9223372036854775808')],
180 my ($bytes, $num1, $num2) = @$test;
181 my $desc = sprintf('Unpack %s => %s', unpack('H*', $bytes), $num1);
182 my $p = unpack_Ql
($bytes);
183 cmp_ok
$p, '==', $num1, $desc or diag
$p;
184 $desc = sprintf('Unpack signed %s => %s', unpack('H*', $bytes), $num2);
185 my $q = unpack_ql
($bytes);
186 cmp_ok
$q, '==', $num2, $desc or diag
$q;