The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

CORION / DBIx-VersionedSubs-0.09 / lib / DBIx / VersionedSubs / Hash.pm 

            

              
1
2
3
4
5
6
7
—
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
—
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
—
115
116
117
118
119
120
121
122
123
124

              
package DBIx::VersionedSubs::Hash;
use strict;
use base 'DBIx::VersionedSubs';
use vars qw($VERSION);
use Carp qw(carp croak);
$VERSION = '0.09';
=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<DBIx::VersionedSubs>
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<DBIx::VersionedSubs>.
If you pass in a hashref to the C<code> 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<DBIx::VersionedSubs> 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__
=head1 AUTHOR
Max Maischein, E<lt>corion@cpan.orgE<gt>
=head1 LICENSE
This module is licensed under the same terms as Perl itself.
=cut