Dogcows Code - chaz/p5-File-KDBX/blob - t/lib/TestCommon.pm

   1 package TestCommon;
   2
   3 use warnings;
   4 use strict;
   5
   6 use Data::Dumper;
   7 use File::KDBX::Constants qw(:magic :kdf);
   8 use File::KDBX::Util qw(can_fork dumper);
   9 use File::Spec::Functions qw(catfile);
  10 use FindBin qw($Bin);
  11 use Test::Fatal;
  12 use Test::Deep;
  13
  14 BEGIN {
  15     $Data::Dumper::Deepcopy = 1;
  16     $Data::Dumper::Deparse = 1;
  17     $Data::Dumper::Indent = 1;
  18     $Data::Dumper::Quotekeys = 0;
  19     $Data::Dumper::Sortkeys = 1;
  20     $Data::Dumper::Terse = 1;
  21     $Data::Dumper::Trailingcomma = 1;
  22     $Data::Dumper::Useqq = 1;
  23 }
  24
  25 sub import {
  26     my $self = shift;
  27     my @args = @_;
  28
  29     my $caller = caller;
  30
  31     require Test::Warnings;
  32     my @warnings_flags;
  33     push @warnings_flags, ':no_end_test' if !$ENV{AUTHOR_TESTING} || grep { $_ eq ':no_warnings_test' } @args;
  34     Test::Warnings->import(@warnings_flags);
  35
  36     # Just export a random assortment of things useful for testing.
  37     no strict 'refs';
  38     *{"${caller}::dumper"}      = \&File::KDBX::Util::dumper;
  39     *{"${caller}::catfile"}     = \&File::Spec::Functions::catfile;
  40
  41     *{"${caller}::exception"}   = \&Test::Fatal::exception;
  42     *{"${caller}::warning"}     = \&Test::Warnings::warning;
  43     *{"${caller}::warnings"}    = \&Test::Warnings::warnings;
  44
  45     *{"${caller}::dump_test_deep_template"}  = \&dump_test_deep_template;
  46     *{"${caller}::ok_magic"}    = \&ok_magic;
  47     *{"${caller}::fast_kdf"}    = \&fast_kdf;
  48     *{"${caller}::can_fork"}    = \&can_fork;
  49     *{"${caller}::testfile"}    = \&testfile;
  50 }
  51
  52 sub testfile {
  53     return catfile($Bin, 'files', @_);
  54 }
  55
  56 sub dump_test_deep_template {
  57     my $struct = shift;
  58
  59     my $str = Dumper $struct;
  60     # booleans: bless( do{\(my $o = 1)}, 'boolean' )
  61     $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/bool($1)/gs;
  62     # objects
  63     $str =~ s/bless\(.+?'([^']+)' \)/obj_isa('$1')/gs;
  64     # convert two to four space indentation
  65     $str =~ s/^( +)/' ' x (length($1) * 2)/gme;
  66
  67     open(my $fh, '>>', 'TEST-DEEP-TEMPLATES.pl') or die "open failed: $!";
  68     print $fh $str, "\n";
  69 }
  70
  71 sub ok_magic {
  72     my $kdbx = shift;
  73     my $vers = shift;
  74     my $note = shift;
  75
  76     my $magic = [$kdbx->sig1, $kdbx->sig2, $kdbx->version];
  77     cmp_deeply $magic, [
  78         KDBX_SIG1,
  79         KDBX_SIG2_2,
  80         $vers,
  81     ], $note // 'KDBX magic numbers are correct';
  82 }
  83
  84 sub fast_kdf {
  85     my $uuid = shift // KDF_UUID_AES;
  86     my $params = {
  87         KDF_PARAM_UUID() => $uuid,
  88     };
  89     if ($uuid eq KDF_UUID_AES || $uuid eq KDF_UUID_AES_CHALLENGE_RESPONSE) {
  90         $params->{+KDF_PARAM_AES_ROUNDS} = 17;
  91         $params->{+KDF_PARAM_AES_SEED} = "\1" x 32;
  92     }
  93     else { # Argon2
  94         $params->{+KDF_PARAM_ARGON2_SALT} = "\1" x 32;
  95         $params->{+KDF_PARAM_ARGON2_PARALLELISM} = 1;
  96         $params->{+KDF_PARAM_ARGON2_MEMORY} = 1 << 13;
  97         $params->{+KDF_PARAM_ARGON2_ITERATIONS} = 2;
  98         $params->{+KDF_PARAM_ARGON2_VERSION} = 0x13;
  99     }
 100     return $params;
 101 }
 102 1;