File Coverage

blib/lib/DBIx/VersionedSubs/Hash.pm

Criterion	Covered	Total	%
statement	35	39	89.7
branch	4	6	66.6
condition	4	4	100.0
subroutine	10	11	90.9
pod	4	4	100.0
total	57	64	89.0

package DBIx::VersionedSubs::Hash;
use strict;
use base 'DBIx::VersionedSubs';
use vars qw($VERSION);
use Carp qw(carp croak);

$VERSION = '0.07';

=head1 NAME

DBIx::VersionedSubs::Hash - store subroutines in a simple hash

=head1 SYNOPSIS

  package My::App;
  use strict;
  use base 'DBIx::VersionedSubs::Hash';

  __PACKAGE__->{code} = {
      say_hello => sub {print "Hello World"},
  };

  package main;
  use strict;

  my $app = My::App->new({code => {},dsn => $dsn );
  while (my $request = Some::Server->get_request) {
      $app->update_code(); # update code from the DB
      $app->handle_request->($request);
  }

=head1 ABSTRACT

This module overrides some methods in L
and replaces the normal namespace based code storage
with simple storage in a hash.
This is useful if you want multiple code versions
in a mod_perl environment for example.

=cut

=head2 C<< Package->new({ %ARGS }) >>

Creates a new object and initializes it from the class
default values as inherited from L.

If you pass in a hashref to the C key, all subroutines will
be stored in it. You can also use this feature to pass in a package
hash (like C< %My::App:: >), then this module will be almost identical
in usage to L itself. The difference
between the two is that subroutine names with characters outside of C<\w>
will not create subroutines in other namespaces with this module.

=cut

sub new {
    my ($package,$args) = @_;
    my $code = delete $args->{ code } || {};
    my $self = bless $args, $package;
    $self->setup( %$args );
    $self->{ code } = $code;
    $self;
};

sub create_sub {
    my ($self,$name,$code) = @_;
    my $package = ref $self;
    my $ref = $self->eval_sub($package,$name,$code);
    if ($ref) {
        if ($name eq 'BEGIN') {
            $ref->($self);
	    return undef
	} else {
	    $self->{code}->{$name} = $ref;
	    $self->code_source->{$name} = $code;
	}
    };
    $ref
};

sub destroy_sub {
    my ($self,$name) = @_;
    delete $self->{code}->{$name};
};

=head2 C<< $app->dispatch( FUNCTION, ARGS ) >>

This is a shorthand method for

    return $self->{code}->{$function}->(@ARGS);

except with error checking

=cut

sub dispatch {
    my $self= shift;
    my $name= shift;
    my $code= $self->{code}->{$name} || sub {croak "Undefined subroutine '$name' called."};
    goto &$code;
};

# Install our accessors
for (qw(code_source code_live code_history code_version verbose dsn)) {
    my $name = $_;
    no strict 'refs';
    *{__PACKAGE__ . "::$name"} = sub {
        @_ > 1 ?  $_[0]->{$name} = $_[1] : $_[0]->{$name}
    };
};

1

__END__