home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / DBI.pm < prev    next >
Encoding:
Perl POD Document  |  2000-03-22  |  31.2 KB  |  1,015 lines
  1. package Tie::DBI;
  2.  
  3. use strict;
  4. use vars qw($VERSION);
  5. use Carp;
  6. use DBI;
  7. $VERSION = '0.91';
  8.  
  9. # Default options for the module
  10. my %DefaultOptions = (
  11.               'user'       =>  '',
  12.               'password'   =>  '',
  13.               'AUTOCOMMIT' =>  1,
  14.               'WARN'       =>  0,
  15.               'DEBUG'      =>  0,
  16.               'CLOBBER'    =>  0,
  17.               );
  18.  
  19. # DBD drivers that work correctly with bound variables
  20. my %CAN_BIND = (
  21.         'mysql' => 1,
  22.         'mSQL'  => 1,
  23.         'Oracle' => 1,
  24.         'CSV'  => 1,
  25.         'Pg'  => 1,
  26.         'Informix'  => 1,
  27.         'Solid'  => 1,
  28.            );
  29. my %CAN_BINDSELECT = (
  30.               'mysql' => 1,
  31.               'mSQL'  => 1,
  32.               'CSV'  => 1,
  33.               'Pg'  => 1,
  34.               'Informix'  => 1,
  35.               'Solid'  => 1,
  36.              );
  37. my %BROKEN_INSERT = (
  38.              'mSQL' => 1
  39.              );
  40. my %NO_QUOTE =(
  41.            'Sybase' => {map {$_=>1} (6..17,20,24)},
  42.          );
  43. my %DOES_IN = (
  44.            'mysql' => 1,
  45.            'Oracle' => 1,
  46.            'Sybase' => 1,
  47.            );
  48.  
  49.  
  50. # TIEHASH interface
  51. # tie %h,Tie::DBI,[dsn|dbh,table,key],\%options
  52. sub TIEHASH {
  53.     my $class = shift;
  54.     my ($dsn,$table,$key,$opt);
  55.     if (ref($_[0]) eq 'HASH') {
  56.     $opt = shift;
  57.     ($dsn,$table,$key) = @{$opt}{'db','table','key'};
  58.     } else {
  59.     ($dsn,$table,$key,$opt) = @_;
  60.     }
  61.  
  62.     croak "Usage tie(%h,Tie::DBI,dsn,table,key,\\%options)\n   or tie(%h,Tie::DBI,{db=>\$db,table=>\$table,key=>\$key})" 
  63.       unless $dsn && $table && $key;
  64.     my $self = {
  65.     %DefaultOptions,
  66.     defined($opt) ? %$opt : ()
  67.     };
  68.     bless $self,$class;
  69.  
  70.     my ($dbh,$driver);
  71.  
  72.     if (UNIVERSAL::isa($dsn,'DBI::db')) {
  73.     $dbh = $dsn;
  74.     $driver = $dsn->{Driver}{Name};
  75.     $dbh->{Warn} = $self->{WARN};
  76.     } else {
  77.     $dsn = "dbi:$dsn" unless $dsn=~ /^dbi/;
  78.     ($driver) = $dsn =~ /\w+:(\w+)/;
  79.  
  80.     # Try to establish connection with data source.
  81.     delete $ENV{NLS_LANG};    # this gives us 8 bit characters ??
  82.  
  83.     $dbh = $class->connect($dsn,$self->{user},$self->{password},
  84.                                { AutoCommit=>$self->{AUTOCOMMIT},
  85.                  ChopBlanks=>1,
  86.                  PrintError=>0,
  87.                  Warn=>$self->{WARN},
  88.                    }
  89.                   );
  90.     $self->{needs_disconnect}++;
  91.     croak "TIEHASH: Can't open $dsn, ",$class->errstr unless $dbh;
  92.       }
  93.  
  94.     # set up more instance variables
  95.     @{$self}{'dbh','table','key'} = ($dbh, $table, $key );
  96.     $self->{BrokenInsert}  = $BROKEN_INSERT{$driver};
  97.     $self->{CanBind}       = $CAN_BIND{$driver};
  98.     $self->{CanBindSelect} = $self->{CanBind} && $CAN_BINDSELECT{$driver};
  99.     $self->{NoQuote}       = $NO_QUOTE{$driver};
  100.     $self->{DoesIN}        = $DOES_IN{$driver};
  101.  
  102.     return $self;
  103. }
  104.  
  105. sub DESTROY {
  106.   $_[0]->{'dbh'}->disconnect if defined $_[0]->{'dbh'} 
  107.   && $_[0]->{needs_disconnect};
  108. }
  109.  
  110. sub FETCH {
  111.     my($s,$key) = @_;
  112.  
  113.     # user could refer to $h{a,b,c}: handle this case
  114.     my (@keys) = split ($;,$key);
  115.     my ($tag,$query);
  116.     if (@keys > 1) {  # need an IN clause
  117.     my ($count) = scalar(@keys);
  118.     $tag = "fetch$count";
  119.     if (!$s->{CanBindSelect}) {
  120.       foreach (@keys) { $_ =  $s->_quote($s->{key},$_); }
  121.     }
  122.     if ($s->{DoesIN}) {
  123.       $query = "SELECT $s->{key} FROM $s->{table} WHERE $s->{key} IN (" .
  124.         join(",",('?')x$count) . ')';
  125.     } else {
  126.       $query = "SELECT $s->{key} FROM $s->{table} WHERE " . join (' OR ',("$s->{key}=?")x$count);
  127.     }
  128.     } else {
  129.     $tag = "fetch1";
  130.     @keys = $s->_quote($s->{key},$key) unless $s->{CanBindSelect};
  131.     $query = "SELECT $s->{key} FROM $s->{table} WHERE $s->{key} = ?";
  132.     }
  133.     my $st = $s->_run_query($tag,$query,@keys) || croak "FETCH: ",$s->errstr;
  134.  
  135.     # slightly more efficient for one key
  136.     if (@keys == 1) {
  137.     my $r = $st->fetch;
  138.     $st->finish;
  139.     return undef unless $r;
  140.     my $h = {};
  141.     tie %$h,'Tie::DBI::Record',$s,$r->[0];
  142.     return $h;
  143.     } 
  144.  
  145.     # general case -- multiple keys
  146.     my ($r,%got);
  147.     while ($r = $st->fetch) {
  148.     my $h = {};
  149.     tie %$h,'Tie::DBI::Record',$s,$r->[0];
  150.     $got{$r->[0]} = $h;
  151.     }
  152.     $st->finish;
  153.     @keys = split($;,$key);
  154.     return (@keys > 1) ? [@got{@keys}] : $got{$keys[0]};
  155. }
  156.  
  157. sub FIRSTKEY {
  158.     my $s = shift;
  159.     my $st = $s->_prepare('fetchkeys',"SELECT $s->{key} FROM $s->{table}") 
  160.     || croak "FIRSTKEY: ",$s->errstr;
  161.     $st->execute() ||
  162.     croak "FIRSTKEY: ",$s->errstr;
  163.     my $ref = $st->fetch;
  164.     unless (defined($ref)) {
  165.       $st->finish;
  166.       delete $s->{'fetchkeys'}; #freakin' sybase bug
  167.       return undef;
  168.     }
  169.     return $ref->[0];
  170. }
  171.  
  172. sub NEXTKEY {
  173.     my $s = shift;
  174.     my $st = $s->_prepare('fetchkeys','');
  175.  
  176.     # no statement handler defined, so nothing to iterate over
  177.     return wantarray ? () : undef unless $st;
  178.     my $r = $st->fetch;
  179.     if (!$r) {
  180.     $st->finish;
  181.     delete $s->{'fetchkeys'}; #freakin' sybase bug
  182.     return wantarray ? () : undef;
  183.     }
  184.     # Should we do a tie here?
  185.     my ($key,$value) = ($r->[0],{});
  186.     return wantarray ? ($key,$value) : $key;
  187. }
  188.  
  189. # Unlike fetch, this never goes to the cache
  190. sub EXISTS {
  191.     my ($s,$key) = @_;
  192.     $key = $s->_quote($s->{key},$key) unless $s->{CanBindSelect};
  193.     my $st = $s->_run_query('fetch1',"SELECT $s->{key} FROM $s->{table} WHERE $s->{key} = ?",$key);
  194.     croak $DBI::errstr unless $st;
  195.     $st->fetch;
  196.     my $rows = $st->rows;
  197.     $st->finish;
  198.     $rows != 0;
  199. }
  200.  
  201. sub CLEAR {
  202.     my $s = shift;
  203.     croak "CLEAR: read-only database"
  204.     unless $s->{CLOBBER} > 2;
  205.  
  206.     my $st = $s->_prepare('clear',"delete from $s->{table}");
  207.     $st->execute() ||
  208.     croak "CLEAR: delete statement failed, ",$s->errstr;
  209.     $st->finish;
  210. }
  211.  
  212. sub DELETE {
  213.     my ($s,$key) = @_;
  214.     croak "DELETE: read-only database"
  215.     unless $s->{CLOBBER} > 1;
  216.     $key = $s->_quote($s->{key},$key) unless $s->{CanBindSelect};    
  217.     my $st = $s->_run_query('delete',"delete from $s->{table} where $s->{key} = ?",$key) ||
  218.     croak "DELETE: delete statement failed, ",$s->errstr;
  219.     $st->finish;
  220.     
  221. }
  222.  
  223. sub STORE {
  224.     my ($s,$key,$value) = @_;
  225.     # There are two cases where this can be called.  In the first case, we are
  226.     # passed a hash reference to field names and their values.  In the second
  227.     # case, we are passed a Tie::DBI::Record, for the purposes of a cloning
  228.     # operation.
  229.     croak "STORE: attempt to store non-hash value into record"
  230.     unless ref($value) eq 'HASH';
  231.  
  232.     croak "STORE: read-only database"
  233.     unless $s->{CLOBBER} > 0;
  234.  
  235.     my (@fields);
  236.     my $ok = $s->_fields();
  237.     foreach (sort keys %$value) {
  238.     if ($_ eq $s->{key}) {
  239.         carp qq/Ignored attempt to change value of key field "$s->{key}"/ if $s->{WARN};
  240.         next;
  241.     }
  242.     if (!$ok->{$_}) {
  243.         carp qq/Ignored attempt to set unknown field "$_"/ if $s->{WARN};
  244.         next;
  245.     }
  246.     push(@fields,$_);
  247.     }
  248.     return undef unless @fields;
  249.     my (@values) = map { $value->{$_} } @fields;
  250.  
  251.     # Attempt an insert.  If that fails (usually because the key already exists), 
  252.     # perform an update. For this to work correctly, the key field MUST be marked
  253.     my $result;
  254.     if ($s->{BrokenInsert}) {  # check for broken drivers
  255.     $result = $s->EXISTS($key) ? 
  256.         $s->_update($key,\@fields,\@values)
  257.         :  $s->_insert($key,\@fields,\@values);
  258.     } else {
  259.       my $errors;
  260.       local($s->{'dbh'}->{PrintError})= 0 unless $s->{'needs_disconnect'};  # not ours
  261.       $result = $s->_insert($key,\@fields,\@values) || $s->_update($key,\@fields,\@values);
  262.     }
  263.     croak "STORE: ",$s->errstr if $s->error;
  264.  
  265.     # Neat special case: If we are passed an empty anonymous hash, then
  266.     # we must tie it to Tie::DBI::Record so that the correct field updating
  267.     # behavior springs into existence.
  268.     tie %$value,'Tie::DBI::Record',$s,$key
  269.         unless %$value;
  270. }
  271.  
  272. sub fields {
  273.     my $s = shift;
  274.     return keys %{$s->_fields()};
  275. }
  276.  
  277. sub dbh {
  278.     $_[0]->{'dbh'};
  279. }
  280.  
  281. sub commit {
  282.     $_[0]->{'dbh'}->commit();
  283. }
  284.  
  285. sub rollback {
  286.     $_[0]->{'dbh'}->rollback();
  287. }
  288.  
  289. # The connect() method is responsible for the low-level connect to
  290. # the database.  It should return a database handle or return undef.
  291. # You may want to override this to connect via a subclass of DBI, such
  292. # as Apache::DBI.
  293. sub connect {
  294.   my ($class,$dsn,$user,$password,$options) = @_;
  295.   return DBI->connect($dsn,$user,$password,$options);
  296. }
  297.  
  298. # Return a low-level error.  You might want to override this
  299. # if you use a subclass of DBI
  300. sub errstr {
  301.   return $DBI::errstr;
  302. }
  303.  
  304. sub error {
  305.   return $DBI::err;
  306. }
  307.  
  308. sub select_where {
  309.     my($s,$query) = @_;
  310.     # get rid of everything but the where clause
  311.     $query=~s/^\s*(select .+)?where\s+//i; 
  312.     my $st = $s->{'dbh'}->prepare("select $s->{key} from $s->{table} where $query") 
  313.     || croak "select_where: ",$s->errstr;
  314.     $st->execute()
  315.     || croak "select_where: ",$s->errstr;
  316.     my ($key,@results);
  317.     $st->bind_columns(undef,\$key);
  318.     while ($st->fetch) {
  319.     push(@results,$key);
  320.     }
  321.     $st->finish;
  322.     return @results;
  323. }
  324.  
  325. # ---------------- everything below this line is private --------------------------
  326. sub _run_query {
  327.     my $self = shift;
  328.     my ($tag,$query,@bind_variables) = @_;
  329.     if ($self->{CanBind}) {
  330.     unless (!$self->{CanBindSelect} && $query=~/\bwhere\b/i) {
  331.         my $sth = $self->_prepare($tag,$query);
  332.         return unless $sth->execute(@bind_variables);
  333.         return $sth;
  334.     }
  335.     }
  336.     local($^W) = 0;  # kill uninitialized variable warning
  337.     # if we get here, then we can't bind, so we replace ? with escaped parameters
  338.     $query =~ s/\?/defined($_ = shift(@bind_variables)) ? $_ : 'null'/eg;
  339.  
  340.     my $sth = $self->{'dbh'}->prepare($query);
  341.     return unless $sth && $sth->execute;
  342.     return $sth;
  343. }
  344.  
  345. sub _fields {
  346.     my $self = shift;
  347.     unless ($self->{'fields'}) {
  348.  
  349.     my ($dbh,$table) = @{$self}{'dbh','table'};
  350.  
  351.     local($^W) = 0;  # kill uninitialized variable warning
  352.     my $sth = $dbh->prepare("LISTFIELDS $table");
  353.     unless (defined($sth) && $sth->execute) {  # doesn't support LISTFIELDS, so try SELECT *
  354.       $sth = $dbh->prepare("SELECT * FROM $table WHERE 0=1") ||
  355.         croak "_fields() failed during prepare(SELECT) statement: ",$self->errstr;
  356.       $sth->execute() ||
  357.         croak "_fields() failed during execute(SELECT) statement: ",$self->errstr;
  358.     }
  359.     # if we get here, we can fetch the names of the fields
  360.     my %fields = map { lc($_)=>1 } @{$sth->{NAME}};
  361.     $sth->finish;
  362.     $self->{'fields'} = \%fields;
  363.     }
  364.     return $self->{'fields'};
  365. }
  366.  
  367. sub _types {
  368.   my $self = shift;
  369.   return $self->{'types'} if $self->{'types'};
  370.   my $sth = $self->{'dbh'}->prepare("SELECT * FROM $self->{table} WHERE 0=1") ||
  371.     croak "_types() failed during prepare(SELECT) statement: $DBI::errstr";
  372.   $sth->execute() ||
  373.     croak "_types() failed during execute(SELECT) statement: $DBI::errstr";
  374.   my $types = $sth->{TYPE};
  375.   my $names = $sth->{NAME};
  376.   my %types = map { shift(@$names) => $_ } @$types;
  377.   return $self->{'types'} = \%types;
  378. }
  379.  
  380. sub _fetch_field ($$) {
  381.     my ($s,$key,$fields) = @_;
  382.     $key = $s->_quote($s->{key},$key) unless $s->{CanBindSelect};
  383.     my $valid = $s->_fields();
  384.     my @valid_fields = grep($valid->{$_},@$fields);
  385.     return undef unless @valid_fields;
  386.  
  387.     my $f = join(',',@valid_fields);
  388.     my $st = $s->_run_query("fetch$f","SELECT $f FROM $s->{table} WHERE $s->{key}=?",$key) ||
  389.     croak "_fetch_field: ",$s->errstr;
  390.  
  391.     my (@r,@results);
  392.     while (@r = $st->fetchrow_array) {
  393.     my @i = map {$valid->{$_} ? shift @r : undef} @$fields;
  394.     push(@results,(@$fields == 1) ? $i[0] : [@i]);
  395.     }
  396.  
  397.     $st->finish;
  398.     return (@results > 1) ? \@results : $results[0];
  399. }
  400.  
  401. sub _insert {
  402.     my ($s,$key,$fields,$values) = @_;
  403.     push (@$fields,$s->{key});
  404.     push (@$values,$key);
  405.     my @values = $s->_quote_many($fields,$values);
  406.     my (@Qs) = ('?') x @$values;
  407.     local($") = ',';
  408.     my $st = $s->_run_query("insert@$fields","insert into $s->{table} (@$fields) values (@Qs)",@values);
  409.     pop (@$fields);
  410.     pop (@$values);    
  411.     return $st ? $st->rows : 0;
  412. }
  413.  
  414. sub _update {
  415.     my ($s,$key,$fields,$values) = @_;
  416.     my (@set) = map {"$_=?"} @$fields;
  417.     my @values = $s->_quote_many($fields,$values);
  418.     $key = $s->_quote($s->{key},$key) unless $s->{CanBindSelect};
  419.     local($") = ',';
  420.     my $st = $s->_run_query("update@$fields",
  421.                 "update $s->{table} set @set where $s->{key}=?",@values,$key);
  422.     return $st ? $st->rows : undef;
  423. }
  424.  
  425. sub _quote_many {
  426.   my ($s,$fields,$values) = @_;
  427.   return @$values if $s->{CanBind};
  428.   return map { $s->{'db'}->quote($_) } @$values 
  429.     unless my $noquote = $s->{NoQuote};
  430.   my @values = @$values;
  431.   my $types = $s->_types;
  432.   my $count = 0;
  433.   foreach (@values) {
  434.     next if $noquote->{$types->{$fields->[$count++]}};
  435.     $_ = $s->{'dbh'}->quote($_);
  436.   }
  437.   return @values;
  438. }
  439.  
  440. sub _quote {
  441.   my ($s,$field,$value) = @_;
  442.   return $s->{'dbh'}->quote($value) 
  443.     unless my $noquote = $s->{NoQuote};
  444.   my $types = $s->_types;
  445.   return $noquote->{$types->{$field}} ? $value : $s->{'dbh'}->quote($value);
  446. }
  447.  
  448. sub _prepare ($$$) {
  449.     my($self,$tag,$q) = @_;
  450.     unless (exists($self->{$tag})) {
  451.     return undef unless $q;
  452.     warn $q,"\n" if $self->{DEBUG};
  453.     my $sth = $self->{'dbh'}->prepare($q);
  454.     $self->{$tag} = $sth;
  455.     } else {
  456.     $self->{$tag}->finish if $q;  # in case we forget
  457.     }
  458.     $self->{$tag};
  459. }
  460.  
  461. package Tie::DBI::Record;
  462. use strict;
  463. use vars qw($VERSION);
  464. use Carp;
  465. use DBI;
  466. $VERSION = '0.50';
  467.  
  468. # TIEHASH interface
  469. # tie %h,Tie::DBI::Record,dbh,table,record
  470. sub TIEHASH {
  471.     my $class = shift;
  472.     my ($table,$record) = @_;
  473.     return bless { 
  474.     'table'=>$table,   # table object
  475.     'record'=>$record, # the record we're keyed to
  476.     },$class;
  477. }
  478.  
  479. sub FETCH {
  480.     my ($s,$field) = @_;
  481.     return undef unless $s->{'table'};
  482.     my (@fields) = split($;,$field);
  483.     return $s->{'table'}->_fetch_field($s->{'record'},\@fields);
  484. }
  485.  
  486. sub DELETE {
  487.     my ($s,$field) = @_;
  488.     $s->STORE($field,undef);
  489. }
  490.  
  491. sub STORE {
  492.     my ($s,$field,$value) = @_;
  493.     $s->{'table'}->STORE($s->{'record'},{$field=>$value});
  494. }
  495.  
  496. # Can't delete the record in this way, but we can
  497. # clear out all the fields by setting them to undef.
  498. sub CLEAR {
  499.     my ($s) = @_;
  500.     croak "CLEAR: read-only database"
  501.     unless $s->{'table'}->{CLOBBER} > 1;
  502.     my %h = map { $_ => undef} keys %{$s->{'table'}->_fields()};
  503.     delete $h{$s->{'record'}};  # can't remove key field
  504.     $s->{'table'}->STORE($s->{'record'},\%h);
  505. }
  506.  
  507. sub FIRSTKEY {
  508.     my $s = shift;
  509.     my $a = scalar keys %{$s->{'table'}->_fields()};
  510.     each %{$s->{'table'}->_fields()};
  511. }
  512.  
  513. sub NEXTKEY {
  514.     my $s = shift;
  515.     each %{$s->{'table'}->_fields()};
  516. }
  517.  
  518. sub EXISTS {
  519.     my $s = shift;
  520.     return $s->{'table'}->_fields()->{$_[0]};
  521. }
  522.  
  523. sub DESTROY {
  524.     my $s = shift;
  525.     warn "$s->{table}:$s->{value} has been destroyed" if $s->{'table'}->{DEBUG};
  526. }
  527.  
  528. =head1 NAME
  529.  
  530. Tie::DBI - Tie hashes to DBI relational databases
  531.  
  532. =head1 SYNOPSIS
  533.  
  534.   use Tie::DBI;
  535.   tie %h,Tie::DBI,'mysql:test','test','id',{CLOBBER=>1};
  536.  
  537.   tie %h,Tie::DBI,{db       => 'mysql:test',
  538.            table    => 'test',
  539.                    key      => 'id',
  540.                    user     => 'nobody',
  541.                    password => 'ghost',
  542.                    CLOBBER  => 1};
  543.  
  544.   # fetching keys and values
  545.   @keys = keys %h;
  546.   @fields = keys %{$h{$keys[0]}};
  547.   print $h{'id1'}->{'field1'};
  548.   while (($key,$value) = each %h) {
  549.     print "Key = $key:\n";
  550.     foreach (sort keys %$value) {
  551.     print "\t$_ => $value->{$_}\n";
  552.     }
  553.   }
  554.  
  555.   # changing data
  556.   $h{'id1'}->{'field1'} = 'new value';
  557.   $h{'id1'} = { field1 => 'newer value',
  558.                 field2 => 'even newer value',
  559.                 field3 => "so new it's squeaky clean" };
  560.  
  561.   # other functions
  562.   tied(%h)->commit;
  563.   tied(%h)->rollback;
  564.   tied(%h)->select_where('price > 1.20');
  565.   @fieldnames = tied(%h)->fields;
  566.   $dbh = tied(%h)->dbh;
  567.  
  568. =head1 DESCRIPTION
  569.  
  570. This module allows you to tie Perl associative arrays (hashes) to SQL
  571. databases using the DBI interface.  The tied hash is associated with a
  572. table in a local or networked database.  One column becomes the hash
  573. key.  Each row of the table becomes an associative array, from which
  574. individual fields can be set or retrieved.
  575.  
  576. =head1 USING THE MODULE
  577.  
  578. To use this module, you must have the DBI interface and at least one
  579. DBD (database driver) installed.  Make sure that your database is up
  580. and running, and that you can connect to it and execute queries using
  581. DBI.
  582.  
  583. =head2 Creating the tie
  584.  
  585.    tie %var,Tie::DBI,[database,table,keycolumn] [,\%options]
  586.  
  587. Tie a variable to a database by providing the variable name, the tie
  588. interface (always "Tie::DBI"), the data source name, the table to tie
  589. to, and the column to use as the hash key.  You may also pass various
  590. flags to the interface in an associative array.
  591.  
  592. =over 4
  593.  
  594. =item database
  595.  
  596. The database may either be a valid DBI-style data source string of the
  597. form "dbi:driver:database_name[:other information]", or a database
  598. handle that has previously been opened.  See the documentation for DBI
  599. and your DBD driver for details.  Because the initial "dbi" is always
  600. present in the data source, Tie::DBI will add it for you if necessary.
  601.  
  602. Note that some drivers (Oracle in particular) have an irritating habit
  603. of appending blanks to the end of fixed-length fields.  This will
  604. screw up Tie::DBI's routines for getting key names.  To avoid this you
  605. should create the database handle with a B<ChopBlanks> option of TRUE.
  606. You should also use a B<PrintError> option of true to avoid complaints
  607. during STORE and LISTFIELD calls.  
  608.  
  609.  
  610. =item table
  611.  
  612. The table in the database to bind to.  The table must previously have
  613. been created with a SQL CREATE statement.  This module will not create
  614. tables for you or modify the schema of the database.
  615.  
  616. =item key
  617.  
  618. The column to use as the hash key.  This column must prevoiusly have
  619. been defined when the table was created.  In order for this module to
  620. work correctly, the key column I<must> be unique and not nullable.
  621. For best performance, the column should be also be declared a key.
  622. These three requirements are automatically satisfied for primary keys.
  623.  
  624. =back
  625.  
  626. It is possible to omit the database, table and keycolumn arguments, in
  627. which case the module tries to retrieve the values from the options
  628. array.  The options array contains a set of option/value pairs.  If
  629. not provided, defaults are assumed.  The options are:
  630.  
  631. =over 4
  632.  
  633. =item user
  634.  
  635. Account name to use for database authentication, if necessary.
  636. Default is an empty string (no authentication necessary).
  637.  
  638. =item password
  639.  
  640. Password to use for database authentication, if necessary.  Default is
  641. an empty string (no authentication necessary).
  642.  
  643. =item db
  644.  
  645. The database to bind to the hash, if not provided in the argument
  646. list.  It may be a DBI-style data source string, or a
  647. previously-opened database handle.
  648.  
  649. =item table
  650.  
  651. The name of the table to bind to the hash, if not provided in the
  652. argument list.
  653.  
  654. =item key
  655.  
  656. The name of the column to use as the hash key, if not provided in the
  657. argument list.
  658.  
  659. =item CLOBBER (default 0)
  660.  
  661. This controls whether the database is writable via the bound hash.  A
  662. zero value (the default) makes the database essentially read only.  An
  663. attempt to store to the hash will result in a fatal error.  A CLOBBER
  664. value of 1 will allow you to change individual fields in the database,
  665. and to insert new records, but not to delete entire records.  A
  666. CLOBBER value of 2 allows you to delete records, but not to erase the
  667. entire table.  A CLOBBER value of 3 or higher will allow you to erase
  668. the entire table.
  669.  
  670.     Operation                       Clobber      Comment
  671.  
  672.     $i = $h{strawberries}->{price}     0       All read operations
  673.     $h{strawberries}->{price} += 5     1       Update fields
  674.     $h{bananas}={price=>23,quant=>3}   1       Add records
  675.     delete $h{strawberries}            2       Delete records
  676.     %h = ()                            3       Clear entire table
  677.     undef %h                           3       Another clear operation
  678.  
  679. All database operations are contingent upon your access privileges.
  680. If your account does not have write permission to the database, hash
  681. store operations will fail despite the setting of CLOBBER.
  682.  
  683. =item AUTOCOMMIT (default 1)
  684.  
  685. If set to a true value, the "autocommit" option causes the database
  686. driver to commit after every store statement.  If set to a false
  687. value, this option will not commit to the database until you
  688. explicitly call the Tie::DBI commit() method.
  689.  
  690. The autocommit option defaults to true.
  691.  
  692. =item DEBUG (default 0)
  693.  
  694. When the DEBUG option is set to a non-zero value the module will echo
  695. the contents of SQL statements and other debugging information to
  696. standard error.  Higher values of DEBUG result in more verbose (and
  697. annoying) output.
  698.  
  699. =item WARN (default 1)
  700.  
  701. If set to a non-zero value, warns of illegal operations, such as
  702. attempting to delete the value of the key column.  If set to a zero
  703. value, these errors will be ignored silently.
  704.  
  705. =back
  706.  
  707. =head1 USING THE TIED ARRAY
  708.  
  709. The tied array represents the database table.  Each entry in the hash
  710. is a record, keyed on the column chosen in the tie() statement.
  711. Ordinarily this will be the table's primary key, although any unique
  712. column will do.
  713.  
  714. Fetching an individual record returns a reference to a hash of field
  715. names and values.  This hash reference is itself a tied object, so
  716. that operations on it directly affect the database.
  717.  
  718. =head2 Fetching information
  719.  
  720. In the following examples, we will assume a database table structured
  721. like this one:
  722.  
  723.                     -produce-
  724.     produce_id    price   quantity   description
  725.  
  726.     strawberries  1.20    8          Fresh Maine strawberries
  727.     apricots      0.85    2          Ripe Norwegian apricots
  728.     bananas       1.30    28         Sweet Alaskan bananas
  729.     kiwis         1.50    9          Juicy New York kiwi fruits
  730.     eggs          1.00   12          Farm-fresh Atlantic eggs
  731.  
  732. We tie the variable %produce to the table in this way:
  733.  
  734.     tie %produce,Tie::DBI,{db    => 'mysql:stock',
  735.                            table => 'produce',
  736.                            key   => 'produce_id',
  737.                            CLOBBER => 2 # allow most updates
  738.                            };
  739.  
  740. We can get the list of keys this way:
  741.  
  742.     print join(",",keys %produce);
  743.        => strawberries,apricots,bananas,kiwis
  744.  
  745. Or get the price of eggs thusly:
  746.  
  747.     $price = $produce{eggs}->{price};
  748.     print "The price of eggs = $price";
  749.         => The price of eggs = 1.2
  750.  
  751. String interpolation works as you would expect:
  752.  
  753.     print "The price of eggs is still $produce{eggs}->{price}"
  754.         => The price of eggs is still 1.2
  755.  
  756. Various types of syntactic sugar are allowed.  For example, you can
  757. refer to $produce{eggs}{price} rather than $produce{eggs}->{price}.
  758. Array slices are fully supported as well:
  759.  
  760.     ($apricots,$kiwis) = @produce{apricots,kiwis};
  761.     print "Kiwis are $kiwis->{description};
  762.         => Kiwis are Juicy New York kiwi fruits
  763.  
  764.     ($price,$description) = @{$produce{eggs}}{price,description};
  765.         => (2.4,'Farm-fresh Atlantic eggs')
  766.  
  767. If you provide the tied hash with a comma-delimited set of record
  768. names, and you are B<not> requesting an array slice, then the module
  769. does something interesting.  It generates a single SQL statement that
  770. fetches the records from the database in a single pass (rather than
  771. the multiple passes required for an array slice) and returns the
  772. result as a reference to an array.  For many records, this can be much
  773. faster.  For example:
  774.  
  775.      $result = $produce{apricots,bananas};
  776.          => ARRAY(0x828a8ac)
  777.  
  778.      ($apricots,$bananas) = @$result;
  779.      print "The price of apricots is $apricots->{price}";
  780.          => The price of apricots is 0.85
  781.  
  782. Field names work in much the same way:
  783.  
  784.      ($price,$quantity) = @{$produce{apricots}{price,quantity}};
  785.      print "There are $quantity apricots at $price each";
  786.          => There are 2 apricots at 0.85 each";
  787.  
  788. =head2 Updating information
  789.  
  790. If CLOBBER is set to a non-zero value (and the underlying database
  791. privileges allow it), you can update the database with new values.
  792. You can operate on entire records at once or on individual fields
  793. within a record.
  794.  
  795. To insert a new record or update an existing one, assign a hash
  796. reference to the record.  For example, you can create a new record in
  797. %produce with the key "avocados" in this manner:
  798.  
  799.    $produce{avocados} = { price       => 2.00,
  800.                           quantity    => 8,
  801.                           description => 'Choice Irish avocados' };
  802.  
  803. This will work with any type of hash reference, including records
  804. extracted from another table or database.
  805.  
  806. Only keys that correspond to valid fields in the table will be
  807. accepted.  You will be warned if you attempt to set a field that
  808. doesn't exist, but the other fields will be correctly set.  Likewise,
  809. you will be warned if you attempt to set the key field.  These
  810. warnings can be turned off by setting the WARN option to a zero value.
  811. It is not currently possible to add new columns to the table.  You
  812. must do this manually with the appropriate SQL commands.
  813.  
  814. The same syntax can be used to update an existing record.  The fields
  815. given in the hash reference replace those in the record.  Fields that
  816. aren't explicitly listed in the hash retain their previous values.  In
  817. the following example, the price and quantity of the "kiwis" record
  818. are updated, but the description remains the same:
  819.  
  820.     $produce{kiwis} = { price=>1.25,quantity=>20 };
  821.  
  822. You may update existing records on a field-by-field manner in the
  823. natural way:
  824.  
  825.     $produce{eggs}{price} = 1.30;
  826.     $produce{eggs}{price} *= 2;
  827.     print "The price of eggs is now $produce{eggs}{price}";
  828.         => The price of eggs is now 2.6.
  829.  
  830. Obligingly enough, you can use this syntax to insert new records too,
  831. as in $produce{mangoes}{description}="Sun-ripened Idaho mangoes".
  832. However, this type of update is inefficient because a separate SQL
  833. statement is generated for each field.  If you need to update more
  834. than one field at a time, use the record-oriented syntax shown
  835. earlier.  It's much more efficient because it gets the work done with
  836. a single SQL command.
  837.  
  838. Insertions and updates may fail for any of a number of reasons, most
  839. commonly:
  840.  
  841. =over 4
  842.  
  843. =item 1. You do not have sufficient privileges to update the database
  844.  
  845. =item 2. The update would violate an integrity constraint, such as
  846. making a non-nullable field null, overflowing a numeric field, storing
  847. a string value in a numeric field, or violating a uniqueness
  848. constraint.
  849.  
  850. =back
  851.  
  852. The module dies with an error message when it encounters an error
  853. during an update.  To trap these erorrs and continue processing, wrap
  854. the update an eval().
  855.  
  856. =head2 Other functions
  857.  
  858. The tie object supports several useful methods.  In order to call
  859. these methods, you must either save the function result from the tie()
  860. call (which returns the object), or call tied() on the tie variable to
  861. recover the object.
  862.  
  863. =over 4
  864.  
  865. =item connect(), error(), errstr()
  866.  
  867. These are low-level class methods.  Connect() is responsible for
  868. establishing the connection with the DBI database.  Errstr() and
  869. error() return $DBI::errstr and $DBI::error respectively.  You may
  870. may override these methods in subclasses if you wish.  For example,
  871. replace connect() with this code in order to use persistent database
  872. connections in Apache modules:
  873.  
  874.  use Apache::DBI;  # somewhere in the declarations
  875.  sub connect {
  876.  my ($class,$dsn,$user,$password,$options) = @_;
  877.     return Apache::DBI->connect($dsn,$user,
  878.                                 $password,$options);
  879.  }
  880.  
  881. =item commit()
  882.  
  883.    (tied %produce)->commit();
  884.  
  885. When using a database with the autocommit option turned off, values
  886. that are stored into the hash will not become permanent until commit()
  887. is called.  Otherwise they are lost when the application terminates or
  888. the hash is untied.
  889.  
  890. Some SQL databases don't support transactions, in which case you will
  891. see a warning message if you attempt to use this function.
  892.  
  893. =item rollback()
  894.  
  895.    (tied %produce)->rollback();
  896.  
  897. When using a database with the autocommit option turned off, this
  898. function will roll back changes to the database to the state they were
  899. in at the last commit().  This function has no effect on database that
  900. don't support transactions.
  901.  
  902. =item select_where()
  903.  
  904.    @keys=(tied %produce)->select_where('price > 1.00 and quantity < 10');
  905.  
  906. This executes a limited form of select statement on the tied table and
  907. returns a list of records that satisfy the conditions.  The argument
  908. you provide should be the contents of a SQL WHERE clause, minus the
  909. keyword "WHERE" and everything that ordinarily precedes it.  Anything
  910. that is legal in the WHERE clause is allowed, including function
  911. calls, ordering specifications, and sub-selects.  The keys to those
  912. records that meet the specified conditions are returned as an array,
  913. in the order in which the select statement returned them.
  914.  
  915. Don't expect too much from this function.  If you want to execute a
  916. complex query, you're better off using the database handle (see below)
  917. to make the SQL query yourself with the DBI interface.
  918.  
  919. =item dbh()
  920.  
  921.    $dbh = (tied %produce)->dbh();
  922.  
  923. This returns the tied hash's underlying database handle.  You can use
  924. this handle to create and execute your own SQL queries.
  925.  
  926. =item CLOBBER, DEBUG, WARN
  927.  
  928. You can get and set the values of CLOBBER, DEBUG and WARN by directly
  929. accessing the object's hash:
  930.  
  931.     (tied %produce)->{DEBUG}++;
  932.  
  933. This lets you change the behavior of the tied hash on the fly, such as
  934. temporarily granting your program write permission.  
  935.  
  936. There are other variables there too, such as the name of the key
  937. column and database table.  Change them at your own risk!
  938.  
  939. =back
  940.  
  941. =head1 PERFORMANCE
  942.  
  943. What is the performance hit when you use this module rather than the
  944. direct DBI interface?  It can be significant.  To measure the
  945. overhead, I used a simple benchmark in which Perl parsed a 6180 word
  946. text file into individual words and stored them into a database,
  947. incrementing the word count with each store.  The benchmark then read
  948. out the words and their counts in an each() loop.  The database driver
  949. was mySQL, running on a 133 MHz Pentium laptop with Linux 2.0.30.  I
  950. compared Tie::RDBM, to DB_File, and to the same task using vanilla DBI
  951. SQL statements.  The results are shown below:
  952.  
  953.               UPDATE         FETCH
  954.   Tie::DBI      70 s        6.1  s
  955.   Vanilla DBI   14 s        2.0  s
  956.   DB_File        3 s        1.06 s
  957.  
  958. There is about a five-fold penalty for updates, and a three-fold
  959. penalty for fetches when using this interface.  Some of the penalty is
  960. due to the overhead for creating sub-objects to handle individual
  961. fields, and some of it is due to the inefficient way the store and
  962. fetch operations are implemented.  For example, using the tie
  963. interface, a statement like $h{record}{field}++ requires as much as
  964. four trips to the database: one to verify that the record exists, one
  965. to fetch the field, and one to store the incremented field back.  If
  966. the record doesn't already exist, an additional statement is required
  967. to perform the insertion.  I have experimented with cacheing schemes
  968. to reduce the number of trips to the database, but the overhead of
  969. maintaining the cache is nearly equal to the performance improvement,
  970. and cacheing raises a number of potential concurrency problems.
  971.  
  972. Clearly you would not want to use this interface for applications that
  973. require a large number of updates to be processed rapidly.
  974.  
  975. =head1 BUGS
  976.  
  977. =head1 BUGS
  978.  
  979. The each() call produces a fatal error when used with the Sybase
  980. driver to access Microsoft SQL server. This is because this server
  981. only allows one query to be active at a given time.  A workaround is
  982. to use keys() to fetch all the keys yourself.  It is not known whether
  983. real Sybase databases suffer from the same problem.
  984.  
  985. The delete() operator will not work correctly for setting field values
  986. to null with DBD::CSV or with DBD::Pg.  CSV files do not have a good
  987. conception of database nulls.  Instead you will set the field to an
  988. empty string.  DBD::Pg just seems to be broken in this regard.
  989.  
  990. =head1 AUTHOR
  991.  
  992. Lincoln Stein, lstein@cshl.org
  993.  
  994. =head1 COPYRIGHT
  995.  
  996.   Copyright (c) 1998, Lincoln D. Stein
  997.  
  998. This library is free software; you can redistribute it and/or
  999. modify it under the same terms as Perl itself.
  1000.  
  1001. =head1 AVAILABILITY
  1002.  
  1003. The latest version can be obtained from:
  1004.  
  1005.    http://www.genome.wi.mit.edu/~lstein/Tie-DBI/
  1006.  
  1007. =head1 SEE ALSO
  1008.  
  1009. perl(1), DBI(3), Tie::RDBM(3)
  1010.  
  1011. =cut
  1012.  
  1013.  
  1014. 1;
  1015.