File Coverage

blib/lib/Class/DBI/SAK.pm

Criterion	Covered	Total	%
statement	39	43	90.7
branch	5	12	41.6
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	51	62	82.2

package Class::DBI::SAK;

use vars qw[$VERSION %EXTENSIONS @OVERRIDES];
use Carp;
use strict;
# use warnings;

$VERSION = '1.4';

%EXTENSIONS = (
    ':useful' => {
        'AbstractSearch'       => 'use %s',
        'Pager'                => 'use %s',
    },
    ':mysql'  => {
        'mysql'                 => 'use base qw[%s]',
        'mysql::FullTextSearch' => 'use %s',
    },
    'Extension'   => 'use base qw[%s]',
    'FromCGI'     => 'use %s',
    'Pg'          => 'use base qw[%s]',
    'Replication' => 'use base qw[%s]',
    'SQLite'      => 'use base qw[%s]',
);

$EXTENSIONS{':all'} = { map {
    ref $EXTENSIONS{$_}   ?
    %{$EXTENSIONS{$_}}    :
    ( $_ => $EXTENSIONS{$_} )
} keys %EXTENSIONS };

@OVERRIDES = ( qw[
    Extension mysql Pg Replication SQLite
] );

sub import {
    my ($class, @requests) = @_;
    my $caller  = caller(0);
    my %modules = ();
    my @uses    = ();

    @requests = ':useful' unless @requests;

    foreach my $req ( @requests ) {
        if ( substr( $req, 0, 1 ) eq ':' ) {
            if ( exists $EXTENSIONS{$req} ) {
                $modules{$_} = $EXTENSIONS{$req}->{$_}
                    foreach keys %{$EXTENSIONS{$req}};
            } else {
                croak "$class does not export a $req tag";
            }
        } else {
            if ( exists $EXTENSIONS{':all'}->{$req} ) {
                $modules{$req} = $EXTENSIONS{':all'}->{$req};
            } else {
                croak "$class does not export $req\n";
            }
        }
    }

    while ( my ($name, $use) = each %modules ) {
        push @uses, sprintf $use, "Class::DBI::$name";
    }

    unshift @uses, 'use base qw[Class::DBI]'
        unless grep { exists $modules{$_} } @OVERRIDES;

    @uses = sort { ( () = $b =~ /base/ ) <=> ( () = $a =~ /base/ ) } @uses;

    my $statement  = join ";\n", sort {
        ( () = $b =~ /base/ ) <=> ( () = $a =~ /base/ )
    } @uses;
    $statement .= ";\n";

    eval qq[
        package $caller;
        $statement;
        package $class;
    ];
    croak $@ if $@;
}

1;

__END__