view release on metacpan or  search on metacpan

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

    $self->{connection_settings} = [ $dsn, $user, $password, $opts ];

    $self->_connect for 1 .. $self->{pool_size};
    return $self;
}

sub _connect {
    my $self = shift;

    my $dbh = DBIx::Poggy::DBI->connect(
        @{ $self->{connection_settings} }
    ) or die DBIx::Poggy::Error->new( 'DBIx::Poggy::DBI' );
    push @{$self->{free}}, $dbh;
    $self->{last_used}{ refaddr $dbh } = time;

    return;
}

=head2 take

Gives one connection from the pool. Takes arguments:

=over 4

=item auto

Connection will be released to the pool once C<dbh> goes out of
scope (gets "DESTROYED"). True by default.

=back

Returns L<DBIx::Poggy::DBI> handle. When "auto" is turned off
then in list context returns also guard object that will L</release>
handle to the pool on destruction.

=cut

sub take {
    my $self = shift;
    my (%args) = (auto => 1, @_);
    unless ( $self->{free} ) {
        die DBIx::Poggy::Error->new(
            err => 666,
            errstr => 'Attempt to take a connection from not initialized pool',
        );
    }
    my $dbh;
    while (1) {
        unless ( @{ $self->{free} } ) {
            warn "DB pool exhausted, creating a new connection";
            $self->_connect;
            $dbh = shift @{ $self->{free} };
            delete $self->{last_used}{ refaddr $dbh };
            last;
        }

        $dbh = shift @{ $self->{free} };
        my $used = delete $self->{last_used}{ refaddr $dbh };
        if ( (time - $used) > $self->{ping_on_take} ) {
            unless ( $dbh->ping ) {
                warn "connection is not alive, dropping";
                next;
            }
        }
        last;
    }

    if ( $args{auto} ) {
        $dbh->{private_poggy_state}{release_to} = $self;
        weaken $dbh->{private_poggy_state}{release_to};
        return $dbh;
    }
    return $dbh unless wantarray;
    return ( $dbh, guard { $self->release($dbh) } );
}

=head2 release

Takes a handle as argument and puts it back into the pool. At the moment,
no protection against double putting or active queries on the handle.

=cut

sub release {
    my $self = shift;
    my $dbh = shift;
    delete $dbh->{private_poggy_state}{release_to};

    if ( $dbh->err && !$dbh->ping ) {
        warn "handle is in error state and not ping'able, not releasing to the pool";
        return $self;
    }

    push @{ $self->{free} }, $dbh;
    $self->{last_used}{ refaddr $dbh } = time;
    return $self;
}

=head2 AUTHOR

Ruslan U. Zakirov E<lt>Ruslan.Zakirov@gmail.comE<gt>

=head2 LICENSE

Under the same terms as perl itself.

=cut

1;