view release on metacpan or  search on metacpan

Easy.pm  view on Meta::CPAN

			   mysql => {COUNT => 1},
			   Pg => {COUNT => 1},
			   Sybase => {COUNT => 1},
			   ODBC => {COUNT => 0});

# Cache
my %structs;
  
# Preloaded methods go here.

sub new
  {
	my $proto = shift;
	my $class = ref ($proto) || $proto;
	my $self = {};

	$self ->{DRIVER} = shift;
	$self ->{DATABASE} = shift;
	$self ->{USER} = shift;
	# check for a host part
	if (defined $self->{USER} && $self->{USER} =~ /@/) {
		$self->{HOST} = $';
		$self->{USER} = $`;
		
	}
    if (defined $self->{HOST} && $self->{HOST} =~ /:/) {
		$self->{PORT} = $';
		$self->{HOST} = $`;
	}
	$self ->{PASS} = shift;
	$self ->{CONN} = undef;
	$self ->{HANDLER} = undef;		# error handler

	bless ($self, $class);
	
    # sanity check: driver
    unless (defined ($self -> {DRIVER}) && $self->{DRIVER} =~ /\S/) {
		$self -> fatal ("No driver selected for $class.");
    }
	unless (exists $kwmap{$self -> {DRIVER}}) {
		$self -> fatal ("Sorry, $class doesn't support the \""
						. $self -> {DRIVER} . "\" driver.\n" 
						. "Please send mail to $maintainer_adr for more information.\n");
    }

	# sanity check: database name
    unless (defined ($self -> {DATABASE}) && $self->{DATABASE} =~ /\S/) {
		# ok for sybase with host
		unless ($self->{DRIVER} eq 'Sybase' && $self->{HOST}) {
			$self -> fatal ("No database selected for $class.");
		}
    }

	return $self if $^O eq 'MSWin32';

    # we may try to get password from DBMS specific
    # configuration file

    unless (defined $self->{PASS}) {
        unless (defined $self->{'USER'}
            && $self->{'USER'} ne getpwuid($<)) {   
            $self->passwd();
        }
    }

	return ($self);
}

# ------------------------------------------------------
# DESTRUCTOR
#
# If called for an object with established connection we
# commit any changes.
# ------------------------------------------------------

sub DESTROY {
	my $self = shift;

	if (defined ($self -> {CONN})) {
        unless ($self -> {CONN} -> {AutoCommit}) {
            $self -> {CONN} -> commit;
        }
	    $self -> {CONN} -> disconnect;
    }
}

# ------------------------------
# METHOD: fatal
#
# Error handler for this module.
# ------------------------------

sub fatal {
	my ($self, $info, $err) = @_;
	my $errstr = '';

	if (defined $self -> {CONN}) {
		$err = $DBI::err;
		$errstr = $DBI::errstr;

		unless ($self -> {CONN} -> {AutoCommit}) {
            # something has gone wrong, rollback anything
            $self -> {CONN} -> rollback ();
        }
    }
    
	if (defined $self -> {'HANDLER'}) {
		&{$self -> {'HANDLER'}} ($info, $err, $errstr);
    } elsif (defined $self -> {CONN}) {
		die "$info (DBERR: $err, DBMSG: $errstr)\n";
    } elsif ($err) {
		die "$info ($err)\n";
    } else {
		die "$info\n";
	}
}

# ---------------------------------------------------------------
# METHOD: connect
#
# Establishes the connection to the database if not already done.

Easy.pm  view on Meta::CPAN

# METHOD: is_auth_error MSG
# -----------------------------------------------------

=head2 MISCELLANEOUS

=over 4

=item is_auth_error I<msg>

This method decides if the error message I<msg>
is caused by an authentification error or not.

=back

=cut

sub is_auth_error {
	my ($self, $msg) = @_;

	if ($self->{DRIVER} eq 'mysql') {
		if ($msg =~ /^DBI\sconnect(\('database=.*?(;host=.*?)?',.*?\))? failed: Access denied for user\s/) {
			return 1;
		}
		if ($msg =~ /^DBI->connect(\(database=.*?(;host=.*?)?\))? failed: Access denied for user:/) {
			return 1;
		}
	} elsif ($self->{DRIVER} eq 'Pg') {
		if ($msg =~ /^DBI\sconnect(\('dbname=.*?(;host=.*?)?',.*?\))? failed:.+no password supplied/) {
			return 1;
		}
    
		if ($msg =~ /^DBI->connect failed.+no password supplied/) {
			return 1;
		}
	}
}

# ------------------------------------------
# METHOD: passwd
#
# Determines password for current user.
# This method is implemented only for Mysql,
# where we can look it up in ~/my.cnf.
# ------------------------------------------

sub passwd {
    my ($self) = shift;
    my $clientsec = 0;
    my ($mycnf, $option, $value);
    
    # implemented only for mysql
    return unless $self->{'DRIVER'} eq 'mysql';

	# makes sense only for the localhost
	return if $self->{'HOST'};
	
    # determine home directory
    if (exists $ENV{'HOME'} && $ENV{'HOME'} =~ /\S/ && -d $ENV{'HOME'}) {
        $mycnf = $ENV{'HOME'};
    } else {
        $mycnf = (getpwuid($>)) [7];
    }
    $mycnf .= '/.my.cnf';

    # just give up if file is not accessible
    open (CNF, $mycnf) || return;
    while (<CNF>) {
        # ignore comments and blank lines
        next if /^\#/ or /^;/;
        next unless /\S/;
        # section ?
        if (/\[(.*?)\]/) {
            if (lc($1) eq 'client') {
                $clientsec = 1;
            } else {
                $clientsec = 0;
            }
        } elsif ($clientsec) {
            # in the [client] section check for password option
            ($option, $value) = split (/=/, $_, 2);
            if ($option =~ /\s*password\s*/) {
                $value =~ s/^\s+//;
                $value =~ s/\s+$//;
                $self->{'PASS'} = $value;
                last;
            }
        }
    }
        
    close (CNF);
}

# install error handler
sub install_handler {$_[0] -> {'HANDLER'} = $_[1];}

# direct interface to DBI
sub prepare {my $self = shift; $self -> connect () -> prepare (@_);}
sub commit {my $self = shift; $self->connect (); return if $self->{CONN}->{AutoCommit}; $self->{CONN}->commit();}
sub rollback {$_[0] -> connect () -> rollback ();}
sub quote {$_[0] -> connect () -> quote ($_[1]);}

# auxiliary functions

# ----------------------------------------------------------------
# FUNCTION: cache TABLE TYPE [HANDLE]
#
# This function handles the internal caching of table informations
# like column names and types.
#
# If HANDLE is provided, the information will be fetched from
# HANDLE and stored cache, otherwise the information from the
# cache will be returned.
# ----------------------------------------------------------------

sub cache {
	my ($table, $type, $handle) = @_;
	my (@types);
	
    if ($cache_structs) {
		if ($handle) {
			$structs{$table}->{$type} = $handle->{$type};