X-Git-Url: https://git.dogcows.com/gitweb?a=blobdiff_plain;f=lib%2FFile%2FKDBX%2FUtil.pm;h=84cb363158b50b14125e970052a0e0244afa6108;hb=22c06c7b833137dc25dab1942f161fde5bc0d9c3;hp=3355d41fa1d3454c119a14dbd98d900abef70083;hpb=05e0bcef1c2165c556b910314312866dc4a667b7;p=chaz%2Fp5-File-KDBX diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm index 3355d41..84cb363 100644 --- a/lib/File/KDBX/Util.pm +++ b/lib/File/KDBX/Util.pm @@ -7,37 +7,50 @@ use strict; use Crypt::PRNG qw(random_bytes random_string); use Encode qw(decode encode); use Exporter qw(import); -use File::KDBX::Constants qw(:bool); use File::KDBX::Error; use List::Util 1.33 qw(any all); use Module::Load; use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref); -use Scalar::Util qw(blessed readonly); +use Scalar::Util qw(blessed looks_like_number readonly); +use Time::Piece; +use boolean; use namespace::clean -except => 'import'; our $VERSION = '999.999'; # VERSION our %EXPORT_TAGS = ( - assert => [qw(assert_64bit)], + assert => [qw(DEBUG assert)], + class => [qw(extends has list_attributes)], clone => [qw(clone clone_nomagic)], + coercion => [qw(to_bool to_number to_string to_time to_tristate to_uuid)], crypt => [qw(pad_pkcs7)], - debug => [qw(dumper)], + debug => [qw(DEBUG dumper)], fork => [qw(can_fork)], function => [qw(memoize recurse_limit)], empty => [qw(empty nonempty)], erase => [qw(erase erase_scoped)], gzip => [qw(gzip gunzip)], - io => [qw(is_readable is_writable read_all)], + int => [qw(int64 pack_ql pack_Ql unpack_ql unpack_Ql)], + io => [qw(read_all)], load => [qw(load_optional load_xs try_load_optional)], - search => [qw(query search search_limited simple_expression_query)], + search => [qw(query query_any search simple_expression_query)], text => [qw(snakify trim)], - uuid => [qw(format_uuid generate_uuid is_uuid uuid)], + uuid => [qw(format_uuid generate_uuid is_uuid uuid UUID_NULL)], uri => [qw(split_url uri_escape_utf8 uri_unescape_utf8)], ); $EXPORT_TAGS{all} = [map { @$_ } values %EXPORT_TAGS]; our @EXPORT_OK = @{$EXPORT_TAGS{all}}; +BEGIN { + my $debug = $ENV{DEBUG}; + $debug = looks_like_number($debug) ? (0 + $debug) : ($debug ? 1 : 0); + *DEBUG = $debug == 1 ? sub() { 1 } : + $debug == 2 ? sub() { 2 } : + $debug == 3 ? sub() { 3 } : + $debug == 4 ? sub() { 4 } : sub() { 0 }; +} + my %OPS = ( 'eq' => 2, # binary 'ne' => 2, @@ -81,14 +94,15 @@ my %OP_NEG = ( '=~' => '!~', '!~' => '=~', ); +my %ATTRIBUTES; =func load_xs $bool = load_xs(); $bool = load_xs($version); -Attempt to load L. Return truthy if C is loaded. If C<$version> is given, it will check -that at least the given version is loaded. +Attempt to load L. Return truthy if it is loaded. If C<$version> is given, it will check that +at least the given version is loaded. =cut @@ -99,7 +113,7 @@ sub load_xs { goto IS_LOADED if defined $XS_LOADED; if ($ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS})) { - return $XS_LOADED = FALSE; + return $XS_LOADED = !1; } $XS_LOADED = !!eval { require File::KDBX::XS; 1 }; @@ -112,18 +126,30 @@ sub load_xs { } } -=func assert_64bit +=func assert - assert_64bit(); + assert { ... }; -Throw if perl doesn't support 64-bit IVs. +Write an executable comment. Only executed if C is set in the environment. =cut -sub assert_64bit() { - require Config; - $Config::Config{ivsize} < 8 - and throw "64-bit perl is required to use this feature.\n", ivsize => $Config::Config{ivsize}; +sub assert(&) { ## no critic (ProhibitSubroutinePrototypes) + return if !DEBUG; + my $code = shift; + return if $code->(); + + (undef, my $file, my $line) = caller; + $file =~ s!([^/\\]+)$!$1!; + my $assertion = ''; + if (try_load_optional('B::Deparse')) { + my $deparse = B::Deparse->new(qw{-P -x9}); + $assertion = $deparse->coderef2text($code); + $assertion =~ s/^\{(?:\s*(?:package[^;]+|use[^;]+);)*\s*(.*?);\s*\}$/$1/s; + $assertion =~ s/\s+/ /gs; + $assertion = ": $assertion"; + } + die "$0: $file:$line: Assertion failed$assertion\n"; } =func can_fork @@ -191,6 +217,10 @@ sub clone_nomagic { return $thing; } +=func DEBUG + +Constant number indicating the level of debuggingness. + =func dumper $str = dumper $thing; @@ -219,7 +249,8 @@ sub dumper { # boolean $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs; # Time::Piece - $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \)/Time::Piece->new($1)/gs; + $str =~ s/bless\([^\)]+?(\d+)'?,\s+\d+,?\s+\], 'Time::Piece' \),/ + "scalar gmtime($1), # " . scalar gmtime($1)->datetime/ges; print STDERR $str if !defined wantarray; push @dumps, $str; @@ -359,6 +390,81 @@ sub erase_scoped { return Scope::Guard->new(sub { erase(@args) }); } +=func extends + + extends $class; + +Set up the current module to inheret from another module. + +=cut + +sub extends { + my $parent = shift; + my $caller = caller; + load $parent; + no strict 'refs'; ## no critic (ProhibitNoStrict) + @{"${caller}::ISA"} = $parent; +} + +=func has + + has $name => %options; + +Create an attribute getter/setter. Possible options: + +=for :list +* C - Either "rw" (default) or "ro" +* C - Default value +* C - Coercive function + +=cut + +sub has { + my $name = shift; + my %args = @_ % 2 == 1 ? (default => shift, @_) : @_; + + my ($package, $file, $line) = caller; + + my $d = $args{default}; + my $default = is_arrayref($d) ? sub { [@$d] } : is_hashref($d) ? sub { +{%$d} } : $d; + my $coerce = $args{coerce}; + my $is = $args{is} || 'rw'; + + my $store = $args{store}; + ($store, $name) = split(/\./, $name, 2) if $name =~ /\./; + + my @path = split(/\./, $args{path} || ''); + my $last = pop @path; + my $path = $last ? join('', map { qq{->$_} } @path) . qq{->{'$last'}} + : $store ? qq{->$store\->{'$name'}} : qq{->{'$name'}}; + my $member = qq{\$_[0]$path}; + + + my $default_code = is_coderef $default ? q{scalar $default->($_[0])} + : defined $default ? q{$default} + : q{undef}; + my $get = qq{$member //= $default_code;}; + + my $set = ''; + if ($is eq 'rw') { + $set = is_coderef $coerce ? qq{$member = scalar \$coerce->(\@_[1..\$#_]) if \$#_;} + : defined $coerce ? qq{$member = do { local @_ = (\@_[1..\$#_]); $coerce } if \$#_;} + : qq{$member = \$_[1] if \$#_;}; + } + + push @{$ATTRIBUTES{$package} //= []}, $name; + $line -= 4; + my $code = <. + +=cut + +sub int64 { + require Config; + if ($Config::Config{ivsize} < 8) { + require Math::BigInt; + return Math::BigInt->new(@_); + } + return 0 + shift; +} + +=func pack_Ql + + $bytes = pack_Ql($int); + +Like C', $int)>, but also works on 32-bit perls. + +=cut + +sub pack_Ql { + my $num = shift; + require Config; + if ($Config::Config{ivsize} < 8) { + if (blessed $num && $num->can('as_hex')) { + return "\xff\xff\xff\xff\xff\xff\xff\xff" if Math::BigInt->new('18446744073709551615') <= $num; + return "\x00\x00\x00\x00\x00\x00\x00\x80" if $num <= Math::BigInt->new('-9223372036854775808'); + my $neg; + if ($num < 0) { + $neg = 1; + $num = -$num; + } + my $hex = $num->as_hex; + $hex =~ s/^0x/000000000000000/; + my $bytes = reverse pack('H16', substr($hex, -16)); + $bytes .= "\0" x (8 - length $bytes) if length $bytes < 8; + if ($neg) { + # two's compliment + $bytes = join('', map { chr(~ord($_) & 0xff) } split(//, $bytes)); + substr($bytes, 0, 1, chr(ord(substr($bytes, 0, 1)) + 1)); + } + return $bytes; + } + else { + my $pad = $num < 0 ? "\xff" : "\0"; + return pack('L<', $num) . ($pad x 4); + }; + } + return pack('Q<', $num); +} + +=func pack_ql + + $bytes = pack_ql($int); + +Like C', $int)>, but also works on 32-bit perls. + +=cut + +sub pack_ql { goto &pack_Ql } + +=func unpack_Ql + + $int = unpack_Ql($bytes); + +Like C', $bytes)>, but also works on 32-bit perls. + +=cut + +sub unpack_Ql { + my $bytes = shift; + require Config; + if ($Config::Config{ivsize} < 8) { + require Math::BigInt; + return Math::BigInt->new('0x' . unpack('H*', scalar reverse $bytes)); + } + return unpack('Q<', $bytes); +} -=func is_writable +=func unpack_ql - $bool = is_readable($mode); - $bool = is_writable($mode); + $int = unpack_ql($bytes); -Determine of an C-style mode is readable, writable or both. +Like C', $bytes)>, but also works on 32-bit perls. =cut -sub is_readable { $_[0] !~ /^[aw]b?$/ } -sub is_writable { $_[0] !~ /^rb?$/ } +sub unpack_ql { + my $bytes = shift; + require Config; + if ($Config::Config{ivsize} < 8) { + require Math::BigInt; + if (ord(substr($bytes, -1, 1)) & 128) { + return Math::BigInt->new('-9223372036854775808') if $bytes eq "\x00\x00\x00\x00\x00\x00\x00\x80"; + # two's compliment + substr($bytes, 0, 1, chr(ord(substr($bytes, 0, 1)) - 1)); + $bytes = join('', map { chr(~ord($_) & 0xff) } split(//, $bytes)); + return -Math::BigInt->new('0x' . unpack('H*', scalar reverse $bytes)); + } + else { + return Math::BigInt->new('0x' . unpack('H*', scalar reverse $bytes)); + } + } + return unpack('q<', $bytes); +} =func is_uuid @@ -486,6 +690,19 @@ Check if a thing is a UUID (i.e. scalar string of length 16). sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 } +=func list_attributes + + @attributes = list_attributes($package); + +Get a list of attributes for a class. + +=cut + +sub list_attributes { + my $package = shift; + return @{$ATTRIBUTES{$package} // []}; +} + =func load_optional $package = load_optional($package); @@ -498,8 +715,9 @@ sub load_optional { for my $module (@_) { eval { load $module }; if (my $err = $@) { - warn $err if $ENV{DEBUG}; - throw "Missing dependency: Please install $module to use this feature.\n", module => $module; + throw "Missing dependency: Please install $module to use this feature.\n", + module => $module, + error => $err; } } return wantarray ? @_ : $_[0]; @@ -551,19 +769,39 @@ The logic can be specified in a manner similar to L for examples. +See L for examples. =cut sub query { _query(undef, '-or', \@_) } +=func query_any + +Get either a L or L, depending on the arguments. + +=cut + +sub query_any { + my $code = shift; + + if (is_coderef($code) || overload::Method($code, '&{}')) { + return $code; + } + elsif (is_scalarref($code)) { + return simple_expression_query($$code, @_); + } + else { + return query($code, @_); + } +} + =func read_all $size = read_all($fh, my $buffer, $size); $size = read_all($fh, my $buffer, $size, $offset); -Like L but returns C if not all C<$size> bytes are read. This is considered an error, -distinguishable from other errors by C<$!> not being set. +Like L but returns C if not all C<$size> bytes are +read. This is considered an error, distinguishable from other errors by C<$!> not being set. =cut @@ -612,50 +850,15 @@ sub recurse_limit { Execute a linear search over an array of records using a L. A "record" is usually a hash. -This is the search engine described with many examples at L. - =cut sub search { my $list = shift; - my $query = shift; - - if (is_coderef($query) && !@_) { - # already a query - } - elsif (is_scalarref($query)) { - $query = simple_expression_query($$query, @_); - } - else { - $query = query($query, @_); - } - - my @match; - for my $item (@$list) { - push @match, $item if $query->($item); - } - return \@match; -} - -sub search_limited { - my $list = shift; - my $query = shift; - my $limit = shift // 1; - - if (is_coderef($query) && !@_) { - # already a query - } - elsif (is_scalarref($query)) { - $query = simple_expression_query($$query, @_); - } - else { - $query = query($query, @_); - } + my $query = query_any(@_); my @match; for my $item (@$list) { push @match, $item if $query->($item); - last if $limit <= @match; } return \@match; } @@ -663,6 +866,7 @@ sub search_limited { =func simple_expression_query $query = simple_expression_query($expression, @fields); + $query = simple_expression_query($expression, $operator, @fields); Generate a query, like L, to be used with L but built from a "simple expression" as L. @@ -764,6 +968,40 @@ sub split_url { return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password); } +=func to_bool + +=func to_number + +=func to_string + +=func to_time + +=func to_tristate + +=func to_uuid + +Various typecasting / coercive functions. + +=cut + +sub to_bool { $_[0] // return; boolean($_[0]) } +sub to_number { $_[0] // return; 0+$_[0] } +sub to_string { $_[0] // return; "$_[0]" } +sub to_time { + $_[0] // return; + return scalar gmtime($_[0]) if looks_like_number($_[0]); + return scalar gmtime if $_[0] eq 'now'; + return Time::Piece->strptime($_[0], '%Y-%m-%d %H:%M:%S') if !blessed $_[0]; + return $_[0]; +} +sub to_tristate { $_[0] // return; boolean($_[0]) } +sub to_uuid { + my $str = to_string(@_) // return; + return sprintf('%016s', $str) if length($str) < 16; + return substr($str, 0, 16) if 16 < length($str); + return $str; +} + =func trim $string = trim($string); @@ -791,7 +1029,7 @@ sub try_load_optional { for my $module (@_) { eval { load $module }; if (my $err = $@) { - warn $err if $ENV{DEBUG}; + warn $err if 3 <= DEBUG; return; } } @@ -848,6 +1086,14 @@ sub uuid { } +=func UUID_NULL + +Get the null UUID (i.e. string of 16 null bytes). + +=cut + +sub UUID_NULL() { "\0" x 16 } + ### -------------------------------------------------------------------------- # Determine if an array looks like keypairs from a hash.