File Coverage

blib/lib/Data/SingletonManager.pm

Criterion	Covered	Total	%
statement	29	30	96.6
branch	6	10	60.0
condition	7	12	58.3
subroutine	8	8	100.0
pod	4	4	100.0
total	54	64	84.3

=head1 NAME

Data::SingletonManager - return/set/clear instances of singletons identified by keys in different namespaces.

=head1 SYNOPSIS

  package My::Object;
  sub instance {
      my %args;
      ...
      my $key = "$args{userid}-$args{object_id}";
      return Data::SingletonManager->instance(
          namespace => __PACKAGE__,    # default; may omit.
          key => $key,
          creator => sub {
              return __PACKAGE__->new_instance($args{userid},
                                               $args{object_id});
          }
      );
  }

  package main;

  # return all singletons loaded in a namespace:
  @loaded_objs = Data::SingletonManager->instances("My::Object");

  # clear all singletons, in all packages (perhaps on new web request)
  Data::SingletonManager->clear_all;

  # clear all singletons in one namespace
  Data::SingletonManager->clear("My::Object");

=head1 DESCRIPTION

This is a small utility class to help manage multiple keyed singletons
in multiple namespaces.  It is not a base class so you can drop it into
any of your classes without namespace clashes with methods you might
already have, like "new", "instance", "new_instance", etc.

=head1 PACKAGE METHODS

All methods below are package methods.  There are no instance methods.

=over

=cut


############################################################################

package Data::SingletonManager;
use strict;
use Carp qw(croak);
use vars qw($VERSION);
$VERSION = "1.00";

my %data;  # namespace -> key -> value

=item instance(%args)

Package method to return (or create and save) a keyed instance where %args are:

=over

=item "namespace"

defaults to the calling package

=item "key"

scalar key for instance.  the (namespace, key) uniquely identifies an instance

=item "creator"

subref to return the instance if it doesn't already exist

=back

=cut

sub instance {
    my $class = shift;

    my %args = @_;

    my $ns  = delete $args{namespace} || _calling_package();

    my $key = delete $args{key} or
	croak "Argument 'key' required.";

    my $creator = delete $args{creator} or
	croak "Argument 'creator' required.";

    croak "Unknown argument(s): " . join(", ", keys %args) if %args;

    # return instance if we have it, else set it
    return $data{$ns}{$key} ||= $creator->();
}

############################################################################

=item instances([ $namespace ])

Return an array of all loaded instances in a namespace, which defaults
to the calling namespace if no namespace is given.

=cut

sub instances {
    my $class = shift;
    my $ns = shift || _calling_package();
    return () unless $data{$ns};
    return values %{ $data{$ns} };
}

############################################################################

=item clear([ $namespace ])

Clears all instances in a namespace, which defaults to the calling
namespace if no namespace is given.

=cut

sub clear {
    my $class = shift;
    my $ns = shift || _calling_package();
    delete $data{$ns};
}

############################################################################

=item clear_all

Clears all instances in all namespaces.

=cut

sub clear_all {
    %data = ();
}


############################################################################
#   Utility methods
############################################################################

sub _calling_package {
    my $i = 0;
    while (my ($pkg) = caller($i++)) {
	next if $pkg eq __PACKAGE__;
	return $pkg;
    }
    die;
}

############################################################################

=head1 AUTHORS

Brad Fitzpatrick

=head1 COPYRIGHT AND LICENSE

Copyright 2005 by Six Apart, Ltd.

License is granted to use and distribute this module under the same
terms as Perl itself.

=cut

1;