Dogcows Code - chaz/p5-File-KDBX/blob - t/util.t

   1 #!/usr/bin/env perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use lib 't/lib';
   7 use TestCommon;
   8
   9 use File::KDBX::Util qw(:all);
  10 use Math::BigInt;
  11 use Scalar::Util qw(blessed);
  12 use Test::More;
  13
  14 can_ok('File::KDBX::Util', qw{
  15     can_fork
  16     dumper
  17     empty
  18     erase
  19     erase_scoped
  20     format_uuid
  21     generate_uuid
  22     gunzip
  23     gzip
  24     load_optional
  25     nonempty
  26     pad_pkcs7
  27     query
  28     search
  29     simple_expression_query
  30     snakify
  31     split_url
  32     trim
  33     uri_escape_utf8
  34     uri_unescape_utf8
  35     uuid
  36 });
  37
  38 subtest 'Emptiness' => sub {
  39     my @empty;
  40     my @nonempty = 0;
  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';
  45
  46     my %empty;
  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';
  52
  53     my $empty = '';
  54     my $nonempty = '0';
  55     my $eref1 = \$empty;
  56     my $eref2 = \$eref1;
  57     my $nref1 = \$nonempty;
  58     my $nref2 = \$nref1;
  59
  60     for my $test (
  61         [0, $empty,     'Empty string'],
  62         [0, undef,      'Undef'],
  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'],
  70         [1, 'hi',       'String'],
  71         [1, 1,          'Number'],
  72         [1, 0,          'Zero'],
  73         [1, {a => 'b'}, 'Hashref'],
  74         [1, [0],        'Arrayref'],
  75         [1, $nref1,     'Reference to string'],
  76         [1, $nref2,     'Reference to reference to string'],
  77         [1, \\\\\\\'z', 'Deep reference to string'],
  78     ) {
  79         my ($expected, $thing, $note) = @$test;
  80         if ($expected) {
  81             ok !empty($thing), "$note should be !empty";
  82             ok nonempty($thing), "$note should be nonempty";
  83         }
  84         else {
  85             ok empty($thing), "$note should be empty";
  86             ok !nonempty($thing), "$note should be !nonempty";
  87         }
  88     }
  89 };
  90
  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');
  96
  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';
 100
 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';
 103
 104     my %uuid_set = ($uuid => 'whatever');
 105
 106     my $new_uuid = generate_uuid(\%uuid_set);
 107     isnt $new_uuid, $uuid, 'Generated UUID is not in set';
 108
 109     $new_uuid = generate_uuid(sub { !$uuid_set{$_} });
 110     isnt $new_uuid, $uuid, 'Generated UUID passes a test function';
 111
 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)';
 114 };
 115
 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';
 121 };
 122
 123 subtest 'Padding' => sub {
 124     plan tests => 8;
 125
 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';
 134 };
 135
 136 subtest '64-bit packing' => sub {
 137     for my $test (
 138         # bytes, value
 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
 158     ) {
 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);
 164     }
 165
 166     for my $test (
 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')],
 179     ) {
 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;
 187     };
 188 };
 189
 190 done_testing;