File Coverage

blib/lib/Class/Dot/Model.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

# $Id: Model.pm 4 2007-09-13 10:16:35Z asksol $
# $Source$
# $Author: asksol $
# $HeadURL: https://class-dot-model.googlecode.com/svn/trunk/lib/Class/Dot/Model.pm $
# $Revision: 4 $
# $Date: 2007-09-13 12:16:35 +0200 (Thu, 13 Sep 2007) $
package Class::Dot::Model;

use strict;
use warnings;
use version; our $VERSION = qv('0.1.3');
use 5.006_001;

use Carp                    qw(croak);
use Params::Util            qw(_ARRAY);
use Config::PlConfig;
use Class::Dot::Model::Util qw(
    push_base_class
    install_coderef run_as_call_class
);

my $BASE_CLASS   = 'DBIx::Class::Schema';

my @INIT_METHODS = qw(
    load_classes
);

my %DSN_PARAMS = (
    hostname    => q{%s},
    database    => q{%s},
    port        => q{%d},
);

my %DSN_DRIVER_REWRITE = (
    mysql => {
        hostname    => 'host',
    },
    Pg    => {
        hostname    => 'hostname',
        database    => 'dbname',
    },
    SQLite => {
        database    => 'dbname',
    },
);

my $dsn_param_rewrite = sub {
    $DSN_DRIVER_REWRITE{$_[0]} ? $DSN_DRIVER_REWRITE{$_[0]} : $_[0];
};

sub requires {
    return $BASE_CLASS;
}

my @MODULES_THAT_IMPORTS_US;

sub import {
    my $class      = shift;
    my $call_class = caller 0;
    my %argv;

    if (scalar  @_ > 1) {
        %argv = @_;
    }

    push_base_class( $BASE_CLASS => $call_class );

    for my $init_method (@INIT_METHODS) {
        run_as_call_class( $call_class, $init_method );
    }

    return if not defined $argv{domain};
    return if $call_class->can('new');

    my $dbconfig  = _load_dbconfig( $argv{domain}, $argv{host} );
    my $dsnstring = _create_dsn_with_config($dbconfig);

    _install_constructor($call_class, $dsnstring, $dbconfig);

    push @MODULES_THAT_IMPORTS_US, $call_class;

    return;
}

# Install a sighandler that walks through all modules that imports
# us + inherits from DBIx::Class and then disconnects them.
BEGIN {
    $SIG{INT} = sub {
        for my $module (@MODULES_THAT_IMPORTS_US) {
            if ($module->isa($BASE_CLASS)) {
                $module->storage->disconnect();
            }
        }
    }
}

sub _load_dbconfig {
    my ($domain, $host) = @_;

    my $plconfig = Config::PlConfig->new({
        host   => $host,
        domain => $domain,
    });
    my $config = $plconfig->load()->{database};

    return $config;
}

sub _install_constructor {
    my ($call_class, $dsn, $config) = @_;

    my $new_coderef = sub {
        my ($class, $options_ref) = @_;
           $options_ref ||= { };

        my $self = $class->connect($dsn, $config->{username}, $config->{password});

        NOSTRICT: {
            no strict 'refs'; ## no critic
            if (my $build_ref = *{ $class . '::BUILD' }{CODE}) { ## no critic
                $build_ref->($self, $options_ref);
            }
        };

        return $self;
    };

    return install_coderef($new_coderef => $call_class, 'new');
}

sub _create_dsn_with_config {
    my ($config) = @_;

    # Format the DSN string.
    # %DSN_PARAMS holds the values we support, and values submitted
    # are copied to %dsn_params;
    my %dsn_params;
    my $dsn_format = qq{
        DBI:$config->{driver}:
    };

    DSNPARAM:
    for my $param_name (sort keys %DSN_PARAMS) {
        my $param_type = $DSN_PARAMS{$param_name};
        next DSNPARAM if not defined $config->{$param_name};
        $dsn_params{$param_name} = $config->{$param_name};

        $dsn_format .= join q{=}, (
            $dsn_param_rewrite->($param_name),
            $param_type
        );
        $dsn_format .= q{;};

    };
    chop $dsn_format;
    $dsn_format =~ s/\s*//xmsg;

    no warnings 'uninitialized';  ## no critic;
    my $dsn = sprintf $dsn_format,
        map { $dsn_params{$_} } sort keys %dsn_params;

    return $dsn;
}

1;

__END__