view release on metacpan or  search on metacpan

misc/lib/Queue/Q4M/Benchmark.pm  view on Meta::CPAN

# $Id: /mirror/coderepos/lang/perl/Queue-Q4M/trunk/misc/lib/Queue/Q4M/Benchmark.pm 65253 2008-07-08T02:20:49.109770Z daisuke  $

package Queue::Q4M::Benchmark;
use Moose;
use Moose::Util::TypeConstraints;

use Benchmark ();
use DBI;
use Queue::Q4M;

with 'MooseX::Getopt';

has 'dsn' => (
    is => 'rw',
    isa => 'Str',
    required => 1,
    trigger => sub { $_[0]->connect_info->[0] = $_[1] }
);

has 'username' => (
    is => 'rw',
    isa => 'Str',
    required => 1,
    default => sub { (getpwuid($>))[0] },
    trigger => sub { $_[0]->connect_info->[1] = $_[1] }
);

has 'password' => (
    is => 'rw',
    isa => 'Str',
    trigger => sub { $_[0]->connect_info->[2] = $_[1] }
);

has '__connect_info' => (
    accessor => 'connect_info',
    is => 'rw',
    isa => 'ArrayRef',
    auto_deref => 1,
    default => sub { +[ undef, undef, undef, { RaiseError => 1 } ] },
);

has '__dbh' => (
    accessor => 'dbh',
    is => 'rw',
    isa => 'Maybe[DBI::db]',
);

around 'dbh' => sub {
    my ($next, $self, @args) = @_;
    my $rv = $next->($self, @args);
    if (! @args) {
        if (! defined $rv || ! $rv->ping) {
            $rv = DBI->connect( $self->connect_info );
            $self->dbh($rv);
        }
    }
    return $rv;
};

role_type 'Queue::Q4M::Benchmark::Plugin';
subtype 'PluginList'
    => as 'ArrayRef[Queue::Q4M::Benchmark::Plugin]';
coerce 'PluginList'
    => from 'ArrayRef'
        => via {
            my @list;
            foreach my $class (@$_) {
                if ($class !~ s/^\+//) {
                    $class = "Queue::Q4M::Benchmark::Plugin::" . ucfirst $class;
                }
                Class::MOP::load_class($class);
                push @list, $class->new;
            }
            \@list;
        }
;

has 'plugins' => (
    is => 'rw',
    isa => 'PluginList',
    auto_deref => 1,
    coerce => 1,
    default => sub { +[] }
);