Prereq Time::Piece 1.33 to fix KDBX4 datetimes

[chaz/p5-File-KDBX] / lib / File / KDBX / Util.pm

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index c970683694fcef37ff0086c2c5a7acc5d54f3efa..b8c901b048d6c73f1187a8d7d5454f409dbc479e 100644 (file)
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -1,6 +1,7 @@
 package File::KDBX::Util;
 # ABSTRACT: Utility functions for working with KDBX files
 
 package File::KDBX::Util;
 # ABSTRACT: Utility functions for working with KDBX files
 

+use 5.010;

 use warnings;
 use strict;
 
 use warnings;
 use strict;
 


@@ -11,33 +12,46 @@ 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 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 1.33;
+use boolean;

 use namespace::clean -except => 'import';
 
 our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (
 use namespace::clean -except => 'import';
 
 our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (

-    assert      => [qw(assert_64bit)],
-    bool        => [qw(FALSE TRUE)],
+    assert      => [qw(DEBUG assert)],
+    class       => [qw(extends has list_attributes)],

     clone       => [qw(clone clone_nomagic)],
     clone       => [qw(clone clone_nomagic)],

+    coercion    => [qw(to_bool to_number to_string to_time to_tristate to_uuid)],

     crypt       => [qw(pad_pkcs7)],
     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)],
     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)],
     load        => [qw(load_optional load_xs try_load_optional)],

-    search      => [qw(query search simple_expression_query)],
+    search      => [qw(query query_any search simple_expression_query)],

     text        => [qw(snakify trim)],
     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}};
 
     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,
 my %OPS = (
     'eq'        =>  2, # binary
     'ne'        =>  2,


@@ -81,19 +95,62 @@ my %OP_NEG = (
     '=~'    =>  '!~',
     '!~'    =>  '=~',
 );
     '=~'    =>  '!~',
     '!~'    =>  '=~',
 );

+my %ATTRIBUTES;

 
 

-=func assert_64bit
+=func load_xs

 
 

-    assert_64bit();
+    $bool = load_xs();
+    $bool = load_xs($version);

 
 

-Throw if perl doesn't support 64-bit IVs.
+Attempt to load L<File::KDBX::XS>. Return truthy if it is loaded. If C<$version> is given, it will check that
+at least the given version is loaded.

 
 =cut
 
 
 =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};
+my $XS_LOADED;
+sub load_xs {
+    my $version = shift;
+
+    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 = !1;
+    }
+
+    $XS_LOADED = !!eval { require File::KDBX::XS; 1 };
+
+    IS_LOADED:
+    {
+        local $@;
+        return $XS_LOADED if !$version;
+        return !!eval { File::KDBX::XS->VERSION($version); 1 };
+    }
+}
+
+=func assert
+
+    assert { ... };
+
+Write an executable comment. Only executed if C<DEBUG> is set in the environment.
+
+=cut
+
+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
 }
 
 =func can_fork


@@ -161,6 +218,10 @@ sub clone_nomagic {
     return $thing;
 }
 
     return $thing;
 }
 

+=func DEBUG
+
+Constant number indicating the level of debuggingness.
+

 =func dumper
 
     $str = dumper $thing;
 =func dumper
 
     $str = dumper $thing;


@@ -189,7 +250,8 @@ sub dumper {
         # boolean
         $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/boolean($1)/gs;
         # Time::Piece
         # 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;
 
         print STDERR $str if !defined wantarray;
         push @dumps, $str;


@@ -243,7 +305,17 @@ Overwrite the memory used by one or more string.
 
 =cut
 
 
 =cut
 

-# use File::KDBX::XS;
+BEGIN {
+    if (load_xs) {
+        *_CowREFCNT = \&File::KDBX::XS::CowREFCNT;
+    }
+    elsif (eval { require B::COW; 1 }) {
+        *_CowREFCNT = \&B::COW::cowrefcnt;
+    }
+    else {
+        *_CowREFCNT = sub { undef };
+    }
+}

 
 sub erase {
     # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just
 
 sub erase {
     # Only bother zeroing out memory if we have the last SvPV COW reference, otherwise we'll end up just


@@ -252,10 +324,8 @@ sub erase {
     for (@_) {
         if (!is_ref($_)) {
             next if !defined $_ || readonly $_;
     for (@_) {
         if (!is_ref($_)) {
             next if !defined $_ || readonly $_;

-            if (_USE_COWREFCNT()) {
-                my $cowrefcnt = B::COW::cowrefcnt($_);
-                goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt;
-            }
+            my $cowrefcnt = _CowREFCNT($_);
+            goto FREE_NONREF if defined $cowrefcnt && 1 < $cowrefcnt;

             # if (__PACKAGE__->can('erase_xs')) {
             #     erase_xs($_);
             # }
             # if (__PACKAGE__->can('erase_xs')) {
             #     erase_xs($_);
             # }


@@ -269,10 +339,8 @@ sub erase {
         }
         elsif (is_scalarref($_)) {
             next if !defined $$_ || readonly $$_;
         }
         elsif (is_scalarref($_)) {
             next if !defined $$_ || readonly $$_;

-            if (_USE_COWREFCNT()) {
-                my $cowrefcnt = B::COW::cowrefcnt($$_);
-                goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt;
-            }
+            my $cowrefcnt = _CowREFCNT($$_);
+            goto FREE_REF if defined $cowrefcnt && 1 < $cowrefcnt;

             # if (__PACKAGE__->can('erase_xs')) {
             #     erase_xs($$_);
             # }
             # if (__PACKAGE__->can('erase_xs')) {
             #     erase_xs($$_);
             # }


@@ -312,6 +380,7 @@ See L</erase>.
 =cut
 
 sub erase_scoped {
 =cut
 
 sub erase_scoped {

+    throw 'Programmer error: Cannot call erase_scoped in void context' if !defined wantarray;

     my @args;
     for (@_) {
         !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_)
     my @args;
     for (@_) {
         !is_ref($_) || is_arrayref($_) || is_hashref($_) || is_scalarref($_)


@@ -322,6 +391,81 @@ sub erase_scoped {
     return Scope::Guard->new(sub { erase(@args) });
 }
 
     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<is> - Either "rw" (default) or "ro"
+* C<default> - Default value
+* C<coerce> - 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 = <<END;
+# line $line "$file"
+sub ${package}::${name} {
+    return $default_code if !Scalar::Util::blessed(\$_[0]);
+    $set
+    $get
+}
+END
+    eval $code; ## no critic (ProhibitStringyEval)
+}
+

 =func format_uuid
 
     $string_uuid = format_uuid($raw_uuid);
 =func format_uuid
 
     $string_uuid = format_uuid($raw_uuid);


@@ -425,75 +569,159 @@ sub gzip {
     return $out;
 }
 
     return $out;
 }
 

-=func is_readable
+=func int64
+
+    $int = int64($string);

 
 

-=func is_writable
+Get a scalar integer capable of holding 64-bit values, initialized with a given default value. On a 64-bit
+perl, it will return a regular SvIV. On a 32-bit perl it will return a L<Math::BigInt>.

 
 

-    $bool = is_readable($mode);
-    $bool = is_writable($mode);
+=cut
+
+sub int64 {
+    require Config;
+    if ($Config::Config{ivsize} < 8) {
+        require Math::BigInt;
+        return Math::BigInt->new(@_);
+    }
+    return 0 + shift;
+}

 
 

-Determine of an C<fopen>-style mode is readable, writable or both.
+=func pack_Ql
+
+    $bytes = pack_Ql($int);
+
+Like C<pack('QE<lt>', $int)>, but also works on 32-bit perls.

 
 =cut
 
 
 =cut
 

-sub is_readable { $_[0] !~ /^[aw]b?$/ }
-sub is_writable { $_[0] !~ /^rb?$/ }
+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 is_uuid
+=func pack_ql

 
 

-    $bool = is_uuid($thing);
+    $bytes = pack_ql($int);

 
 

-Check if a thing is a UUID (i.e. scalar string of length 16).
+Like C<pack('qE<lt>', $int)>, but also works on 32-bit perls.

 
 =cut
 
 
 =cut
 

-sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 }
+sub pack_ql { goto &pack_Ql }

 
 

-=func load_optional
+=func unpack_Ql

 
 

-    $package = load_optional($package);
+    $int = unpack_Ql($bytes);

 
 

-Load a module that isn't required but can provide extra functionality. Throw if the module is not available.
+Like C<unpack('QE<lt>', $bytes)>, but also works on 32-bit perls.

 
 =cut
 
 
 =cut
 

-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;
+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 unpack_ql
+
+    $int = unpack_ql($bytes);
+
+Like C<unpack('qE<lt>', $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;
+        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 wantarray ? @_ : $_[0];
+    return unpack('q<', $bytes);

 }
 
 }
 

-=func load_xs
+=func is_uuid

 
 

-    $bool = load_xs();
-    $bool = load_xs($version);
+    $bool = is_uuid($thing);

 
 

-Attempt to load L<File::KDBX::XS>. Return truthy if C<XS> is loaded. If C<$version> is given, it will check
-that at least the given version is loaded.
+Check if a thing is a UUID (i.e. scalar string of length 16).

 
 =cut
 
 
 =cut
 

-sub load_xs {
-    my $version = shift;
+sub is_uuid { defined $_[0] && !is_ref($_[0]) && length($_[0]) == 16 }

 
 

-    require File::KDBX;
+=func list_attributes

 
 

-    my $has_xs = File::KDBX->can('XS_LOADED');
-    return $has_xs->() && ($version ? eval { File::KDBX::XS->VERSION($version); 1 } : 1) if $has_xs;
+    @attributes = list_attributes($package);

 
 

-    my $try_xs = 1;
-    $try_xs = 0 if $ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS});
+Get a list of attributes for a class.

 
 

-    my $use_xs = 0;
-    $use_xs = try_load_optional('File::KDBX::XS') if $try_xs;
+=cut

 
 

-    *File::KDBX::XS_LOADED = *File::KDBX::XS_LOADED = $use_xs ? sub() { 1 } : sub() { 0 };
-    return $version ? eval { File::KDBX::XS->VERSION($version); 1 } : 1;
+sub list_attributes {
+    my $package = shift;
+    return @{$ATTRIBUTES{$package} // []};
+}
+
+=func load_optional
+
+    $package = load_optional($package);
+
+Load a module that isn't required but can provide extra functionality. Throw if the module is not available.
+
+=cut
+
+sub load_optional {
+    for my $module (@_) {
+        eval { load $module };
+        if (my $err = $@) {
+            throw "Missing dependency: Please install $module to use this feature.\n",
+                module  => $module,
+                error   => $err;
+        }
+    }
+    return wantarray ? @_ : $_[0];

 }
 
 =func memoize
 }
 
 =func memoize


@@ -542,19 +770,39 @@ The logic can be specified in a manner similar to L<SQL::Abstract/"WHERE CLAUSES
 for this function, but this code is distinct, supporting an overlapping but not identical feature set and
 having its own bugs.
 
 for this function, but this code is distinct, supporting an overlapping but not identical feature set and
 having its own bugs.
 

-See L<File::KDBX/QUERY> for examples.
+See L<File::KDBX/"Declarative Syntax"> for examples.

 
 =cut
 
 sub query { _query(undef, '-or', \@_) }
 
 
 =cut
 
 sub query { _query(undef, '-or', \@_) }
 

+=func query_any
+
+Get either a L</query> or L</simple_expression_query>, 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);
 
 =func read_all
 
     $size = read_all($fh, my $buffer, $size);
     $size = read_all($fh, my $buffer, $size, $offset);
 

-Like L<functions/read> but returns C<undef> if not all C<$size> bytes are read. This is considered an error,
-distinguishable from other errors by C<$!> not being set.
+Like L<perlfunc/"read FILEHANDLE,SCALAR,LENGTH,OFFSET"> but returns C<undef> if not all C<$size> bytes are
+read. This is considered an error, distinguishable from other errors by C<$!> not being set.

 
 =cut
 
 
 =cut
 


@@ -603,31 +851,15 @@ sub recurse_limit {
 
 Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
 
 
 Execute a linear search over an array of records using a L</query>. A "record" is usually a hash.
 

-This is the search engine described with many examples at L<File::KDBX/QUERY>.
-

 =cut
 
 sub search {
     my $list    = shift;
 =cut
 
 sub search {
     my $list    = shift;

-    my $query   = shift;
-    # my %args    = @_;
-
-    if (is_coderef($query) && !@_) {
-        # already a query
-    }
-    elsif (is_scalarref($query)) {
-        $query = simple_expression_query($$query, @_);
-    }
-    else {
-        $query = query($query, @_);
-    }
-
-    # my $limit = $args{limit};
+    my $query   = query_any(@_);

 
     my @match;
     for my $item (@$list) {
         push @match, $item if $query->($item);
 
     my @match;
     for my $item (@$list) {
         push @match, $item if $query->($item);

-        # last if defined $limit && $limit <= @match;

     }
     return \@match;
 }
     }
     return \@match;
 }


@@ -635,6 +867,7 @@ sub search {
 =func simple_expression_query
 
     $query = simple_expression_query($expression, @fields);
 =func simple_expression_query
 
     $query = simple_expression_query($expression, @fields);

+    $query = simple_expression_query($expression, $operator, @fields);

 
 Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as
 L<described here|https://keepass.info/help/base/search.html#mode_se>.
 
 Generate a query, like L</query>, to be used with L</search> but built from a "simple expression" as
 L<described here|https://keepass.info/help/base/search.html#mode_se>.


@@ -736,6 +969,40 @@ sub split_url {
     return ($scheme, $auth, $host, $port, $path, $query, $hash, $username, $password);
 }
 
     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);
 =func trim
 
     $string = trim($string);


@@ -763,7 +1030,7 @@ sub try_load_optional {
     for my $module (@_) {
         eval { load $module };
         if (my $err = $@) {
     for my $module (@_) {
         eval { load $module };
         if (my $err = $@) {

-            warn $err if $ENV{DEBUG};
+            warn $err if 3 <= DEBUG;

             return;
         }
     }
             return;
         }
     }


@@ -820,21 +1087,13 @@ sub uuid {
 
 }
 
 
 }
 

-=func FALSE
+=func UUID_NULL

 
 

-=func TRUE
-
-Constants appropriate for use as return values in functions claiming to return true or false.
+Get the null UUID (i.e. string of 16 null bytes).

 
 =cut
 
 
 =cut
 

-sub FALSE() { !1 }
-sub TRUE()  {  1 }
-
-BEGIN {
-    my $use_cowrefcnt = eval { require B::COW; 1 };
-    *_USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 };
-}
+sub UUID_NULL() { "\0" x 16 }

 
 ### --------------------------------------------------------------------------
 
 
 ### --------------------------------------------------------------------------