File Coverage

blib/lib/Test2/Util/ExternalMeta.pm
Criterion Covered Total %
statement 40 40 100.0
branch 13 14 92.8
condition 9 11 81.8
subroutine 9 9 100.0
pod 4 5 80.0
total 75 79 94.9


line stmt bran cond sub pod time code
1             package Test2::Util::ExternalMeta;
2 246     246   2077 use strict;
  246         477  
  246         7143  
3 246     246   1193 use warnings;
  246         456  
  246         9896  
4              
5             our $VERSION = '1.302182';
6              
7              
8 246     246   1415 use Carp qw/croak/;
  246         487  
  246         28557  
9              
10             sub META_KEY() { '_meta' }
11              
12             our @EXPORT = qw/meta set_meta get_meta delete_meta/;
13 246     246   1807 BEGIN { require Exporter; our @ISA = qw(Exporter) }
  246         101614  
14              
15             sub set_meta {
16 5     5 1 21 my $self = shift;
17 5         67 my ($key, $value) = @_;
18              
19 5         23 validate_key($key);
20              
21 5   50     34 $self->{+META_KEY} ||= {};
22 5         19 $self->{+META_KEY}->{$key} = $value;
23             }
24              
25             sub get_meta {
26 315     315 1 500 my $self = shift;
27 315         602 my ($key) = @_;
28              
29 315         752 validate_key($key);
30              
31 315 100       741 my $meta = $self->{+META_KEY} or return undef;
32 309         907 return $meta->{$key};
33             }
34              
35             sub delete_meta {
36 4     4 1 22 my $self = shift;
37 4         12 my ($key) = @_;
38              
39 4         12 validate_key($key);
40              
41 2 50       8 my $meta = $self->{+META_KEY} or return undef;
42 2         9 delete $meta->{$key};
43             }
44              
45             sub meta {
46 2242     2242 1 4266 my $self = shift;
47 2242         4967 my ($key, $default) = @_;
48              
49 2242         6300 validate_key($key);
50              
51 2240         4253 my $meta = $self->{+META_KEY};
52 2240 100 100     6818 return undef unless $meta || defined($default);
53              
54 2237 100       4627 unless($meta) {
55 371         857 $meta = {};
56 371         1055 $self->{+META_KEY} = $meta;
57             }
58              
59             $meta->{$key} = $default
60 2237 100 100     9403 if defined($default) && !defined($meta->{$key});
61              
62 2237         6637 return $meta->{$key};
63             }
64              
65             sub validate_key {
66 2566     2566 0 4163 my $key = shift;
67              
68 2566 100 66     12497 return if $key && !ref($key);
69              
70 4 100       20 my $render_key = defined($key) ? "'$key'" : 'undef';
71 4         399 croak "Invalid META key: $render_key, keys must be true, and may not be references";
72             }
73              
74             1;
75              
76             __END__
77              
78             =pod
79              
80             =encoding UTF-8
81              
82             =head1 NAME
83              
84             Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data
85             to your instances.
86              
87             =head1 DESCRIPTION
88              
89             This package lets you define a clear, and consistent way to allow third party
90             tools to attach meta-data to your instances. If your object consumes this
91             package, and imports its methods, then third party meta-data has a safe place
92             to live.
93              
94             =head1 SYNOPSIS
95              
96             package My::Object;
97             use strict;
98             use warnings;
99              
100             use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
101              
102             ...
103              
104             Now to use it:
105              
106             my $inst = My::Object->new;
107              
108             $inst->set_meta(foo => 'bar');
109             my $val = $inst->get_meta('foo');
110              
111             =head1 WHERE IS THE DATA STORED?
112              
113             This package assumes your instances are blessed hashrefs, it will not work if
114             that is not true. It will store all meta-data in the C<_meta> key on your
115             objects hash. If your object makes use of the C<_meta> key in its underlying
116             hash, then there is a conflict and you cannot use this package.
117              
118             =head1 EXPORTS
119              
120             =over 4
121              
122             =item $val = $obj->meta($key)
123              
124             =item $val = $obj->meta($key, $default)
125              
126             This will get the value for a specified meta C<$key>. Normally this will return
127             C<undef> when there is no value for the C<$key>, however you can specify a
128             C<$default> value to set when no value is already set.
129              
130             =item $val = $obj->get_meta($key)
131              
132             This will get the value for a specified meta C<$key>. This does not have the
133             C<$default> overhead that C<meta()> does.
134              
135             =item $val = $obj->delete_meta($key)
136              
137             This will remove the value of a specified meta C<$key>. The old C<$val> will be
138             returned.
139              
140             =item $obj->set_meta($key, $val)
141              
142             Set the value of a specified meta C<$key>.
143              
144             =back
145              
146             =head1 META-KEY RESTRICTIONS
147              
148             Meta keys must be defined, and must be true when used as a boolean. Keys may
149             not be references. You are free to stringify a reference C<"$ref"> for use as a
150             key, but this package will not stringify it for you.
151              
152             =head1 SOURCE
153              
154             The source code repository for Test2 can be found at
155             F<http://github.com/Test-More/test-more/>.
156              
157             =head1 MAINTAINERS
158              
159             =over 4
160              
161             =item Chad Granum E<lt>exodist@cpan.orgE<gt>
162              
163             =back
164              
165             =head1 AUTHORS
166              
167             =over 4
168              
169             =item Chad Granum E<lt>exodist@cpan.orgE<gt>
170              
171             =back
172              
173             =head1 COPYRIGHT
174              
175             Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
176              
177             This program is free software; you can redistribute it and/or
178             modify it under the same terms as Perl itself.
179              
180             See F<http://dev.perl.org/licenses/>
181              
182             =cut