Commits

Toby Inkster committed e39b933

Initial release

Comments (0)

Files changed (12)

+use inc::Module::Package 'RDF:standard';
+

lib/Object/AUTHORITY.pm

+package Object::AUTHORITY;
+
+use 5.006;
+use strict;
+
+BEGIN {
+	$Object::AUTHORITY::AUTHORITY = 'cpan:TOBYINK';
+	$Object::AUTHORITY::VERSION   = '0.001';
+}
+
+use Carp qw[croak];
+use Scalar::Util qw[blessed];
+use Sub::Name qw[subname];
+
+sub import
+{
+	my ($invocant, @args) = @_;
+	
+	my %args;
+	while (defined(my $arg = shift @args))
+	{
+		if ($arg =~ /^-/)
+		{
+			$args{$arg} = shift @args;
+		}
+		else
+		{
+			push @{$args{-method}}, $arg;
+		}
+	}
+	
+	my $package = $args{-package} // caller;
+	$package = [$package] unless ref $package;
+	
+	for my $caller (@$package)
+	{
+		no strict 'refs';
+		my $name = "$caller\::AUTHORITY";
+		*$name = my $ref = subname($name, \&AUTHORITY);
+	}
+}
+
+sub AUTHORITY
+{
+	my ($invocant, $test) = @_;
+	$invocant = ref $invocant if blessed($invocant);
+	
+	my $authority = do {
+		no strict 'refs';
+		${"$invocant\::AUTHORITY"};
+		};
+	
+	if (scalar @_ > 1)
+	{
+		if (defined $authority)
+		{
+			croak("Invocant ($invocant) has authority '$authority'")
+				unless reasonably_smart_match($authority, $test);
+		}
+		else
+		{
+			croak("Invocant ($invocant) has no authority defined")
+				unless reasonably_smart_match($authority, $test);
+		}
+	}
+	
+	return $authority;
+}
+
+sub reasonably_smart_match
+{
+	my ($a, $b) = @_;
+	
+	if (!defined $b)
+	{
+		return !defined $a;
+	}
+	elsif (ref $b eq 'CODE')
+	{
+		return $b->($a);
+	}
+	elsif (ref $b eq 'HASH')
+	{
+		return unless defined $a;
+		return exists $b->{$a};
+	}
+	elsif (ref $b eq 'ARRAY')
+	{
+		return grep { reasonably_smart_match($a, $_) } @$b;
+	}
+	elsif (ref $b eq 'Regexp')
+	{
+		return ($a =~ $b);
+	}
+	else
+	{
+		return ($a eq $b);
+	}
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Object::AUTHORITY - adds an AUTHORITY method to your class
+
+=head1 SYNOPSIS
+
+ {
+   package MyClass;
+   use Object::AUTHORITY;
+   BEGIN {
+     $MyClass::AUTHORITY = 'cpan:TOBYINK';
+     $MyClass::VERSION   = '0.001';
+   }
+ }
+ 
+ print MyClass->AUTHORITY . "\n";   # prints "cpan:TOBYINK\n";
+ MyClass->AUTHORITY('cpan:FOO');    # assertion fails, 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 { $MyApp::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 C<< cpan: >> is the most commonly used identifier.
+
+=head2 C<< AUTHORITY >>
+
+Called with no parameters returns the authority of the module.
+
+=head2 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 C<eq> comparison, a regular
+expression, a code reference to use as a callback, or an array reference
+that will be grepped.)
+
+=head2 Utility Function
+
+=over
+
+=item C<< Object::AUTHORITY::reasonably_smart_match($a, $b) >>
+
+Object::AUTHORITY exposes its smart match implementation in case
+classes wish to reuse it for their own custom C<AUTHORITY> methods. (There
+are various interesting use cases for custom C<AUTHORITY> methods, just as
+there are for custom C<can> and C<isa> methods.)
+
+The C<< $a >> parameter is assumed to be a scalar.
+
+=back
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=Object-AUTHORITY>.
+
+=head1 SEE ALSO
+
+=over
+
+=item * I<Object::AUTHORITY> (this module) - an AUTHORITY method for your class
+
+=item * L<authority::shared> - a more sophisticated AUTHORITY method for your class
+
+=item * L<UNIVERSAL::AUTHORITY> - an AUTHORITY method for every class (deprecated)
+
+=item * L<UNIVERSAL::AUTHORITY::Lexical> - an AUTHORITY method for every class, within a lexical scope
+
+=item * L<authority> - load modules only if they have a particular authority
+
+=back
+
+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) 2011 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.
+
+# This file acts as the project's changelog.
+
+@prefix :        <http://usefulinc.com/ns/doap#> .
+@prefix dcs:     <http://ontologi.es/doap-changeset#> .
+@prefix dc:      <http://purl.org/dc/terms/> .
+@prefix dist:    <http://purl.org/NET/cpan-uri/dist/Object-AUTHORITY/> .
+@prefix rdfs:    <http://www.w3.org/2000/01/rdf-schema#> .
+@prefix xsd:     <http://www.w3.org/2001/XMLSchema#> .
+
+dist:project :release dist:v_0-001 .
+dist:v_0-001
+	a               :Version ;
+	dc:issued       "2011-12-01"^^xsd:date ;
+	:revision       "0.001"^^xsd:string ;
+	:file-release   <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/Object-AUTHORITY-0.001.tar.gz> ;
+	rdfs:label      "Initial release" .
+
+# This file contains general metadata about the project.
+
+@prefix :        <http://usefulinc.com/ns/doap#> .
+@prefix dc:      <http://purl.org/dc/terms/> .
+@prefix foaf:    <http://xmlns.com/foaf/0.1/> .
+@prefix rdfs:    <http://www.w3.org/2000/01/rdf-schema#> .
+@prefix xsd:     <http://www.w3.org/2001/XMLSchema#> .
+
+<http://purl.org/NET/cpan-uri/dist/Object-AUTHORITY/project>
+	a               :Project ;
+	:programming-language "Perl" ;
+	:name           "Object-AUTHORITY" ;
+	:shortdesc      "adds an AUTHORITY method to your class" ;
+	:homepage       <https://metacpan.org/release/Object-AUTHORITY> ;
+	:download-page  <https://metacpan.org/release/Object-AUTHORITY> ;
+	:repository     [ a :HgRepository ; :browse <https://bitbucket.org/tobyink/p5-object-authority> ] ;
+	:bug-database   <http://rt.cpan.org/Dist/Display.html?Queue=Object-AUTHORITY> ;
+	:created        "2011-12-01"^^xsd:date ;
+	:license        <http://dev.perl.org/licenses/> ;
+	:developer      [ a foaf:Person ; foaf:name "Toby Inkster" ; foaf:mbox <mailto:tobyink@cpan.org> ] .
+
+<http://dev.perl.org/licenses/>
+	dc:title        "the same terms as the perl 5 programming language system itself" .
+

meta/makefile.ttl

+# This file provides instructions for packaging.
+
+@prefix : <http://purl.org/NET/cpan-uri/terms#> .
+
+<http://purl.org/NET/cpan-uri/dist/Object-AUTHORITY/project>
+	:perl_version_from _:main ;
+	:version_from _:main ;
+	:readme_from _:main ;
+	:test_requires "Test::More 0.61" ;
+	:requires "Scalar::Util" , "Sub::Name" , "Carp" .
+
+_:main <http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#fileName> "lib/Object/AUTHORITY.pm" .
+
+use Test::More tests => 1;
+BEGIN { use_ok('Object::AUTHORITY') };
+
+package Local::MyTest;
+
+our $AUTHORITY = 'http://example.net/';
+
+package main;
+
+use Test::More tests => 2;
+use Object::AUTHORITY -package => 'Local::MyTest';
+
+is(
+	Local::MyTest->AUTHORITY,
+	'http://example.net/',
+	'test package has correct authority',
+	);
+
+SKIP: {
+	skip "need Moose 2.02", 1
+		unless eval 'use Moose 2.02; 1;';
+	skip "Moose seems to have stopped defining an authority", 1
+		unless defined $Moose::AUTHORITY;
+		
+	Object::AUTHORITY->import(-package => 'Moose');
+	ok(
+		defined Moose->AUTHORITY,
+		'Moose has an authority',
+		);
+}
+package Local::MyTest;
+
+our $AUTHORITY = 'http://example.net/';
+
+package main;
+
+use Test::More tests => 7;
+use Test::Exception;
+use Object::AUTHORITY -package => 'Local::MyTest';
+
+dies_ok
+	{ Local::MyTest->AUTHORITY('cpan:TOBYINK') }
+	'dies passed string';
+
+dies_ok
+	{ Local::MyTest->AUTHORITY(qr/^cpan:/i) }
+	'dies passed regexp';
+
+dies_ok
+	{ Local::MyTest->AUTHORITY(undef) }
+	'dies passed undef';
+	
+dies_ok
+	{ Local::MyTest->AUTHORITY(['mailto:joe@example.net' , qr/^cpan:/i]) }
+	'dies passed arrayref';
+
+lives_ok
+	{ Local::MyTest->AUTHORITY('http://example.net/') }
+	'lives passed string';
+
+lives_ok
+	{ Local::MyTest->AUTHORITY(qr/^http:/i) }
+	'lives passed regexp';
+
+lives_ok
+	{ Local::MyTest->AUTHORITY(['mailto:joe@example.net' , qr/^cpan:/i, 'http://example.net/']) }
+	'lives passed arrayref';
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
+

xt/02pod_coverage.t

+use Test::More;
+use Test::Pod::Coverage;
+
+my @modules = qw(Object::AUTHORITY);
+pod_coverage_ok($_, "$_ is covered")
+	foreach @modules;
+done_testing(scalar @modules);
+

xt/03meta_uptodate.t

+use Test::More tests => 1;
+use Test::RDF::DOAP::Version;
+doap_version_ok('Object-AUTHORITY', 'Object::AUTHORITY');
+
+use Test::EOL;
+all_perl_files_ok();