14. Database Access

Introduction

#-----------------------------
AsciiDB   DBI Db     MLDBM    OLE    Pg        Sybase

CDB_File  DBZ_ File  Fame     Msql   ObjStore  Postgres  XBase

DBD       DB_File    Ingperl  MySQL  Oraperl   Sprite
#-----------------------------

Making and Using a DBM File

#-----------------------------
use DB_File;                      # optional; overrides default
dbmopen %HASH, $FILENAME, 0666    # open database, accessed through %HASH
    or die "Can't open $FILENAME: $!\n";

$V = $HASH{$KEY};                 # retrieve from database
$HASH{$KEY} = $VALUE;             # put value into database
if (exists $HASH{$KEY}) {         # check whether in database
    # ...
}
delete $HASH{$KEY};               # remove from database
dbmclose %HASH;                   # close the database
#-----------------------------
use DB_File;                      # load database module

tie %HASH, "DB_File", $FILENAME   # open database, to be accessed
    or die "Can't open $FILENAME:$!\n";    # through %HASH

$V = $HASH{$KEY};                 # retrieve from database
$HASH{$KEY} = $VALUE;             # put value into database
if (exists $HASH{$KEY}) {         # check whether in database
    # ...
}
delete $HASH{$KEY};               # delete from database
untie %hash;                      # close the database
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# userstats - generates statistics on who is logged in.
# call with an argument to display totals

use DB_File;

$db = '/tmp/userstats.db';       # where data is kept between runs

tie(%db, 'DB_File', $db)         or die "Can't open DB_File $db : $!\n";

if (@ARGV) {
    if ("@ARGV" eq "ALL") {
        @ARGV = sort keys %db;
    }
    foreach $user (@ARGV) {
            print "$user\t$db{$user}\n";
    }
} else {
    @who = `who`;                                   # run who(1)
    if ($?) {
        die "Couldn't run who: $?\n";               # exited abnormally
    }
    # extract username (first thing on the line) and update
    foreach $line (@who) {
        $line =~ /^(\S+)/;
        die "Bad line from who: $line\n" unless $1;
        $db{$1}++;
    }
}

untie %db;

#-----------------------------
gnat     ttyp1   May 29 15:39   (coprolith.frii.com)
#-----------------------------

Emptying a DBM File

#-----------------------------
dbmopen(%HASH, $FILENAME, 0666)         or die "Can't open FILENAME: $!\n";
%HASH = ();
dbmclose %HASH;
#-----------------------------
use DB_File;

tie(%HASH, "DB_File", $FILENAME)        or die "Can't open FILENAME: $!\n";
%HASH = ();
untie %hash;
#-----------------------------
unlink $FILENAME
    or die "Couldn't unlink $FILENAME to empty the database: $!\n";
dbmopen(%HASH, $FILENAME, 0666)
    or die "Couldn't create $FILENAME database: $!\n";
#-----------------------------

Converting Between DBM Files

#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# db2gdbm: converts DB to GDBM

use strict;

use DB_File;
use GDBM_File;

unless (@ARGV == 2) {
    die "usage: db2gdbm infile outfile\n";
}

my ($infile, $outfile) = @ARGV;                     
my (%db_in, %db_out);                               

# open the files
tie(%db_in, 'DB_File', $infile)
    or die "Can't tie $infile: $!";
tie(%db_out, 'GDBM_File', $outfile, GDBM_WRCREAT, 0666)
    or die "Can't tie $outfile: $!";

# copy (don't use %db_out = %db_in because it's slow on big databases)
while (my($k, $v) = each %db_in) {
    $db_out{$k} = $v;
}

# these unties happen automatically at program exit
untie %db_in;
untie %db_out;

#-----------------------------
#% db2gdbm /tmp/users.db /tmp/users.gdbm
#-----------------------------

Merging DBM Files

#-----------------------------
%OUTPUT = (%INPUT1, %INPUT2);
#-----------------------------
%OUTPUT = ();
foreach $href ( \%INPUT1, \%INPUT2 ) {
    while (my($key, $value) = each(%$href)) {
        if (exists $OUTPUT{$key}) {
            # decide which value to use and set $OUTPUT{$key} if necessary
        } else {
            $OUTPUT{$key} = $value;
        }
    }
}
#-----------------------------

Locking DBM Files

#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# dblockdemo - demo locking dbm databases
use DB_File;
use strict;

sub LOCK_SH { 1 }                   # In case you don't have
sub LOCK_EX { 2 }                   # the standard Fcntl module.  You
sub LOCK_NB { 4 }                   # should, but who can tell
sub LOCK_UN { 8 }                   # how those chips fall?

my($oldval, $fd, $db, %db, $value, $key);

$key    = shift || 'default';
$value  = shift || 'magic';
$value .= " $$";

$db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0666)
    or die "dbcreat /tmp/foo.db $!";
$fd = $db->fd;                      # need this for locking
print "$$: db fd is $fd\n";
open(DB_FH, "+<&=$fd")
    or die "dup $!";

unless (flock (DB_FH, LOCK_SH | LOCK_NB)) {
    print "$$: CONTENTION; can't read during write update!
                Waiting for read lock ($!) ....";
    unless (flock (DB_FH, LOCK_SH)) { die "flock: $!" }
}
print "$$: Read lock granted\n";

$oldval = $db{$key};
print "$$: Old value was $oldval\n";
flock(DB_FH, LOCK_UN);

unless (flock (DB_FH, LOCK_EX | LOCK_NB)) {
    print "$$: CONTENTION; must have exclusive lock!
                Waiting for write lock ($!) ....";
    unless (flock (DB_FH, LOCK_EX)) { die "flock: $!" }
}

print "$$: Write lock granted\n";
$db{$key} = $value;
$db->sync;  # to flush
sleep 10;

flock(DB_FH, LOCK_UN);
undef $db;
untie %db;
close(DB_FH);
print "$$: Updated db to $key=$value\n";

#-----------------------------

Sorting Large DBM Files

#-----------------------------
use DB_File;

# specify the Perl sub to do key comparison using the
# exported $DB_BTREE hash reference
$DB_BTREE->{'compare'} = sub {
    my ($key1, $key2) = @_ ;
    return "\L$key1" cmp "\L$key2";
};

tie(%hash, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE)
    or die "can't tie $filename: $!";
#-----------------------------
# download the following standalone program
#!/usr/bin/perl
# sortdemo - show auto dbm sorting
use strict;
use DB_File;

$DB_BTREE->{'compare'} = sub {
    my ($key1, $key2) = @_ ;
    "\L$key1" cmp "\L$key2" ;
};

my %hash;
my $filename = '/tmp/sorthash.db';
tie(%hash, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE)
    or die "can't tie $filename: $!";

my $i = 0;
for my $word (qw(Can't you go camp down by Gibraltar)) {
    $hash{$word} = ++$i;
}

while (my($word, $number) = each %hash) {
    printf "%-12s %d\n", $word, $number;
}

#-----------------------------
#by           6
#
#camp         4
#
#Can't        1
#
#down         5
#
#Gibraltar    7
#
#go           3
#
#you          2
#-----------------------------
tie(%hash, "DB_File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE)
        or die "can't tie: $!";
#-----------------------------

Treating a Text File as a Database Array

#-----------------------------
use DB_File;

tie(@array, "DB_File", "/tmp/textfile", O_RDWR|O_CREAT, 0666, $DB_RECNO)
    or die "Cannot open file 'text': $!\n" ;

$array[4] = "a new line";
untie @array;
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# recno_demo - show how to use the raw API on recno bindings
use strict;
use vars qw(@lines $dbobj $file $i);
use DB_File;

$file = "/tmp/textfile";
unlink $file;               # just in case

$dbobj = tie(@lines, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO)
    or die "Cannot open file $file: $!\n";

# first create a text file to play with
$lines[0] = "zero";
$lines[1] = "one";
$lines[2] = "two";
$lines[3] = "three";
$lines[4] = "four";

# Print the records in order.
#
# The length method is needed here because evaluating a tied
# array in a scalar context does not return the number of
# elements in the array.

print "\nORIGINAL\n";
foreach $i (0 .. $dbobj->length - 1) {
    print "$i: $lines[$i]\n";
}

# use the push & pop methods
$a = $dbobj->pop;
$dbobj->push("last");
print "\nThe last record was [$a]\n";

# and the shift & unshift methods
$a = $dbobj->shift;
$dbobj->unshift("first");
print "The first record was [$a]\n";

# Use the API to add a new record after record 2.
$i = 2;
$dbobj->put($i, "Newbie", R_IAFTER);
    
# and a new record before record 1.
$i = 1;
$dbobj->put($i, "New One", R_IBEFORE);

# delete record 3
$dbobj->del(3);

# now print the records in reverse order
print "\nREVERSE\n";
for ($i = $dbobj->length - 1; $i >= 0; -- $i) {
    print "$i: $lines[$i]\n";
}

# same again, but use the API functions instead
print "\nREVERSE again\n";
my ($s, $k, $v)  = (0, 0, 0);
for ($s = $dbobj->seq($k, $v, R_LAST);
     $s == 0;
     $s = $dbobj->seq($k, $v, R_PREV))
{
    print "$k: $v\n"
}

undef $dbobj;
untie @lines;

#-----------------------------
#ORIGINAL
#
#0: zero
#
#1: one
#
#2: two
#
#3: three
#
#4: four
#
#
#The last record was [four]
#
#The first record was [zero]
#
#
#REVERSE
#
#5: last
#
#4: three
#
#3: Newbie
#
#2: one
#
#1: New One
#
#0: first
#
#
#REVERSE again
#
#5: last
#
#4: three
#
#3: Newbie
#
#2: one
#
#1: New One
#
#0: first
#-----------------------------
    foreach $item (@lines) { }
#-----------------------------
    foreach $i (0 .. $dbobj->length - 1) { }
#-----------------------------
    for ($done_yet = $dbobj->get($k, $v, R_FIRST);
         not $done_yet;
         $done_yet = $dbobj->get($k, $v, R_NEXT) )
    {
        # process key or value
    }
#-----------------------------

Storing Complex Data in a DBM File

#-----------------------------
use MLDBM 'DB_File';
tie(%HASH, 'MLDBM', [... other DBM arguments]) or die $!;
#-----------------------------
# %hash is a tied hash
$hash{"Tom Christiansen"} = [ "book author", 'tchrist@perl.com' ];          
$hash{"Tom Boutell"} = [ "shareware author", 'boutell@boutell.com' ];

# names to compare
$name1 = "Tom Christiansen";
$name2 = "Tom Boutell";

$tom1 = $hash{$name1};      # snag local pointer
$tom2 = $hash{$name2};      # and another           

print "Two Toming: $tom1 $tom2\n";

Tom Toming: ARRAY(0x73048) ARRAY(0x73e4c)
#-----------------------------
if ($tom1->[0] eq $tom2->[0] &&
    $tom1->[1] eq $tom2->[1]) {
    print "You're having runtime fun with one Tom made two.\n";
} else {
    print "No two Toms are ever alike.\n";
}
#-----------------------------
if ($hash{$name1}->[0] eq $hash{$name2}->[0] &&     # INEFFICIENT
    $hash{$name1}->[1] eq $hash{$name2}->[1]) {
    print "You're having runtime fun with one Tom made two.\n";
} else {
    print "No two Toms are ever alike.\n";
}
#-----------------------------
$hash{"Tom Boutell"}->[0] = "Poet Programmer";      # WRONG
#-----------------------------
$entry = $hash{"Tom Boutell"};                      # RIGHT
$entry->[0] = "Poet Programmer";
$hash{"Tom Boutell"} = $entry;
#-----------------------------

Persistent Data

#-----------------------------
use MLDBM 'DB_File';

my ($VARIABLE1,$VARIABLE2);
my $Persistent_Store = '/projects/foo/data';
BEGIN {
    my %data;
    tie(%data, 'MLDBM', $Persistent_Store)
        or die "Can't tie to $Persistent_Store : $!";
    $VARIABLE1 = $data{VARIABLE1};
    $VARIABLE2 = $data{VARIABLE2};
    # ...
    untie %data;
}
END {
    my %data;
    tie (%data, 'MLDBM', $Persistent_Store)
        or die "Can't tie to $Persistent_Store : $!";
    $data{VARIABLE1} = $VARIABLE1;
    $data{VARIABLE2} = $VARIABLE2;
    # ...
    untie %data;
}
#-----------------------------
push(@{$db{$user}}, $duration);
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# mldbm_demo - show how to use MLDBM with DB_File

use MLDBM "DB_File";

$db = "/tmp/mldbm-array";

tie %db, 'MLDBM', $db
  or die "Can't open $db : $!";

while(<DATA>) {
    chomp;
    ($user, $duration) = split(/\s+/, $_);
    $array_ref = exists $db{$user} ? $db{$user} : [];
    push(@$array_ref, $duration);
    $db{$user} = $array_ref;
}

foreach $user (sort keys %db) {
    print "$user: ";
    $total = 0;
    foreach $duration (@{ $db{$user} }) {
        print "$duration ";
        $total += $duration;
    }
        print "($total)\n";
    }

__END__

#gnat        15.3
#tchrist     2.5
#jules       22.1
#tchrist     15.9
#gnat        8.7
#-----------------------------
use MLDBM qw(DB_File Storable);
#-----------------------------

Executing an SQL Command Using DBI and DBD

#-----------------------------
use DBI;


$dbh = DBI->connect('DBI:driver:database', 'username', 'auth',

            { RaiseError => 1, AutoCommit => 1});

$dbh->do($sql);

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

$sth->execute();

while (@row = $sth->fetchrow_array) {

    # ...

}

$sth->finish();

$dbh->disconnect();
#-----------------------------
#disconnect(DBI::db=HASH(0x9df84)) invalidates 1 active cursor(s) 
#    at -e line 1.
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# dbusers - manage MySQL user table
use DBI;
use User::pwent;

$dbh = DBI->connect('DBI:mysql:dbname:mysqlserver.domain.com:3306',
                    'user', 'password',
                    { RaiseError => 1 })
  or die "connecting : $DBI::errstr\n";

$dbh->do("CREATE TABLE users (uid INT, login CHAR(8))");

$sql_fmt = "INSERT INTO users VALUES( %d, %s )";
while ($user = getpwent) {
    $sql = sprintf($sql_fmt, $user->uid, $dbh->quote($user->name));
    $dbh->do($sql);
}

$sth = $dbh->prepare("SELECT * FROM users WHERE uid < 50");
$sth->execute;

while ((@row) = $sth->fetchrow) {
    print join(", ", map {defined $_ ? $_ : "(null)"} @row), "\n";
}
$sth->finish;

$dbh->do("DROP TABLE users");

$dbh->disconnect;

#-----------------------------

Program: ggh - Grep Netscape Global History

#-----------------------------
#% ggh http://www.perl.com/index.html
#-----------------------------
#% ggh perl
#-----------------------------
#% ggh mailto:
#-----------------------------
#% ggh -regexp '(?i)\bfaq\b'
#-----------------------------
#% ggh -epoch http://www.perl.com/perl/
#-----------------------------
#% ggh -gmtime http://www.perl.com/perl/
#-----------------------------
#% ggh | less
#-----------------------------
#% ggh -epoch | sort -rn | less
#-----------------------------
#% ggh -epoch | sort -rn | perl -pe 's/\d+/localtime $&/e' | less
#-----------------------------
# download the following standalone program
#!/usr/bin/perl -w
# ggh - grovel global history in netscape logs
$USAGE = <<EO_COMPLAINT;
usage: $0 [-database dbfilename] [-help]
           [-epochtime | -localtime | -gmtime]
           [ [-regexp] pattern] | href ... ]
EO_COMPLAINT

use Getopt::Long;

($opt_database, $opt_epochtime, $opt_localtime,
 $opt_gmtime,   $opt_regexp,    $opt_help,
 $pattern,                                  )      = (0) x 7;

usage() unless GetOptions qw{ database=s
                              regexp=s
                              epochtime localtime gmtime
                              help
                            };

if ($opt_help) { print $USAGE; exit; }

usage("only one of localtime, gmtime, and epochtime allowed")
    if $opt_localtime + $opt_gmtime + $opt_epochtime > 1;

if ( $opt_regexp ) {
    $pattern = $opt_regexp;
} elsif (@ARGV && $ARGV[0] !~ m(://)) {
    $pattern = shift;
}

usage("can't mix URLs and explicit patterns")
    if $pattern && @ARGV;

if ($pattern && !eval { '' =~ /$pattern/; 1 } ) {
    $@ =~ s/ at \w+ line \d+\.//;
    die "$0: bad pattern $@";
}

require DB_File; DB_File->import();  # delay loading until runtime
$| = 1;                              # feed the hungry PAGERs

$dotdir  = $ENV{HOME}    || $ENV{LOGNAME};
$HISTORY = $opt_database || "$dotdir/.netscape/history.db";

die "no netscape history dbase in $HISTORY: $!" unless -e $HISTORY;
die "can't dbmopen $HISTORY: $!" unless dbmopen %hist_db, $HISTORY, 0666;

# the next line is a hack because the C programmers who did this
# didn't understand strlen vs strlen+1.  jwz told me so. :-)
$add_nulls   = (ord(substr(each %hist_db, -1)) == 0);

# XXX: should now do scalar keys to reset but don't 
#      want cost of full traverse, required on tied hashes.
#   better to close and reopen?

$nulled_href = "";  
$byte_order  = "V";         # PC people don't grok "N" (network order)
    
if (@ARGV) {
    foreach $href (@ARGV) {
        $nulled_href = $href . ($add_nulls && "\0");
        unless ($binary_time = $hist_db{$nulled_href}) {
            warn "$0: No history entry for HREF $href\n";
            next;
        }
        $epoch_secs = unpack($byte_order, $binary_time);
        $stardate   = $opt_epochtime ? $epoch_secs
                                     : $opt_gmtime ? gmtime    $epoch_secs
                                                   : localtime $epoch_secs;
        print "$stardate $href\n";
    }
} else {
    while ( ($href, $binary_time) = each %hist_db ) {
        chop $href if $add_nulls;
        # gnat reports some binary times are missing
        $binary_time = pack($byte_order, 0) unless $binary_time;
        $epoch_secs = unpack($byte_order, $binary_time);
        $stardate   = $opt_epochtime ? $epoch_secs
                                     : $opt_gmtime ? gmtime    $epoch_secs
                                                   : localtime $epoch_secs;
        print "$stardate $href\n" unless $pattern && $href !~ /$pattern/o;
    }
}

sub usage {
    print STDERR "@_\n" if @_;
    die $USAGE;
}

#-----------------------------