File Coverage

blib/lib/MySQL/Easy.pm

Criterion	Covered	Total	%
statement	24	240	10.0
branch	0	116	0.0
condition	0	30	0.0
subroutine	8	40	20.0
pod	14	21	66.6
total	46	447	10.2

package MySQL::Easy::sth;

use Carp;
use common::sense;

our $AUTOLOAD;

# new {{{
sub new {
    my ($class, $mysql_e, $statement) = @_;
    my $this  = bless { s=>$statement, dbo=>$mysql_e }, $class;

    $this->{sth} = $this->{dbo}->handle->prepare( $statement );

    return $this;
}
# }}}
# bind_execute {{{
sub bind_execute {
    my $this = shift;

    $this->{sth}->execute;
    $this->{sth}->bind_columns( @_ );

    return $this;
}
# }}}
# {{{ sub repair_statement
sub repair_statement {
    my $this = shift;

    $this->{sth} = $this->{dbo}->handle->prepare( $this->{s} );
    return $this;
}

# }}}
# AUTOLOAD {{{
sub AUTOLOAD {
    my $_self = shift;
    my $sub = $AUTOLOAD;
       $sub = $1 if $sub =~ m/::(\w+)$/;

    return unless $_self->{sth}; # I should be dead?
    croak "$sub is not a member of " . ref($_self->{sth}) unless $_self->{sth}->can($sub);

    *{ __PACKAGE__ . "::$sub" } = sub {
        my $this = shift;
        my $tries = 2;

        return unless $this->{sth}; # I should be dead?

        my $wa = wantarray;
        my ($err, $warn, $ret, @ret);

        # warn "DEBUG: FYI, $$-$this is loading $sub()";

        EVAL_IT: eval {
            no strict 'refs';
            local $SIG{__WARN__} = sub { $warn = "@_"; };

            if( $wa ) {
                @ret = $this->{sth}->$sub( @_ );

            } else {
                $ret = $this->{sth}->$sub( @_ );
            }
        };

        $err = $@;

        if( $warn and not $err ) {
            $err = $warn;
            chomp $err;
        }

        if( $err ) {
          # my @c = caller;
          # my $p = "at $c[1] line $c[2], prepared at $this->{_ready_caller}[1] line $this->{_ready_caller}[2]\n";
            my $p = "(prepared at $this->{_ready_caller}[1] line $this->{_ready_caller}[2])";

            1 while $err =~ s/\s+at(?:\s+\S+)?\s+line\s+\d+\.?$//;

            # ERROR executing execute(): DBD::mysql::st execute failed: You have an error in your SQL syntax; check the manual
            $err =~ s/DBD::mysql::sth? execute failed:\s*//;

            if( $err =~ m/(?:MySQL server has gone away|Lost connection)/ ) {
                if( $sub eq "execute" ) {
                    $this->repair_statement;
                    $warn = undef;

                    goto EVAL_IT if ((--$tries) > 0);

                } else {
                    croak "MySQL::Easy::sth can only recover from connection problems during execute(): $err $p";
                }
            }

            croak "ERROR executing $sub(): $err $p";
        }

        return ($wa ? @ret : $ret);
    };

    return $_self->$sub(@_);
}
# }}}
# DESTROY {{{
sub DESTROY {
    my $this = shift;

    # warn "MySQL::Easy::sth is dying"; # This is here to make sure we don't normally die during global destruction.
                                        # Once it appeared to function correctly, it was removed.
                                        # Lastly, we would die during global dest iff: our circular ref from new() were not removed.
                                        # Although, to be truely circular, the MySQL::Easy would need to point to this ::sth also
                                        # and it probably doesn't.  So, is this delete paranoid?  Yeah...  meh.
    delete $this->{dbo};
}
# }}}

package MySQL::Easy;

use Carp ();
use common::sense;
use Scalar::Util qw(blessed);
use overload fallback=>1, '""' => sub { ref($_[0]) . "($_[0]{dbase})" };

use DBI;

our $AUTOLOAD;
our $VERSION = "2.1019";
our $CNF_ENV = "ME_CNF";
our $USER_ENV = "ME_USER";
our $PASS_ENV = "ME_PASS";
our $HOME_ENV = "HOME";
our @MY_CNF_LOCATIONS = (
    $ENV{$CNF_ENV}, "$ENV{$HOME_ENV}/.my.cnf", "/etc/mysql-easy.cnf", "/etc/mysql/my.cnf"
);

# {{{ sub mycroak
sub mycroak(;$) {
    my $error = shift;

    my $i = 1;
    my @c = caller(  $i);
       @c = caller(++$i) while $c[0] eq __PACKAGE__;

    chomp $error;

    1 while
    $error =~ s{\s+at\s+\S+\s+line\s+\d+\.}{}g;
    $error =~ s{\s+\(prepared at $c[1] line $c[2]\)}{}; # this would be a dup error in this case

    #arn "<<<$error\[$i]>>>";

    Carp::croak($error);
}

# }}}

# AUTOLOAD {{{
sub AUTOLOAD {
    my $_self = shift;
    my $sub   = $AUTOLOAD;
       $sub   = $1 if $sub =~ m/::(\w+)$/;

    {
        my $handle = $_self->handle;
        mycroak "$sub is not a member of " . ref($handle) unless $handle->can($sub);
    }

    *{ __PACKAGE__ . "::$sub" } = sub {
        my $this = shift;
        my $handle = $this->handle;

        my $wa = wantarray;
        my ($err, $warn, $ret, @ret);
        my @oargs = @_;
        my $tries = 2;

        EVAL_IT: my $eval_result = eval {
            my @cargs = @oargs;
            local $SIG{__WARN__} = sub { $warn = "@_"; };

            $cargs[0] = $cargs[0]->{sth} if @cargs and blessed $cargs[0] and $cargs[0]->isa("MySQL::Easy::sth");

            if( wantarray ) {
                @ret = $handle->$sub(@cargs);

            } else {
                $ret = $handle->$sub(@cargs);
            }

            !$warn
        };

        unless( $eval_result ) {
            $err = $@;

            if( $err =~ m/(?:MySQL server has gone away|Lost connection)/ ) {
                if( blessed $oargs[0] ) {
                    if( $oargs[0]->isa("MySQL::Easy::sth") ) {
                        $oargs[0]->repair_statement;

                    } else {
                        warn "argument to $sub is blessed, but is not a MySQL::Easy::sth, connection rebuild will probably fail";
                    }
                }
                goto EVAL_IT if ((--$tries) > 0);
            }

            if( $warn and not $err ) {
                $err = $warn;
                chomp $err;
            }

            $err =~ s/DBD::mysql::dbh? \S+ failed:\s*//;
            mycroak "ERROR executing $sub(): $err";
        }

        return ($wa ? @ret : $ret);
    };

    #arn "created method $sub, calling";

    return $_self->$sub(@_);
}
# }}}

# check_warnings {{{
sub check_warnings {
    my $this = shift;
    my $sth  = $this->ready("show warnings");

    # mysql> show warnings;
    # +---------+------+------------------------------------------+
    # | Level   | Code | Message                                  |
    # +---------+------+------------------------------------------+
    # | Warning | 1265 | Data truncated for column 'var' at row 1 |
    # +---------+------+------------------------------------------+

    my @warnings;

    execute $sth or die $this->errstr;
    while( my $a = fetchrow_arrayref $sth ) {
        push @warnings, $a;
    }
    finish $sth;

    if( @warnings ) {
        $@ = join("\n", map("$_->[0]($_->[1]): $_->[2]", @warnings)) . "\n";

        return 0;
    }

    return 1;
}
# }}}
# new {{{
sub new {
    my $this = shift;

    $this = bless {}, $this;

    $this->{dbase} = shift; mycroak "dbase = '$this->{dbase}'?" unless $this->{dbase};
    $this->{dbh} = $this->{dbase} if ref($this->{dbase}) and $this->{dbase}->isa("DBI::db");

    my $args = shift;
    my $tr   = ref($args) ? delete $args->{trace} : $args;

    $this->trace($tr) if $tr and $this->{dbh};

    if( ref $args ) {
        for my $k (keys %$args) {
            my $f;

            if( $this->can($f = "set_$k") ) {
                $this->$f($args->{$k});

            } else {
                mycroak "unrecognized attribute: $k"
            }
        }
    }

    return $this;
}
# }}}
# do {{{
sub do {
    my $this = shift; return unless @_;
    my $sql  = shift;
    my $r; eval { $r = $this->ready($sql)->execute(@_); 1 } or mycroak $@;
    return $r;
}
# }}}
# light_lock {{{
sub light_lock {
    my $this   = shift; return unless @_;
    my $tolock = join(", ", map("$_ read", @_));

    $this->do("lock tables $tolock");
}
# }}}
# lock {{{
sub lock {
    my $this   = shift; return unless @_;
    my $tolock = join(", ", map("$_ write", @_));

    $this->do("lock tables $tolock");
}
# }}}
# unlock {{{
sub unlock {
    my $this = shift;

    $this->do("unlock tables");
}
# }}}
# ready {{{
sub ready {
    my $this = shift;

    my $i = 0;
    my $sth = MySQL::Easy::sth->new( $this, @_ );
       $sth->{_ready_caller} = [ caller(  $i) ];
       $sth->{_ready_caller} = [ caller(++$i) ] while $sth->{_ready_caller}[0] eq __PACKAGE__;

    return $sth;
}
# }}}
# firstcol {{{
sub firstcol {
    my $this = shift;
    my $query = shift;

    my $r;
    eval { $r = $this->selectcol_arrayref($query, undef, @_); 1 }
        or mycroak $@;

    return wantarray ? @$r : $r;
}
# }}}
# firstval {{{
sub firstval {
    my $this = shift;
    my $query = shift;

    my $r;
    eval { $r = $this->selectcol_arrayref($query, undef, @_); 1 }
        or mycroak $@;

    return $r->[0];
}
# }}}
# firstrow {{{
sub firstrow {
    my $this = shift;
    my $query = shift;

    my $r;
    eval { $r = $this->selectrow_arrayref($query, undef, @_); 1 }
        or mycroak $@;

    return wantarray ? @$r : $r;
}
# }}}
# thread_id {{{
sub thread_id {
    my $this = shift;

    return $this->handle->{mysql_thread_id};
}
# }}}
# last_insert_id {{{
sub last_insert_id {
    my $this = shift;

    # return $this->firstcol("select last_insert_id()")->[0];
    # return $this->handle->{mysql_insertid};
    return $this->handle->last_insert_id(undef,undef,undef,undef);
}
# }}}
# DESTROY {{{
sub DESTROY {
    my $this = shift;

    $this->{dbh}->disconnect if $this->{dbh};
}
# }}}
# handle {{{
sub handle {
    my $this = shift;

    return $this->{dbh} if defined($this->{dbh}) and $this->{dbh}->ping;
    # warn "WARNING: MySQL::Easy is trying to reconnect (if possible)" if defined $this->{dbh};

    ($this->{user}, $this->{pass}) = $this->unp unless $this->{user} and $this->{pass};

    $this->{host}  = "localhost" unless $this->{host};
    $this->{port}  =      "3306" unless $this->{port};
    $this->{dbase} =      "test" unless $this->{dbase};
    $this->{trace} =           0 unless $this->{trace};

    if( $this->{dbh} ) {
        eval {
            local $SIG{__WARN__} = sub {};  # Curiously, sometimes we do have a handle, but the ping doesn't work.
                                            # If we replace the handle, DBI complains about not disconnecting.
                                            # If we disconnect, it complains about not desting statement handles.
                                            # Heh.  It's gone dude, let it go.
            $this->{dbh}->disconnect;
        };
    }

    $this->{dbh} =
    DBI->connect("DBI:mysql:$this->{dbase}:host=$this->{host}:port=$this->{port}",
        $this->{user}, $this->{pass}, {

            RaiseError => ($this->{raise} ? 1:0),
            PrintError => ($this->{raise} ? 0:1),

            AutoCommit => 0,

            mysql_enable_utf8    => 1,
            mysql_compression    => 1,
            mysql_ssl            => 1,
            mysql_auto_reconnect => 1,

        });

    mycroak "failed to generate connection: " . DBI->errstr unless $this->{dbh};

    $this->{dbh}->trace($this->{trace});

    return $this->{dbh};
}
# }}}
# unp {{{
sub unp {
    my $this = shift;

    return ($ENV{$USER_ENV}, $ENV{$PASS_ENV}) if $ENV{$USER_ENV} and $ENV{$PASS_ENV};

    my ($user, $pass, $file, $fh);

    for $file (@MY_CNF_LOCATIONS) {
        next unless -f $file;
        next unless open $fh, $file;

        while(<$fh>) {
            $user = $1 if m/user\s*=\s*(.+)/;
            $pass = $1 if m/password\s*=\s*(.+)/;

            return ($user, $pass) if $user and $pass;
        }
    }

    die "unable to locate a username and password\n";
    return;
}
# }}}
# set_host set_user set_pass {{{
sub set_host {
    my $this = shift;

    $this->{host} = shift;
}

sub set_port {
    my $this = shift;

    $this->{port} = shift;
}

sub set_user {
    my $this = shift;

    $this->{user} = shift;
}

sub set_pass {
    my $this = shift;

    $this->{pass} = shift;
}

sub set_raise {
    my $this = shift;

    $this->{raise} = shift;
}
# }}}
# bind_execute {{{
sub bind_execute {
    my $this = shift;
    my $sql  = shift;

    my $sth = $this->ready($sql);

    $sth->execute            or return;
    $sth->bind_columns( @_ ) or return;

    return $sth;
}
# }}}

1;