view release on metacpan or  search on metacpan

lib/DBIx/TNDBO.pm  view on Meta::CPAN

    my %config = (
        dbh    => $Dbh_For{$database},
        table  => "$database.$table",
        schema => $Schema_Hr->{"$database.$table"},
    );
    return DBIx::TNDBO::iter->_new( $sth, \%config );
}

sub count {
    my ( $database, $table, $where_hr, $option_hr ) = @_;

    printf "%s::%s::list(%s)\n", $Class_Base, ucfirst $table,
        _dumper($where_hr)
        if $Debug;

    my ( $sql, $param_ar )
        = _build_sql( "$database.$table", $where_hr, 'count' );

    my $dbh = _get_dbh( $database, $table );

    my $sth = $dbh->prepare($sql);

    croak $DBI::errstr
        if $DBI::errstr;

    $sth->execute( @{$param_ar} );

    my ($n) = $sth->fetchrow();

    $sth->finish();

    return $n;
}

# Called by Perl on use

sub import {
    my ( $class, @databases ) = @_;

    SYMBOL:
    for my $symbol ( keys %:: ) {

        next SYMBOL
            if $symbol !~ m{ :: \z}xms;

        next SYMBOL
            if !defined $::{$symbol}->{ISA};

        if ( grep { $_ eq __PACKAGE__ } @{ $::{$symbol}->{ISA} } ) {

            $Class_Base = substr $symbol, 0, -2;
            last SYMBOL;
        }
    }

    die 'unable to determine the class using ', __PACKAGE__, ' as its base'
        if !$Class_Base;

    {
        no strict 'refs';
        *{ __PACKAGE__ . '::credentials' }
            = *{ $Class_Base . '::credentials' };
    }

    croak sprintf 'You must define %s::credentials( $dbname ) ', $Class_Base
        if !defined &credentials;

    my $creds_key;

    NAME:
    for my $dbname (@databases) {

        if ( $dbname =~ m{\A : ( \w+ ) \z}xms ) {

            $creds_key = $1;
            last NAME;
        }
    }

    if ($creds_key) {

        @databases = grep { $_ ne ":$creds_key" } @databases;

        my $cred_hr = credentials();

        if ( ref $cred_hr->{$creds_key} eq 'ARRAY' ) {

            push @databases, @{ $cred_hr->{$creds_key} };
        }
        elsif ( ref $cred_hr->{$creds_key} eq 'HASH' ) {

            push @databases, keys %{ $cred_hr->{$creds_key} };
        }
        elsif ( $cred_hr->{$creds_key} ) {

            push @databases, $cred_hr->{$creds_key};
        }
    }

    return
        if !@databases;

    if ( !$Schema_Hr ) {

        $Schema_Hr = _read_schema( \@databases );
    }

    my @tables = keys %{ $Schema_Hr };

    for my $database_table (@tables) {

        my ( $database, $table ) = split /[.]/, $database_table;

        for my $method (qw( new list iterator count )) {

            my $class = sprintf '%s::%s', $Class_Base, ucfirst lc $table;
            {
                no strict 'refs';

                *{"${class}::${method}"} = sub {

                    croak 'call constructors with arrow operator:',
                        sprintf ' %s->%s(...)', $class, $method
                        if $_[0] ne $class;

                    shift @_;

                    return *{$method}->( $database, $table, @_ );
                };
            }
        }
    }

    return;
}

# Internal

sub _read_schema {
    my ($database_ar) = @_;

    if ( !$Schema_Cache_Filename ) {

        my $tmpdir = File::Spec->tmpdir();

lib/DBIx/TNDBO.pm  view on Meta::CPAN

                        delete $desc_hr->{$name};
                    }
                }

                push @columns, $desc_hr;
            }

            $Schema_Hr->{"$database.$table"} = \@columns;
        }
    }

    croak sprintf 'failed to read schema from any of (%s)', join ',',
        @{$database_ar}
        if !%{$Schema_Hr};

    Storable::store( $Schema_Hr, $Schema_Cache_Filename );

    return $Schema_Hr;
}

sub _build_sql {
    my ( $from, $where_hr, $operation ) = @_;

    $operation ||= 'select';

    my $sql = SQL::Abstract->new();

    my @fields;

    if ( $operation eq 'count' ) {

        $operation = 'select';
        @fields = qw/ count(*) /;
    }
    else {

        @fields = map { $_->{field} } @{ $Schema_Hr->{$from} };
    }

    my ( $stmt, @bind ) = $sql->$operation( $from, \@fields, $where_hr );

    # TODO error condition handling

    return ( $stmt, \@bind );
}

sub _get_dbh {
    my ($database) = @_;

    my $dbh;

    if ( $database && exists $Dbh_For{$database} ) {

        $dbh = $Dbh_For{$database};
    }

    if ( !$dbh || !$dbh->ping() ) {

        my ( $user, $pass, $driver, $host, $port );
        {
            my $cred_hr = credentials($database);

            my @keys = qw( user pass driver host port );

            my @creds = grep {$_} @{$cred_hr}{@keys};

            croak sprintf 'credentials() should include (%s)', join ',', @keys
                if @creds != @keys;

            ( $user, $pass, $driver, $host, $port ) = @creds;
        }

        my $dsn
            = sprintf 'DBI:%s:database=%s;host=%s;port=%s',
            $driver, $database, $host, $port;

        $dbh = DBI->connect( $dsn, $user, $pass );

        croak $DBI::errstr
            if $DBI::errstr;

        $Dbh_For{$database} = $dbh;
    }

    return $dbh;
}

sub _dumper {
    my ($ref) = @_;

    my $text;
    {
        require Data::Dumper;

        no warnings 'once';
        local $Data::Dumper::Terse  = 1;
        local $Data::Dumper::Indent = 0;

        $text = Data::Dumper::Dumper($ref);
    }

    $text =~ s{ ;? \s* \z}{}xms;

    return $text;
}

# Secluded Iterator Package
{
    package DBIx::TNDBO::iter;

    use strict;
    use warnings;
    {
        use Carp;
    }

    my $Index = 0;
    my ( @Sths, @Configs, @Counts );

    sub _new {
        my ( $class, $sth, $config_hr ) = @_;

        my $self = $Index++;
        {
            $Sths[$self]    = $sth;
            $Counts[$self]  = $sth->rows();
            $Configs[$self] = $config_hr;