1package Test2::Util::ExternalMeta;
2use strict;
3use warnings;
4
5our $VERSION = '1.302175';
6
7
8use Carp qw/croak/;
9
10sub META_KEY() { '_meta' }
11
12our @EXPORT = qw/meta set_meta get_meta delete_meta/;
13BEGIN { require Exporter; our @ISA = qw(Exporter) }
14
15sub set_meta {
16    my $self = shift;
17    my ($key, $value) = @_;
18
19    validate_key($key);
20
21    $self->{+META_KEY} ||= {};
22    $self->{+META_KEY}->{$key} = $value;
23}
24
25sub get_meta {
26    my $self = shift;
27    my ($key) = @_;
28
29    validate_key($key);
30
31    my $meta = $self->{+META_KEY} or return undef;
32    return $meta->{$key};
33}
34
35sub delete_meta {
36    my $self = shift;
37    my ($key) = @_;
38
39    validate_key($key);
40
41    my $meta = $self->{+META_KEY} or return undef;
42    delete $meta->{$key};
43}
44
45sub meta {
46    my $self = shift;
47    my ($key, $default) = @_;
48
49    validate_key($key);
50
51    my $meta = $self->{+META_KEY};
52    return undef unless $meta || defined($default);
53
54    unless($meta) {
55        $meta = {};
56        $self->{+META_KEY} = $meta;
57    }
58
59    $meta->{$key} = $default
60        if defined($default) && !defined($meta->{$key});
61
62    return $meta->{$key};
63}
64
65sub validate_key {
66    my $key = shift;
67
68    return if $key && !ref($key);
69
70    my $render_key = defined($key) ? "'$key'" : 'undef';
71    croak "Invalid META key: $render_key, keys must be true, and may not be references";
72}
73
741;
75
76__END__
77
78=pod
79
80=encoding UTF-8
81
82=head1 NAME
83
84Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data
85to your instances.
86
87=head1 DESCRIPTION
88
89This package lets you define a clear, and consistent way to allow third party
90tools to attach meta-data to your instances. If your object consumes this
91package, and imports its methods, then third party meta-data has a safe place
92to 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
104Now 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
113This package assumes your instances are blessed hashrefs, it will not work if
114that is not true. It will store all meta-data in the C<_meta> key on your
115objects hash. If your object makes use of the C<_meta> key in its underlying
116hash, 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
126This will get the value for a specified meta C<$key>. Normally this will return
127C<undef> when there is no value for the C<$key>, however you can specify a
128C<$default> value to set when no value is already set.
129
130=item $val = $obj->get_meta($key)
131
132This will get the value for a specified meta C<$key>. This does not have the
133C<$default> overhead that C<meta()> does.
134
135=item $val = $obj->delete_meta($key)
136
137This will remove the value of a specified meta C<$key>. The old C<$val> will be
138returned.
139
140=item $obj->set_meta($key, $val)
141
142Set the value of a specified meta C<$key>.
143
144=back
145
146=head1 META-KEY RESTRICTIONS
147
148Meta keys must be defined, and must be true when used as a boolean. Keys may
149not be references. You are free to stringify a reference C<"$ref"> for use as a
150key, but this package will not stringify it for you.
151
152=head1 SOURCE
153
154The source code repository for Test2 can be found at
155F<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
175Copyright 2019 Chad Granum E<lt>exodist@cpan.orgE<gt>.
176
177This program is free software; you can redistribute it and/or
178modify it under the same terms as Perl itself.
179
180See F<http://dev.perl.org/licenses/>
181
182=cut
183