#----------------------------- AsciiDB DBI Db MLDBM OLE Pg Sybase CDB_File DBZ_ File Fame Msql ObjStore Postgres XBase DBD DB_File Ingperl MySQL Oraperl Sprite #----------------------------- |
#----------------------------- 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) #----------------------------- |
#----------------------------- 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"; #----------------------------- |
#----------------------------- # 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 #----------------------------- |
#----------------------------- %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; } } } #----------------------------- |
#----------------------------- # 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"; #----------------------------- |
#----------------------------- 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: $!"; #----------------------------- |
#----------------------------- 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 } #----------------------------- |
#----------------------------- 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; #----------------------------- |
#----------------------------- 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); #----------------------------- |
#----------------------------- 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; #----------------------------- |
#----------------------------- #% 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; } #----------------------------- |