1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
use 5.008;
use strict;
use warnings;
package Role::Commons::Authority;
use Carp qw[croak];
use match::simple qw[match];
use Scalar::Util qw[blessed];
BEGIN {
use Moo::Role;
$Role::Commons::Authority::AUTHORITY = 'cpan:TOBYINK';
$Role::Commons::Authority::VERSION = '0.104';
}
our %ENABLE_SHARED;
our %SHARED_AUTHORITIES;
our $setup_for_class = sub {
my ($role, $package, %args) = @_;
if ( exists $args{-authorities} )
{
$ENABLE_SHARED{ $package } = 1;
ref($args{-authorities}) eq 'ARRAY' and
$SHARED_AUTHORITIES{ $package } = $args{-authorities};
}
};
sub AUTHORITY
{
my ($invocant, $test) = @_;
$invocant = ref $invocant if blessed($invocant);
my @authorities = do {
no strict 'refs';
my @a = ${"$invocant\::AUTHORITY"};
if (exists $ENABLE_SHARED{ $invocant })
{
push @a, @{$SHARED_AUTHORITIES{$invocant} || []};
push @a, @{"$invocant\::AUTHORITIES"};
}
@a;
};
if (scalar @_ > 1)
{
my $ok = undef;
AUTH: for my $A (@authorities)
{
if (match($A, $test))
{
$ok = $A;
last AUTH;
}
}
return $ok if defined $ok;
@authorities
? croak("Invocant ($invocant) has authority '$authorities[0]'")
: croak("Invocant ($invocant) has no authority defined");
}
wantarray ? @authorities : $authorities[0];
}
1;
__END__
=head1 NAME
Role::Commons::Authority - a class method indicating who published the package
=head1 SYNOPSIS
package MyApp;
use Role::Commons -all;
BEGIN { our $AUTHORITY = 'cpan:JOEBLOGGS' };
say MyApp->AUTHORITY; # says "cpan:JOEBLOGGS"
MyApp->AUTHORITY("cpan:JOEBLOGGS"); # does nothing much
MyApp->AUTHORITY("cpan:JOHNTCITIZEN"); # croaks
=head1 DESCRIPTION
This module adds an C<AUTHORITY> function to your package, which works along
the same lines as the C<VERSION> function.
The authority of a package can be defined like this:
package MyApp;
BEGIN { our $AUTHORITY = 'cpan:JOEBLOGGS' };
The authority should be a URI identifying the person, team, organisation or
trained chimp responsible for the release of the package. The pseudo-URI
scheme "cpan:" is the most commonly used identifier.
=head2 Method
=over
=item C<< AUTHORITY >>
Called with no parameters returns the authority of the module.
=item C<< AUTHORITY($test) >>
If passed a test, will croak if the test fails. The authority is tested
against the test using something approximating Perl 5.10's smart match
operator. (Briefly, you can pass a string for eq comparison, a regular
expression, a code reference to use as a callback, or an array reference
that will be grepped.)
=back
=head2 Multiple Authorities
This module allows you to indicate that your module is issued by multiple
authorities. The package variable C<< $AUTHORITY >> should still be used
to indicate the primary authority for the package.
package MyApp;
use Role::Commons
Authority => { -authorities => [qw( cpan:ALICE cpan:BOB )] };
BEGIN { $MyApp::AUTHORITY = 'cpan:JOE'; }
package main;
use feature qw(say);
say scalar MyApp->AUTHORITY; # says "cpan:JOE"
MyApp->AUTHORITY('cpan:JOE'); # lives
MyApp->AUTHORITY('cpan:ALICE'); # lives
MyApp->AUTHORITY('cpan:BOB'); # lives
MyApp->AUTHORITY('cpan:CAROL'); # croaks
The main use case for shared authorities is for team projects. The team would
designate a URI to represent the team as a whole. For example,
C<< http://datetime.perl.org/ >>, C<< http://moose.iinteractive.com/ >> or
C<< http://www.perlrdf.org/ >>. Releases can then be officially stamped with
the authority of the team.
And users can check they have an module released by the official team using:
RDF::TakeOverTheWorld->AUTHORITY(
q<http://www.perlrdf.org/>,
);
which will croak if package RDF::TakeOverTheWorld doesn't have the specified
authority.
=head1 BUGS
An obvious limitation is that this module relies on honesty. Don't release
modules under authorities you have no authority to use.
Please report any bugs to
L<http://rt.cpan.org/Dist/Display.html?Queue=Role-Commons>.
=head1 SEE ALSO
L<Role::Commons>,
L<authority>.
Background reading:
L<http://feather.perl6.nl/syn/S11.html>,
L<http://www.perlmonks.org/?node_id=694377>.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2012, 2014 by Toby Inkster.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=head1 DISCLAIMER OF WARRANTIES
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
