Commits

Toby Inkster committed a4bcc48

Initial commit

Comments (0)

Files changed (10)

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

lib/Object/Role.pm

+package Object::Role;
+
+use 5.006;
+use strict;
+use utf8;
+
+BEGIN {
+	$Object::Role::AUTHORITY = 'cpan:TOBYINK';
+	$Object::Role::VERSION   = '0.001';
+}
+
+use Sub::Name qw/subname/;
+use Object::AUTHORITY;
+
+sub parse_arguments
+{
+	my (undef, $default, @args) = @_;
+	my %args;
+	
+	while (defined(my $arg = shift @args))
+	{
+		if ($arg =~ /^-/)
+		{
+			$args{$arg} = shift @args;
+		}
+		else
+		{
+			push @{$args{$default}}, $arg;
+		}
+	}
+	
+	my $caller = defined $args{-package} ? $args{-package} : caller(1);
+	
+	return ($caller, %args);
+}
+
+sub install_method
+{
+	my ($class, $subname, $coderef, $caller) = @_;
+	my $name = "$caller\::$subname";
+	no strict 'refs';
+	no warnings 'redefine';
+	*{$name} = subname($name, $coderef);
+	$class->register_consumer($caller)
+		unless $class->has_consumer($caller);
+	$class;
+}
+
+sub register_consumer
+{
+	my ($class, $consumer) = @_;
+	no strict 'refs';
+	no warnings 'redefine';
+	push @{"$class\::CONSUMERS"}, $consumer;
+	$class;
+}
+
+sub has_consumer
+{
+	my ($class, $consumer) = @_;
+	$consumer = ref($consumer) if ref($consumer);
+	no strict 'refs';
+	no warnings 'redefine';
+	foreach (@{"$class\::CONSUMERS"})
+	{
+		return $class if $_ eq $consumer;
+	}
+	return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Object::Role - base class for non-Moose roles
+
+=head1 SYNOPSIS
+
+ {
+   package Object::Dumpable;
+   use base qw/Object::Role/;
+   use Data::Dumper;
+   sub import
+   {
+     my ($class, @args) = @_;
+     my ($caller, %args) = __PACKAGE__->parse_arguments(undef, @args);
+     my $coderef = sub
+       {
+         my ($self) = @_;
+         return Dumper($self);
+       };
+     __PACKAGE__->install_method(dump => $coderef, $caller);
+   }
+ }
+ 
+ {
+   package Foo;
+   use Object::Dumpable;
+   sub new { ... }
+ }
+ 
+ {
+   package main;
+   my $foo = Foo->new;
+   warn $foo->dump;
+ }
+
+=head1 DESCRIPTION
+
+This will be better documented once I fully understand it myself!
+
+The idea of this is to be a base class for roles like L<Object::DOES>,
+L<Object::Stash> and L<Object::ID>. It handles parsing of import arguments,
+installing methods into the caller's namespace (like L<Exporter>, but using
+a technique that is immune to L<namespace::autoclean>) and tracking which
+packages have consumed your role.
+
+While C<Object::Role> is a base class for roles, it is not itself a role,
+so does not export anything. Instead, your role must inherit from it.
+
+=head2 Methods
+
+=over
+
+=item C<< parse_arguments($default_arg_name, @arguments) >>
+
+Will parse:
+
+  package My::Class;
+  use My::Role -foo => 1, -bar => [2,3], 4, 5;
+
+as:
+
+  (
+    'My::Class',   # caller,
+    (
+      '-foo'             => [1],
+      '-bar'             => [2, 3],
+      $default_arg_name  => [4, 5],
+    )
+  )
+
+=item C<< install_method($subname => $coderef, $package) >>
+
+Installs $coderef as "$package\::$subname".
+
+Automatically calls register_consumer($package).
+
+=item C<< register_consumer($package) >>
+
+Records that $package has consumed (used) your role.
+
+=item C<< has_consumer($package) >>
+
+Check if $package has consumed (used) your role.
+
+=back
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=Object-Role>.
+
+=head1 SEE ALSO
+
+L<Exporter>.
+
+=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-Role/> .
+@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-14"^^xsd:date ;
+	:revision       "0.001"^^xsd:string ;
+	:file-release   <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/Object-Role-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-Role/project>
+	a               :Project ;
+	:programming-language "Perl" ;
+	:name           "Object-Role" ;
+	:shortdesc      "a module that does something-or-other" ;
+	:homepage       <https://metacpan.org/release/Object-Role> ;
+	:download-page  <https://metacpan.org/release/Object-Role> ;
+	:bug-database   <http://rt.cpan.org/Dist/Display.html?Queue=Object-Role> ;
+	:created        "2011-12-14"^^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-Role/project>
+	:perl_version_from _:main ;
+	:version_from _:main ;
+	:readme_from _:main ;
+	:test_requires "Test::More 0.61" ;
+	:requires "Scalar::Util" , "autodie" , "boolean" , "common::sense" .
+
+_:main <http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#fileName> "lib/Object/Role.pm" .
+
+use Test::More tests => 1;
+BEGIN { use_ok('Object::Role') };
+
+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::Role);
+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-Role', 'Object::Role');
+
+use Test::EOL;
+all_perl_files_ok();