Fix test fail with older versions of Time::Piece

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

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index 7d51a21cf3c81f525e18e3803825e657b4ac1bd5..84cb363158b50b14125e970052a0e0244afa6108 100644 (file)
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -10,33 +10,47 @@ use Exporter qw(import);
 use File::KDBX::Error;
 use List::Util 1.33 qw(any all);
 use Module::Load;
 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 is_ref);
-use Scalar::Util qw(blessed isdual looks_like_number readonly refaddr);
+use Ref::Util qw(is_arrayref is_coderef is_hashref is_ref is_refref is_scalarref);
+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 = (
 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)],
     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,


@@ -80,19 +94,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


@@ -160,6 +217,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;


@@ -188,7 +249,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;


@@ -242,7 +304,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


@@ -251,10 +323,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($_);
             # }


@@ -268,10 +338,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($$_);
             # }


@@ -311,6 +379,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($_)


@@ -321,6 +390,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);


@@ -424,75 +568,159 @@ sub gzip {
     return $out;
 }
 
     return $out;
 }
 

-=func is_readable
+=func int64
+
+    $int = int64($string);
+
+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>.

 
 

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

 
 

-    $bool = is_readable($mode);
-    $bool = is_writable($mode);
+=func pack_Ql

 
 

-Determine of an C<fopen>-style mode is readable, writable or both.
+    $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 }
+
+=func list_attributes
+
+    @attributes = list_attributes($package);
+
+Get a list of attributes for a class.
+
+=cut

 
 

-    require File::KDBX;
+sub list_attributes {
+    my $package = shift;
+    return @{$ATTRIBUTES{$package} // []};
+}

 
 

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

 
 

-    my $try_xs = 1;
-    $try_xs = 0 if $ENV{PERL_ONLY} || (exists $ENV{PERL_FILE_KDBX_XS} && !$ENV{PERL_FILE_KDBX_XS});
+Load a module that isn't required but can provide extra functionality. Throw if the module is not available.

 
 

-    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 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


@@ -541,19 +769,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
 


@@ -602,31 +850,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;
 }


@@ -634,6 +866,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>.


@@ -735,6 +968,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);


@@ -762,7 +1029,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;
         }
     }


@@ -819,10 +1086,13 @@ sub uuid {
 
 }
 
 
 }
 

-BEGIN {
-    my $use_cowrefcnt = eval { require B::COW; 1 };
-    *_USE_COWREFCNT = $use_cowrefcnt ? sub() { 1 } : sub() { 0 };
-}
+=func UUID_NULL
+
+Get the null UUID (i.e. string of 16 null bytes).
+
+=cut
+
+sub UUID_NULL() { "\0" x 16 }

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