Further expand support for attributes

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

diff --git a/lib/File/KDBX/Util.pm b/lib/File/KDBX/Util.pm
index 9fe9a9eb318faf99efe195d2928b875b79ef4185..c3d77ae69b2f08e156eeeb11ed29f330ee76fc53 100644 (file)
--- a/lib/File/KDBX/Util.pm
+++ b/lib/File/KDBX/Util.pm
@@ -21,7 +21,7 @@ our $VERSION = '999.999'; # VERSION
 
 our %EXPORT_TAGS = (
     assert      => [qw(assert_64bit)],
-    class       => [qw(extends has)],
+    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)],
@@ -85,6 +85,7 @@ my %OP_NEG = (
     '=~'    =>  '!~',
     '!~'    =>  '=~',
 );
+my %ATTRIBUTES;
 
 =func load_xs
 
@@ -223,7 +224,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;
@@ -404,9 +406,14 @@ sub has {
     my $has_default = is_coderef $default;
     my $has_coerce  = is_coderef $coerce;
 
+    my $store = $args{store};
+    ($store, $name) = split(/\./, $name, 2) if $name =~ /\./;
+
     my $caller = caller;
+    push @{$ATTRIBUTES{$caller} //= []}, $name;
+
     no strict 'refs'; ## no critic (ProhibitNoStrict)
-    if (my $store = $args{store}) {
+    if ($store) {
         *{"${caller}::${name}"} = $is eq 'ro' && $has_default ? sub {
             $_[0]->$store->{$name} //= scalar $default->($_[0]);
         } : $is eq 'ro' ? sub {
@@ -573,6 +580,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);