Commits

Toby Inkster  committed 37f8e67

stashes

  • Participants

Comments (0)

Files changed (11)

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

File lib/Object/Stash.pm

+package Object::Stash;
+
+use 5.010;
+use strict;
+use utf8;
+
+BEGIN {
+	$Object::Stash::AUTHORITY = 'cpan:TOBYINK';
+	$Object::Stash::VERSION   = '0.001';
+}
+
+use Carp qw/croak/;
+use Hash::FieldHash qw/fieldhashes/;
+use Scalar::Util qw/blessed/;
+use Sub::Name qw/subname/;
+
+fieldhashes \my (%known_stashes);
+
+sub import
+{
+	my ($invocant, @args) = @_;
+	
+	my %args;
+	while (defined(my $arg = shift @args))
+	{
+		if ($arg =~ /^-/)
+		{
+			$args{$arg} = shift @args;
+		}
+		else
+		{
+			push @{$args{-method}}, $arg;
+		}
+	}
+	$args{-method} = ['stash'] if !exists $args{-method};
+	
+	my $caller = $args{-package} // caller;
+	
+	for my $method (@{$args{-method}})
+	{
+		no strict 'refs';
+		my $name = "$caller\::$method";
+		*$name = my $ref = subname($name, sub { unshift @_, $name; goto &_stash; });
+		$known_stashes{ $ref } = $name;
+	}
+}
+
+sub is_stash
+{
+	shift if (!ref $_[0] and $_[0]->isa(__PACKAGE__));
+	my ($name) = @_;
+	
+	return $known_stashes{ $name } if exists $known_stashes{ $name };
+	return;
+}
+
+{
+	fieldhashes \my (%Stashes);
+	
+	sub _stash
+	{
+		my ($stashname, $self, @args) = @_;
+		
+		my %set;
+		if (scalar @args == 1 and ref $args[0] eq 'HASH')
+		{
+			%set = %{ $args[0] };
+		}
+		elsif (scalar @args % 2 == 0)
+		{
+			%set = @args;
+		}
+		elsif (@args)
+		{
+			croak "$stashname expects to be passed a hash, hash reference, or nothing.";
+		}
+		
+		return unless (defined wantarray or @args);
+		
+		my $stash = $Stashes{ $self }{ $stashname };
+		$stash = $Stashes{ $self }{ $stashname } = {} unless defined $stash;
+		
+		while (my ($k, $v) = each %set)
+		{
+			$stash->{$k} = $v;
+		}
+		
+		return $stash;
+	}
+}
+
+'Secret stash';
+
+__END__
+
+=head1 NAME
+
+Object::Stash - provides a Catalyst-like "stash" method for your class
+
+=head1 SYNOPSIS
+
+ {
+   package MyClass;
+   use Object::New;
+   use Object::Stash 'data';
+ }
+ 
+ use feature 'say';
+ use Data::Printer qw(p);
+ my $obj = MyClass->new;
+ p $obj->data;                     # an empty hashref
+ $obj->data(foo => 1, bar => 2);   # sets values in the 'data' stash
+ $obj->data({foo => 1, bar => 2}); # same
+ p $obj->data;                     # hashref with keys 'foo', 'bar'
+ say $obj->data->{foo};            # says '1'
+
+=head1 DESCRIPTION
+
+The L<Catalyst> context object has a method called stash, that provides a
+hashref for storing arbitrary data associated with the object. This is
+arguably a little hackish - the proper solution might be to create a slot
+for each piece of information you wish to store, with appropriate accessor
+methods. But often hackish will do.
+
+Object::Stash sets up one or more stash methods for your class. How these
+methods are named depends on how Object::Stash is imported. Object::Stash
+is a role, like L<Object::New> or L<Object::ID>. This means you import it,
+but don't inherit from it.
+
+=head2 Default method name
+
+ package MyClass;
+ use Object::Stash;
+
+Creates a single method for MyClass objects. The method is called "stash".
+
+=head2 Custom method name
+
+ package MyClass;
+ use Object::Stash 'data';
+
+Creates a single method for MyClass objects. The method is called "data".
+
+=head2 Multiple methods
+
+ package MyClass;
+ use Object::Stash qw/important trivial/;
+
+Creates two stashes for MyClass objects, called "important" and "trivial".
+Adding data to one stash will not affect the other stash. You could
+alternatively write:
+
+ package MyClass;
+ use Object::Stash 'important'
+ use Object::Stash 'trivial';
+
+=head2 Adding stashes to other classes
+
+ package MyClass;
+ use Object::Stash -package => 'YourClass', 'my_stash';
+
+Creates a stash called "my_stash" for YourClass objects.
+
+=head2 Utility Functions
+
+=over
+
+=item C<< Object::Stash->is_stash( $coderef ) >>
+
+Returns true if the method is a stash. For example:
+
+  my $method = MyClass->can('trivial');
+  if (Object::Stash->is_stash($method))
+  {
+    $method->(foo => 1, bar => 2);
+  }
+
+Can also be called as C<< Object::Stash::is_stash($coderef) >>.
+
+=back
+
+=head2 Stash Storage
+
+Stashes are stored "inside-out", meaning that they will work not only with
+objects which are blessed hashrefs, but also with any other type of object
+internals. Dumping your object with L<Data::Dumper> or similar will not
+display the contents of the stashes. (A future release of this module may
+introduce other storage options, but the current inside-out storage is
+likely to remain the default.)
+
+Thanks to L<Hash::FieldHash>, an object's stashes I<should> get automatically
+garbage collected once the object itself is destroyed, unless you've
+maintained your own references to the stashes.
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=Object-Stash>.
+
+=head1 SEE ALSO
+
+L<Object::New>, L<Object::ID>.
+
+=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.
+

File meta/changes.ttl

+# 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-Stash/> .
+@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-11-28"^^xsd:date ;
+	:revision       "0.001"^^xsd:string ;
+	:file-release   <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/Object-Stash-0.001.tar.gz> ;
+	rdfs:label      "Initial release" .
+

File meta/doap.ttl

+# 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-Stash/project>
+	a               :Project ;
+	:programming-language "Perl" ;
+	:name           "Object-Stash" ;
+	:shortdesc      "provides a Catalyst-like \"stash\" method for your class" ;
+	:homepage       <https://metacpan.org/release/Object-Stash> ;
+	:download-page  <https://metacpan.org/release/Object-Stash> ;
+	:bug-database   <http://rt.cpan.org/Dist/Display.html?Queue=Object-Stash> ;
+	:created        "2011-11-28"^^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" .
+

File 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-Stash/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/Stash.pm" .
+
+use Test::More tests => 1;
+BEGIN { use_ok('Object::Stash') };
+

File t/02stashes.t

+use Test::More tests => 18;
+use Object::Stash;
+
+{
+	package Local::TestClass1;
+	use Object::Stash;
+	sub new {bless[@_],shift}
+}
+
+{
+	package Local::TestClass2;
+	use Object::Stash qw/data vital_data/;
+	sub new {bless[@_],shift}
+}
+
+{
+	package Local::TestClass3;
+	use Object::Stash -package => 'Local::TestClass2', qw/trivial_data/;
+	sub new {bless[@_],shift}
+}
+
+my ($o1, $o2, $o3) = map { "Local::TestClass$_"->new } 1..3;
+
+ok(!Object::Stash->is_stash($o1->can('new')), 'Normal methods are not stashes');
+
+ok($o1->can('stash'), 'Default name, creates method');
+ok(Object::Stash->is_stash($o1->can('stash')), 'Default name, is stash');
+
+ok(!$o2->can('stash'), 'Non-default name, does not create default method');
+ok($o2->can('data'), 'Non-default name, creates method');
+ok(Object::Stash->is_stash($o2->can('data')), 'Non-default name, is stash');
+ok($o2->can('vital_data'), 'Multiple names, creates method');
+ok(Object::Stash->is_stash($o2->can('vital_data')), 'Multiple names, is stash');
+
+ok(!$o3->can('stash'), '-package argument, does not create default stash in caller');
+ok(!$o3->can('trivial_data'), '-package argument, does not create named stash in caller');
+ok($o2->can('trivial_data'), '-package argument, creates method in requested package');
+ok(Object::Stash->is_stash($o2->can('trivial_data')), '-package argument, creates stash');
+
+is(ref $o1->stash, 'HASH', 'stash is a hashref');
+
+is_deeply($o2->vital_data(foo=>1,bar=>2), {foo=>1, bar=>2}, 'can set data by providing hash');
+is_deeply($o2->trivial_data({foo=>1,baz=>2}), {foo=>1, baz=>2}, 'can set data by providing hashref');
+ok(!exists $o2->vital_data->{baz}, "methods kept separate");
+
+my $o2b = Local::TestClass2->new;
+ok(!$o2b->vital_data->{foo},'objects kept separate');
+
+ok(Object::Stash::is_stash($o1->can('stash')), 'is_stash can be called as a non-method');
+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();
+

File xt/02pod_coverage.t

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

File xt/03meta_uptodate.t

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