DBD-XBase-1.08/0000755000175000017500000000000013037112723012670 5ustar adeltonadeltonDBD-XBase-1.08/lib/0000755000175000017500000000000013037112723013436 5ustar adeltonadeltonDBD-XBase-1.08/lib/XBase.pm0000644000175000017500000011714413037112627015011 0ustar adeltonadelton use XBase::Memo; =head1 NAME XBase - Perl module for reading and writing the dbf files =cut # ############ package XBase; use 5.010; use strict; use XBase::Base; # will give us general methods # ############## # General things use vars qw( $VERSION $errstr $CLEARNULLS @ISA ); @ISA = qw( XBase::Base ); $VERSION = '1.08'; $CLEARNULLS = 1; # Cut off white spaces from ends of char fields *errstr = \$XBase::Base::errstr; # ######################################### # Open, read_header, init_memo_field, close # Open the specified file or try to append the .dbf suffix. sub open { my ($self) = shift; my %options; if (scalar(@_) % 2) { $options{'name'} = shift; } $self->{'openoptions'} = { %options, @_ }; my %locoptions; @locoptions{ qw( name readonly ignorememo fh ) } = @{$self->{'openoptions'}}{ qw( name readonly ignorememo fh ) }; my $filename = $locoptions{'name'}; if ($filename eq '-') { return $self->SUPER::open(%locoptions); } for my $ext ('', '.dbf', '.DBF') { if (-f $filename.$ext) { $locoptions{'name'} = $filename.$ext; $self->NullError(); return $self->SUPER::open(%locoptions); } } $locoptions{'name'} = $filename; return $self->SUPER::open(%locoptions); # for nice error message } # We have to provide way to fill up the object upon open sub read_header { my $self = shift; my $fh = $self->{'fh'}; my $header; # read the header $self->read($header, 32) == 32 or do { __PACKAGE__->Error("Error reading header of $self->{'filename'}: $!\n"); return; }; @{$self}{ qw( version last_update num_rec header_len record_len encrypted ) } = unpack 'Ca3Vvv@15a1', $header; # parse the data ### if (0 and $self->{'encrypted'} ne "\000") ### { __PACKAGE__->Error("We don't support encrypted files, sorry.\n"); return; }; my $header_len = $self->{'header_len'}; my ($names, $types, $lengths, $decimals) = ( [], [], [], [] ); my ($unpacks, $readproc, $writeproc) = ( [], [], [] ); my $lastoffset = 1; while ($self->tell() < $header_len - 1) { # read the field desc's my $field_def; $self->read($field_def, 1); last if $field_def eq "\r"; # we have found the terminator my $read = $self->read($field_def, 31, 1); if ($read != 31) { __PACKAGE__->Error("Error reading field description: $!\n"); return; } my ($name, $type, $length, $decimal) = unpack 'A11a1 @16CC', $field_def; my ($rproc, $wproc); if ($type eq 'C') { # char # fixup for char length > 256 if ($decimal and not $self->{'openoptions'}{'nolongchars'}) { $length += 256 * $decimal; $decimal = 0; } $rproc = sub { my $value = $_[0]; if ($self->{'ChopBlanks'}) { $value =~ s/\s+$//; } return $value; ( $value eq '' ? undef : $value ); }; $wproc = sub { my $value = shift; sprintf '%-*.*s', $length, $length, (defined $value ? $value : ''); }; } elsif ($type eq 'L') { # logical (boolean) $rproc = sub { my $value = shift; if ($value =~ /^[YyTt]$/) { return 1; } if ($value =~ /^[NnFf]$/) { return 0; } undef; }; $wproc = sub { my $value = shift; sprintf '%-*.*s', $length, $length, (defined $value ? ( $value ? 'T' : 'F') : '?'); }; } elsif ($type =~ /^[NFD]$/) { # numbers, dates $rproc = sub { my $value = shift; ($value =~ /\d/) ? $value + 0 : undef; }; $wproc = sub { my $value = shift; if (defined $value) { substr(sprintf('%*.*f', $length, $decimal, ($value + 0)), -$length); } else { ' ' x $length; } }; } elsif ($type eq 'I') { # Fox integer $rproc = sub { unpack 'V', shift; }; $wproc = sub { pack 'V', shift; }; } elsif ($type eq 'B' and $length == 8) { # Fox double if (pack("L", 1) eq pack("V", 1)) { $rproc = sub { unpack 'd', scalar shift; }; $wproc = sub { scalar pack 'd', shift; }; } else { $rproc = sub { unpack 'd', reverse scalar shift; }; $wproc = sub { reverse scalar pack 'd', shift; }; } } elsif ($type =~ /^[WMGPB]$/) { # memo fields my $memo = $self->{'memo'}; if (not defined $memo and not $self->{'openoptions'}{'ignorememo'}) { $memo = $self->{'memo'} = $self->init_memo_field() or return; } if (defined $memo and $length == 10) { if (ref $memo eq 'XBase::Memo::Apollo') { $rproc = sub { $memo->read_record(shift); }; $wproc = sub { $memo->write_record(shift); }; } else { $rproc = sub { my $value = shift; return if not $value =~ /\d/ or $value < 0; $memo->read_record($value - 1) if defined $memo; }; $wproc = sub { my $value = $memo->write_record(-1, $type, $_[0]) if defined $memo and defined $_[0] and $_[0] ne ''; sprintf '%*.*s', $length, $length, (defined $value ? $value + 1: ''); }; } } elsif (defined $memo and $length == 4) { $rproc = sub { my $val = unpack('V', $_[0]) - 1; return if $val < 0; $memo->read_record($val) if defined $memo; }; $wproc = sub { my $value = $memo->write_record(-1, $type, shift) if defined $memo; pack 'V', (defined $value ? $value + 1: 0); }; } else { $rproc = sub { undef; }; $wproc = sub { ' ' x $length; }; } } elsif ($type eq 'T') { # time fields # datetime is stored internally as two # four-byte numbers; the first is the day under # the Julian Day System (JDS) and the second is # the number of milliseconds since midnight $rproc = sub { my ($day, $time) = unpack 'VV', $_[0]; my $localday = $day - 2440588; my $localtime = $localday * 24 * 3600; $localtime += $time / 1000; ### print STDERR "day,time: ($day,$time -> $localtime)\n"; return $localtime; my $localdata = "[$localday] $localtime: @{[localtime($localtime)]}"; my $usec = $time % 1000; my $hour = int($time / 3600000); my $min = int(($time % 3600000) / 60000); my $sec = int(($time % 60000) / 1000); return "$day($localdata)-$hour:$min:$sec.$usec"; }; $wproc = sub { my $localtime = shift; my $day = int($localtime / (24 * 3600)) + 2440588; my $time = int(($localtime % (3600 * 24)) * 1000); ### print STDERR "day,time: ($localtime -> $day,$time)\n"; return pack 'VV', $day, $time; } } elsif ($type eq '0') { # SNa : field "_NULLFLAGS" $rproc = $wproc = sub { '' }; } elsif ($type eq 'Y') { # Fox money $rproc = sub { my ($x, $y) = unpack 'VV', scalar shift; if ($y & 0x80000000) { - ($y ^ 0xffffffff) * (2**32 / 10**$decimal) - (($x - 1) ^ 0xffffffff) / 10**$decimal; } else { $y * (2**32 / 10**$decimal) + $x / 10**$decimal; } }; $wproc = sub { my $value = shift; if ($value < 0) { pack 'VV', (-$value * 10**$decimal + 1) ^ 0xffffffff, (-$value * 10**$decimal / 2**32) ^ 0xffffffff; } else { pack 'VV', ($value * 10**$decimal) % 2**32, (($value * 10**$decimal) >> 32); } }; } $name =~ s/[\000 ].*$//s; $name = uc $name; # no locale yet push @$names, $name; push @$types, $type; push @$lengths, $length; push @$decimals, $decimal; push @$unpacks, '@' . $lastoffset . 'a' . $length; push @$readproc, $rproc; push @$writeproc, $wproc; $lastoffset += $length; } if ($lastoffset > $self->{'record_len'} and not defined $self->{'openoptions'}{'nolongchars'}) { $self->seek_to(0); $self->{'openoptions'}{'nolongchars'} = 1; return $self->read_header; } if ($lastoffset != $self->{'record_len'} and not defined $self->{'openoptions'}{'ignorebadheader'}) { __PACKAGE__->Error("Missmatch in header of $self->{'filename'}: record_len $self->{'record_len'} but offset $lastoffset\n"); return; } if ($self->{'openoptions'}{'recompute_lastrecno'}) { $self->{num_rec} = int(((-s $self->{'fh'}) - $self->{header_len}) / $self->{record_len}); } my $hashnames = {}; # create name-to-num_of_field hash @{$hashnames}{ reverse @$names } = reverse ( 0 .. $#$names ); # now it's the time to store the values to the object @{$self}{ qw( field_names field_types field_lengths field_decimals hash_names last_field field_unpacks field_rproc field_wproc ChopBlanks) } = ( $names, $types, $lengths, $decimals, $hashnames, $#$names, $unpacks, $readproc, $writeproc, $CLEARNULLS ); 1; # return true since everything went fine } # When there is a memo field in dbf, try to open the memo file sub init_memo_field { my $self = shift; return $self->{'memo'} if defined $self->{'memo'}; require XBase::Memo; my %options = ( 'dbf_version' => $self->{'version'}, 'memosep' => $self->{'openoptions'}{'memosep'} ); if (defined $self->{'openoptions'}{'memofile'}) { return XBase::Memo->new($self->{'openoptions'}{'memofile'}, %options); } for (qw( dbt DBT fpt FPT smt SMT dbt )) { my $memo; my $memoname = $self->{'filename'}; ($memoname =~ s/\.dbf$/.$_/i or $memoname =~ s/(\.dbf)?$/.$_/i) and $memo = XBase::Memo->new($memoname, %options) and return $memo; } return; } # Close the file (and memo) sub close { my $self = shift; if (defined $self->{'memo'}) { $self->{'memo'}->close(); delete $self->{'memo'}; } $self->SUPER::close(); } # ############### # Little decoding sub version { shift->{'version'}; } sub last_record { shift->{'num_rec'} - 1; } sub last_field { shift->{'last_field'}; } # List of field names, types, lengths and decimals sub field_names { @{shift->{'field_names'}}; } sub field_types { @{shift->{'field_types'}}; } sub field_lengths { @{shift->{'field_lengths'}}; } sub field_decimals { @{shift->{'field_decimals'}}; } # Return field number for field name sub field_name_to_num { my ($self, $name) = @_; $self->{'hash_names'}{uc $name}; } sub field_type { my ($self, $name) = @_; defined (my $num = $self->field_name_to_num($name)) or return; ($self->field_types)[$num]; } sub field_length { my ($self, $name) = @_; defined (my $num = $self->field_name_to_num($name)) or return; ($self->field_lengths)[$num]; } sub field_decimal { my ($self, $name) = @_; defined (my $num = $self->field_name_to_num($name)) or return; ($self->field_decimals)[$num]; } # ############################# # Header, field and record info # Returns (not prints!) the info about the header of the object *header_info = \&get_header_info; sub get_header_info { my $self = shift; my $hexversion = sprintf '0x%02x', $self->version; my $longversion = $self->get_version_info()->{'string'}; my $printdate = $self->get_last_change; my $numfields = $self->last_field() + 1; my $result = sprintf <<"EOF"; Filename: $self->{'filename'} Version: $hexversion ($longversion) Num of records: $self->{'num_rec'} Header length: $self->{'header_len'} Record length: $self->{'record_len'} Last change: $printdate Num fields: $numfields Field info: Num Name Type Len Decimal EOF return join '', $result, map { $self->get_field_info($_) } (0 .. $self->last_field); } # Return info about field in dbf file sub get_field_info { my ($self, $num) = @_; sprintf "%d.\t%-16.16s%-8.8s%-8.8s%s\n", $num + 1, map { $self->{$_}[$num] } qw( field_names field_types field_lengths field_decimals ); } # Return last_change item as printable string sub get_last_change { my $self = shift; my $date = $self; if (ref $self) { $date = $self->{'last_update'}; } my ($year, $mon, $day) = unpack 'C3', $date; $year += ($year >= 70) ? 1900 : 2000; return "$year/$mon/$day"; } # Return text description of the version value sub get_version_info { my $version = shift; $version = $version->version() if ref $version; my $result = {}; $result->{'vbits'} = $version & 0x07; if ($version == 0x30 or $version == 0xf5) { $result->{'vbits'} = 5; $result->{'foxpro'} = 1; } elsif ($version & 0x08) { $result->{'vbits'} = 4; $result->{'memo'} = 1; } elsif ($version & 0x80) { $result->{'dbt'} = 1; } my $string = "ver. $result->{'vbits'}"; if (exists $result->{'foxpro'}) { $string .= " (FoxPro)"; } if (exists $result->{'memo'}) { $string .= " with memo file"; } elsif (exists $result->{'dbt'}) { $string .= " with DBT file"; } $result->{'string'} = $string; $result; } # Print the records as colon separated fields sub dump_records { my $self = shift; my %options = ( 'rs' => "\n", 'fs' => ':', 'undef' => '' ); my %inoptions = @_; for my $key (keys %inoptions) { my $value = $inoptions{$key}; my $outkey = lc $key; $outkey =~ s/[^a-z]//g; $options{$outkey} = $value; } my ($rs, $fs, $undef, $fields, $table) = @options{ qw( rs fs undef fields table ) }; if (defined $table) { eval 'use Data::ShowTable'; if ($@) { warn "You requested table output format but the module Data::ShowTable doesn't\nseem to be installed correctly. Falling back to standard\n"; $table = undef; } else { delete $options{'rs'}; delete $options{'fs'}; } } my @fields = (); my @unknown_fields; if (defined $fields) { if (ref $fields eq 'ARRAY') { @fields = @$fields; } else { @fields = split /\s*,\s*/, $fields; my $i = 0; while ($i < @fields) { if (defined $self->field_name_to_num($fields[$i])) { $i++; } elsif ($fields[$i] =~ /^(.*)-(.*)/) { local $^W = 0; my @allfields = $self->field_names; my ($start, $end) = ($1, $2); if ($start eq '') { $start = $allfields[0]; } if ($end eq '') { $end = $allfields[$#allfields]; } my $start_num = $self->field_name_to_num($start); my $end_num = $self->field_name_to_num($end); if ($start ne '' and not defined $start_num) { push @unknown_fields, $start; } if ($end ne '' and not defined $end_num) { push @unknown_fields, $end; } unless (defined $start and defined $end) { $start = 0; $end = -1; } splice @fields, $i, 1, @allfields[$start_num .. $end_num]; } else { push @unknown_fields, $fields[$i]; $i++; } } } } if (@unknown_fields) { $self->Error("There have been unknown fields `@unknown_fields' specified.\n"); return 0; } my $cursor = $self->prepare_select(@fields); my @record; if (defined $table) { local $^W = 0; &ShowBoxTable( $cursor->names(), [], [], sub { if ($_[0]) { $cursor->rewind(); } else { $cursor->fetch() } }); } else { while (@record = $cursor->fetch) { print join($fs, map { defined $_ ? $_ : $undef } @record), $rs; } } 1; } # ################### # Reading the records # Returns fields of the specified record; parameters and number of the # record (starting from 0) and optionally names of the required # fields. If no names are specified, all fields are returned. The # first value in the returned list if always 1/0 deleted flag. Returns # empty list on error. sub get_record { my ($self, $num) = (shift, shift); $self->NullError(); $self->get_record_nf( $num, map { $self->field_name_to_num($_); } @_); } *get_record_as_hash = \&get_record_hash; sub get_record_hash { my ($self, $num) = @_; my @list = $self->get_record($num) or return; my $hash = {}; @{$hash}{ '_DELETED', $self->field_names() } = @list; return %$hash if wantarray; $hash; } sub get_record_nf { my ($self, $num, @fieldnums) = @_; my $data = $self->read_record($num) or return; if (not @fieldnums) { @fieldnums = ( 0 .. $self->last_field ); } my $unpack = join ' ', '@0a1', map { my $e; defined $_ and $e = $self->{'field_unpacks'}[$_]; defined $e ? $e : '@0a0'; } @fieldnums; my $rproc = $self->{'field_rproc'}; my @fns = (\&_read_deleted, map { (defined $_ and defined $rproc->[$_]) ? $rproc->[$_] : sub { undef; }; } @fieldnums); my @out = unpack $unpack, $data; ### if ($self->{'encrypted'} ne "\000") { ### for my $data (@out) { ### for (my $i = 0; $i < length($data); $i++) { ### ## my $num = unpack 'C', substr($data, $i, 1); ### ## substr($data, $i, 1) = pack 'C', (($num >> 3) | ($num << 5) ^ 020); ### my $num = unpack 'C', substr($data, $i, 1); ### substr($data, $i, 1) = pack 'C', (($num >> 1) | ($num << 7) ^ 052); ### } ### } ### } for (@out) { $_ = &{ shift @fns }($_); } @out; } # Processing on read sub _read_deleted { my $value = shift; if ($value eq '*') { return 1; } elsif ($value eq ' ') { return 0; } undef; } sub get_all_records { my $self = shift; my $cursor = $self->prepare_select(@_); my $result = []; my @record; while (@record = $cursor->fetch()) { push @$result, [ @record ]; } $result; } # ############# # Write records # Write record, values of the fields are in the argument list. # Record is always undeleted sub set_record { my ($self, $num, @data) = @_; $self->NullError(); my $wproc = $self->{'field_wproc'}; if (defined $self->{'attached_index_columns'}) { my @nfs = keys %{$self->{'attached_index_columns'}}; my ($del, @old_data) = $self->get_record_nf($num, @nfs); local $^W = 0; for my $nf (@nfs) { if ($old_data[$nf] ne $data[$nf]) { for my $idx (@{$self->{'attached_index_columns'}{$nf}}) { $idx->delete($old_data[$nf], $num + 1); $idx->insert($data[$nf], $num + 1); } } } } for (my $i = 0; $i <= $#$wproc; $i++) { $data[$i] = &{ $wproc->[$i] }($data[$i]); } unshift @data, ' '; ### if ($self->{'encrypted'} ne "\000") { ### for my $data (@data) { ### for (my $i = 0; $i < length($data); $i++) { ### my $num = unpack 'C', substr($data, $i, 1); ### substr($data, $i, 1) = pack 'C', (($num << 3) | ($num >> 5) ^ 020); ### } ### } ### } $self->write_record($num, @data); } # Write record, fields are specified as hash, unspecified are set to # undef/empty sub set_record_hash { my ($self, $num, %data) = @_; $self->NullError(); $self->set_record($num, map { $data{$_} } $self->field_names ); } # Write record, fields specified as hash, unspecified will be # unchanged sub update_record_hash { my ($self, $num) = ( shift, shift ); $self->NullError(); my %olddata = $self->get_record_hash($num); return unless %olddata; $self->set_record_hash($num, %olddata, @_); } # Actually write the data (calling XBase::Base::write_record) and keep # the overall structure of the file correct; sub write_record { my ($self, $num) = (shift, shift); my $ret = $self->SUPER::write_record($num, @_) or return; if ($num > $self->last_record) { $self->SUPER::write_record($num + 1, "\x1a"); # add EOF $self->update_last_record($num) or return; } $self->update_last_change or return; $ret; } # Delete and undelete record sub delete_record { my ($self, $num) = @_; $self->NullError(); $self->write_record($num, "*"); } sub undelete_record { my ($self, $num) = @_; $self->NullError(); $self->write_record($num, " "); } # Update the last change date sub update_last_change { my $self = shift; return 1 if defined $self->{'updated_today'}; my ($y, $m, $d) = (localtime)[5, 4, 3]; $m++; $y -= 100 if $y >= 100; $self->write_to(1, pack "C3", ($y, $m, $d)) or return; $self->{'updated_today'} = 1; } # Update the number of records sub update_last_record { my ($self, $last) = @_; $last++; $self->write_to(4, pack "V", $last); $self->{'num_rec'} = $last; } # Creating new dbf file sub create { XBase->NullError(); my $class = shift; my %options = @_; if (ref $class) { %options = ( %$class, %options ); $class = ref $class; } my $version = $options{'version'}; if (not defined $version) { if (defined $options{'memofile'} and $options{'memofile'} =~ /\.fpt$/i) { $version = 0xf5; } else { $version = 3; } } my $key; for $key ( qw( field_names field_types field_lengths field_decimals ) ) { if (not defined $options{$key}) { __PACKAGE__->Error("Tag $key must be specified when creating new table\n"); return; } } my $needmemo = 0; my $fieldspack = ''; my $record_len = 1; my $i; for $i (0 .. $#{$options{'field_names'}}) { my $name = uc $options{'field_names'}[$i]; $name = "FIELD$i" unless defined $name; $name .= "\0"; my $type = $options{'field_types'}[$i]; $type = 'C' unless defined $type; my $length = $options{'field_lengths'}[$i]; my $decimal = $options{'field_decimals'}[$i]; if (not defined $length) { # defaults if ($type eq 'C') { $length = 64; } elsif ($type =~ /^[TD]$/) { $length = 8; } elsif ($type =~ /^[NF]$/) { $length = 8; } } # force correct lengths if ($type =~ /^[MBGP]$/) { $length = 10; $decimal = 0; } elsif ($type eq 'L') { $length = 1; $decimal = 0; } elsif ($type eq 'Y') { $length = 8; $decimal = 4; } if (not defined $decimal) { $decimal = 0; } $record_len += $length; my $offset = $record_len; if ($type eq 'C') { $decimal = int($length / 256); $length %= 256; } $fieldspack .= pack 'a11a1VCCvCvCa7C', $name, $type, $offset, $length, $decimal, 0, 0, 0, 0, '', 0; if ($type eq 'M') { $needmemo = 1; if ($version != 0x30) { $version |= 0x80; } } } $fieldspack .= "\x0d"; { local $^W = 0; $options{'codepage'} += 0; } my $header = pack 'C CCC V vvv CC a12 CC v', $version, 0, 0, 0, 0, (32 + length $fieldspack), $record_len, 0, 0, 0, '', 0, $options{'codepage'}, 0; $header .= $fieldspack; $header .= "\x1a"; my $tmp = $class->new(); my $basename = $options{'name'}; $basename =~ s/\.dbf$//i; my $newname = $options{'name'}; if (defined $newname and not $newname =~ /\.dbf$/) { $newname .= '.dbf'; } $tmp->create_file($newname, 0700) or return; $tmp->write_to(0, $header) or return; $tmp->update_last_change(); $tmp->close(); if ($needmemo) { require XBase::Memo; my $dbtname = $options{'memofile'}; if (not defined $dbtname) { $dbtname = $options{'name'}; if ($version == 0x30 or $version == 0xf5) { $dbtname =~ s/\.DBF$/.FPT/ or $dbtname =~ s/(\.dbf)?$/.fpt/; } else { $dbtname =~ s/\.DBF$/.DBT/ or $dbtname =~ s/(\.dbf)?$/.dbt/; } } my $dbttmp = XBase::Memo->new(); my $memoversion = ($version & 15); $memoversion = 5 if $version == 0x30; $dbttmp->create('name' => $dbtname, 'version' => $memoversion, 'dbf_filename' => $basename) or return; } return $class->new($options{'name'}); } # Drop the table sub drop { my $self = shift; my $filename = $self; if (ref $self) { if (defined $self->{'memo'}) { $self->{'memo'}->drop(); delete $self->{'memo'}; } return $self->SUPER::drop(); } XBase::Base::drop($filename); } # Lock and unlock sub locksh { my $self = shift; my $ret = $self->SUPER::locksh or return; if (defined $self->{'memo'}) { unless ($self->{'memo'}->locksh()) { $self->SUPER::unlock; return; } } $ret; } sub lockex { my $self = shift; my $ret = $self->SUPER::lockex or return; if (defined $self->{'memo'}) { unless ($self->{'memo'}->lockex()) { $self->SUPER::unlock; return; } } $ret; } sub unlock { my $self = shift; $self->{'memo'}->unlock() if defined $self->{'memo'}; $self->SUPER::unlock; } # # Attaching index file # sub attach_index { my ($self, $indexfile) = @_; require XBase::Index; my $index = $self->XBase::Index::new($indexfile) or do { print STDERR XBase->errstr, "\n"; $self->Error(XBase->errstr); return; }; print "Got index $index\n" if $XBase::Index::VERBOSE; my @tags = $index->tags; my @indexes; if (@tags) { for my $tag (@tags) { my $index = $self->XBase::Index::new($indexfile, 'tag' => $tag) or do { print STDERR XBase->errstr, "\n"; $self->Error(XBase->errstr); return; }; push @indexes, $index; } } else { @indexes = ( $index ); } for my $idx (@indexes) { my $key = $idx->{'key_string'}; my $num = $self->field_name_to_num($key); print "Got key string $key -> $num\n" if $XBase::Index::VERBOSE; $self->{'attached_index'} = [] unless defined $self->{'attached_index'}; push @{$self->{'attached_index'}}, $idx; push @{$self->{'attached_index_columns'}{$num}}, $idx; } 1; } # # Cursory select # sub prepare_select { my $self = shift; my $fieldnames = [ @_ ]; if (not @_) { $fieldnames = [ $self->field_names ] }; my $fieldnums = [ map { $self->field_name_to_num($_); } @$fieldnames ]; return bless [ $self, undef, $fieldnums, $fieldnames ], 'XBase::Cursor'; # object, recno, field numbers, field names } sub prepare_select_nf { my $self = shift; my @fieldnames = $self->field_names; if (@_) { @fieldnames = @fieldnames[ @_ ] } return $self->prepare_select(@fieldnames); } sub prepare_select_with_index { my ($self, $file) = ( shift, shift ); my @tagopts = (); if (ref $file eq 'ARRAY') { ### this is suboptimal ### interface but should suffice for the moment @tagopts = ('tag' => $file->[1]); if (defined $file->[2]) { push @tagopts, ('type' => $file->[2]); } $file = $file->[0]; } my $fieldnames = [ @_ ]; if (not @_) { $fieldnames = [ $self->field_names ] }; my $fieldnums = [ map { $self->field_name_to_num($_); } @$fieldnames ]; require XBase::Index; my $index = new XBase::Index $file, 'dbf' => $self, @tagopts or do { $self->Error(XBase->errstr); return; }; $index->prepare_select or do { $self->Error($index->errstr); return; }; return bless [ $self, undef, $fieldnums, $fieldnames, $index ], 'XBase::IndexCursor'; # object, recno, field numbers, field names, index file } package XBase::Cursor; use vars qw( @ISA ); @ISA = qw( XBase::Base ); sub fetch { my $self = shift; my ($xbase, $recno, $fieldnums, $fieldnames) = @$self; if (defined $recno) { $recno++; } else { $recno = 0; } my $lastrec = $xbase->last_record; while ($recno <= $lastrec) { my ($del, @result) = $xbase->get_record_nf($recno, @$fieldnums); if (@result and not $del) { $self->[1] = $recno; return @result; } $recno++; } return; } sub fetch_hashref { my $self = shift; my @data = $self->fetch; my $hashref = {}; if (@data) { @{$hashref}{ @{$self->[3]} } = @data; return $hashref; } return; } sub last_fetched { shift->[1]; } sub table { shift->[0]; } sub names { shift->[3]; } sub rewind { shift->[1] = undef; '0E0'; } sub attach_index { my $self = shift; require XBase::Index; } package XBase::IndexCursor; use vars qw( @ISA ); @ISA = qw( XBase::Cursor ); sub find_eq { my $self = shift; $self->[4]->prepare_select_eq(shift); } sub fetch { my $self = shift; my ($xbase, $recno, $fieldnums, $fieldnames, $index) = @$self; my ($key, $val); while (($key, $val) = $index->fetch) { my ($del, @result) = $xbase->get_record_nf($val - 1, @$fieldnums); unless ($del) { $self->[1] = $val; return @result; } } return; } # Indexed number the records starting from one, not zero. sub last_fetched { shift->[1] - 1; } 1; __END__ =head1 SYNOPSIS use XBase; my $table = new XBase "dbase.dbf" or die XBase->errstr; for (0 .. $table->last_record) { my ($deleted, $id, $msg) = $table->get_record($_, "ID", "MSG"); print "$id:\t$msg\n" unless $deleted; } =head1 DESCRIPTION This module can read and write XBase database files, known as dbf in dBase and FoxPro world. It also reads memo fields from the dbt and fpt files, if needed. An alpha code of reading index support for ndx, ntx, mdx, idx and cdx is available for testing -- see the DBD::Index(3) man page. Module XBase provides simple native interface to XBase files. For DBI compliant database access, see the DBD::XBase and DBI modules and their man pages. The following methods are supported by XBase module: =head2 General methods =over 4 =item new Creates the XBase object, loads the info about the table form the dbf file. The first parameter should be the name of existing dbf file (table, in fact) to read. A suffix .dbf will be appended if needed. This method creates and initializes new object, will also check for memo file, if needed. The parameters can also be specified in the form of hash: value of B is then the name of the table, other flags supported are: B specifies non standard name for the associated memo file. By default it's the name of the dbf file, with extension dbt or fpt. B ignore memo file at all. This is usefull if you've lost the dbt file and you do not need it. Default is false. B separator of memo records in the dBase III dbt files. The standard says it should be C<"\x1a\x1a">. There are however implamentations that only put in one C<"\x1a">. XBase.pm tries to guess which is valid for your dbt but if it fails, you can tell it yourself. B prevents XBase to treat the decimal value of character fields as high byte of the length -- there are some broken products around producing character fields with decimal values set. my $table = new XBase "table.dbf" or die XBase->errstr; my $table = new XBase "name" => "table.dbf", "ignorememo" => 1; B forces XBase.pm to disbelieve the information about the number of records in the header of the dbf file and recompute the number of records. Use this only if you know that some other software of yours produces incorrect headers. =item close Closes the object/file, no arguments. =item create Creates new database file on disk and initializes it with 0 records. A dbt (memo) file will be also created if the table contains some memo fields. Parameters to create are passed as hash. You can call this method as method of another XBase object and then you only need to pass B value of the hash; the structure (fields) of the new file will be the same as of the original object. If you call B using class name (XBase), you have to (besides B) also specify another four values, each being a reference to list: B, B, B and B. The field types are specified by one letter strings (C, N, L, D, ...). If you set some value as undefined, create will make it into some reasonable default. my $newtable = $table->create("name" => "copy.dbf"); my $newtable = XBase->create("name" => "copy.dbf", "field_names" => [ "ID", "MSG" ], "field_types" => [ "N", "C" ], "field_lengths" => [ 6, 40 ], "field_decimals" => [ 0, undef ]); Other attributes are B for non standard memo file location, B to set the codepage flag in the dbf header (it does not affect how XBase.pm reads or writes the data though, just to make FoxPro happy), and B to force different version of the dbt (dbt) file. The default is the version of the object from which you create the new one, or 3 if you call this as class method (XBase->create). The new file mustn't exist yet -- XBase will not allow you to overwrite existing table. Use B (or unlink) to delete it first. =item drop This method closes the table and deletes it on disk (including associated memo file, if there is any). =item last_record Returns number of the last record in the file. The lines deleted but present in the file are included in this number. =item last_field Returns number of the last field in the file, number of fields minus 1. =item field_names, field_types, field_lengths, field_decimals Return list of field names and so on for the dbf file. =item field_type, field_length, field_decimal For a field name, returns the appropriate value. Returns undef if the field doesn't exist in the table. =back =head2 Reading the data one by one When dealing with the records one by one, reading or writing (the following six methods), you have to specify the number of the record in the file as the first argument. The range is C<0 .. $table-Elast_record>. =over 4 =item get_record Returns a list of data (field values) from the specified record (line of the table). The first parameter in the call is the number of the record. If you do not specify any other parameters, all fields are returned in the same order as they appear in the file. You can also put list of field names after the record number and then only those will be returned. The first value of the returned list is always the 1/0 C<_DELETED> value saying whether the record is deleted or not, so on success, B never returns empty list. =item get_record_nf Instead if the names of the fields, you can pass list of numbers of the fields to read. =item get_record_as_hash Returns hash (in list context) or reference to hash (in scalar context) containing field values indexed by field names. The name of the deleted flag is C<_DELETED>. The only parameter in the call is the record number. The field names are returned as uppercase. =back =head2 Writing the data All three writing methods always undelete the record. On success they return true -- the record number actually written. =over 4 =item set_record As parameters, takes the number of the record and the list of values of the fields. It writes the record to the file. Unspecified fields (if you pass less than you should) are set to undef/empty. =item set_record_hash Takes number of the record and hash as parameters, sets the fields, unspecified are undefed/emptied. =item update_record_hash Like B but fields that do not have value specified in the hash retain their value. =back To explicitely delete/undelete a record, use methods B or B with record number as a parameter. Assorted examples of reading and writing: my @data = $table->get_record(3, "jezek", "krtek"); my $hashref = $table->get_record_as_hash(38); $table->set_record_hash(8, "jezek" => "jezecek", "krtek" => 5); $table->undelete_record(4); This is a code to update field MSG in record where ID is 123. use XBase; my $table = new XBase "test.dbf" or die XBase->errstr; for (0 .. $table->last_record) { my ($deleted, $id) = $table->get_record($_, "ID") die $table->errstr unless defined $deleted; next if $deleted; $table->update_record_hash($_, "MSG" => "New message") if $id == 123; } =head2 Sequentially reading the file If you plan to sequentially walk through the file, you can create a cursor first and then repeatedly call B to get next record. =over 4 =item prepare_select As parameters, pass list of field names to return, if no parameters, the following B will return all fields. =item prepare_select_with_index The first parameter is the file name of the index file, the rest is as above. For index types that can hold more index structures in on file, use arrayref instead of the file name and in that array include file name and the tag name, and optionaly the index type. The B will then return records in the ascending order, according to the index. =back Prepare will return object cursor, the following method are methods of the cursor, not of the table. =over 4 =item fetch Returns the fields of the next available undeleted record. The list thus doesn't contain the C<_DELETED> flag since you are guaranteed that the record is not deleted. =item fetch_hashref Returns a hash reference of fields for the next non deleted record. =item last_fetched Returns the number of the record last fetched. =item find_eq This only works with cursor created via B. Will roll to the first record what is equal to specified argument, or to the first greater if there is none equal. The following Bes then continue normally. =back Examples of using cursors: my $table = new XBase "names.dbf" or die XBase->errstr; my $cursor = $table->prepare_select("ID", "NAME", "STREET"); while (my @data = $cursor->fetch) { ### do something here, like print "@data\n"; } my $table = new XBase "employ.dbf"; my $cur = $table->prepare_select_with_index("empid.ndx"); ## my $cur = $table->prepare_select_with_index( ["empid.cdx", "ADDRES", "char"], "id", "address"); $cur->find_eq(1097); while (my $hashref = $cur->fetch_hashref and $hashref->{"ID"} == 1097) { ### do something here with $hashref } The second example shows that after you have done B, the Bes continue untill the end of the index, so you have to check whether you are still on records with given value. And if there is no record with value 1097 in the indexed field, you will just get the next record in the order. The updating example can be rewritten to: use XBase; my $table = new XBase "test.dbf" or die XBase->errstr; my $cursor = $table->prepare_select("ID") while (my ($id) = $cursor->fetch) { $table->update_record_hash($cursor->last_fetched, "MSG" => "New message") if $id == 123 } =head2 Dumping the content of the file A method B returns reference to an array containing array of values for each undeleted record at once. As parameters, pass list of fields to return for each record. To print the content of the file in a readable form, use method B. It prints all not deleted records from the file. By default, all fields are printed, separated by colons, one record on a row. The method can have parameters in a form of a hash with the following keys: =over 4 =item rs Record separator, string, newline by default. =item fs Field separator, string, one colon by default. =item fields Reference to a list of names of the fields to print. By default it's undef, meaning all fields. =item undef What to print for undefined (NULL) values, empty string by default. =back Example of use is use XBase; my $table = new XBase "table" or die XBase->errstr; $table->dump_records("fs" => " | ", "rs" => " <-+\n", "fields" => [ "id", "msg" ]);' Also note that there is a script dbfdump(1) that does the printing. =head2 Errors and debugging If the method fails (returns false or null list), the error message can be retrieved via B method. If the B or B method fails, you have no object so you get the error message using class syntax Cerrstr()>. The method B returns (not prints) string with information about the file and about the fields. Module XBase::Base(3) defines some basic functions that are inherited by both XBase and XBase::Memo(3) module. =head1 DATA TYPES The character fields are returned "as is". No charset or other translation is done. The numbers are converted to Perl numbers. The date fields are returned as 8 character string of the 'YYYYMMDD' form and when inserting the date, you again have to provide it in this form. No checking for the validity of the date is done. The datetime field is returned in the number of (possibly negative) seconds since 1970/1/1, possibly with decimal part (since it allows precision up to 1/1000 s). To get the fields, use the gmtime (or similar) Perl function. If there is a memo field in the dbf file, the module tries to open file with the same name but extension dbt, fpt or smt. It uses module XBase::Memo(3) for this. It reads and writes this memo field transparently (you do not know about it) and returns the data as single scalar. =head1 INDEX, LOCKS B A support for ndx, ntx, mdx, idx and cdx index formats is available with alpha status for testing. Some of the formats are already rather stable (ndx). Please read the XBase::Index(3) man page and the eg/use_index file in the distribution for examples and ideas. Send me examples of your data files and suggestions for interface if you need indexes. General locking methods are B, B and B for shared lock, exclusive lock and unlock. They call flock but you can redefine then in XBase::Base package. =head1 INFORMATION SOURCE This module is built using information from and article XBase File Format Description by Erik Bachmann, URL http://www.clicketyclick.dk/databases/xbase/format/ Thanks a lot. =head1 VERSION 1.08 =head1 AVAILABLE FROM http://www.adelton.com/perl/DBD-XBase/ =head1 AUTHOR (c) 1997--2017 Jan Pazdziora. All rights reserved. This package is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Contact the author at jpx dash perl at adelton dot com. =head1 THANKS Many people have provided information, test files, test results and patches. This project would not be so great without them. See the Changes file for (I hope) complete list. Thank you all, guys! Special thanks go to Erik Bachmann for his great page about the file structures; to Frans van Loon, William McKee, Randy Kobes and Dan Albertsson for longtime cooperation and many emails we've exchanged when fixing and polishing the modules' behaviour; and to Dan Albertsson for providing support for the project. =head1 SEE ALSO perl(1); XBase::FAQ(3); DBD::XBase(3) and DBI(3) for DBI interface; dbfdump(1) =cut DBD-XBase-1.08/lib/DBD/0000755000175000017500000000000013037112723014027 5ustar adeltonadeltonDBD-XBase-1.08/lib/DBD/XBase.pm0000644000175000017500000005715513037112604015402 0ustar adeltonadelton =head1 NAME DBD::XBase - DBI driver for XBase compatible database files =cut # ################################## # Here starts the DBD::XBase package package DBD::XBase; use strict; use DBI (); # we want DBI use XBase; # and we want the basic XBase handling modules use XBase::SQL; # including the SQL parsing routines use Exporter; use vars qw( $VERSION @ISA @EXPORT $err $errstr $drh $sqlstate ); # a couple of global variables that may come handy $VERSION = '1.08'; $err = 0; $errstr = ''; $sqlstate = ''; $drh = undef; # The driver method creates the drivers instance; we store it in the # global $drh variable to only load the driver once sub driver { return $drh if $drh; my ($class, $attr) = @_; $class .= '::dr'; $drh = DBI::_new_drh($class, { 'Name' => 'XBase', 'Version' => $VERSION, 'Err' => \$DBD::XBase::err, 'Errstr' => \$DBD::XBase::errstr, 'State' => \$DBD::XBase::sqlstate, 'Attribution' => 'DBD::XBase by Jan Pazdziora', }); } # The data_sources method should return list of possible "databases" # for the driver. With DBD::XBase, the database is in fact a directory. # So should we return all direcoties in current? Right now, we only # return the current directory. sub data_sources { 'dbi:XBase:.'; } # ################## # The driver package package DBD::XBase::dr; use strict; $DBD::XBase::dr::imp_data_size = 0; # The connect method returns a dbh; we require that the directory we # want to search for tables exists. sub connect { my ($drh, $dsn) = @_; $dsn = '.' if $dsn eq ''; if (not -d $dsn) { $drh->DBI::set_err(1, "Connect failed: directory `$dsn' doesn't exist"); return; } DBI::_new_dbh($drh, { 'Name' => $dsn } ); } # We do not want to do anything upon disconnecting, but we might in # the future (flush, close files) sub disconnect_all { 1; } # #################### # The database package package DBD::XBase::db; use strict; $DBD::XBase::db::imp_data_size = 0; # The prepare method takes dbh and a SQL query and should return # statement handler sub prepare { my ($dbh, $statement) = @_; # we basically call XBase::SQL parsing and get an object my $parsed_sql = parse XBase::SQL($statement); ### use Data::Dumper; print Dumper $parsed_sql; if (defined $parsed_sql->{'errstr'}) { $dbh->DBI::set_err(2, $parsed_sql->{'errstr'}); return; } # we create a new statement handler; the only thing the the # specs requires us to do here (except parsing the query) is # to se the number of bind parameters found, which we do; # we do not set NUM_OF_FIELDS (which the specs doesn't require) # since for select * we do not know the number yet, for example DBI::_new_sth($dbh, { 'Statement' => $statement, 'xbase_parsed_sql' => $parsed_sql, 'NUM_OF_PARAMS' => scalar(keys %{$parsed_sql->{'binds'}}), }); } # Storing and fetching attributes in the database handler sub STORE { my ($dbh, $attrib, $value) = @_; if ($attrib eq 'AutoCommit') { unless ($value) { die "Can't disable AutoCommit"; } return 1; } elsif ($attrib =~ /^xbase_/) { $dbh->{$attrib} = $value; return 1; } $dbh->DBD::_::db::STORE($attrib, $value); } sub FETCH { my ($dbh, $attrib) = @_; if ($attrib eq 'AutoCommit') { return 1; } elsif ($attrib =~ /^xbase_/) { return $dbh->{$attrib}; } $dbh->DBD::_::db::FETCH($attrib); } # Method tables provides a list of tables in the directory sub tables { my $dbh = shift; opendir DIR, $dbh->{'Name'} or return; my @result = (); while (defined(my $item = readdir DIR)) { next unless $item =~ s/\.dbf$//i; push @result, $item; } closedir DIR; @result; } # Quoting method sub quote { my $text = $_[1]; return 'NULL' unless defined $text; $text =~ s/\\/\\\\/sg; $text =~ s/\'/\\\'/sg; return "'$text'"; ### return "'\Q$text\E'"; } # Commit and rollback do not do anything usefull sub commit { warn "Commit ineffective while AutoCommit is on" if $_[0]->FETCH('Warn'); 1; } sub rollback { warn "Rollback ineffective while AutoCommit is on" if $_[0]->FETCH('Warn'); 0; } # Upon disconnecting we close all tables sub disconnect { my $dbh = shift; foreach my $table (keys %{$dbh->{'xbase_tables'}}) { $dbh->{'xbase_tables'}->{$table}->close; delete $dbh->{'xbase_tables'}{$table}; } 1; } # Table_info is a strange method that returns information about # tables. There is not much we could say about the files so we only # return list of them. sub table_info { my $dbh = shift; my $xbase_lines = [ map { [ undef, undef, $_, 'TABLE', undef ] } $dbh->tables ]; my $sth = DBI::_new_sth($dbh, { 'xbase_lines' => $xbase_lines, 'xbase_nondata_name' => [ qw! TABLE_QUALIFIER TABLE_OWNER TABLE_NAME TABLE_TYPE REMARKS !], }, ); $sth->STORE('NUM_OF_FIELDS', 5); $sth->DBD::XBase::st::_set_rows(scalar @$xbase_lines); return $sth; } # Very unreadable structure that the specs requires us to keep. It # summarizes information about various data types we support. I do not # hide the fact that this is not polished and probably not correct. my @TYPE_INFO_ALL = ( [ qw( TYPE_NAME DATA_TYPE PRECISION LITERAL_PREFIX LITERAL_SUFFIX CREATE_PARAMS NULLABLE CASE_SENSITIVE SEARCHABLE UNSIGNED_ATTRIBUTE MONEY AUTO_INCREMENT LOCAL_TYPE_NAME MINIMUM_SCALE MAXIMUM_SCALE ) ], [ 'VARCHAR', DBI::SQL_VARCHAR, 65535, "'", "'", 'max length', 0, 1, 2, undef, 0, 0, undef, undef, undef ], [ 'CHAR', DBI::SQL_CHAR, 65535, "'", "'", 'max length', 0, 1, 2, undef, 0, 0, undef, undef, undef ], [ 'INTEGER', DBI::SQL_INTEGER, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], [ 'FLOAT', DBI::SQL_FLOAT, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], [ 'NUMERIC', DBI::SQL_NUMERIC, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], [ 'BOOLEAN', DBI::SQL_BINARY, 0, '', '', undef, 1, 0, 2, 0, 0, 0, undef, 1, 1 ], [ 'DATE', DBI::SQL_DATE, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], [ 'TIME', DBI::SQL_TIME, 0, '', '', 'number of digits', 1, 0, 2, 0, 0, 0, undef, 0, undef ], [ 'BLOB', DBI::SQL_LONGVARBINARY, 0, '', '', undef, 1, 0, 2, 0, 0, 0, undef, 0, undef ], ); my %TYPE_INFO_TYPES = map { ( $TYPE_INFO_ALL[$_][0] => $_ ) } ( 1 .. $#TYPE_INFO_ALL ); my %REVTYPES = qw( C char N numeric F float L boolean D date M blob T time ); my %REVSQLTYPES = map { ( $_ => $TYPE_INFO_ALL[ $TYPE_INFO_TYPES{ uc $REVTYPES{$_} } ][1] ) } keys %REVTYPES; ### use Data::Dumper; print STDERR Dumper \@TYPE_INFO_ALL, \%TYPE_INFO_TYPES, \%REVTYPES, \%REVSQLTYPES; sub type_info_all { my $dbh = shift; my $result = [ @TYPE_INFO_ALL ]; my $i = 0; my $hash = { map { ( $_ => $i++) } @{$result->[0]} }; $result->[0] = $hash; $result; } sub type_info { my ($dbh, $type) = @_; my @result = (); for my $row ( 1 .. $#TYPE_INFO_ALL ) { if ($type == DBI::SQL_ALL_TYPES or $type == $TYPE_INFO_ALL[$row][1]) { push @result, { map { ( $TYPE_INFO_ALL[0][$_] => $TYPE_INFO_ALL[$row][$_] ) } ( 0 .. $#{$TYPE_INFO_ALL[0]} ) } } } @result; } sub DESTROY { # To avoid autoloaded DESTROY } # ##################### # The statement package package DBD::XBase::st; use strict; $DBD::XBase::st::imp_data_size = 0; # Binding of parameters: numbers are converted to :pnumber form, # values are stored in the sth->{'xbase_bind_values'}->name of the # parameter hash sub bind_param { my ($sth, $parameter) = (shift, shift); if ($parameter =~ /^\d+$/) { $parameter = ':p'.$parameter; } $sth->{'xbase_bind_values'}{$parameter} = shift; 1; } # Returns number of rows fetched until now sub rows { defined $_[0]->{'xbase_rows'} ? $_[0]->{'xbase_rows'} : -1; } sub _set_rows { my $sth = shift; if (not @_ or not defined $_[0]) { $sth->{'xbase_rows'} = undef; return -1; } $sth->{'xbase_rows'} = ( $_[0] ? $_[0] : '0E0' ); } # Execute the current statement, possibly binding parameters. For # nonselect commands the actions needs to be done here, for select we # just create the cursor and wait for fetchrows sub execute { my $sth = shift; # the binds_order arrayref holds the conversion from the first # occurence of the named parameter to its name; # we bind the parameters here my $parsed_sql = $sth->{'xbase_parsed_sql'}; for (my $i = 0; $i < @_; $i++) { $sth->bind_param($parsed_sql->{'binds_order'}[$i], $_[$i]); } # binded parameters my $bind_values = $sth->{'xbase_bind_values'}; # cancel the count of rows done in the previous run, this is a # new execute $sth->{'xbase_rows'} = undef; delete $sth->{'xbase_lines'}; # we'll nee dbh, table name and to command to do with them my $dbh = $sth->{'Database'}; my $table = $parsed_sql->{'table'}[0]; my $command = $parsed_sql->{'command'}; # create table first; we just create it and are done if ($command eq 'create') { my $filename = $dbh->{'Name'} . '/' . $table; my %opts; # get the name and the fields info @opts{ qw( name field_names field_types field_lengths field_decimals ) } = ( $filename, @{$parsed_sql}{ qw( createfields createtypes createlengths createdecimals ) } ); # try to create the table (and memo automatically) my $xbase = XBase->create(%opts) or do { $sth->DBI::set_err(10, XBase->errstr()); return; }; # keep the table open $dbh->{'xbase_tables'}->{$table} = $xbase; return $sth->DBD::XBase::st::_set_rows(0); # return true } # let's see if we've already opened the table my $xbase = $dbh->{'xbase_tables'}->{$table}; if (not defined $xbase) { # if not, open the table now my $filename = $dbh->{'Name'} . '/' . $table; my %opts = ('name' => $filename); $opts{'ignorememo'} = 1 if $dbh->{'xbase_ignorememo'}; # try to open the table using XBase.pm $xbase = new XBase(%opts) or do { $sth->DBI::set_err(3, "Table $table not found: " . XBase->errstr()); return; }; $dbh->{'xbase_tables'}->{$table} = $xbase; } # the following is not multiple-statements safe -- I'd overwrite # the attribute here; but I do not think anybody needs # ChopBlanks = 0 anyway if (defined $parsed_sql->{'ChopBlanks'}) { $xbase->{'ChopBlanks'} = $parsed_sql->{'ChopBlanks'}; } $parsed_sql->{'ChopBlanks'} = \$xbase->{'ChopBlanks'}; # I cannot see what I meant by this line -- never mind # the array usedfields holds a list of field names that were # explicitely mentioned somewhere in the SQL query -- select # fields list, where clause, set clauses in update ... # we'll try to make a list of those that do not exist in the table my %nonexist; for my $field (@{$parsed_sql->{'usedfields'}}) { $nonexist{$field} = 1 unless defined $xbase->field_type($field); } if (keys %nonexist) { $sth->DBI::set_err(4, sprintf 'Field %s not found in table %s', join(', ', sort keys %nonexist), $table); return; } # inserting values means appending a new row with reasonable # values; the insertfn function expects the TABLE object and # the BIND hash (it doesn' make use of them at the moment, # AFAIK, because only constants are supported), it returns list # of values if ($command eq 'insert') { my $last = $xbase->last_record; my @values = &{$parsed_sql->{'insertfn'}}($xbase, $bind_values); ### here, we'd really need a check for too many or too ### few values if (defined $parsed_sql->{'insertfields'}) { my %newval; @newval{ @{$parsed_sql->{'insertfields'} } } = @values; @values = @newval{ $xbase->field_names }; } $xbase->set_record($last + 1, @values) or do { $sth->DBI::set_err(49,'Insert failed: '.$xbase->errstr); return; }; return $sth->DBD::XBase::st::_set_rows(1); # we've added one row } # rows? what do we need rows here for? never mind. my $rows; # wherefn is defined if the statement had where clause; it # should be called with $TABLE, $VALUES and $BIND parameters my $wherefn = $parsed_sql->{'wherefn'}; # we expand selectall to list of fields if (defined $parsed_sql->{'selectall'} and not defined $parsed_sql->{'selectfieldscount'}) { $parsed_sql->{'selectnames'} = [ $xbase->field_names ]; push @{$parsed_sql->{'usedfields'}}, $xbase->field_names; $parsed_sql->{'selectfieldscount'} = scalar $xbase->field_names; } # we only set NUM_OF_FIELDS for select command -- which is # exactly what selectfieldscount means if (not $sth->FETCH('NUM_OF_FIELDS')) { $sth->STORE('NUM_OF_FIELDS', $parsed_sql->{'selectfieldscount'}); } # this cursor will be needed, because both select and update and # delete with where clause need to fetch the data first my $cursor = $xbase->prepare_select(@{$parsed_sql->{'usedfields'}}); # select with order by clause will be done using "substatement" if ($command eq 'select' and defined $parsed_sql->{'orderfields'}) { my @orderfields = @{$parsed_sql->{'orderfields'}}; # make a copy of the $parsed_sql hash, but delete the # orderfields value my $subparsed_sql = { %$parsed_sql }; delete $subparsed_sql->{'orderfields'}; delete $subparsed_sql->{'selectall'}; my $selectfn = $parsed_sql->{'selectfn'}; $subparsed_sql->{'selectfn'} = sub { my ($TABLE, $VALUES, $BINDS) = @_; return map({ XBase::SQL::Expr->field($_, $TABLE, $VALUES)->value } @orderfields), &{$selectfn}($TABLE, $VALUES, $BINDS); }; ### use Data::Dumper; print STDERR Dumper $subparsed_sql; $subparsed_sql->{'selectfieldscount'} += scalar(@orderfields); # make new $sth my $substh = DBI::_new_sth($dbh, { 'Statement' => $sth->{'Statement'}, 'xbase_parsed_sql' => $subparsed_sql, }); # bind all parameters in the substh for my $key (keys %$bind_values) { $substh->bind_param($key, $bind_values->{$key}); } # execute and fetch all rows $substh->execute; ### use Data::Dumper; print STDERR Dumper $substh->{'xbase_parsed_sql'}; my $data = $substh->fetchall_arrayref; my $sortfn = ''; for (my $i = 0; $i < @orderfields; $i++) { $sortfn .= ' or ' if $i > 0; if ($xbase->field_type($orderfields[$i]) =~ /^[CML]$/) { if (lc($parsed_sql->{'orderdescs'}[$i]) eq 'desc') { $sortfn .= "\$_[1]->[$i] cmp \$_[0]->[$i]"; } else { $sortfn .= "\$_[0]->[$i] cmp \$_[1]->[$i]"; } } else { if (lc($parsed_sql->{'orderdescs'}[$i]) eq 'desc') { $sortfn .= "\$_[1]->[$i] <=> \$_[0]->[$i]"; } else { $sortfn .= "\$_[0]->[$i] <=> \$_[1]->[$i]"; } } } my $fn = eval "sub { $sortfn }"; # sort them and store in xbase_lines $sth->{'xbase_lines'} = [ map { [ @{$_}[scalar(@orderfields) .. scalar(@$_) - 1 ] ] } sort { &{$fn}($a, $b) } @$data ]; } elsif ($command eq 'select') { $sth->{'xbase_cursor'} = $cursor; } elsif ($command eq 'delete') { if (not defined $wherefn) { my $last = $xbase->last_record; for (my $i = 0; $i <= $last; $i++) { if (not (($xbase->get_record_nf($i, 0))[0])) { $xbase->delete_record($i); $rows = 0 unless defined $rows; $rows++; } } } else { my $values; while (defined($values = $cursor->fetch_hashref)) { next unless &{$wherefn}($xbase, $values, $bind_values, 0); $xbase->delete_record($cursor->last_fetched); $rows = 0 unless defined $rows; $rows++; } } } elsif ($command eq 'update') { my $values; while (defined($values = $cursor->fetch_hashref)) { next if defined $wherefn and not &{$wherefn}($xbase, $values, $bind_values); my %newval; @newval{ @{$parsed_sql->{'updatefields'}} } = &{$parsed_sql->{'updatefn'}}($xbase, $values, $bind_values); $xbase->update_record_hash($cursor->last_fetched, %newval); $rows = 0 unless defined $rows; $rows++; } } elsif ($command eq 'drop') { # dropping the table is really easy $xbase->drop or do { $sth->DBI::set_err(60, "Dropping table $table failed: " . $xbase->errstr); return; }; delete $dbh->{'xbase_tables'}{$table}; $rows = -1; } # finaly, set the number of rows (what if somebody will ask) and # return it to curious crowds return $sth->DBD::XBase::st::_set_rows($rows); } sub fetch { my $sth = shift; my $retarray; if (defined $sth->{'xbase_lines'}) { $retarray = shift @{$sth->{'xbase_lines'}}; } elsif (defined $sth->{'xbase_cursor'}) { my $cursor = $sth->{'xbase_cursor'}; my $wherefn = $sth->{'xbase_parsed_sql'}{'wherefn'}; my $xbase = $cursor->table; my $values; while (defined($values = $cursor->fetch_hashref)) { ### use Data::Dumper; print Dumper $sth->{'xbase_bind_values'}; next if defined $wherefn and not &{$wherefn}($xbase, $values, $sth->{'xbase_bind_values'}); last; } $retarray = [ &{$sth->{'xbase_parsed_sql'}{'selectfn'}}($xbase, $values, $sth->{'xbase_bind_values'}) ] if defined $values; } ### use Data::Dumper; print Dumper $retarray; return unless defined $retarray; ### print STDERR "sth->{'NUM_OF_FIELDS'}: $sth->{'NUM_OF_FIELDS'} sth->{'NUM_OF_PARAMS'}: $sth->{'NUM_OF_PARAMS'}\n"; $sth->_set_fbav($retarray); return $retarray; my $i = 0; for my $ref ( @{$sth->{'xbase_bind_col'}} ) { next unless defined $ref; $$ref = $retarray->[$i]; } continue { $i++; } return $retarray; } *fetchrow_arrayref = \&fetch; sub FETCH { my ($sth, $attrib) = @_; my $parsed_sql = $sth->{'xbase_parsed_sql'}; if ($attrib =~ /^xbase_/) { return $sth->{$attrib}; } if ($attrib eq 'NAME') { if (defined $sth->{'xbase_nondata_name'}) { return $sth->{'xbase_nondata_name'}; } return [ @{$parsed_sql->{'selectnames'}} ]; } elsif ($attrib eq 'NULLABLE') { return [ (1) x scalar(@{$parsed_sql->{'selectnames'}}) ]; } elsif ($attrib eq 'TYPE') { return [ map { ( $REVSQLTYPES{$_} or undef ) } map { ( $sth->{'Database'}->{'xbase_tables'}->{$parsed_sql->{'table'}[0]}->field_type($_) or undef ) } @{$parsed_sql->{'selectnames'}} ]; } elsif ($attrib eq 'PRECISION') { return [ map { $sth->{'Database'}->{'xbase_tables'}->{$parsed_sql->{'table'}[0]}->field_length($_) } @{$parsed_sql->{'selectnames'}} ]; } elsif ($attrib eq 'SCALE') { return [ map { $sth->{'Database'}->{'xbase_tables'}->{$parsed_sql->{'table'}[0]}->field_decimal($_) } @{$parsed_sql->{'selectnames'}} ]; } elsif ($attrib eq 'ChopBlanks') { return $parsed_sql->{'ChopBlanks'}; } else { return $sth->DBD::_::st::FETCH($attrib); } } sub STORE { my ($sth, $attrib, $value) = @_; if ($attrib =~ /^xbase_/) { $sth->{$attrib} = $value; } if ($attrib eq 'ChopBlanks') { $sth->{'xbase_parsed_sql'}->{'ChopBlanks'} = $value; } return $sth->DBD::_::st::STORE($attrib, $value); } sub finish { 1; } sub DESTROY { } 1; __END__ =head1 SYNOPSIS use DBI; my $dbh = DBI->connect("DBI:XBase:/directory/subdir") or die $DBI::errstr; my $sth = $dbh->prepare("select MSG from test where ID != 1") or die $dbh->errstr(); $sth->execute() or die $sth->errstr(); my @data; while (@data = $sth->fetchrow_array()) { ## further processing } $dbh->do('update table set name = ? where id = 45', {}, 'krtek'); =head1 DESCRIPTION DBI compliant driver for module XBase. Please refer to DBI(3) documentation for how to actually use the module. In the B call, specify the directory containing the dbf files (and other, memo, etc.) as the third part of the connect string. It defaults to the current directory. Note that with dbf, there is no database server that the driver would talk to. This DBD::XBase calls methods from XBase.pm module to read and write the files on the disk directly, so any limitations and features of XBase.pm apply to DBD::XBase as well. DBD::XBase basically adds SQL, DBI compliant interface to XBase.pm. The DBD::XBase doesn't make use of index files at the moment. If you really need indexed access, check XBase(3) for notes about support for variour index types. =head1 SUPPORTED SQL COMMANDS The SQL commands currently supported by DBD::XBase's prepare are: =head2 select select fields_or_expressions from table [ where condition ] [ order by field ] Fields_or_expressions is a comma separated list of fields or arithmetic expressions, or a C<*> for all fields from the table. The C condition specifies which rows will be returned, you can have arbitrary arithmetic and boolean expression here, compare fields and constants and use C and C. Match using C is also supported. Examples: select * from salaries where name = "Smith" select first,last from people where login = "ftp" or uid = 1324 select id,first_name,last_name from employ where last_name like 'Ki%' order by last_name select id + 1, substr(name, 1, 10) from employ where age > 65 select id, name from employ where id = ? You can use bind parameters in the where clause, as the last example shows. The actual value has to be supplied via bind_param or in the call to execute or do, see DBI(3) for details. To check for NULL values in the C expression, use C and C, not C. Please note that you can only select from one table, joins are not supported and are not planned to be supported. If you need them, get a real RDBMS (or send me a patch). In the arithmetic expressions you can use a couple of SQL functions -- currently supported are concat, substr (and substring), trim, ltrim and rtrim, length. I do not have an exact idea of which and how many functions I want to support. It's easy to write them in a couple of minutes now the interface is there (check the XBase::SQL module if you want to send a patch containing support for more), it's just that I do not really need them and sometimes it's hard to tell what is usefull and what is SQL92 compatible. Comment welcome. The select command may contain and order by clause. Only one column is supported for sorting at the moment, patches are welcome. The group by clause is not supported (and I do not plan them), nor are the aggregate functions. =head2 delete delete from table [ where condition ] The C condition is the same as for B does not work. Aggregate functions are not supported. It would probably be very slow, since the DBD doesn't make use of indexes at the moment. I do not have plans to add this support in some near future. =item Cconnect> says that the directory doesn't exist ... ... but it's there. Is B mad or what? The third part of the first parameter to the connect is the directory where B will look for the dbf files. During connect, the module checks C. So if it says it's not there, it's not there and the only thing B can do about it is to report it to you. It might be that the directory is not mounted, you do not have permissions to it, the script is running under different UID than when you try it from command line, or you use relative patch and run the script from a different directory (pwd) than you expect. Anyway, add die "Error reading $dir: $!\n" unless -d $dir; to your script and you will see that it's not B problem. =item The B stops after reading I records ... ... why doesn't it read all I<10 x n> records? Check if the file isn't truncated. C will tell you the expected number of records and length of one record, like Filename: file.dbf Version: 0x03 (ver. 3) Num of records: 65 Header length: 1313 Record length: 1117 Last change: 1998/12/18 Num fields: 40 So the expected length of the file is at least I<1313 + 65 * 1117>. If it's shorter, you've got damaged file and B only reads as much rows as it can find in the dbf. =item How is this B related to B? B reads the dbf files directly, using the (included) B module. So it will run on any platform with reasonable new perl. With B, you need an ODBC server, or some program, that B could talk to. Many proprietary software can serve as ODBC source for dbf files, it just doesn't seem to run on Un*x systems. And is also much more resource intensive, if you just need to read the file record by record and convert it to HTML page or do similary simple operation with it. =item How do I pack the dbf file, after the records were deleted? B doesn't support this directly. You'd probably want to create new table, copy the data and rename back. Patches are always welcome. =item Foxpro doesn't see all fields in dbf created with B. Put 'version' => 3 options in to the create call -- that way we say that the dbf file is dBaseIII style. =back =cut =head1 AVAILABLE FROM http://www.adelton.com/perl/DBD-XBase/ DBD-XBase-1.08/lib/XBase/Index.pm0000644000175000017500000015335012521607341016056 0ustar adeltonadelton =head1 NAME XBase::Index - base class for the index files for dbf =cut package XBase::Index; use strict; use vars qw( @ISA $DEBUG $VERSION $VERBOSE $BIGEND ); use XBase::Base; @ISA = qw( XBase::Base ); $VERSION = '1.05'; $DEBUG = 0; $VERBOSE = 0 unless defined $VERBOSE; # We will setup global variable to denote the byte order (endian) my $packed = pack('d', 1); if ($packed eq "\077\360\000\000\000\000\000\000") { $BIGEND = 1; } elsif ($packed eq "\000\000\000\000\000\000\360\077") { $BIGEND = 0; } else { die "XBase::Index: your architecture is not supported.\n"; } # Open appropriate index file and create object according to suffix sub new { my ($class, $file) = (shift, shift); my @opts = @_; print "XBase::Index::new($class, $file, @_)\n" if $XBase::Index::VERBOSE; if (ref $class) { @opts = ('dbf', $class, @opts); } my ($ext) = ($file =~ /\.(...)$/); $ext = lc $ext; if ($ext eq 'sdbm' or $ext eq 'pag' or $ext eq 'dir') { require XBase::SDBM; $ext = 'SDBM'; } my $object = eval "new XBase::$ext \$file, \@opts"; return $object if defined $object; __PACKAGE__->Error("Error loading index: unknown extension\n") if $@; return; } # For XBase::*x object, a record is one page, object XBase::*x::Page here sub get_record { my ($self, $num) = @_; return $self->{'pages_cache'}{$num} if defined $self->{'pages_cache'}{$num}; my $newpage = (ref $self) . '::Page::new'; my $page = $self->$newpage($num); if (defined $page) { $self->{'pages_cache'}{$num} = $page; local $^W = 0; print "Page $page->{'num'}:\tkeys: @{[ map { s/\s+$//; $_; } @{$page->{'keys'}}]}\n\tvalues: @{$page->{'values'}}\n" if $DEBUG; print "\tlefts: @{$page->{'lefts'}}\n" if defined $page->{'lefts'} and $DEBUG; } $page; } # Get next (value, record number in dbf) pair # The important values of the index object are 'level' holding the # current level of the "cursor", 'pages' holding an array of pages # currently open for each level and 'rows' with an array of current row # in each level sub fetch { my $self = shift; my ($level, $page, $row, $key, $val, $left); # cycle while we get to the leaf record or otherwise get # a real value, not a pointer to lower page while (not defined $val) { $level = $self->{'level'}; # if we do not have level, let's start from zero if (not defined $level) { $level = $self->{'level'} = 0; $page = $self->get_record($self->{'start_page'}); if (not defined $page) { $self->Error("Index corrupt: $self: no root page $self->{'start_page'}\n"); return; } # and initialize 'pages' and 'rows' $self->{'pages'} = [ $page ]; $self->{'rows'} = []; } # get current page for this level $page = $self->{'pages'}[$level]; if (not defined $page) { $self->Error("Index corrupt: $self: page for level $level lost in normal course\n"); return; } # get current row for current level and increase it # (or setup to zero) my $row = $self->{'rows'}[$level]; if (not defined $row) { $row = $self->{'rows'}[$level] = 0; } else { $self->{'rows'}[$level] = ++$row; } # get the (key, value, pointer) from the page ($key, $val, $left) = $page->get_key_val_left($row); # there is another page to walk if (defined $left) { # go deeper $level++; my $oldpage = $page; # load the next page $page = $self->get_record($left); if (not defined $page) { $self->Error("Index corrupt: $self: no page $left, ref'd from $oldpage, row $row, level $level\n"); return; } # and put it into the structure $self->{'pages'}[$level] = $page; $self->{'rows'}[$level] = undef; $self->{'level'} = $level; # and even if some index structures allow the # value in the same row as record, we want to # skip it when going down $val = undef; next; } # if we're lucky and got the value, return it if (defined $val) { return ($key, $val); } # we neither got link to lower page, nor the value # so it means we are backtracking the structure one # (or more) levels back else { $self->{'level'} = --$level; # go up the levels return if $level < 0; # do not fall over $page = $self->{'pages'}[$level]; if (not defined $page) { $self->Error("Index corrupt: $self: page for level $level lost when backtracking\n"); return; } ### next unless defined $page; $row = $self->{'rows'}[$level]; my ($backkey, $backval, $backleft) = $page->get_key_val_left($row); # this is a hook for ntx files where we do not # want to miss a values that are stored inside # the structure, not only in leaves. if (not defined $page->{'last_key_is_just_overflow'} and defined $backleft and defined $backval) { return ($backkey, $backval); } } } return; } # Get list of tags in the indexfile (an indexfile may not have any) sub tags { my $self = shift; @{$self->{'tags'}} if defined $self->{'tags'}; } # Method allowing to refetch the active values (key, val) without # rolling forward sub fetch_current { my $self = shift; my $level = $self->{'level'}; my $page = $self->{'pages'}[$level]; my $row = $self->{'rows'}[$level]; my ($key, $val, $left) = $page->get_key_val_left($row); return ($key, $val); } # Rewind the index to start # the easiest way to do this is to cancel the 'level' -- this way we # do not know where we are and we have to start anew sub prepare_select { my $self = shift; delete $self->{'level'}; delete $self->{'pages'}; delete $self->{'rows'}; 1; } # Position index to a value (or behind it, if nothing found), so that # next fetch fetches the correct value sub prepare_select_eq { my ($self, $eq, $recno) = @_; $self->prepare_select(); # start from scratch ### { local $^W = 0; print STDERR "Will look for $eq $recno\n"; } my $left = $self->{'start_page'}; my $level = 0; my $parent = undef; # we'll need to know if we want numeric or string compares my $numdate = ($self->{'key_type'} ? 1 : 0); while (1) { my $page = $self->get_record($left); # get page if (not defined $page) { $self->Error("Index corrupt: $self: no page $left for level $level\n"); return; } my $row = 0; my ($key, $val); my $empty = 1; while (($key, $val, my $newleft) = $page->get_key_val_left($row)) { ### { local $^W = 0; print "Got: $key, $val, $newleft ($numdate)\n"; } $empty = 0; # There is at least 1 key $left = $newleft; # Joe Campbell says: # Compound char keys have two parts preceded by white space # get rid of the white space so that I can do a matching.... # and suggests # $key =~ s/^\s*//g; # finish if we are at the end of the page or # behind the correct value if (not defined $key) { last; } if ($numdate == 1 ? $key >= $eq : $key ge $eq) { last; } $row++; } # we know where we are positioned on the page now $self->{'pages'}[$level] = $page; $self->{'rows'}[$level] = $row; # if there is no lower level if ($empty or not defined $left) { $self->{'rows'}[$level] = ( $row ? $row - 1: undef); $self->{'level'} = $level; last; } $page->{'parent'} = $parent->{'num'} if defined $parent; $parent = $page; $level++; } if (defined $recno) { # exact match requested # get current values my ($key, $val) = $self->fetch_current; while (defined $val) { last if ($numdate ? $key > $eq : $key gt $eq); # if we're here, we still have exact match last if $val == $recno; # move forward ($key, $val) = $self->fetch; } } 1; } # Get (key, dbf record number, lower page index) from the index page sub get_key_val_left { my ($self, $num) = @_; { local $^W = 0; my $printkey = $self->{'keys'}[$num]; $printkey =~ s/\s+$//; $printkey =~ s/\000/\\0/g; print "Getkeyval: Page $self->{'num'}, row $num: $printkey, $self->{'values'}[$num], $self->{'lefts'}[$num]\n" if $DEBUG > 5; return ($self->{'keys'}[$num], $self->{'values'}[$num], $self->{'lefts'}[$num]) if $num <= $#{$self->{'keys'}}; } return; } sub num_keys { $#{shift->{'keys'}}; } sub delete { my ($self, $key, $value) = @_; print "XBase::Index::delete($key, $value) called ($self->{'tag'} -> $self->{'key_string'}/$self->{'for_string'})\n" if $XBase::Index::VERBOSE; $self->prepare_select_eq($key, $value) or return; my ($foundkey, $foundvalue) = $self->fetch_current; if (defined $foundvalue and $foundkey eq $key and $foundvalue == $value) { $self->delete_current; return 1; } print "$key/$value is not in the index (wanted to delete)\n" if $XBase::Index::VERBOSE; undef; } sub insert { my ($self, $key, $value) = @_; print "XBase::Index::insert($key, $value) called\n" if $XBase::Index::VERBOSE; $self->prepare_select_eq($key, $value) or return; my ($foundkey, $foundvalue) = $self->fetch_current; if (defined $foundvalue and $foundkey eq $key and $foundvalue == $value) { print STDERR "Already found, strange.\n"; return; } $self->insert_before_current($key, $value); } sub delete_current { my $self = shift; print "Delete_current called\n" if $XBase::Index::VERBOSE; my $level = $self->{'level'}; my $page = $self->{'pages'}[$level]; my $row = $self->{'rows'}[$level]; splice @{$page->{'values'}}, $row, 1; splice @{$page->{'keys'}}, $row, 1; splice @{$page->{'lefts'}}, $row, 1; $self->{'rows'}[$level]--; if ($self->{'rows'}[$level] < 0) { $self->{'rows'}[$level] = undef; } $page->write_with_context; delete $self->{'pages_cache'}; print STDERR "Delete_current returning\n" if $DEBUG; } sub insert_before_current { my ($self, $key, $value) = @_; print "Insert_current called ($key $value)\n" if $XBase::Index::VERBOSE; my $level = $self->{'level'}; my $page = $self->{'pages'}[$level]; my $row = $self->{'rows'}[$level]; $row = 0 unless defined $row; # update keys and values and then call save splice @{$page->{'keys'}}, $row, 0, $key; splice @{$page->{'values'}}, $row, 0, $value; splice @{$page->{'lefts'}}, $row, 0, undef if defined $page->{'lefts'}; $page->write_with_context; delete $self->{'pages_cache'}; print STDERR "Insert_current returning\n" if $DEBUG; } # ############# # dBase III NDX package XBase::ndx; use strict; use vars qw( @ISA $DEBUG ); @ISA = qw( XBase::Base XBase::Index ); *DEBUG = \$XBase::Index::DEBUG; sub read_header { my $self = shift; my %opts = @_; my $header; $self->{'dbf'} = $opts{'dbf'}; $self->{'fh'}->read($header, 512) == 512 or do { __PACKAGE__->Error("Error reading header of $self->{'filename'}: $!\n"); return; }; @{$self}{ qw( start_page total_pages key_length keys_per_page key_type key_record_length unique key_string ) } = unpack 'VV @12vvvv @23c a*', $header; $self->{'key_string'} =~ s/[\000 ].*$//s; $self->{'record_len'} = 512; $self->{'header_len'} = 0; $self; } sub last_record { shift->{'total_pages'}; } package XBase::ndx::Page; use strict; use vars qw( @ISA $DEBUG ); @ISA = qw( XBase::ndx ); *DEBUG = \$XBase::Index::DEBUG; # Constructor for the ndx page sub new { my ($indexfile, $num) = @_; my $parent; # we can be called from parent page if ((ref $indexfile) =~ /::Page$/) { $parent = $indexfile; $indexfile = $parent->{'indexfile'}; } my $data = $indexfile->read_record($num) or return; # get 512 bytes my $noentries = unpack 'V', $data; # num of entries my $keylength = $indexfile->{'key_length'}; my $keyreclength = $indexfile->{'key_record_length'}; # length print "page $num, noentries $noentries, keylength $keylength\n" if $DEBUG; my $numdate = $indexfile->{'key_type'}; # numeric or string? my $offset = 4; my $i = 0; my ($keys, $values, $lefts) = ([], [], []); # three arrays # walk the page while ($i < $noentries) { # get the values for entry my ($left, $recno, $key) = unpack 'VVa*', substr($data, $offset, $keylength + 8); if ($numdate) { # some decoding for numbers $key = reverse $key if $XBase::Index::BIGEND; $key = unpack 'd', $key; } print "$i: \@$offset VVa$keylength -> ($left, $recno, $key)\n" if $DEBUG > 1; push @$keys, $key; push @$values, ($recno ? $recno : undef); $left = ($left ? $left : undef); push @$lefts, $left; if ($i == 0 and defined $left) { $noentries++; } # fixup for nonleaf page ### shouldn't this be for last page only? } continue { $i++; $offset += $keyreclength; } my $self = bless { 'keys' => $keys, 'values' => $values, 'num' => $num, 'keylength' => $keylength, 'lefts' => $lefts, 'indexfile' => $indexfile }, __PACKAGE__; if ($num == $indexfile->{'start_page'} or (defined $parent->{'last_key_is_just_overflow'} and $parent->{'lefts'}[$#{$parent->{'lefts'}}] == $num)) { $self->{'last_key_is_just_overflow'} = 1; } $self; } # ########### # Clipper NTX package XBase::ntx; use strict; use vars qw( @ISA $DEBUG ); @ISA = qw( XBase::Base XBase::Index ); sub read_header { my $self = shift; my %opts = @_; my $header; $self->{'dbf'} = $opts{'dbf'}; $self->{'fh'}->read($header, 1024) == 1024 or do { __PACKAGE__->Error("Error reading header of $self->{'filename'}: $!\n"); return; }; @{$self}{ qw( signature compiler_version start_offset first_unused key_record_length key_length decimals max_item half_page key_string unique ) } = unpack 'vvVVvvvvvA256c', $header; my $key_string = uc $self->{'key_string'}; $key_string =~ s/^.*?->//; $self->{'key_string'} = $key_string; if ($self->{'signature'} != 3 and $self->{'signature'} != 6) { __PACKAGE__->Error("$self: bad signature value `$self->{'signature'}' found\n"); return; } $self->{'key_string'} =~ s/[\000 ].*$//s; $self->{'record_len'} = 1024; $self->{'header_len'} = 0; $self->{'start_page'} = int($self->{'start_offset'} / $self->{'record_len'}); my $field_type; if (defined $opts{'type'}) { $field_type = $opts{'type'}; } elsif (defined $self->{'dbf'}) { $field_type = $self->{'dbf'}->field_type($key_string); if (not defined $field_type) { __PACKAGE__->Error("Couldn't find key string `$key_string' in dbf file, can't determine field type\n"); return; } } else { __PACKAGE__->Error("Index type (char/numeric) unknown for $self\n"); return; } $self->{'key_type'} = ($field_type =~ /^[NDIF]$/ ? 1 : 0); $self; } sub last_record { -1; } package XBase::ntx::Page; use strict; use vars qw( @ISA $DEBUG ); @ISA = qw( XBase::ntx ); *DEBUG = \$XBase::Index::DEBUG; # Constructor for the ntx page sub new { my ($indexfile, $num) = @_; my $parent; # we could be called from parent page if ((ref $indexfile) =~ /::Page$/) { $parent = $indexfile; $indexfile = $parent->{'indexfile'}; } my $data = $indexfile->read_record($num) or return; # get data my $maxnumitem = $indexfile->{'max_item'} + 1; # limit from header my $keylength = $indexfile->{'key_length'}; my $record_len = $indexfile->{'record_len'}; # length my $numdate = $indexfile->{'key_type'}; # numeric or string? my ($noentries, @pointers) = unpack "vv$maxnumitem", $data; # get pointers where the entries are print "page $num, noentries $noentries, keylength $keylength; pointers @pointers\n" if $DEBUG; my ($keys, $values, $lefts) = ([], [], []); # walk the pointers for (my $i = 0; $i < $noentries; $i++) { my $offset = $pointers[$i]; my ($left, $recno, $key) = unpack 'VVa*', substr($data, $offset, $keylength + 8); if ($numdate) { ### if looks like with ntx the numbers are ### stored as ASCII strings or something ### To Be Done if ($key =~ tr!,+*)('&%$#"!0123456789!) { $key = '-' . $key; } $key += 0; } print "$i: \@$offset VVa$keylength -> ($left, $recno, $key)\n" if $DEBUG > 1; push @$keys, $key; push @$values, ($recno ? $recno : undef); $left = ($left ? ($left / $record_len) : undef); push @$lefts, $left; ### if ($i == 0 and defined $left and (not defined $parent or $num == $parent->{'lefts'}[-1])) if ($i == 0 and defined $left) { $noentries++; } ### shouldn't this be for last page only? } my $self = bless { 'num' => $num, 'indexfile' => $indexfile, 'keys' => $keys, 'values' => $values, 'lefts' => $lefts, }, __PACKAGE__; $self; } # ########### # FoxBase IDX package XBase::idx; use strict; use vars qw( @ISA $DEBUG ); @ISA = qw( XBase::Base XBase::Index ); *DEBUG = \$XBase::Index::DEBUG; sub read_header { my $self = shift; my %opts = @_; my $header; $self->{'dbf'} = $opts{'dbf'}; $self->{'fh'}->read($header, 512) == 512 or do { __PACKAGE__->Error("Error reading header of $self->{'filename'}: $!\n"); return; }; @{$self}{ qw( start_page start_free_list total_pages key_length index_options index_signature key_string for_expression ) } = unpack 'VVVv CC a220 a276', $header; $self->{'key_record_length'} = $self->{'key_length'} + 4; $self->{'key_string'} =~ s/[\000 ].*$//s; $self->{'record_len'} = 512; $self->{'start_page'} /= $self->{'record_len'}; $self->{'start_free_list'} /= $self->{'record_len'}; $self->{'header_len'} = 0; if ($opts{'type'} eq 'N') { $self->{'key_type'} = 1; } $self; } sub last_record { shift->{'total_pages'}; } sub create { my ($class, $table, $filename, $column) = @_; my $type = $table->field_type($column); if (not defined $type) { die "XBase::idx: could determine index type for `$column'\n"; } my $numdate = 0; $numdate = 1 if $type eq 'N' or $type eq 'D'; my $self = bless {}, $class; $self->create_file($filename) or die "Error creating `$filename'\n"; $self->write_to(0, "\000" x 512); my $key_length = $table->field_length($column); $key_length = 8 if $numdate; my $count = int((512 - 12) / ($key_length + 4)); ### warn "Key length $key_length, per page $count.\n"; my $encode_function; if ($numdate) { $encode_function = sub { my $key = pack 'd', shift; $key = reverse $key unless $XBase::Index::BIGEND; if ((substr($key, 0, 1) & "\200") eq "\200") { $key ^= "\377\377\377\377\377\377\377\377"; } else { $key ^= "\200"; } return $key; }; } else { $encode_function = sub { return sprintf "%-${key_length}s", shift; }; } my @data; my $last_record = $table->last_record; for (my $i = 0; $i <= $last_record; $i++) { my ($deleted, $data) = $table->get_record($i, $column); push @data, [ $encode_function->($data), $i + 1 ]; } @data = sort { $a->[0] cmp $b->[0] } @data; $self->{'header_len'} = 0; # it is 512 really, but we # count from 1, not from 0 $self->{'record_len'} = 512; my $pageno = 1; my $level = 1; my @newdata; while ($level == 1 or @data > 1) { last if $pageno > 5; my $attributes = 0; $attributes = 2 if $level == 1; if (scalar(@data) < $count) { # we have less than one page, so it's root. $attributes++; } my $left_page = 0xFFFFFFFF; my $current_count = 0; my $out = ''; @newdata = (); for (my $i = 0; $i < @data; $i++) { my $key = $data[$i][0]; ### print STDERR "Page $pageno: $i: @{$data[$i]}\n"; $out .= pack "a$key_length N", $key, $data[$i][1]; $current_count++; if ($current_count == $count or $i == $#data) { ### print STDERR "Dumping $pageno.\n"; # time to close this page and move on my $right_page = 0xFFFFFFFF; if ($i < $#data) { $right_page = $pageno + 1; } $self->write_record($pageno, pack 'a512', pack('vvVV', $attributes, $current_count, $left_page, $right_page) . $out); push @newdata, [$data[$i][0], $pageno * 512]; $left_page = $pageno; $current_count = 0; $pageno++; $out = ''; } } @data = @newdata; $level++; } my $header = pack 'VVVv CC a220 a276', ($pageno - 1) * 512, 0xFFFFFFFF, $pageno * 512, $key_length, 0, 0, $column, ''; $self->write_to(0, $header); $self->close; return new XBase::Index($filename, 'type' => $type); } package XBase::idx::Page; use strict; use vars qw( @ISA $DEBUG ); @ISA = qw( XBase::idx ); *DEBUG = \$XBase::Index::DEBUG; ### $DEBUG = 1; # Constructor for the idx page sub new { local $^W = 0; my ($indexfile, $num) = @_; my $parent; # we can be called from parent page if ((ref $indexfile) =~ /::Page$/) { $parent = $indexfile; $indexfile = $parent->{'indexfile'}; } my $data = $indexfile->read_record($num) or return; # get 512 bytes my ($attributes, $noentries, $left_brother, $right_brother) = unpack 'vvVV', $data; # parse header of the page my $keylength = $indexfile->{'key_length'}; my $keyreclength = $indexfile->{'key_record_length'}; # length print "page $num, noentries $noentries, keylength $keylength\n" if $DEBUG; my $numdate = $indexfile->{'key_type'}; # numeric or string? my $offset = 12; my $i = 0; my ($keys, $values, $lefts) = ([], [], []); # three arrays # walk the page while ($i < $noentries) { # get the values for entry my ($key, $recno) = unpack "\@$offset a$keylength N", $data; my $left; unless ($attributes & 2) { $left = $recno / 512; $recno = undef; } print "$i: \@$offset a$keylength N -> ($left, $recno, $key)\n" if $DEBUG > 1; ### use Data::Dumper; print Dumper $indexfile; # some decoding for numbers if ($numdate) { if ((substr($key, 0, 1) & "\200") ne "\200") { $key ^= "\377\377\377\377\377\377\377\377"; } else { $key ^= "\200"; } if (not $XBase::Index::BIGEND) { $key = reverse $key; } $key = unpack 'd', $key; } print "$i: \@$offset a$keylength N -> ($left, $recno, $key)\n" if $DEBUG > 1; push @$keys, $key; push @$values, ($recno ? $recno : undef); $left = ($left ? $left : undef); push @$lefts, $left; if ($i == 0 and defined $left) { $noentries++; } # fixup for nonleaf page ### shouldn't this be for last page only? } continue { $i++; $offset += $keyreclength; } my $self = bless { 'keys' => $keys, 'values' => $values, 'num' => $num, 'keylength' => $keylength, 'lefts' => $lefts, 'indexfile' => $indexfile, 'attributes' => $attributes, 'left_brother' => $left_brother, 'right_brother' => $right_brother }, __PACKAGE__; $self; } # ############ # dBase IV MDX package XBase::mdx; use strict; use vars qw( @ISA $DEBUG ); @ISA = qw( XBase::Base XBase::Index ); sub read_header { my $self = shift; my %opts = @_; my $expr_name = $opts{'tag'}; my $header; $self->{'dbf'} = $opts{'dbf'}; $self->{'fh'}->read($header, 544) == 544 or do { __PACKAGE__->Error("Error reading header of $self->{'filename'}: $!\n"); return; }; @{$self}{ qw( version created dbf_filename block_size block_size_adder production noentries tag_length res tags_used res nopages first_free noavail last_update ) } = unpack 'Ca3A16vvccccvvVVVa3', $header; $self->{'record_len'} = 512; $self->{'header_len'} = 0; for my $i (1 .. $self->{'tags_used'}) { my $len = $self->{'tag_length'}; $self->seek_to(544 + ($i - 1) * $len) or do { __PACKAGE__->Error($self->errstr); return; }; $self->{'fh'}->read($header, $len) == $len or do { __PACKAGE__->Error("Error reading tag header $i in $self->{'filename'}: $!\n"); return; }; my $tag; @{$tag}{ qw( header_page tag_name key_format fwd_low fwd_high backward res key_type ) } = unpack 'VA11ccccca1', $header; $self->{'tags'}{$tag->{'tag_name'}} = $tag; $expr_name ||= $tag->{'tag_name'}; # Default to first tag $self->seek_to($tag->{'header_page'} * 512) or do { __PACKAGE__->Error($self->errstr); return; }; $self->{'fh'}->read($header, 24) == 24 or do { __PACKAGE__->Error("Error reading tag definition in $self->{'filename'}: $!\n"); return; }; @{$tag}{ qw( start_page file_size key_format_1 key_type_1 res key_length max_no_keys_per_page second_key_type key_record_length res unique) } = unpack 'VVca1vvvvva3c', $header; } ### use Data::Dumper; print Dumper $self; if (defined $expr_name) { if (defined $self->{'tags'}{$expr_name}) { $self->{'active'} = $self->{'tags'}{$expr_name}; $self->{'start_page'} = $self->{'active'}{'start_page'}; } else { __PACKAGE__->Error("No tag $expr_name found in index file $self->{'filename'}.\n"); return; } } $self; } sub last_record { -1; } sub tags { my $self = shift; return sort keys %{$self->{'tags'}} if defined $self->{'tags'}; } package XBase::mdx::Page; use strict; use vars qw( @ISA $DEBUG ); @ISA = qw( XBase::mdx ); *DEBUG = \$XBase::Index::DEBUG; # Constructor for the mdx page sub new { my ($indexfile, $num) = @_; my $parent; ### parent page if ((ref $indexfile) =~ /::Page$/) { $parent = $indexfile; $indexfile = $parent->{'indexfile'}; } $indexfile->seek_to_record($num) or return; my $data; $indexfile->{'fh'}->read($data, 1024) == 1024 or return; my $keylength = $indexfile->{'active'}{'key_length'}; my $keyreclength = $indexfile->{'active'}{'key_record_length'}; my $offset = 8; my ($noentries, $noleaf) = unpack 'VV', $data; print "page $num, noentries $noentries, keylength $keylength; noleaf: $noleaf\n" if $DEBUG; my ($keys, $values, $lefts, $refs) = ([], [], [], []); for (my $i = 0; $i < $noentries; $i++) { my ($left, $key) = unpack "\@${offset}Va${keylength}", $data; push @$keys, $key; push @$refs, $left; $offset += $keyreclength; } my $right; $right = unpack "\@${offset}V", $data if $offset <= (1024-4); if ($right) { # It's a branch page and the next ref is for values > last key push @$keys, ""; push @$refs, $right; $lefts = $refs; } else { # It's a leaf page $values = $refs; } my $self = bless { 'num' => $num, 'indexfile' => $indexfile, 'keys' => $keys, 'values' => $values, 'lefts' => $lefts, }, __PACKAGE__; $self; } # ########### # FoxBase CDX package XBase::cdx; use strict; use vars qw( @ISA $DEBUG ); @ISA = qw( XBase::Base XBase::Index ); *DEBUG = \$XBase::Index::DEBUG; sub prepare_write_header { my $self = shift; my $data = pack 'VVNv CC @502 vvv @510 v @512 a512', $self->{'start_page'} * 512, $self->{'start_free_list'} * 512, @{$self}{ qw( total_pages key_length index_options index_signature sort_order total_expr_length for_expression_length key_expression_length key_string ) }; $data; } sub write_header { my $self = shift; my $data = $self->prepare_write_header; $self->{'fh'}->seek($self->{'adjusted_offset'} || 0, 0); $self->{'fh'}->print($data); } sub read_header { my ($self, %opts) = @_; $self->{'dbf'} = $opts{'dbf'} if not exists $self->{'dbf'}; my $header; $self->{'fh'}->read($header, 1024) == 1024 or do { __PACKAGE__->Error("Error reading header of $self->{'filename'}: $!\n"); return; }; @{$self}{ qw( start_page start_free_list total_pages key_length index_options index_signature sort_order total_expr_length for_expression_length key_expression_length key_string ) } = unpack 'VVNv CC @502 vvv @510 v @512 a512', $header; $self->{'total_pages'} = -1; ### the total_pages value 11 ### that found in rooms.cdx is not correct, so we invalidate it ($self->{'key_string'}, $self->{'for_string'}) = ($self->{'key_string'} =~ /^([^\000]*)\000([^\000]*)/); $self->{'key_record_length'} = $self->{'key_length'} + 4; $self->{'record_len'} = 512; $self->{'start_page'} /= $self->{'record_len'}; $self->{'start_free_list'} /= $self->{'record_len'}; $self->{'header_len'} = 0; $self->{'key_type'} = 0; ## my $out = $self->prepare_write_header; ## if ($out ne $header) { ## print STDERR "I won't be able to write the header back\n", ## unpack("H*", $out), "\n ++\n", ## unpack("H*", $header), "\n"; ## } if (not defined $self->{'tag'}) { # top level $self->prepare_select; while (my ($tag) = $self->fetch) { push @{$self->{'tags'}}, $tag; $opts{'tag'} ||= $tag; # Default to first tag } } ### use Data::Dumper; print Dumper \%opts; if (defined $opts{'tag'}) { $self->prepare_select_eq($opts{'tag'}); my ($foundkey, $value) = $self->fetch; if (not defined $foundkey or $opts{'tag'} ne $foundkey) { __PACKAGE__->Error("No tag $opts{'tag'} found in index file $self->{'filename'}.\n"); return; }; my $subidx = bless { %$self }, ref $self; print "Adjusting start_page value by $value for $opts{'tag'}\n" if $DEBUG; $subidx->{'fh'}->seek($value, 0); $subidx->{'adjusted_offset'} = $value; $subidx->{'tag'} = $opts{'tag'}; $subidx->read_header; my $key_string = $subidx->{'key_string'}; my $field_type; if (defined $opts{'type'}) { $field_type = $opts{'type'}; } elsif (defined $subidx->{'dbf'}) { $field_type = $subidx->{'dbf'}->field_type($key_string); if (not defined $field_type) { __PACKAGE__->Error("Couldn't find key string `$key_string' in dbf file, can't determine field type\n"); return; } } else { __PACKAGE__->Error("Index type (char/numeric) unknown for $subidx\n"); return; } $subidx->{'key_type'} = ($field_type =~ /^[NDIF]$/ ? 1 : 0); if ($field_type eq 'D') { $subidx->{'key_type'} = 2; require Time::JulianDay; } for (keys %$self) { delete $self->{$_} } for (keys %$subidx) { $self->{$_} = $subidx->{$_} } $self = $subidx; ### use Data::Dumper; print Dumper $self; } $self; } sub last_record { shift->{'total_pages'}; } package XBase::cdx::Page; use strict; use vars qw( @ISA $DEBUG ); @ISA = qw( XBase::cdx ); *DEBUG = \$XBase::Index::DEBUG; # Constructor for the cdx page sub new { my ($indexfile, $num) = @_; my $data = $indexfile->read_record($num) or do { print $indexfile->errstr; return; }; # get 512 bytes my $origdata = $data; my ($attributes, $noentries, $left_brother, $right_brother) = unpack 'vvVV', $data; # parse header of the page my $keylength = $indexfile->{'key_length'}; my $keyreclength = $indexfile->{'key_record_length'}; # length print "page $num, attr $attributes, noentries $noentries, keylength $keylength (bro $left_brother, $right_brother)\n" if $DEBUG; my $numdate = $indexfile->{'key_type'}; # numeric or string? my ($keys, $values, $lefts) = ([], [], undef); my %opts = (); if ($attributes & 2) { print "leaf page, compressed\n" if $DEBUG; my ($free_space, $recno_mask, $duplicate_count_mask, $trailing_count_mask, $recno_count, $duplicate_count, $trailing_count, $holding_recno) = unpack '@12 vVCCCCCC', $data; print '$free_space, $recno_mask, $duplicate_count_mask, $trailing_count_mask, $recno_count, $duplicate_count, $trailing_count, $holding_recno) = ', "$free_space, $recno_mask, $duplicate_count_mask, $trailing_count_mask, $recno_count, $duplicate_count, $trailing_count, $holding_recno)\n" if $DEBUG > 2; @opts{ qw! recno_count duplicate_count trailing_count holding_recno ! } = ( $recno_count, $duplicate_count, $trailing_count, $holding_recno); my $prevkeyval = ''; for (my $i = 0; $i < $noentries; $i++) { my $one_item = substr($data, 24 + $i * $holding_recno, $holding_recno) . "\0" x 4; my $numeric_one_item = unpack 'V', $one_item; print "one_item: 0x", unpack('H*', $one_item), " ($numeric_one_item)\n" if $DEBUG > 3; my $recno = $numeric_one_item & $recno_mask; my $bytes_of_recno = int($recno_count / 8); $one_item = substr($one_item, $bytes_of_recno); $numeric_one_item = unpack 'V', $one_item; $numeric_one_item >>= $recno_count - (8 * $bytes_of_recno); my $dupl = $numeric_one_item & $duplicate_count_mask; $numeric_one_item >>= $duplicate_count; my $trail = $numeric_one_item & $trailing_count_mask; ### $numeric_one_item >>= $trailing_count; print "Item $i: trail $trail, dupl $dupl, recno $recno\n" if $DEBUG > 6; my $getlength = $keylength - $trail - $dupl; my $key = substr($prevkeyval, 0, $dupl); $key .= substr($data, -$getlength) if $getlength; $key .= "\000" x $trail; substr($data, -$getlength) = '' if $getlength; $prevkeyval = $key; ### print "Numdate $numdate\n"; if ($numdate) { # some decoding for numbers ### print " *** In: ", unpack("H*", $key), "\n"; if (0x80 & unpack('C', $key)) { substr($key, 0, 1) &= "\177"; } else { $key = ~$key; } if ($keylength == 8) { $key = reverse $key unless $XBase::Index::BIGEND; $key = unpack 'd', $key; } else { $key = unpack 'N', $key; } if ($numdate == 2 and $key) { # date $key = sprintf "%04d%02d%02d", Time::JulianDay::inverse_julian_day($key); } } else { substr($key, -$trail) = '' if $trail; } print "$key -> $recno\n" if $DEBUG > 4; push @$keys, $key; push @$values, $recno; } } else { for (my $i = 0; $i < $noentries; $i++) { my $offset = 12 + $i * ($keylength + 8); my ($key, $recno, $page) = unpack "\@$offset a$keylength NN", $data; # some decoding for numbers if ($numdate) { if (0x80 & unpack('C', $key)) { ### if ("\200" & substr($key, 0, 1)) { ### print STDERR "Declean\n"; ### print STDERR unpack("H*", $key), ' -> '; substr($key, 0, 1) &= "\177"; ### print STDERR unpack("H*", $key), "\n"; } else { $key = ~$key; } if ($keylength == 8) { $key = reverse $key unless $XBase::Index::BIGEND; $key = unpack 'd', $key; } else { $key = unpack 'N', $key; } if ($numdate == 2 and $key) { # date $key = sprintf "%04d%02d%02d", Time::JulianDay::inverse_julian_day($key); } } else { $key =~ s/\000+$//; } print "item: $key -> $recno via $page\n" if $DEBUG > 4; push @$keys, $key; push @$values, $recno; $lefts = [] unless defined $lefts; push @$lefts, $page / 512; } $opts{'last_key_is_just_overflow'} = 1; } my $self = bless { 'keys' => $keys, 'values' => $values, 'num' => $num, 'keylength' => $keylength, 'lefts' => $lefts, 'indexfile' => $indexfile, 'attributes' => $attributes, 'left_brother' => $left_brother, 'right_brother' => $right_brother, %opts, }, __PACKAGE__; my $outdata = $self->prepare_scalar_for_write; if (0 and $outdata ne $origdata) { print "I won't be able to write this page back.\n", unpack("H*", $outdata), "\n ++\n", unpack("H*", $origdata), "\n"; } else { ### print STDERR " ** Bingo: I will be able to write this page back ($num).\n"; } $self; } # Create "new" page -- allocates memory in the file and returns # structure that can reasonably used as XBase::cdx::Page sub create { my ($class, $indexfile) = @_; if (not defined $indexfile and ref $class) { $indexfile = $class->{'indexfile'}; } my $fh = $indexfile->{'fh'}; $fh->seek(0, 2); # seek to the end; my $position = $fh->tell; # get the length of the file if ($position % 512) { $fh->print("\000" x (512 - ($position % 512))); # pad the file to multiply of 512 $position = $fh->tell; # get the length of the file } $fh->print("\000" x 512); return bless { 'num' => $position / 512, 'keylength' => $indexfile->{'key_length'}, 'indexfile' => $indexfile }, $class; } sub prepare_scalar_for_write { my $self = shift; my ($attributes, $noentries, $left_brother, $right_brother) = ($self->{'attributes'}, scalar(@{$self->{'keys'}}), $self->{'left_brother'}, $self->{'right_brother'}); my $data = pack 'vvVV', $attributes, $noentries, $left_brother, $right_brother; my $indexfile = $self->{'indexfile'}; my $numdate = $indexfile->{'key_type'}; # numeric or string? my $record_len = $indexfile->{'record_len'}; my $keylength = $self->{'keylength'}; if ($attributes & 2) { my ($recno_count, $duplicate_count, $trailing_count, $holding_recno) = (16, 4, 4, 3); if (defined $self->{'recno_count'}) { ($recno_count, $duplicate_count, $trailing_count, $holding_recno) = @{$self}{ qw! recno_count duplicate_count trailing_count holding_recno ! }; } ### print STDERR "Hmmm. We are setting hardcoded values for bitmasks, not good. Write to adelton.\n"; my ($recno_mask, $duplicate_mask, $trailing_mask) = ( 2**$recno_count - 1, 2**$duplicate_count - 1, 2**$trailing_count - 1); my $recno_data = ''; my $keys_string = ''; my $prevkey = ''; my $row = 0; for my $key (@{$self->{'keys'}}) { my $dupl = 0; my $out = $key; # some encoding for numbers if ($numdate) { if ($keylength == 8) { $out = pack 'd', $out; $out = reverse $out unless $XBase::Index::BIGEND; } else { $out = pack 'N', $out; } unless (0x80 & unpack('C', $out)) { substr($out, 0, 1) |= "\200"; } else { $out = ~$out; } } for my $i (0 .. length($out) - 1) { unless (substr($out, $i, 1) eq substr($prevkey, $i, 1)) { last; } $dupl++; } my $trail = $keylength - length $out; while (substr($out, -1) eq "\000") { $out = substr($out, 0, length($out) - 1); $trail++; } $keys_string = substr($out, $dupl) . $keys_string; my $numdata = (((($trail & $trailing_mask) << $duplicate_count) | ($dupl & $duplicate_mask)) << $recno_count) | ($self->{'values'}[$row] & $recno_mask); $recno_data .= substr(pack('V', $numdata), 0, $holding_recno); ### print unpack("H*", substr($out, $dupl)), ": trail $trail, dupl $dupl\n"; $prevkey = $out; $row++; } ### print $keys_string, "\n"; ### print STDERR "Hmmm. The \$numdata is really just a hack -- the shifts have to be made 64 bit clean.\n"; $data .= pack 'vVCCCCCC', ($record_len - length($recno_data) - length($keys_string) - 24), $recno_mask, $duplicate_mask, $trailing_mask, $recno_count, $duplicate_count, $trailing_count, $holding_recno; $data .= $recno_data; $data .= "\000" x ($record_len - length($data) - length($keys_string)); $data .= $keys_string; } else { my $row = 0; for my $key (@{$self->{'keys'}}) { my $out = $key; # some encoding for numbers if ($numdate) { if ($keylength == 8) { $out = pack 'd', $out; $out = reverse $out unless $XBase::Index::BIGEND; } else { $out = pack 'N', $out; } unless (0x80 & unpack('C', $out)) { substr($out, 0, 1) |= "\200"; } else { $out = ~$out; } ### print " *** Out2: ", unpack("H*", $out), "\n"; } $data .= pack "a$keylength NN", $out, $self->{'values'}[$row], $self->{'lefts'}[$row] * 512; $row++; } $data .= "\000" x ($record_len - length($data)); } $data; } sub write_page { my $self = shift; my $indexfile = $self->{'indexfile'}; my $data = $self->prepare_scalar_for_write; die "Data is too long in cdx::write_page for $self->{'num'}\n" if length $data > 512; $indexfile->write_record($self->{'num'}, $data); } # Saves current page, taking into account all neighbour and parent # pages. We can safely assume that this method is called for pages # that have been loaded using prepare_select_eq and fetch, so they # have the parent pointers set correctly. sub write_with_context { my $self = shift; # page to save print STDERR "XBase::cdx::Page::write_with_context called ($self->{'num'})\n" if $DEBUG; my $indexfile = $self->{'indexfile'}; my $self_num = $self->{'num'}; # get the current page as data to be written my $data = $self->prepare_scalar_for_write; if (not @{$self->{'keys'}}) { $indexfile->write_record($self_num, $data); # empty root page means no more work, just save return if $self_num == $indexfile->{'start_page'}; print STDERR "The page $self_num is empty, releasing from the chain\n"; # first we update the brothers my $right_brother_num = $self->{'right_brother'}; my $left_brother_num = $self->{'left_brother'}; if ($right_brother_num != 0xFFFFFFFF) { my $fix_brother = $indexfile->get_record($right_brother_num / 512); $fix_brother->{'left_brother'} = $left_brother_num; $fix_brother->write_page; } if ($left_brother_num != 0xFFFFFFFF) { my $fix_brother = $indexfile->get_record($left_brother_num / 512); $fix_brother->{'right_brother'} = $right_brother_num; $fix_brother->write_page; } # now we need to release ourselves from parent as well my $parent = $self->get_parent_page or die "Index corrupt: no parent for page $self ($self_num)\n"; my $maxindex = $#{$parent->{'lefts'}}; my $i; for ($i = 0; $i <= $maxindex; $i++) { if ($parent->{'lefts'}[$i] == $self_num) { splice @{$parent->{'keys'}}, $i, 1; splice @{$parent->{'values'}}, $i, 1; splice @{$parent->{'lefts'}}, $i, 1; last; } } if ($i > $maxindex) { die "Index corrupt: parent doesn't point to us in write_with_context $self ($self_num)\n"; } $parent->write_with_context; return; } if (length $data > 512) { # we need to split the page print STDERR "Splitting full page $self ($self_num)\n"; # create will give us brand new empty page my $new_page = __PACKAGE__->create($indexfile); $self->{'attributes'} &= 0xfffe; $new_page->{'attributes'} = $self->{'attributes'}; my $total_rows = scalar(@{$self->{'keys'}}); my $half_rows = int($total_rows / 2); # primary split if ($half_rows == 0) { $half_rows++; } if ($half_rows == $total_rows) { die "Fatal trouble: page $self ($self_num) is full but I'm not able to split it\n"; } # new page is right brother (will get bigger values) $new_page->{'right_brother'} = $self->{'right_brother'}; $new_page->{'left_brother'} = $self_num * 512; $self->{'right_brother'} = $new_page->{'num'} * 512; if ($new_page->{'right_brother'} != 0xFFFFFFFF) { my $fix_brother = $indexfile->get_record($new_page->{'right_brother'} / 512); $fix_brother->{'left_brother'} = $new_page->{'num'} * 512; $fix_brother->write_page; } # we'll split keys and values $new_page->{'keys'} = [ @{$self->{'keys'}}[$half_rows .. $total_rows - 1] ]; splice @{$self->{'keys'}}, $half_rows, $total_rows - $half_rows; $new_page->{'values'} = [ @{$self->{'values'}}[$half_rows .. $total_rows - 1] ]; splice @{$self->{'values'}}, $half_rows, $total_rows - $half_rows; # and we'll split pointers to lower levels, if there are any if (defined $self->{'lefts'}) { $new_page->{'lefts'} = [ @{$self->{'lefts'}}[$half_rows .. $total_rows - 1] ]; my $new_page_num = $new_page->{'num'}; for my $q (@{$new_page->{'lefts'}}) { if (defined $q and defined $indexfile->{'pages_cache'}{$q}) { $indexfile->{'pages_cache'}{$q}{'parent'} = $new_page_num; } } splice @{$self->{'lefts'}}, $half_rows, $total_rows - $half_rows - 1; } my $parent; if ($self_num == $indexfile->{'start_page'}) { # we're splitting the root page, so we will # create new one $parent = __PACKAGE__->create($indexfile); $indexfile->{'start_page'} = $parent->{'num'}; $indexfile->write_header; ### xxxxxxxxxxxxxxxxxxx ### And here we should write the header so that ### the new root page is saved to disk. Not ### tested yet. ### xxxxxxxxxxxxxxxxxxx $parent->{'attributes'} = 1; # root page $parent->{'keys'} = [ $self->{'keys'}[-1], $new_page->{'keys'}[-1] ]; $parent->{'values'} = [ $self->{'values'}[-1], $new_page->{'values'}[-1] ]; $parent->{'lefts'} = [ $self_num, $new_page->{'num'} ]; } else { # update pointers in parent page $parent = $self->get_parent_page or die "Index corrupt: no parent for page $self ($self_num)\n"; my $maxindex = $#{$parent->{'lefts'}}; my $i = 0; # find pointer to ourselves in the parent while ($i <= $maxindex) { last if $parent->{'lefts'}[$i] == $self_num; $i++; } if ($i > $maxindex) { die "Index corrupt: parent doesn't point to us in write_with_context $self ($self_num)\n"; } # now $i is index in parent of the record pointing to us splice @{$parent->{'keys'}}, $i, 1, $self->{'keys'}[-1], $new_page->{'keys'}[-1]; splice @{$parent->{'values'}}, $i, 1, $self->{'values'}[-1], $new_page->{'values'}[-1]; splice @{$parent->{'lefts'}}, $i, 1, $self_num, $new_page->{'num'}; } $self->write_page; $new_page->{'parent'} = $self->{'parent'}; $new_page->write_page; $parent->write_with_context; } elsif ($self_num != $indexfile->{'start_page'}) { # the output data is OK, write is out # but this is not root page, so we need to make sure the # parent is updated as well $indexfile->write_record($self_num, $data); # now we need to check if the parent page still points # correctly to us (the last value might have changed) my $parent = $self->get_parent_page or die "Index corrupt: no parent for page $self ($self_num)\n"; my $maxindex = $#{$parent->{'lefts'}}; my $i = 0; # find pointer to ourselves in the parent while ($i <= $maxindex) { last if $parent->{'lefts'}[$i] == $self_num; $i++; } if ($i > $maxindex) { die "Index corrupt: parent doesn't point to us in write_with_context $self ($self_num)\n"; } # now $i is index in parent of the record pointing to us if ($parent->{'values'}[$i] != $self->{'values'}[-1]) { print STDERR "Will need to update the parent -- last value in myself changed ($self_num)\n"; $parent->{'values'}[$i] = $self->{'values'}[-1]; $parent->{'keys'}[$i] = $self->{'keys'}[-1]; $parent->write_with_context; } } else { # write out root page $indexfile->write_record($self_num, $data); } print STDERR "XBase::cdx::Page::write_with_context finished ($self->{'num'})\n" if $DEBUG; } # finds parent page for the object sub get_parent_page_num { my $self = shift; return $self->{'parent'} if defined $self->{'parent'}; my $indexfile = $self->{'indexfile'}; return if $self->{'num'} == $indexfile->{'start_page'}; # this should search to this page, effectivelly setting the # level array in such a way that the parent page is there $indexfile->prepare_select_eq($self->{'keys'}[0], $self->{'values'}[0]); ### print STDERR "self($self->{'num'}): $self, pages: @{$indexfile->{'pages'}}\n"; ### use Data::Dumper; print Dumper $indexfile; my $pageindex = $#{$indexfile->{'pages'}}; while ($pageindex >= 0) { if ("$self" eq "$indexfile->{'pages'}[$pageindex]") { print STDERR "Parent page for $self->{'num'} is $indexfile->{'pages'}[$pageindex - 1]{'num'}.\n"; return $indexfile->{'pages'}[$pageindex - 1]->{'num'}; } $pageindex--; } return undef; } sub get_parent_page { my $self = shift; my $parent_num = $self->get_parent_page_num or return; my $indexfile = $self->{'indexfile'}; return $indexfile->get_record($parent_num); } 1; __END__ =head1 SYNOPSIS use XBase; my $table = new XBase "data.dbf"; my $cur = $table->prepare_select_with_index("id.ndx", "ID", "NAME); $cur->find_eq(1097); while (my @data = $cur->fetch()) { last if $data[0] != 1097; print "@data\n"; } This is a snippet of code to print ID and NAME fields from dbf data.dbf where ID equals 1097. Provided you have index on ID in file id.ndx. You can use the same code for ntx and idx index files. For the cdx and mdx, the prepare_select call would be prepare_select_with_index(['rooms.cdx', 'ROOMNAME']) so instead of plain filename you specify an arrayref with filename and an index tag in that file. The reason is that cdx and mdx can contain multiple indexes in one file and you have to distinguish, which you want to use. =head1 DESCRIPTION The module XBase::Index is a collection of packages to provide index support for XBase-like dbf database files. An index file is generaly a file that holds values of certain database field or expression in sorted order, together with the record number that the record occupies in the dbf file. So when you search for a record with some value, you first search in this sorted list and once you have the record number in the dbf, you directly fetch the record from dbf. =head2 What indexes do To make the searching in this ordered list fast, it's generally organized as a tree -- it starts with a root page with records that point to pages at lower level, etc., until leaf pages where the pointer is no longer a pointer to the index but to the dbf. When you search for a record in the index file, you fetch the root page and scan it (lineary) until you find key value that is equal or grater than that you are looking for. That way you've avoided reading all pages describing the values that are lower. Here you descend one level, fetch the page and again search the list of keys in that page. And you repeat this process until you get to the leaf (lowest) level and here you finaly find a pointer to the dbf. XBase::Index does this for you. Some of the formats also support multiple indexes in one file -- usually there is one top level index that for different field values points to different root pages in the index file (so called tags). XBase::Index supports (or aims to support) the following index formats: ndx, ntx, mdx, cdx and idx. They differ in a way they store the keys and pointers but the idea is always the same: make a tree of pages, where the page contains keys and pointer either to pages at lower levels, or to dbf (or both). XBase::Index only supports read only access to the index fields at the moment (and if you need writing them as well, follow reading because we need to have the reading support stable before I get to work on updating the indexes). =head2 Testing your index file (and XBase::Index) You can test your index using the indexdump script in the main directory of the DBD::XBase distribution (I mean test XBase::Index on correct index data, not testing corrupted index file, of course ;-) Just run ./indexdump ~/path/index.ndx ./indexdump ~/path/index.cdx tag_name or perl -Ilib ./indexdump ~/path/index.cdx tag_name if you haven't installed this version of XBase.pm/DBD::XBase yet. You should get the content of the index file. On each row, there is the key value and a record number of the record in the dbf file. Let me know if you get results different from those you expect. I'd probably ask you to send me the index file (and possibly the dbf file as well), so that I can debug the problem. The index file is (as already noted) a complement to a dbf file. Index file without a dbf doesn't make much sense because the only thing that you can get from it is the record number in the dbf file, not the actual data. But it makes sense to test -- dump the content of the index to see if the sequence is OK. The index formats usually distinguish between numeric and character data. Some of the file formats include the information about the type in the index file, other depend on the dbf file. Since with indexdump we only look at the index file, you may need to specify the -type option to indexdump if it complains that it doesn't know the data type of the values (this is the case with cdx at least). The possible values are num, char and date and the call would be like ./indexdump -type=num ~/path/index.cdx tag_name (this -type option may not work with all index formats at the moment -- will be fixed and patches always welcome). You can use C<-ddebug> option to indexdump to see how pages are fetched and decoded, or run debugger to see the calls and parsing. =head2 Using the index files to speed up searches in dbf The syntax for using the index files to access data in the dbf file is generally my $table = new XBase "tablename"; # or any other arguments to get the XBase object # see XBase(3) my $cur = $table->prepare_select_with_index("indexfile", "list", "of", "fields", "to", "return"); or my $cur = $table->prepare_select_with_index( [ "indexfile_with_tags", "tag_name" ], "list", "of", "fields", "to", "return"); where we specify the tag in the index file (this is necessary with cdx and mdx). After we have the cursor, we can search to given record and start fetching the data: $cur->find_eq('jezek'); while (my @data = $cur->fetch) { # do something =head2 Supported index formats The following table summarizes which formats are supproted by XBase::Index. If the field says something else that Yes, I welcome testers and offers of example index files. Reading of index files -- types supported by XBase::Index type string numeric date ---------------------------------------------------------- ndx Yes Yes Yes (you need to convert to Julian) ntx Yes Yes Untested idx Untested Untested Untested (but should be pretty usable) mdx Untested Untested Untested cdx Yes Yes Untested Writing of index files -- not supported untill the reading is stable enough. So if you have access to an index file that is untested or unsupported and you care about support of these formats, contact me. If you are able to actually generate those files on request, the better because I may need specific file size or type to check something. If the file format you work with is supported, I still appreciate a report that it really works for you. B that there is very little documentation about the file formats and the work on XBase::Index is heavilly based on making assumption based on real life data. Also, the documentation is often wrong or only describing some format variations but not the others. I personally do not need the index support but am more than happy to make it a reality for you. So I need your help -- contact me if it doesn't work for you and offer me your files for testing. Mentioning word XBase somewhere in the Subject line will get you (hopefully ;-) fast response. Mentioning work Help or similar stupidity will probably make my filters to consider your email as spam. Help yourself by making my life easier in helping you. =head2 Programmer's notes Programmers might find the following information usefull when trying to debug XBase::Index from their files: The XBase::Index module contains the basic XBase::Index package and also packages XBase::ndx, XBase::ntx, XBase::idx, XBase::mdx and XBase::cdx, and for each of these also a package XBase::index_type::Page. Reading the file goes like this: you create as object calling either new XBase::Index or new XBase::ndx (or whatever the index type is). This can also be done behind the scenes, for example XBase::prepare_select_with_index calls new XBase::Index. The index file is opened using the XBase::Base::new/open and then the XBase::index_type::read_header is called. This function fills the basic data fields of the object from the header of the file. The new method returns the object corresponding to the index type. Then you probably want to do $index->prepare_select or $index->prepare_select_eq, that would possition you just before record equal or greater than the parameter (record in the index file, that is). Then you do a series of fetch'es that return next pair of (key, pointer_to_dbf). Behind the scenes, prepare_select_eq or fetch call XBase::Index::get_record which in turn calls XBase::index_type::Page::new. From the index file perspective, the atomic item in the file is one index page (or block, or whatever you call it). The XBase::index_type::Page::new reads the block of data from the file and parses the information in the page -- pages have more or less complex structures. Page::new fills the structure, so that the fetch calls can easily check what values are in the page. For some examples, please see eg/use_index in the distribution directory. =head1 VERSION 1.05 =head1 AVAILABLE FROM http://www.adelton.com/perl/DBD-XBase/ =head1 AUTHOR (c) 1998--2013 Jan Pazdziora. =head1 SEE ALSO XBase(3), XBase::FAQ(3) =cut DBD-XBase-1.08/lib/XBase/SQL.pm0000644000175000017500000005022112712070132015431 0ustar adeltonadelton # #################### # Parsing SQL commands package XBase::SQL::Expr; package XBase::SQL; use strict; use vars qw( $VERSION %COMMANDS ); $VERSION = '1.06'; # ################################# # Type conversions for create table my %TYPES = ( 'char' => 'C', 'varchar' => 'C', 'num' => 'N', 'numeric' => 'N', 'int' => 'N', 'decimal' => 'N', 'integer' => 'N', 'float' => 'F', 'boolean' => 'L', 'blob' => 'M', 'memo' => 'M', 'date' => 'D', 'time' => 'T', 'datetime' => 'T', 'money' => 'Y' ); # ################## # Regexp definitions %COMMANDS = ( # Top level SQL commands 'COMMANDS' => ' ( SELECT | INSERT | DELETE | UPDATE | CREATE | DROP ) [\\s|;]* ', 'SELECT' => 'select ( SELECTALL | SELECTFIELDS ) from TABLE WHERE ? ORDERBY ?', 'INSERT' => 'insert into TABLE ( \( INSERTFIELDS \) ) ? values \( INSERTCONSTANTS \)', 'DELETE' => 'delete from TABLE WHERE ?', 'UPDATE' => 'update TABLE set SETCOLUMNS WHERE ?', 'CREATE' => 'create table TABLE \( COLUMNDEF ( , COLUMNDEF ) * \)', 'DROP' => 'drop table TABLE', # select fields 'SELECTFIELDS' => 'SELECTFIELD ( , SELECTFIELD ) *', 'SELECTFIELD' => 'SELECTEXPFIELD ( as ? FIELDNAMENOTFROM SELECTFIELDNAME ) ? ', 'SELECTALL' => q'\*', 'SELECTEXPFIELD' => 'ARITHMETIC', 'FIELDNAMENOTFROM' => '(?!from)(?=\w)|(?=from\s+from\b)', 'SELECTFIELDNAME' => 'STRING | [a-z_][a-z0-9_]*', # insert definitions 'INSERTFIELDS' => 'INSERTFIELDNAME ( , INSERTFIELDNAME ) *', 'INSERTFIELDNAME' => 'FIELDNAME', 'INSERTCONSTANTS' => 'CONSTANT ( , CONSTANT ) *', # update definitions 'SETCOLUMNS' => 'SETCOLUMN ( , SETCOLUMN ) *', 'SETCOLUMN' => 'UPDATEFIELDNAME = UPDATEARITHMETIC', 'UPDATEFIELDNAME' => 'FIELDNAME', 'UPDATEARITHMETIC' => 'ARITHMETIC', # create definitions 'COLUMNDEF' => 'COLUMNKEY | COLUMNNAMETYPE ( not null ) ?', 'COLUMNKEY' => 'primary key \( FIELDNAME \)', 'COLUMNNAMETYPE' => 'FIELDNAME FIELDTYPE', 'FIELDTYPE' => 'TYPECHAR | TYPENUM | TYPEBOOLEAN | TYPEMEMO | TYPEDATE | money ', 'TYPECHAR' => ' ( varchar | char ) ( \( TYPELENGTH \) ) ?', 'TYPENUM' => '( num | numeric | decimal | float | int | integer ) ( \( TYPELENGTH ( , TYPEDEC ) ? \) ) ?', 'TYPEDEC' => '\d+', 'TYPELENGTH' => '\d+', 'TYPEBOOLEAN' => 'boolean | logical', 'TYPEMEMO' => 'memo | blob', 'TYPEDATE' => 'date | time | datetime', # table, field name, number, string 'TABLE' => '[^\s\(]+', 'FIELDNAME' => '[a-z_][a-z0-9_.]*', 'NUMBER' => q'-?\d*\.?\d+', 'STRING' => q! \\" STRINGDBL \\" | \\' STRINGSGL \\' !, 'STRINGDBL' => q' STRINGDBLPART ( \\\\. STRINGDBLPART ) * ', 'STRINGSGL' => q' STRINGSGLPART ( \\\\. STRINGSGLPART ) * ', 'STRINGDBLPART' => q' [^\\\\"]* ', 'STRINGSGLPART' => q! [^\\\\']* !, # where clause 'WHERE' => 'where WHEREEXPR', 'WHEREEXPR' => 'BOOLEAN', 'BOOLEAN' => q'not BOOLEAN | ( \( BOOLEAN \) | RELATION ) ( ( AND | OR ) BOOLEAN ) *', 'RELATION' => 'ARITHMETIC ( is not ? null | LIKE CONSTANT_NOT_NULL | RELOP ARITHMETIC )', 'AND' => 'and', 'OR' => 'or', 'RELOP' => [ qw{ == | = | <= | >= | <> | != | < | > } ], 'LIKE' => 'not ? like', 'ARITHMETIC' => [ qw{ ( \( ARITHMETIC \) | CONSTANT | FUNCTION | EXPFIELDNAME ) ( ( \+ | \- | \* | \/ | \% | CONCATENATION ) ARITHMETIC ) ? } ], 'EXPFIELDNAME' => 'FIELDNAME', 'CONCATENATION' => '\|\|', 'CONSTANT' => ' CONSTANT_NOT_NULL | NULL ', 'CONSTANT_NOT_NULL' => ' BINDPARAM | NUMBER | STRING ', 'BINDPARAM' => q'\? | : [a-z0-9]* ', 'NULL' => 'null', 'ARITHMETICLIST' => ' ARITHMETIC ( , ARITHMETICLIST ) * ', 'FUNCTION' => ' FUNCTION1 | FUNCTION23 | FUNCTIONANY ', 'FUNCTION1' => ' ( length | trim | ltrim | rtrim ) \( ARITHMETIC \) ', 'FUNCTION23' => ' ( substr | substring ) \( ARITHMETIC , ARITHMETIC ( , ARITHMETIC ) ? \) ', 'FUNCTIONANY' => ' concat \( ARITHMETICLIST \) ', 'ORDERBY' => 'order by ORDERFIELDNAME ORDERDESC ? ( , ORDERFIELDNAME ORDERDESC ? ) *', 'ORDERDESC' => 'asc | desc', 'ORDERFIELDNAME' => 'FIELDNAME', ); # ##################################### # "Expected" messages for various types my %ERRORS = ( 'COMMANDS' => 'Unknown SQL command', 'TABLE' => 'Table name expected', 'RELATION' => 'Relation expected', 'ARITHMETIC' => 'Arithmetic expression expected', 'from' => 'From specification expected', 'into' => 'Into specification expected', 'values' => 'Values specification expected', '\\(' => 'Left paren expected', '\\)' => 'Right paren expected', '\\*' => 'Star expected', '\\"' => 'Double quote expected', "\\'" => 'Single quote expected', 'STRING' => 'String expected', 'SELECTFIELDS' => 'Columns to select expected', 'FIELDTYPE' => 'Field type expected', ); # ######### # Callbacks to be called after everything is nicely matched my %STORE = ( 'SELECT' => sub { shift->{'command'} = 'select'; }, 'SELECTALL' => sub { my $self = shift; $self->{'selectall'} = '*'; $self->{'selectfn'} = sub { my ($TABLE, $VALUES, $BIND) = @_; map { XBase::SQL::Expr->field($_, $TABLE, $VALUES)->value } $TABLE->field_names; }; undef; }, 'SELECTEXPFIELD' => 'fields', 'SELECTFIELDS' => sub { my $self = shift; my $select_fn = 'sub { my ($TABLE, $VALUES, $BIND) = @_; map { $_->value } (' . join(', ', @{$self->{'fields'}} ) . ')}'; ### print "Selectfn: $select_fn\n"; my $fn = eval $select_fn; if ($@) { $self->{'selecterror'} = $@; } else { $self->{'selectfn'} = $fn; } $self->{'selectfieldscount'} = scalar(@{$self->{'fields'}}); undef; }, 'SELECTFIELDNAME' => sub { my $self = shift; my $fieldnum = @{$self->{'fields'}} - 1; my $name = (get_strings(@_))[0]; $self->{'selectnames'}[$fieldnum] = $name; undef; }, 'INSERT' => sub { shift->{'command'} = 'insert'; }, 'INSERTFIELDNAME' => 'insertfields', 'INSERTCONSTANTS' => sub { my $self = shift; my $insert_fn = 'sub { my ($TABLE, $BIND) = @_; map { $_->value() } ' . join(' ', get_strings(@_)) . ' }'; my $fn = eval $insert_fn; ### print STDERR "Evalling insert_fn: $insert_fn\n"; if ($@) { $self->{'inserterror'} = $@; } else { $self->{'insertfn'} = $fn; } undef; }, 'INSERTFIELDS' => sub { my ($self, @fields) = @_; while (@fields) { push @{$self->{'fields'}}, shift @fields; shift @fields; }}, 'DELETE' => sub { shift->{'command'} = 'delete'; }, 'UPDATE' => sub { shift->{'command'} = 'update'; }, 'UPDATEFIELDNAME' => 'updatefields', 'UPDATEARITHMETIC' => 'updateexprs', 'SETCOLUMNS' => sub { my $self = shift; my $list = join ', ', @{$self->{'updateexprs'}};; my $update_fn = 'sub { my ($TABLE, $VALUES, $BIND) = @_; map { $_->value() } (' . $list . ') }'; my $fn = eval $update_fn; ### print STDERR "Evalling update_fn: $update_fn\n"; if ($@) { $self->{'updateerror'} = $@; } else { $self->{'updatefn'} = $fn; } undef; }, 'CREATE' => sub { shift->{'command'} = 'create'; }, 'COLUMNNAMETYPE' => sub { my $self = shift; my @results = get_strings(@_); push @{$self->{'createfields'}}, $results[0]; push @{$self->{'createtypes'}}, $TYPES{lc $results[1]}; push @{$self->{'createlengths'}}, $results[3]; push @{$self->{'createdecimals'}}, $results[5]; }, 'DROP' => sub { shift->{'command'} = 'drop'; }, 'TABLE' => sub { my $self = shift; my $table = (get_strings(@_))[0]; push @{$self->{'table'}}, $table; $table; }, 'FIELDNAME' => sub { my $self = shift; my $field = uc ((get_strings(@_))[0]); $field =~ s/^.*\.//; push @{$self->{'usedfields'}}, $field; $field; }, 'EXPFIELDNAME' => sub { my $self = shift; my $e = (get_strings(@_))[0]; "XBase::SQL::Expr->field('$e', \$TABLE, \$VALUES)"; }, 'BINDPARAM' => sub { my $self = shift; my $string = join '', get_strings(@_); my $bindcount = keys %{$self->{'binds'}}; $bindcount = 0 unless defined $bindcount; if ($string eq '?') { $string = ':p'.($bindcount+1); } $self->{'binds_order'}[$bindcount] = $string unless exists $self->{'binds'}{$string}; $self->{'binds'}{$string}++; "XBase::SQL::Expr->string(\$BIND->{'$string'})"; }, 'FUNCTION' => sub { my $self = shift; my @params = get_strings(@_); my $fn = uc shift @params; "XBase::SQL::Expr->function('$fn', \$TABLE, \$VALUES, @params)"; }, 'ORDERFIELDNAME' => 'orderfields', 'ORDERDESC' => 'orderdescs', 'STRINGDBL' => sub { my $self = shift; join '', '"', get_strings(@_), '"'; }, 'STRINGSGL' => sub { my $self = shift; join '', '\'', get_strings(@_), '\''; }, 'STRING' => sub { shift; my $e = (get_strings(@_))[1]; "XBase::SQL::Expr->string($e)"; }, 'NUMBER' => sub { shift; my $e = (get_strings(@_))[0]; "XBase::SQL::Expr->number($e)"; }, 'NULL' => sub { 'XBase::SQL::Expr->null()' }, 'AND' => sub { 'and' }, 'OR' => sub { 'or' }, 'LIKE' => sub { shift; join ' ', get_strings(@_); }, 'CONCATENATION' => sub { ' . ' }, 'WHEREEXPR' => sub { my $self = shift; my $expr = join ' ', get_strings(@_); ### print STDERR "Evalling: $expr\n"; ### use Data::Dumper; my $fn = eval ' sub { ### print Dumper @_; my ($TABLE, $VALUES, $BIND) = @_; ' . $expr . '; }'; if ($@) { $self->{'whereerror'} = $@; } else { $self->{'wherefn'} = $fn; } ''; }, 'RELOP' => sub { shift; my $e = (get_strings(@_))[0]; if ($e eq '=') { $e = '=='; } elsif ($e eq '<>') { $e = '!=';} $e; }, 'ARITHMETIC' => sub { shift; join ' ', get_strings(@_); }, 'RELATION' => sub { shift; my @values = get_strings(@_); local $^W = 0; my $testnull = join ' ', @values[1 .. 3]; if ($testnull =~ /^is (not )?null ?$/i) { return "not $1 defined(($values[0])->value)"; } elsif ($values[1] =~ /^(not )?like$/i) { return "$1(XBase::SQL::Expr->likematch($values[0], $values[2])) " } else { return join ' ', @values; } }, ); sub find_verbatim_select_names { my ($self, @result) = @_; my $i = 0; while ($i < @result) { if ($result[$i] eq 'SELECTEXPFIELD') { my @out = $self->get_verbatim_select_names(@result[$i, $i + 1]); push @{$self->{'selectnames'}}, uc join '', @out; } elsif (ref $result[$i + 1] eq 'ARRAY') { $self->find_verbatim_select_names(@{$result[$i + 1]}); } $i += 2; } } sub get_verbatim_select_names { my ($self, @result) = @_; my $i = 1; my @out = (); while ($i < @result) { if (ref $result[$i] eq 'ARRAY') { push @out, $self->get_verbatim_select_names(@{$result[$i]}); } else { push @out, $result[$i]; } $i += 2; } @out; } ####### # Parse is called with a string -- the whole SQL query. It should # return the object with all properties filled, or errstr upon error # First, we call match. Then, after we know that the match was # successfull, we call store_results sub parse { $^W = 0; my ($class, $string) = @_; my $self = bless {}, $class; # try to match the $string against $COMMANDS{'COMMANDS'} # that's the top level starting point my ($srest, $error, $errstr, @result) = match($string, 'COMMANDS'); # after the parse, nothing should have left from the $string # if it does, it's some rubbish if ($srest ne '' and not $error) { $error = 1; $errstr = 'Extra characters in SQL command'; } # we want to have meaningfull error messages. if it heasn't # been specified so far, let's just say Error if ($error) { if (not defined $errstr) { $errstr = 'Error in SQL command'; } # and only show the relevant part of the SQL string substr($srest, 40) = '...' if length $srest > 44; if ($srest ne '') { $self->{'errstr'} = "$errstr near `$srest'"; } else { $self->{'errstr'} = "$errstr at the end of query"; } } else { # take the results and store them to $self $self->find_verbatim_select_names(@result); $self->store_results(\@result, \%STORE); if (defined $self->{'whereerror'}) { $self->{'errstr'} = "Some deeper problem: eval failed: $self->{'whereerror'}"; } ### use Data::Dumper; print STDERR "Parsed $string to\n", Dumper $self if $ENV{'SQL_DUMPER'}; } $self; } ########## # Function match is called with a string and a list of regular # expressions we need to match sub match { my $string = shift; my @regexps = @_; # we save the starting string, for case when we need to backtrack my $origstring = $string; # the title is the name of the goal (bigger entity) we now try # to match; it's mainly used to find correct error message my $title; if (@regexps == 1 and defined $COMMANDS{$regexps[0]}) { $title = $regexps[0]; my $c = $COMMANDS{$regexps[0]}; # if we are to match a thing in %COMMANDS, let's expand it @regexps = expand( ( ref $c ) ? @$c : grep { $_ ne '' } split /\s+/, $c); } # as the first element of the @regexp list, we might have got # modifiers -- ? or * -- we will use them in cse of non-match my $modif; if (@regexps and $regexps[0] eq '?' or $regexps[0] eq '*') { $modif = shift @regexps; } # let's walk through the @regexp list and see my @result; my $i = 0; while ($i < @regexps) { my $regexp = $regexps[$i]; my ($error, $errstr, @r); # if it's an array, call match recursivelly if (ref $regexp) { ($string, $error, $errstr, @r) = match($string, @$regexp); } # if it's a thing in COMMANDS, call match recursivelly elsif (defined $COMMANDS{$regexp}) { ($string, $error, $errstr, @r) = match($string, $regexp); } # if we've found |, it means that one alternative matched # fine and we can leave the loop -- we use next to go # through continue elsif ($regexp eq '|') { $i = $#regexps; next; } # otherwise do a regexp match elsif ($string =~ s/^\s*?($regexp)(?:$|\b|(?=\W))//si) { @r = $1; } # and yet otherwise we have a problem else { $error = 1; } # if we have a problem if (defined $error) { # if nothing has matched yet, try to find next # alternative if ($origstring eq $string) { while ($i < @regexps) { last if $regexps[$i] eq '|'; $i++; } next if $i < @regexps; last if defined $modif; } # if we got here, we haven't found any alternative # and no modifier was specified for this list # so just form the errstr and return with shame if (not defined $errstr) { if (defined $ERRORS{$regexp}) { $errstr = $ERRORS{$regexp}; } elsif (defined $title and defined $ERRORS{$title}) { $errstr = $ERRORS{$title}; } } return ($string, 1, $errstr, @result); } # add result to @result if (ref $regexp) { push @result, @r; } elsif (@r > 1) { push @result, $regexp, [ @r ]; } else { push @result, $regexp, $r[0]; } } continue { $i++; # if we hve *, let's try another round if (defined $modif and $modif eq '*' and $i >= @regexps) { $origstring = $string; $i = 0; } } return ($string, undef, undef, @result); } sub expand { my @result; my $i = 0; while ($i < @_) { my $t = $_[$i]; if ($t eq '(') { $i++; my $begin = $i; my $nest = 1; while ($i < @_ and $nest) { my $t = $_[$i]; if ($t eq '(') { $nest++; } elsif ($t eq ')') { $nest--; } $i++; } $i--; push @result, [ expand(@_[$begin .. $i - 1]) ]; } elsif ($t eq '?' or $t eq '*') { my $prev = pop @result; push @result, [ $t, ( ref $prev ? @$prev : $prev ) ]; } else { push @result, $t; } $i++; } @result; } # # We run this method on the XBase::SQL object, with the tree structure # in the $result arrayref sub store_results { my ($self, $result) = @_; my $i = 0; # Walk through the list while ($i < @$result) { # get the key and the value matched for the key my ($key, $match) = @{$result}[$i, $i + 1]; # if there is some structure below, process it if (ref $match) { $self->store_results($match); } # see what are we supposed to do for this key my $store_value = $STORE{$key}; if (defined $store_value) { if (ref $store_value eq 'CODE') { my @out = &{$store_value}($self, (ref $match ? @$match : $match)); if (@out == 1) { $result->[$i+1] = $out[0]; } else { $result->[$i+1] = [ @out ]; } } else { push @{$self->{$store_value}}, get_strings($match); } } =comment if (defined $m) { my @result = (( ref $m eq 'CODE' ) ? &{$m}( ref $match ? @$match : $match) : $m); if (@result == 1) { $match = $result[0]; } else { $match = [ @result ]; } $result->[$i + 1] = $match; } if (defined $stval) { my @result; if (ref $match) { @result = get_strings($match); } else { @result = $match; } if (ref $stval eq 'CODE') { &{$stval}($self, @result); } else { push @{$self->{$stval}}, @result; } } =cut $i += 2; } } # # sub get_strings { my @strings = @_; if (@strings == 1 and ref $strings[0]) { @strings = @{$strings[0]}; } my @result; my $i = 1; while ($i < @strings) { if (ref $strings[$i]) { push @result, get_strings($strings[$i]); } else { push @result, $strings[$i]; } $i += 2; } @result; } sub print_result { my $result = shift; my @result = @$result; my @before = @_; my $i = 0; while ($i < @result) { my ($regexp, $string) = @result[$i, $i + 1]; if (ref $string) { print_result($string, @before, $regexp); } else { print "$string:\t @before $regexp\n"; } $i += 2; } } # ####################################### # Implementing methods in SQL expressions package XBase::SQL::Expr; use strict; use overload '+' => sub { XBase::SQL::Expr->number($_[0]->value + $_[1]->value); }, '-' => sub { my $a = $_[0]->value - $_[1]->value; $a = -$a if $_[2]; XBase::SQL::Expr->number($a); }, '/' => sub { my $a = ( $_[2] ? $_[1]->value / $_[0]->value : $_[0]->value / $_[1]->value ); XBase::SQL::Expr->number($a); }, '%' => sub { my $a = ( $_[2] ? $_[1]->value % $_[0]->value : $_[0]->value % $_[1]->value ); XBase::SQL::Expr->number($a); }, '<' => \&less, '<=' => \&lesseq, '>' => sub { $_[1]->less(@_[0, 2]); }, '>=' => sub { $_[1]->lesseq(@_[0, 2]); }, '!=' => \¬equal, '<>' => \¬equal, '==' => sub { my $a = shift->notequal(@_); return ( $a ? 0 : 1); }, '""' => sub { ref shift; }, '.' => sub { XBase::SQL::Expr->string($_[0]->value . $_[1]->value); }, '*' => sub { XBase::SQL::Expr->number($_[0]->value * $_[1]->value);}, '!' => sub { not $_[0]->value }, ; sub new { bless {}, shift; } sub value { shift->{'value'}; } sub field { my ($class, $field, $table, $values) = @_; my $self = $class->new; $self->{'field'} = $field; $self->{'value'} = $values->{$field}; my $type = $table->field_type($field); if ($type eq 'N') { $self->{'number'} = 1; } else { $self->{'string'} = 1; } $self; } sub string { my $self = shift->new; $self->{'value'} = shift; $self->{'string'} = 1; $self; } sub number { my $self = shift->new; $self->{'value'} = shift; $self->{'number'} = 1; $self; } sub null { my $self = shift->new; $self->{'value'} = undef; $self; } sub other { my $class = shift; my $other = shift; $other; } sub function { my ($class, $function, $table, $values, @params) = @_; my $self = $class->new; $self->{'string'} = 1; if ($function eq 'LENGTH') { $self->{'value'} = length($params[0]->value); delete $self->{'string'}; $self->{'number'} = 1; } elsif ($function eq 'TRIM') { ($self->{'value'} = $params[0]->value) =~ s/^\s+|\s+$//g; } elsif ($function eq 'LTRIM') { ($self->{'value'} = $params[0]->value) =~ s/^\s+//; } elsif ($function eq 'RTRIM') { ($self->{'value'} = $params[0]->value) =~ s/\s+$//; } elsif ($function eq 'CONCAT') { $self->{'value'} = join '', map { $_->value } @params; } elsif ($function eq 'SUBSTR' or $function eq 'SUBSTRING') { my ($string, $start, $length) = map { $_->value } @params; if ($start == 0) { $start = 1; } $self->{'value'} = substr($string, $start - 1, $length); } $self; } 1; # # Function working on Expr objects # sub less { my ($self, $other, $reverse) = @_; my $answer; if (defined $self->{'string'} or defined $other->{'string'}) { $answer = ($self->value lt $other->value); } else { $answer = ($self->value < $other->value); } return -$answer if $reverse; $answer; } sub lesseq { my ($self, $other, $reverse) = @_; my $answer; if (defined $self->{'string'} or defined $other->{'string'}) { $answer = ($self->value le $other->value); } else { $answer = ($self->value <= $other->value); } return -$answer if $reverse; $answer; } sub notequal { my ($self, $other) = @_; local $^W = 0; if (defined $self->{'string'} or defined $other->{'string'}) { ($self->value ne $other->value); } else { ($self->value != $other->value); } } sub likematch { my $class = shift; my ($field, $string) = @_; my $regexp = $string->value; $regexp =~ s/(\\\\[%_]|.)/ ($1 eq '%') ? '.*' : ($1 eq '_') ? '.' : "\Q$1" /seg; $field->value =~ /^$regexp$/si; } 1; DBD-XBase-1.08/ToDo0000644000175000017500000000275512521607341013473 0ustar adeltonadelton This is the to-do list for the XBase and DBD::XBase packages: Short term (I will do them as my time allows): Improve write index support. Date cdx and dbf bug reports by Dan Albertsson (1999/05/12). Handling large cdx files, patch provided by Jon Bloom (1999/08/04). Bug report and patch for ntx by Maksim Bazhanov (1999/11/09). Bug report (undefined value) by Jose L. Ornelas pending (1999/12/16). Bug report and patch for ntx by Sergey Wasiliew pending (2000/01/05). Gregory McCann reports (2000/01/13) that the Visual FoxPro v6 dbf file leads to Can't use string ("") as a subroutine ref while "strict refs" in use warning. I'd need a test file for that (provided the 0.160 patch for _NULLFLAGS didn't fix it, in which case I'd still appreciate some ideas of what that type means). The cdx parsing is still not exactly correct -- Carlos H. Lopez reports (2000/02/07) different number of records than XBase::Index finds for big (50k records) files. Mid term (would appreciate help or comments): Need to fix handling attributes in DBD ... When creating table, have option to specify version. Finish write index support. Add sorting on more than one field in DBD. Polish error reporting from XBase::Index. Long term (it really depends on many things, mainly whether other people will demand the feature, offer help): Add index support to DBD::XBase (once it's stable in XBase.pm). Add memo position caching. Some support for LIMIT SQL clause, perhaps. -- Jan Pazdziora DBD-XBase-1.08/t/0000755000175000017500000000000013037112723013133 5ustar adeltonadeltonDBD-XBase-1.08/t/ndx-char.dbf0000644000175000017500000000434612520435413015323 0ustar adeltonadeltona AOV1CćFN 10 8 6 1 3 5 15 7 2 4 10 9 8 7 6 5 4 3 2 1 3a 5b 8d 4e 6g 2h 1z 2z DBD-XBase-1.08/t/XBase.dbtest0000644000175000017500000000473412520435413015354 0ustar adeltonadelton# # Database specific definitions for a XBase module # # This function generates a mapping of ANSI type names to # database specific type names; it is called by TableDefinition(). sub AnsiTypeToDb ($;$) { my ($type, $size) = @_; my ($ret); if ((lc $type) eq 'blob') { $ret = 'memo'; } elsif ((lc $type) eq 'int' || (lc $type) eq 'integer') { $ret = $type; } elsif ((lc $type) eq 'char') { $ret = "CHAR($size)"; } else { warn "Unknown type $type\n"; $ret = $type; } $ret; } # # This function generates a table definition based on an # input list. The input list consists of references, each # reference referring to a single column. The column # reference consists of column name, type, size and a bitmask of # certain flags, namely # # $COL_NULLABLE - true, if this column may contain NULL's # $COL_KEY - true, if this column is part of the table's # primary key # # Hopefully there's no big need for you to modify this function, # if your database conforms to ANSI specifications. # sub TableDefinition ($@) { my($tablename, @cols) = @_; my($def); # # Should be acceptable for most ANSI conformant databases; # # msql 1 uses a non-ANSI definition of the primary key: A # column definition has the attribute "PRIMARY KEY". On # the other hand, msql 2 uses the ANSI fashion ... # my($col, @keys, @colDefs, $keyDef); # # Count number of keys # @keys = (); foreach $col (@cols) { if ($$col[2] & $::COL_KEY) { push(@keys, $$col[0]); } } foreach $col (@cols) { my $colDef = $$col[0] . " " . AnsiTypeToDb($$col[1], $$col[2]); # if (!($$col[3] & $::COL_NULLABLE)) { # $colDef .= " NOT NULL"; # } $$col[3] |= $::COL_NULLABLE; push(@colDefs, $colDef); } if (@keys) { $keyDef = ", PRIMARY KEY (" . join(", ", @keys) . ")"; } else { $keyDef = ""; } $def = sprintf("CREATE TABLE %s (%s%s)", $tablename, join(", ", @colDefs), $keyDef); } ### DBI->trace(2); # # This function generates a list of tables associated to a # given DSN. # sub ListTables(@) { my($dbh) = shift; my(@tables); @tables = $dbh->func('_ListTables'); if ($dbh->errstr) { die "Cannot create table list: " . $dbh->errstr; } @tables; } # # Return a string for checking, whether a given column is NULL. # sub IsNull($) { my($var) = @_; "$var IS NULL"; } # # Return TRUE, if database supports transactions # sub HaveTransactions () { 0; } 1; DBD-XBase-1.08/t/types.dbf0000644000175000017500000000034612521607341014761 0ustar adeltonadeltonIDN PAYMENTYTT 1'Œ=% 2˙˙˙˙ţl%Řůz 3îŘ˙˙˙˙˙˙Œ=% 4ţ˙˙˙ţl%8g{DBD-XBase-1.08/t/8_dbd_delete.t0000644000175000017500000000436712521607341015636 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; eval 'use DBI 1.00'; if ($@ ne '') { print "1..0 # SKIP No DBI module\n"; print "DBI couldn't be loaded, aborting test\n"; print "Error returned from eval was:\n", $@; exit; } print "1..7\n"; print "DBI loaded\n"; } END { print "not ok 1\n" unless $::DBIloaded; } ### DBI->trace(2); $::DBIloaded = 1; print "ok 1\n"; my $dir = ( -d './t' ? 't' : '.' ); print "Unlinking write.dbf write.dbt\n"; if (-f "$dir/write.dbf") { unlink "$dir/write.dbf" or print "Error unlinking $dir/write.dbf: $!\n"; } print "We will make a copy of database files rooms.dbf\n"; eval "use File::Copy;"; if ($@) { print "Look's like you do not have File::Copy, we will do cp\n"; system("cp", "$dir/rooms.dbf", "$dir/write.dbf"); } else { print "Will use File::Copy\n"; copy("$dir/rooms.dbf", "$dir/write.dbf"); } unless (-f "$dir/write.dbf") { print "not ok 2\n"; exit; } # Does not make sense to continue print "ok 2\n"; print "Connect to dbi:XBase:$dir\n"; my $dbh = DBI->connect("dbi:XBase:$dir") or do { print $DBI::errstr; print "not ok 3\n"; exit; }; print "ok 3\n"; my $command = 'delete from write where facility != "Audio"'; print "Prepare command `$command'\n"; my $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 4\n"; exit; }; print "ok 4\n"; print "Execute it\n"; $sth->execute() or do { print $sth->errstr(); print "not ok 5\n"; exit; }; print "ok 5\n"; print "And now we should check if it worked\n"; my $selcom = 'select * from write'; print "Prepare and execute '$selcom'\n"; my $select = $dbh->prepare($selcom) or do { print $dbh->errstr(); print "not ok 6\n"; exit; }; $select->execute() or do { print $select->errstr(); print "not ok 6\n"; exit; }; print "ok 6\n"; my $result = ''; my @data; while (@data = $select->fetchrow_array()) { $result .= "@data\n"; } my $expected_result = join '', ; if ($result ne $expected_result) { print "Expected:\n$expected_result"; print "Got:\n$result"; print "not "; } print "ok 7\n"; $sth->finish(); $dbh->disconnect(); 1; __DATA__ Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio ADR-Foley Audio Mach Rm Audio Transfer Audio Flambe Audio Mix F Audio Mix G Audio Mix H Audio Mix J Audio DBD-XBase-1.08/t/test.dbt0000644000175000017500000000303507234231211014602 0ustar adeltonadelton‡^d1‡This is a memo for record no oneThis is a memo for record 2This is a memo for record 3DBD-XBase-1.08/t/5_sdbm.t0000644000175000017500000000772112521607341014502 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..9\n"; } END { print "not ok 1\n" unless $::XBaseloaded; } $| = 1; print "Load the module: use XBase\n"; use XBase; $::XBaseloaded = 1; print "ok 1\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems my @files = <$dir/rooms.sdbm*.*>; if (@files) { print "Dropping: @files\n"; unlink @files; } print "Open table $dir/rooms\n"; my $table = new XBase "$dir/rooms" or do { print XBase->errstr, "not ok 2\n"; exit }; print "ok 2\n"; print "Create SDBM index room on ROOMNAME\n"; use XBase::Index; use XBase::SDBM; my $index = XBase::SDBM->create($table, 'room', 'ROOMNAME'); print "ok 3\n"; print "prepare_select_with_index on ROOMNAME\n"; my $cur = $table->prepare_select_with_index([ "$dir/rooms.pag", 'room' ]) or print $table->errstr, 'not '; print "seems fine\n"; my $result = ''; print "Fetch all data\n"; while (my @data = $cur->fetch) { $result .= "@data\n"; } my $expected_result = ''; my $line; while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 4\n"; print "find_eq('Celco') and fetch\n"; $cur->find_eq('Celco'); $result = ''; $expected_result = ''; while (my @data = $cur->fetch()) { $result .= "@data\n"; } while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 5\n"; print "find_eq('Celca') and fetch (it doesn't exist, so the result should be the same)\n"; $cur->find_eq('Celca'); $result = ''; while (my @data = $cur->fetch()) { $result .= "@data\n"; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 6\n"; print "prepare_select_with_index on FACILITY\n"; $cur = $table->prepare_select_with_index([ "$dir/rooms.cdx", 'FACILITY' ], 'FACILITY', 'ROOMNAME') or print $table->errstr, 'not '; print "ok 7\n"; print "find_eq('Film') and fetch\n"; $cur->find_eq('Film'); $result = ''; $expected_result = ''; while (my @data = $cur->fetch()) { last if $data[0] ne 'Film'; $result .= "@data\n"; } while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 8\n"; print "find_eq('Main') and fetch\n"; $cur->find_eq('Main'); $result = ''; $expected_result = ''; while (my @data = $cur->fetch()) { last if $data[0] ne 'Main'; $result .= "@data\n"; } while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 9\n"; __END__ None ADR-Foley Audio AVID Main BAY 7 Main Bay 1 Main Bay 2 Main Bay 3 Main Bay 4 Main Bay 5 Main Bay 6 Main Bay 8 Main Bay 10 Main Bay 11 Main Bay 12 Main Bay 14 Main Bay 15 Main Bay 16 Main Bay 17 Main Bay 18 Main Bay 19 Main BullPen Film Celco Film Dub Main FILM 1 Film FILM 2 Film FILM 3 Film Flambe Audio Gigapix Main MacGrfx Main Mach Rm Audio Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio Mix F Audio Mix G Audio Mix H Audio Mix J Audio SCANNING Film Transfer Audio __END_DATA__ Celco Film Dub Main FILM 1 Film FILM 2 Film FILM 3 Film Flambe Audio Gigapix Main MacGrfx Main Mach Rm Audio Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio Mix F Audio Mix G Audio Mix H Audio Mix J Audio SCANNING Film Transfer Audio __END_DATA__ Film FILM 1 Film FILM 2 Film FILM 3 Film SCANNING Film BullPen Film Celco __END_DATA__ Main Bay 1 Main Bay 14 Main Bay 2 Main Bay 5 Main Bay 11 Main Bay 6 Main Bay 3 Main Bay 4 Main Bay 10 Main Bay 8 Main Gigapix Main Bay 12 Main Bay 15 Main Bay 16 Main Bay 17 Main Bay 18 Main Bay 19 Main Dub Main MacGrfx Main AVID Main BAY 7 __END_DATA__ DBD-XBase-1.08/t/5_idx.t0000644000175000017500000000407512521607341014340 0ustar adeltonadelton#!/usr/bin/perl -w use strict; END { print "not ok 1\n" unless $::XBaseloaded; } BEGIN { $| = 1; print "1..6\n"; print "Load modules: use XBase; use XBase::Index;\n"; } use XBase; use XBase::Index; $::XBaseloaded = 1; print "ok 1\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems unlink "$dir/tstidx.dbf", "$dir/tstidxid.idx", "$dir/tstidxname.idx"; my $table = create XBase('name' => "$dir/tstidx.dbf", 'field_names' => [ 'ID', 'NAME' ], 'field_types' => [ 'N', 'C' ], 'field_lengths' => [ 6, 100 ], 'field_decimals' => [ 0, undef ]) or do { print XBase->errstr, "not ok 2\n"; exit; }; print "ok 2\n"; my $i = 0; $table->set_record($i++, 56, 'Padesat sest'); $table->set_record($i++, 123, 'Stodvacettri'); $table->set_record($i++, 9, 'Krtek'); $table->set_record($i++, 88, 'Osmaosmdesat'); $table->set_record($i++, -7, 'minus sedm'); $table->set_record($i++, 7, 'plus sedm'); $table->set_record($i++, 15, 'Patnact'); $table->set_record($i++, -1000, 'Tisic pod nulou'); my $numindex = create XBase::idx($table, "$dir/tstidxid.idx", "id"); if (not defined $numindex) { print XBase->errstr, 'not '; } print "ok 3\n"; my $got = ''; $numindex->prepare_select; while (my ($key, $num) = $numindex->fetch) { $got .= "$key $num\n"; } my $expected = ''; while () { last if $_ eq "__END_DATA__\n"; $expected .= $_; } if ($got ne $expected) { print "Expected:\n$expected\nGot:\n$got\nnot "; } print "ok 4\n"; my $charindex = create XBase::idx($table, "$dir/tstidxname.idx", "name"); if (not $charindex) { print XBase->errstr, 'not '; } print "ok 5\n"; $got = ''; $charindex->prepare_select; while (my ($key, $num) = $charindex->fetch) { $key =~ s/\s+$//; $got .= "$key $num\n"; } $expected = ''; while () { last if $_ eq "__END_DATA__\n"; $expected .= $_; } if ($got ne $expected) { print "Expected:\n$expected\nGot:\n$got\nnot "; } print "ok 6\n"; __DATA__ -1000 8 -7 5 7 6 9 3 15 7 56 1 88 4 123 2 __END_DATA__ Krtek 3 Osmaosmdesat 4 Padesat sest 1 Patnact 7 Stodvacettri 2 Tisic pod nulou 8 minus sedm 5 plus sedm 6 DBD-XBase-1.08/t/3_create_drop.t0000644000175000017500000000605112521607341016035 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..11\n"; } END { print "not ok 1\n" unless $::XBaseloaded; } print "Load the module: use XBase\n"; use XBase; $::XBaseloaded = 1; print "ok 1\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems $XBase::CLEARNULLS = 1; # Yes, we want that print "Unlinking newtable.dbf and newtable.dbt\n"; if (-f "$dir/newtable.dbf") { unlink "$dir/newtable.dbf" or print "Error unlinking $dir/newtable.dbf: $!\n"; } if (-f "$dir/newtable.dbt") { unlink "$dir/newtable.dbt" or print "Error unlinking $dir/newtable.dbt: $!\n"; } print "Create new table, newtable.dbf & newtable.dbt, with types C M D F L\n"; my $table = create XBase('name' => "$dir/newtable", 'field_names' => [ 'NAME', 'COMMENT', 'UID', 'FLOAT', 'ACTIVE' ], 'field_types' => [ 'C', 'M', 'D', 'F', 'L' ], 'field_lengths' => [ 15, 10, 8, 6, 1 ], 'field_decimals' => [ undef, undef, undef, 2, undef ], codepage => 1); print "not " unless defined $table; print "ok 2\n"; exit unless defined $table; print "Check if both (dbf and dbt) files were created\n"; print "not " unless -f "$dir/newtable.dbf"; print "ok 3\n"; print "not " unless -f "$dir/newtable.dbt"; print "ok 4\n"; print "Check their lengths (expect 194 and 512)\n"; my $len = -s "$dir/newtable.dbf"; if ($len != 194) { print "Got $len\nnot "; } print "ok 5\n"; $len = -s "$dir/newtable.dbt"; if ($len != 512) { print "Got $len\nnot "; } print "ok 6\n"; print "Now, fill two records\n"; $table->set_record(0, 'Michal', 'Michal seems to be a nice guy', 24513, 186.45, 1) or print $table->errstr(), 'not '; print "ok 7\n"; $table->set_record(1, 'Martin', 'Martin is fine, too', 89, 13, 0) or print $table->errstr(), 'not '; print "ok 8\n"; print "Check the header of the newly created table\n"; my $header = $table->get_header_info(); $header =~ s!^Last change:\t.*$!Last change:\txxxx/xx/xx!m; $header =~ s!^Filename:\tt/!Filename:\t!; my $goodheader = join '', ; if ($header ne $goodheader) { print "Got header:\n", $header; print "Good header is:\n", $goodheader; print "not "; } print "ok 9\n"; print "Drop the table\n"; $table->drop() or print "not "; print "ok 10\n"; print "Check if the files newtable.dbf and newtable.dbt have been deleted\n"; print "not " if (-f "$dir/newtable.dbf" or -f "$dir/newtable.dbt"); print "ok 11\n"; ### use XBase; ### my $table = XBase->create( ### 'name' => 'tab.dbf', ### 'memofile' => 'tab.fpt', ### 'field_names' => [ 'ID', 'MSG' ], ### 'field_types' => [ 'C', 'M' ], ### 'field_lengths' => [ 20 ], ### 'field_decimals' => [] ### ) or die XBase->errstr; ### $table->set_record(0, 'jezek', 'krtek'); __DATA__ Filename: newtable.dbf Version: 0x83 (ver. 3 with DBT file) Num of records: 2 Header length: 193 Record length: 41 Last change: xxxx/xx/xx Num fields: 5 Field info: Num Name Type Len Decimal 1. NAME C 15 0 2. COMMENT M 10 0 3. UID D 8 0 4. FLOAT F 6 2 5. ACTIVE L 1 0 DBD-XBase-1.08/t/4_dbfdump.t0000644000175000017500000000232612521607341015171 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..2\n"; } my $dir = ( -d "t" ? "." : ".." ); use ExtUtils::testlib; my $libs = join " -I", '', @INC; my $dbfdump = "$dir/blib/script/dbfdump"; my $expected = join '', ; my $result = ''; my $command = qq!$^X $libs $dbfdump "$dir/t/rooms.dbf"!; print "Running dbfdump rooms.dbf: $command\n"; $result = `$command`; if ($result ne $expected) { print "Got\n$result\nExpected\n$expected\nwhich is not OK\nnot "; } print "ok 1\n"; $command = qq!$^X $libs $dbfdump -- - < "$dir/t/rooms.dbf"!; print "Running stdin dbfdump < rooms.dbf: $command\n"; $result = `$command`; if ($result ne $expected) { print "Got\n$result\nwhich is not OK\nnot "; } print "ok 2\n"; 1; __DATA__ None: Bay 1:Main Bay 14:Main Bay 2:Main Bay 5:Main Bay 11:Main Bay 6:Main Bay 3:Main Bay 4:Main Bay 10:Main Bay 8:Main Gigapix:Main Bay 12:Main Bay 15:Main Bay 16:Main Bay 17:Main Bay 18:Main Mix A:Audio Mix B:Audio Mix C:Audio Mix D:Audio Mix E:Audio ADR-Foley:Audio Mach Rm:Audio Transfer:Audio Bay 19:Main Dub:Main Flambe:Audio FILM 1:Film FILM 2:Film FILM 3:Film SCANNING:Film Mix F:Audio Mix G:Audio Mix H:Audio BullPen:Film Celco:Film MacGrfx:Main Mix J:Audio AVID:Main BAY 7:Main : DBD-XBase-1.08/t/2_write.t0000644000175000017500000000637312521607330014704 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..11\n"; } END { print "not ok 1\n" unless $::XBaseloaded; } print "Load the module: use XBase\n"; use XBase; $::XBaseloaded = 1; print "ok 1\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems print "Unlink write.dbf and write.dbt, make a copy of test.dbf and test.dbt\n"; my @FILES = map { "$dir/$_" } qw! write.dbf write.dbt write1.dbf write1.FPT !; for (@FILES) { if (-f $_ and not unlink $_) { print "Error unlinking $_: $!\n"; } } use File::Copy; copy("$dir/test.dbf", "$dir/write.dbf"); copy("$dir/test.dbt", "$dir/write.dbt"); copy("$dir/afox5.dbf", "$dir/write1.dbf"); copy("$dir/afox5.FPT", "$dir/write1.FPT"); for (@FILES) { if (not -f $_) { die "The files to do the write tests were not created, aborting\n"; } # Does not make sense to continue } print "ok 2\n"; print "Load the table write.dbf\n"; my $table = new XBase("$dir/write.dbf"); print XBase->errstr, 'not ' unless defined $table; print "ok 3\n"; exit unless defined $table; print "Check the last record number (number of records, in fact)\n"; my $last_record = $table->last_record(); if ($last_record != 2) { print "Expecting 2, got $last_record\nnot "; } print "ok 4\n"; print "Overwrite the record and check it back\n"; $table->set_record(1, 5, 'New message', 'New note', 1, '19700101') or print STDERR $table->errstr(); $table->get_record(0); # Force emptying caches my $result = join ':', map { defined $_ ? $_ : '' } $table->get_record(1); my $result_expected = '0:5:New message:New note:1:19700101'; if ($result_expected ne $result) { print "Expected: $result_expected\nGot: $result\nnot "; } print "ok 5\n"; print "Did last record number stay the same?\n"; $last_record = $table->last_record(); if ($last_record != 2) { print "Expecting 2, got $last_record\nnot "; } print "ok 6\n"; print "Now append data and read them back\n"; $table->set_record(3, 245, 'New record no 4', 'New note for record 4', undef, '19700102'); $table->get_record(0); # Force flushing cache $result = join ':', map { defined $_ ? $_ : '' } $table->get_record(3); $result_expected = '0:245:New record no 4:New note for record 4::19700102'; if ($result_expected ne $result) { print "Expected: $result_expected\nGot: $result\nnot "; } print "ok 7\n"; print "Now the number of records should have increased\n"; $last_record = $table->last_record(); if ($last_record != 3) { print "Expecting 3, got $last_record\nnot "; } print "ok 8\n"; print "Load the table write1.dbf\n"; $table = new XBase("$dir/write1.dbf"); print XBase->errstr, 'not ' unless defined $table; print "ok 9\n"; exit unless defined $table; print "Append one record\n"; $table->set_record(2, 'd22', 15, 'Mike', 'third desc.', 'third mess.') or print STDERR $table->errstr(); $table->get_record(0); # Force emptying caches $result = join ':', map { defined $_ ? $_ : '' } $table->get_record(2); $result_expected = '0:d22:15:Mike:third desc.:third mess.'; if ($result_expected ne $result) { print "Expected: $result_expected\nGot: $result\nnot "; } print "ok 10\n"; print "Check the size of the resulting fpt\n"; $table->close; my $size = -s "$dir/write1.FPT"; if ($size != 896) { print "Expected size 896, got $size\nnot " } print "ok 11\n"; 1; DBD-XBase-1.08/t/7_dbd_select_func.t0000644000175000017500000001300712521607341016654 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; eval 'use DBI 1.00'; if ($@ ne '') { print "1..0 # SKIP No DBI module\n"; print "DBI couldn't be loaded, aborting test\n"; print "Error returned from eval was:\n", $@; exit; } print "1..31\n"; print "DBI loaded\n"; } END { print "not ok 1\n" unless $::DBIloaded; } ### DBI->trace(2); $::DBIloaded = 1; print "ok 1\n"; my $dir = ( -d './t' ? 't' : '.' ); print "Connect to dbi:XBase:$dir\n"; my $dbh = DBI->connect("dbi:XBase:$dir", undef, undef, {'PrintError' => 1}) or do { print $DBI::errstr; print "not ok 2\n"; exit; }; print "ok 2\n"; my $command; my $sth; my ($result, $expected_result); sub compare_result { my ($result, $testnum) = @_; my $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if (not $result =~ /\n$/) { $result .= "\n"; } if (not $expected_result =~ /\n$/) { $expected_result .= "\n"; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok $testnum\n"; } $command = "select ID, MSG from test"; print "Prepare command `$command'\n"; $sth = $dbh->prepare($command) or print $dbh->errstr(), 'not '; print "ok 3\n"; print "Test the NAME attribute of the sth\n"; compare_result("@{$sth->{'NAME'}}", 4); print "Execute the command\n"; $sth->execute() or print $sth->errstr(), 'not '; print "ok 5\n"; print "Read the data and test them\n"; $result = ''; while (my @data = $sth->fetchrow_array) { $result .= "@data\n"; } compare_result($result, 6); $command = "select ID cislo, ID + 1, ID - ? from test"; print "Prepare command `$command'\n"; $sth = $dbh->prepare($command) or print $dbh->errstr(), 'not '; print "ok 7\n"; print "Test the NAME attribute of the sth\n"; compare_result("@{$sth->{'NAME'}}", 8); print "Execute the command with value 5\n"; $sth->execute(5) or print $sth->errstr(), 'not '; print "ok 9\n"; print "Read the data and test them\n"; $result = ''; while (my @data = $sth->fetchrow_array) { $result .= "@data\n"; } compare_result($result, 10); $command = "select 1 jedna, id, ? parametr from test where id = ?"; print "Prepare command `$command'\n"; $sth = $dbh->prepare($command) or print $dbh->errstr(), 'not '; print "ok 11\n"; print "Test the NAME attribute of the sth\n"; compare_result("@{$sth->{'NAME'}}", 12); print "Execute the command with values 8, 3\n"; $sth->execute(8, 3) or print $sth->errstr(), 'not '; print "ok 13\n"; print "Read the data and test them\n"; $result = ''; while (my @data = $sth->fetchrow_array) { $result .= "@data\n"; } compare_result($result, 14); ### $ENV{'SQL_DUMPER'} = 1; $command = "select id, length(msg), msg txt from test where id < ?"; print "Prepare command `$command'\n"; $sth = $dbh->prepare($command) or print $dbh->errstr(), 'not '; print "ok 15\n"; print "Test the NAME attribute of the sth\n"; compare_result("@{$sth->{'NAME'}}", 16); print "Execute the command with value 4\n"; $sth->execute(4) or print $sth->errstr(), 'not '; print "ok 17\n"; print "Read the data and test them\n"; $result = ''; while (my @data = $sth->fetchrow_array) { $result .= "@data\n"; } compare_result($result, 18); print "Execute the command with value 16\n"; $sth->execute(16) or print $sth->errstr(), 'not '; print "ok 19\n"; print "Read the data and test them (note that with bind params, it's string)\n"; $result = ''; while (my @data = $sth->fetchrow_array) { $result .= "@data\n"; } compare_result($result, 20); $command = "select (id + 5) || msg str, msg || ' datum ' || dates from test"; print "Prepare command `$command'\n"; $sth = $dbh->prepare($command) or print $dbh->errstr(), 'not '; print "ok 21\n"; print "Test the NAME attribute of the sth\n"; compare_result("@{$sth->{'NAME'}}", 22); print "Execute the command\n"; $sth->execute() or print $sth->errstr(), 'not '; print "ok 23\n"; print "Read the data and test them\n"; $result = ''; while (my @data = $sth->fetchrow_array) { $result .= "@data\n"; } compare_result($result, 24); $command = "select concat(45, ' jezek', '-krtek') from test where id = 1"; print "Prepare command `$command'\n"; $sth = $dbh->prepare($command) or print $dbh->errstr(), 'not '; print "ok 25\n"; print "Execute the command\n"; $sth->execute() or print $sth->errstr(), 'not '; print "ok 26\n"; print "Read the data and test them\n"; $result = ''; while (my @data = $sth->fetchrow_array) { $result .= "@data\n"; } compare_result($result, 27); $command = "select substr('jezek leze', 3, 7) cast, substring(trim(' krtek '), 0, 3) from test where id = 1"; print "Prepare command `$command'\n"; $sth = $dbh->prepare($command) or print $dbh->errstr(), 'not '; print "ok 28\n"; print "Test the NAME attribute of the sth\n"; compare_result("@{$sth->{'NAME'}}", 29); print "Execute the command\n"; $sth->execute() or print $sth->errstr(), 'not '; print "ok 30\n"; print "Read the data and test them\n"; $result = ''; while (my @data = $sth->fetchrow_array) { $result .= "@data\n"; } compare_result($result, 31); $sth->finish(); $dbh->disconnect(); 1; __DATA__ ID MSG __END_DATA__ 1 Record no 1 3 Message no 3 __END_DATA__ cislo ID+1 ID-? __END_DATA__ 1 2 -4 3 4 -2 __END_DATA__ jedna ID parametr __END_DATA__ 1 3 8 __END_DATA__ ID LENGTH(MSG) txt __END_DATA__ 1 11 Record no 1 3 12 Message no 3 __END_DATA__ 1 11 Record no 1 __END_DATA__ str MSG||' DATUM '||DATES __END_DATA__ 6Record no 1 Record no 1 datum 19960813 8Message no 3 Message no 3 datum 19960102 __END_DATA__ 45 jezek-krtek __END_DATA__ cast SUBSTRING(TRIM(' KRTEK '),0,3) __END_DATA__ zek lez krt __END_DATA__ DBD-XBase-1.08/t/afox5.FPT0000644000175000017500000000140012520440636014526 0ustar adeltonadelton @ first desc. first mess. second desc. second mess.DBD-XBase-1.08/t/8_dbd_update.t0000644000175000017500000000761412521607341015654 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; eval 'use DBI 1.00'; if ($@ ne '') { print "1..0 # SKIP No DBI module\n"; print "DBI couldn't be loaded, aborting test\n"; print "Error returned from eval was:\n", $@; exit; } print "1..10\n"; print "DBI loaded\n"; } END { print "not ok 1\n" unless $::DBIloaded; } ### DBI->trace(2); $::DBIloaded = 1; print "ok 1\n"; my $dir = ( -d './t' ? 't' : '.' ); print "Unlinking write.dbf write.dbt\n"; if (-f "$dir/write.dbf") { unlink "$dir/write.dbf" or print "Error unlinking $dir/write.dbf: $!\n"; } print "We will make a copy of database files rooms.dbf\n"; eval "use File::Copy;"; unless ($@) { print "Will use File::Copy\n"; copy("$dir/rooms.dbf", "$dir/write.dbf"); } else { print "Look's like you do not have File::Copy, we will do cp\n"; system("cp", "$dir/rooms.dbf", "$dir/write.dbf"); } unless (-f "$dir/write.dbf") { print "not ok 2\n"; exit; } # Does not make sense to continue print "ok 2\n"; print "Connect to dbi:XBase:$dir\n"; my $dbh = DBI->connect("dbi:XBase:$dir") or do { print $DBI::errstr; print "not ok 3\n"; exit; }; print "ok 3\n"; my $command = 'update write set roomname = "ABC" where facility != "Audio"'; print "Prepare command `$command'\n"; my $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 4\n"; exit; }; print "ok 4\n"; print "Execute it\n"; $sth->execute() or do { print $sth->errstr(); print "not ok 5\n"; exit; }; $sth->finish(); print "ok 5\n"; print "And now we should check if it worked\n"; my $selcom = 'select * from write'; print "Prepare and execute '$selcom'\n"; my $select = $dbh->prepare($selcom) or do { print $dbh->errstr(); print "not ok 6\n"; exit; }; $select->execute() or do { print $select->errstr(); print "not ok 6\n"; exit; }; print "ok 6\n"; my $result = ''; my @data; while (@data = $select->fetchrow_array()) { $result .= "@data\n"; } my $expected_result = ''; my $line; while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n$expected_result"; print "Got:\n$result"; print "not "; } print "ok 7\n"; my $bindupdate = 'update write set roomname = ?, facility = ? where facility = ? and roomname = ?'; print "Now prepare update with bind parameters\nCommand: $bindupdate\n"; my $sth2 = $dbh->prepare($bindupdate) or print $dbh->errstr(), 'not '; print "ok 8\n"; print "Execute it with 'Jezek', 'Krtek', 'Film', 'ABC'\n"; $sth2->execute('Jezek', 'Krtek', 'Film', 'ABC') or print $sth2->errstr(), 'not '; print "ok 9\n"; print "Now check the result back\n"; my $select2 = $dbh->prepare('select * from write'); $select2->execute(); my $result2 = join '', map { "@$_\n" } @{ $select2->fetchall_arrayref }; $expected_result = ''; while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result2 ne $expected_result) { print "Expected:\n$expected_result"; print "Got:\n$result2"; print "not "; } print "ok 10\n"; $dbh->disconnect(); 1; __DATA__ ABC ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio ADR-Foley Audio Mach Rm Audio Transfer Audio ABC Main ABC Main Flambe Audio ABC Film ABC Film ABC Film ABC Film Mix F Audio Mix G Audio Mix H Audio ABC Film ABC Film ABC Main Mix J Audio ABC Main ABC Main ABC __END_DATA__ ABC ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main ABC Main Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio ADR-Foley Audio Mach Rm Audio Transfer Audio ABC Main ABC Main Flambe Audio Jezek Krtek Jezek Krtek Jezek Krtek Jezek Krtek Mix F Audio Mix G Audio Mix H Audio Jezek Krtek Jezek Krtek ABC Main Mix J Audio ABC Main ABC Main ABC DBD-XBase-1.08/t/7_dbd_select.t0000644000175000017500000003046512712110237015643 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; eval 'use DBI 1.00'; if ($@ ne '') { print "1..0 # SKIP No DBI module\n"; print "DBI couldn't be loaded, aborting test\n"; print "Error returned from eval was:\n", $@; exit; } print "1..47\n"; print "DBI loaded\n"; } END { print "not ok 1\n" unless $::DBIloaded; } ### DBI->trace(2); $::DBIloaded = 1; print "ok 1\n"; my $dir = ( -d './t' ? 't' : '.' ); print "Connect to dbi:XBase:$dir\n"; my $dbh = DBI->connect("dbi:XBase:$dir") or do { print $DBI::errstr; print "not ok 2\n"; exit; }; print "ok 2\n"; my $command = "select ID, MSG from test"; print "Prepare command `$command'\n"; my $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 3\n"; exit; }; print "ok 3\n"; print "Execute it\n"; $sth->execute() or do { print $sth->errstr(); print "not ok 4\n"; exit; }; print "ok 4\n"; print "And get two lines\n"; my @line; @line = $sth->fetchrow_array(); my $result = join ":", @line; print "Got: $result\n"; print "not " if $result ne "1:Record no 1"; print "ok 5\n"; @line = $sth->fetchrow_array(); $result = join ":", @line; print "Got: $result\n"; print "not " if $result ne "3:Message no 3"; print "ok 6\n"; @line = $sth->fetchrow_array(); print "Got empty list\n" unless @line; print "not " if scalar(@line) != 0; print "ok 7\n"; my $attrib; print "Check attributes NAME, TYPE, PRECISION\n"; $attrib = "[@{$sth->{'NAME'}}] [@{$sth->{'TYPE'}}] [@{$sth->{'PRECISION'}}]"; if ($attrib ne '[ID MSG] [2 1] [5 254]') { print "Got $attrib\nnot "; } print "ok 8\n"; $sth->finish(); $command = "select * from rooms where facility = 'Audio' or roomname > 'B'"; print "Prepare command `$command'\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 9\n"; exit; }; print "ok 9\n"; print "Execute it\n"; $sth->execute() or do { print $sth->errstr(); print "not ok 10\n"; exit; }; print "ok 10\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n"; } my $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ($result ne $expected_result) { print "Expected:\n$expected_result"; print "Got:\n$result"; print "not "; } print "ok 11\n"; print "Check attributes NAME, TYPE, PRECISION\n"; $attrib = "[@{$sth->{'NAME'}}] [@{$sth->{'TYPE'}}] [@{$sth->{'PRECISION'}}]"; if ($attrib ne '[ROOMNAME FACILITY] [1 1] [10 10]') { print "Got $attrib\nnot "; } print "ok 12\n"; $command = "select * from rooms where facility = ? or roomname > ?"; print "Prepare command `$command'\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 13\n"; exit; }; print "ok 13\n"; print "Execute it with bind parameters ('Audio', 'B')\n"; $sth->execute('Audio', 'B') or do { print $sth->errstr(); print "not ok 14\n"; exit; }; print "ok 14\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n"; } if ($result ne $expected_result) { print "Expected:\n$expected_result"; print "Got:\n$result"; print "not "; } print "ok 15\n"; $command = "select facility,roomname from rooms where roomname > ? or facility = ? order by roomname"; print "Prepare command\t`$command'\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 16\n"; exit; }; print "ok 16\n"; print "Execute it with bind parameters ('F', 'Audio')\n"; $sth->execute('F', 'Audio') or do { print $sth->errstr(); print "not ok 17\n"; exit; }; print "ok 17\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n"; } $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ($result ne $expected_result) { print "Expected:\n$expected_result"; print "Got:\n$result"; print "not "; } print "ok 18\n"; $command = 'select * from rooms where roomname like ?'; print "Prepare $command\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr, "not ok 19\n"; exit; }; print "ok 19\n"; print "Execute it with parameter '%f%'\n"; $sth->execute('%f%') or do { print $dbh->errstr, "not ok 20\n"; exit; }; print "ok 20\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n" } $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 21\n"; $command = 'select * from rooms where facility like ? and roomname not like ?'; print "Prepare $command\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr, "not ok 22\n"; exit; }; print "ok 22\n"; print "Execute it with parameters '%o', 'mi%'\n"; $sth->execute('%o', 'mi%') or do { print $dbh->errstr, "not ok 23\n"; exit; }; print "ok 23\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n"; } $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 24\n"; $command = 'select facility, roomname from rooms where (facility = :fac or facility = :fac1) and roomname not like :name'; print "Prepare $command\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr, "not ok 25\n"; exit; }; print "ok 25\n"; print "Bind named parameters: Film, Main, Bay%\n"; $sth->bind_param(':fac', 'Film'); $sth->bind_param(':fac1', 'Main'); $sth->bind_param(':name', 'Bay%'); $sth->execute or do { print $dbh->errstr, "not ok 26\n"; exit; }; print "ok 26\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n"; } $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 27\n"; print "Check attributes NAME, TYPE, PRECISION\n"; $attrib = "[@{$sth->{'NAME'}}] [@{$sth->{'TYPE'}}] [@{$sth->{'PRECISION'}}]"; if ($attrib ne '[FACILITY ROOMNAME] [1 1] [10 10]') { print "Got $attrib\nnot "; } print "ok 28\n"; $command = 'select facility, roomname from rooms where roomname like :bay or facility = :film'; print "Prepare $command\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr, "not ok 29\n"; exit; }; print "ok 29\n"; print "Bind named parameters in execute call\n"; $sth->execute('Bay _', 'Film') or do { print $dbh->errstr, "not ok 30\n"; exit; }; print "ok 30\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n"; } $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 31\n"; $command = 'select (id + 9) / 3, msg message, dates as Datum from test where id > 2 + ?'; print "Prepare $command\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr, "not ok 32\n"; exit; }; print "ok 32\n"; print "Bind -1 (to make it into id > 1)\n"; $sth->execute(-1) or print $sth->errstr, "\nnot "; print "ok 33\n"; print "Check the names of the fields to return\n"; $expected_result = '(ID+9)/3 message Datum'; $result = "@{$sth->{'NAME'}}"; if ($result ne $expected_result) { print "Expected:\n${expected_result}\nGot:\n${result}\nnot "; } print "ok 34\n"; print "Fetch the resulting row\n"; $expected_result = '4 Message no 3 19960102'; $result = join ' ', $sth->fetchrow_array; if ($result ne $expected_result) { print "Expected:\n${expected_result}\nGot:\n${result}\nnot "; } print "ok 35\n"; $command = 'select * from test order by id'; print "Prepare $command\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr, "not ok 36\n"; exit; }; print "ok 36\n"; print "Execute it\n"; $sth->execute() or do { print $dbh->errstr, "not ok 37\n"; exit; }; print "ok 37\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n"; } $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 38\n"; $command = "select facility,roomname from rooms where roomname > ? or facility = ? order by facility DESC, roomname"; print "Prepare command\t`$command'\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 39\n"; exit; }; print "ok 39\n"; print "Execute it with bind parameters ('F', 'Audio')\n"; $sth->execute('F', 'Audio') or do { print $sth->errstr(); print "not ok 40\n"; exit; }; print "ok 40\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n"; } $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ($result ne $expected_result) { print "Expected:\n$expected_result"; print "Got:\n$result"; print "not "; } print "ok 41\n"; $command = 'select * from test where msg = ? order by id'; print "Prepare $command\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr, "not ok 42\n"; exit; }; print "ok 42\n"; print "Execute it with parameter ('Message no 3')\n"; $sth->execute('Message no 3') or do { print $dbh->errstr, "not ok 43\n"; exit; }; print "ok 43\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n"; } $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 44\n"; print "Execute it with parameter ('Record no 1')\n"; $sth->execute('Record no 1') or do { print $dbh->errstr, "not ok 45\n"; exit; }; print "ok 45\n"; print "And now get the result\n"; $result = ''; while (@line = $sth->fetchrow_array()) { $result .= "@line\n"; } $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 46\n"; $command = 'select test.msg from test where test.id = ?'; print "selectrow_array $command with 3\n"; my @data = $dbh->selectrow_array(q! select test.msg from test where test.id = ? !, {}, 3); $expected_result = ''; while () { last if /^__END_DATA__$/; $expected_result .= $_; } if ("@data\n" ne $expected_result) { print "Expected:\n${expected_result}Got:\n@{data}\nnot "; } print "ok 47\n"; $sth->finish(); $dbh->disconnect(); 1; __DATA__ Bay 1 Main Bay 14 Main Bay 2 Main Bay 5 Main Bay 11 Main Bay 6 Main Bay 3 Main Bay 4 Main Bay 10 Main Bay 8 Main Gigapix Main Bay 12 Main Bay 15 Main Bay 16 Main Bay 17 Main Bay 18 Main Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio ADR-Foley Audio Mach Rm Audio Transfer Audio Bay 19 Main Dub Main Flambe Audio FILM 1 Film FILM 2 Film FILM 3 Film SCANNING Film Mix F Audio Mix G Audio Mix H Audio BullPen Film Celco Film MacGrfx Main Mix J Audio BAY 7 Main __END_DATA__ Audio ADR-Foley Film FILM 1 Film FILM 2 Film FILM 3 Audio Flambe Main Gigapix Main MacGrfx Audio Mach Rm Audio Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio Mix F Audio Mix G Audio Mix H Audio Mix J Film SCANNING Audio Transfer __END_DATA__ ADR-Foley Audio Transfer Audio Flambe Audio FILM 1 Film FILM 2 Film FILM 3 Film Mix F Audio MacGrfx Main __END_DATA__ ADR-Foley Audio Mach Rm Audio Transfer Audio Flambe Audio __END_DATA__ Main Gigapix Main Dub Film FILM 1 Film FILM 2 Film FILM 3 Film SCANNING Film BullPen Film Celco Main MacGrfx Main AVID __END_DATA__ Main Bay 1 Main Bay 2 Main Bay 5 Main Bay 6 Main Bay 3 Main Bay 4 Main Bay 8 Film FILM 1 Film FILM 2 Film FILM 3 Film SCANNING Film BullPen Film Celco __END_DATA__ 1 Record no 1 This is a memo for record no one 19960813 3 Message no 3 This is a memo for record 3 0 19960102 __END_DATA__ Main Gigapix Main MacGrfx Film FILM 1 Film FILM 2 Film FILM 3 Film SCANNING Audio ADR-Foley Audio Flambe Audio Mach Rm Audio Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio Mix F Audio Mix G Audio Mix H Audio Mix J Audio Transfer __END_DATA__ 3 Message no 3 This is a memo for record 3 0 19960102 __END_DATA__ 1 Record no 1 This is a memo for record no one 19960813 __END_DATA__ Message no 3 __END_DATA__ DBD-XBase-1.08/t/5_cdx.t0000644000175000017500000000734212521607341014332 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..9\n"; } END { print "not ok 1\n" unless $::XBaseloaded; } $| = 1; print "Load the module: use XBase\n"; use XBase; $::XBaseloaded = 1; print "ok 1\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems print "Open table $dir/rooms\n"; my $table = new XBase "$dir/rooms" or do { print XBase->errstr, "not ok 2\n"; exit }; print "ok 2\n"; print "prepare_select_with_index on ROOMNAME\n"; my $cur = $table->prepare_select_with_index([ "$dir/rooms.cdx", 'ROOMNAME' ]) or print $table->errstr, 'not '; print "ok 3\n"; my $result = ''; print "Fetch all data\n"; while (my @data = $cur->fetch) { print "@data\n"; $result .= "@data\n"; } my $expected_result = ''; my $line; while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 4\n"; print "find_eq('Celco') and fetch\n"; $cur->find_eq('Celco'); $result = ''; $expected_result = ''; while (my @data = $cur->fetch()) { $result .= "@data\n"; } while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 5\n"; print "find_eq('Celca') and fetch (it doesn't exist, so the result should be the same)\n"; $cur->find_eq('Celca'); $result = ''; while (my @data = $cur->fetch()) { $result .= "@data\n"; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 6\n"; print "prepare_select_with_index on FACILITY\n"; $cur = $table->prepare_select_with_index([ "$dir/rooms.cdx", 'FACILITY' ], 'FACILITY', 'ROOMNAME') or print $table->errstr, 'not '; print "ok 7\n"; print "find_eq('Film') and fetch\n"; $cur->find_eq('Film'); $result = ''; $expected_result = ''; while (my @data = $cur->fetch()) { last if $data[0] ne 'Film'; $result .= "@data\n"; } while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 8\n"; print "find_eq('Main') and fetch\n"; $cur->find_eq('Main'); $result = ''; $expected_result = ''; while (my @data = $cur->fetch()) { last if $data[0] ne 'Main'; $result .= "@data\n"; } while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 9\n"; __END__ None ADR-Foley Audio AVID Main BAY 7 Main Bay 1 Main Bay 2 Main Bay 3 Main Bay 4 Main Bay 5 Main Bay 6 Main Bay 8 Main Bay 10 Main Bay 11 Main Bay 12 Main Bay 14 Main Bay 15 Main Bay 16 Main Bay 17 Main Bay 18 Main Bay 19 Main BullPen Film Celco Film Dub Main FILM 1 Film FILM 2 Film FILM 3 Film Flambe Audio Gigapix Main MacGrfx Main Mach Rm Audio Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio Mix F Audio Mix G Audio Mix H Audio Mix J Audio SCANNING Film Transfer Audio __END_DATA__ Celco Film Dub Main FILM 1 Film FILM 2 Film FILM 3 Film Flambe Audio Gigapix Main MacGrfx Main Mach Rm Audio Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio Mix F Audio Mix G Audio Mix H Audio Mix J Audio SCANNING Film Transfer Audio __END_DATA__ Film FILM 1 Film FILM 2 Film FILM 3 Film SCANNING Film BullPen Film Celco __END_DATA__ Main Bay 1 Main Bay 14 Main Bay 2 Main Bay 5 Main Bay 11 Main Bay 6 Main Bay 3 Main Bay 4 Main Bay 10 Main Bay 8 Main Gigapix Main Bay 12 Main Bay 15 Main Bay 16 Main Bay 17 Main Bay 18 Main Bay 19 Main Dub Main MacGrfx Main AVID Main BAY 7 __END_DATA__ DBD-XBase-1.08/t/2_read.t0000644000175000017500000000662712521607330014467 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..9\n"; } END { print "not ok 1\n" unless $::XBaseloaded; } print "Load the module: use XBase\n"; use XBase; $::XBaseloaded = 1; print "ok 1\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems print "Load table test.dbf\n"; my $table = new XBase("$dir/test"); print XBase->errstr(), 'not ' unless defined $table; print "ok 2\n"; exit unless defined $table; # It doesn't make sense to continue here ;-) print "Read the records, one by one\n"; my $records_expected = join "\n", '0:1:Record no 1:This is a memo for record no one::19960813', '1:2:No 2:This is a memo for record 2:1:19960814', '0:3:Message no 3:This is a memo for record 3:0:19960102'; my $records = join "\n", map { join ":", map { defined $_ ? $_ : "" } $table->get_record($_) } ( 0 .. 2 ); if ($records_expected ne $records) { print "Expected:\n$records_expected\nGot:\n$records\nnot "; } print "ok 3\n"; print "Get record 0 as hash\n"; my $hash_values_expected = 'undef, 19960813, 1, "Record no 1", "This is a memo for record no one", 0'; my %hash = $table->get_record_as_hash(0); my $hash_values = join ', ', map { defined $_ ? ( /^\d+$/ ? $_ : qq["$_"] ) : 'undef' } map { $hash{$_} } sort keys %hash; if ($hash_values_expected ne $hash_values) { print "Expected:\n\@hash{ qw( @{[sort keys %hash]} ) } =\n ($hash_values_expected)\nGot:\n$hash_values\nnot "; } print "ok 4\n"; print "Load the table rooms\n"; my $rooms = new XBase("$dir/rooms"); print XBase->errstr, 'not ' unless defined $rooms; print "ok 5\n"; print "Check the records using read_record\n"; $records_expected = join '', ; $records = join "\n", (map { join ':', map { defined $_ ? $_ : '' } $rooms->get_record($_) } (0 .. $rooms->last_record())), ''; if ($records_expected ne $records) { print "Expected:\n$records_expected\nGot:\n$records\nnot "; } print "ok 6\n"; print "Check the records using get_all_records\n"; my $all_records = $rooms->get_all_records('ROOMNAME', 'FACILITY'); if (not defined $all_records) { print $rooms->errstr, "not "; } else { $records = join "\n", (map { join ':', 0, @$_; } @$all_records), ''; if ($records_expected ne $records) { print "Expected:\n$records_expected\nGot:\n$records\nnot "; } } print "ok 7\n"; $XBase::Base::DEBUG = 0; print "Check if reading record that doesn't exist will produce error\n"; my (@result) = $table->get_record(3); print "not " if @result; print "ok 8\n"; print "Check error message\n"; my $errstr = $table->errstr(); my $errstr_expected = "Can't read record 3, there is not so many of them\n"; if ($errstr ne $errstr_expected) { print "Expected: $errstr_expected\nGot: $errstr\nnot "; } print "ok 9\n"; print <v1 nÄpĆrČt1 1 1 01 10 10 10 '10 15 D tnÄĆrpČ1z 71z 2 2 :2w /2 2h 62h 2z 91w nÄpĆtrČ3 3 !3 .3 3a 13a 4 4 &4 ;3w nÄpĆrtČ4e 44e 5 5 "5 ,5 5b 25b &4 <4w =5w nÄpĆrČt6 6 +6 6g 56g 7 7 $7 &4 >6w tnÄpĆrČ8 8 8 A8w 8d 38d 9 (9 &4 ?7w @7w nÄprĆČt#15 82z -4 6 *7 $%2 )8 ĆrpČnÄt1z 71z 2 2 :2w /2 2h 62h 2z 91w pĆrtnČÄC9h D9w 8 A8w 8d 38d 9 (9 &4 ?7w B9g DBD-XBase-1.08/t/9_dbd_create.t0000644000175000017500000000712312712070132015623 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; eval 'use DBI 1.00'; if ($@ ne '') { print "1..0 # SKIP No DBI module\n"; print "DBI couldn't be loaded, aborting test\n"; print "Error returned from eval was:\n", $@; exit; } print "1..16\n"; print "DBI loaded\n"; } END { print "not ok 1\n" unless $::DBIloaded; } ### DBI->trace(2); $::DBIloaded = 1; print "ok 1\n"; my $dir = ( -d './t' ? 't' : '.' ); print "Unlinking newtable.dbf and newtable.dbt\n"; if (-f "$dir/newtable.dbf") { unlink "$dir/newtable.dbf" or print "Error unlinking $dir/newtable.dbf: $!\n"; } if (-f "$dir/newtable.dbt") { unlink "$dir/newtable.dbt" or print "Error unlinking $dir/newtable.dbt: $!\n"; } print "ok 2\n"; print "Connect to dbi:XBase:$dir\n"; my $dbh = DBI->connect("dbi:XBase:$dir") or do { print $DBI::errstr; print "not ok 3\n"; exit; }; print "ok 3\n"; my $command = 'create table newtable (name char(15), comment memo, uid date, float float(6,2), active boolean)'; print "Prepare command `$command'\n"; my $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 4\n"; exit; }; print "ok 4\n"; print "Execute it\n"; $sth->execute() or do { print $sth->errstr(); print "not ok 5\n"; exit; }; print "ok 5\n"; print "Check if both (dbf and dbt) files were created\n"; print "not " unless -f "$dir/newtable.dbf"; print "ok 6\n"; print "not " unless -f "$dir/newtable.dbt"; print "ok 7\n"; print "Check the new table using core XBase.pm\n"; print "Do new XBase('newtable')\n"; my $table = new XBase("$dir/newtable.dbf"); if (not defined $table) { print XBase->errstr, "\n"; print "not ok 8\n"; exit; } print "ok 8\n"; print "Check the header of the newly created table\n"; my $header = $table->get_header_info(); $header =~ s!^Last change:\t.*$!Last change:\txxxx/xx/xx!m; $header =~ s!^Filename:\tt/!Filename:\t!; $table->close; my $goodheader = join '', ; if ($header ne $goodheader) { print "Got header:\n", $header; print "Good header is:\n", $goodheader; print "not "; } print "ok 9\n"; print "Will select from the newtable table.\n"; if (not $dbh->selectall_arrayref(q! select * from newtable !)) { print $dbh->errstr, "\nnot "; } print "ok 10\n"; print "Will drop the newtable table.\n"; if (not $dbh->do(q! drop table newtable !)) { print $dbh->errstr, "\nnot "; } print "ok 11\n"; print "Will select from the newtable table (should fail).\n"; $dbh->{PrintError} = 0; if ($dbh->selectall_arrayref(q! select * from newtable !)) { print "It did not fail.\nnot "; } print "ok 12\n"; my $table_info_sth = $dbh->table_info(); if (defined $table_info_sth) { print "ok 13\n"; my $table_info_data = $table_info_sth->fetchall_arrayref; if (defined $table_info_data) { print "ok 14\n"; if (scalar @$table_info_data != 12) { print 'not '; } print "ok 15\n"; my @tables = sort map { $_->[2] } grep { not defined $_->[0] and not defined $_->[1] and $_->[3] eq 'TABLE' } @$table_info_data; my $expected_tables = 'afox5 ndx-char ndx-date ndx-num ntx-char rooms rooms1 test tstidx types write write1'; if ("@tables" ne $expected_tables) { print STDERR "Expected table_info: [$expected_tables]\nGot table_info: [@tables]\n"; print 'not '; } print "ok 16\n"; } } $dbh->disconnect(); 1; __DATA__ Filename: newtable.dbf Version: 0x83 (ver. 3 with DBT file) Num of records: 0 Header length: 193 Record length: 41 Last change: xxxx/xx/xx Num fields: 5 Field info: Num Name Type Len Decimal 1. NAME C 15 0 2. COMMENT M 10 0 3. UID D 8 0 4. FLOAT F 6 2 5. ACTIVE L 1 0 DBD-XBase-1.08/t/afox5.dbf0000644000175000017500000000105512520440636014636 0ustar adeltonadelton0cČ2IDC PRICEN NAMECDESCM*MESSAGEM. b20 10John  c21 5Bill DBD-XBase-1.08/t/ndx-date.ndx0000644000175000017500000001400012520435413015345 0ustar adeltonadelton field1 ěƒěš 3˙6x‚š83šŹ 3Ä64&‹&‹T‰Fú‰Vü‹^YƒűvéËŃă.˙§ż á hH@dH@ÇH@*H@H@đH@P@eP@ČP@ rein €†˛BAd€†˛BAǀ†˛BA‡˛BAe‡˛BAȇ˛BA€‡˛BAf€‡˛BAɀ‡˛BAˆ˛BAgˆ˛BAʈ˛BA€ˆ˛BAh€ˆ˛BAˀˆ˛BA‰˛BAi‰˛BẢ˛BA€‰˛BAj€‰˛BÀ‰˛BAŠ˛BAkŠ˛BAΊ˛BA €Š˛BAl€Š˛BAπŠ˛BA ‹˛BAm‹˛BAЋ˛BA €‹˛BAGn€‹˛BAр‹˛BA Œ˛BAoŒ˛BAҌ˛BA €Œ˛BAp€Œ˛BAӀŒ˛BA˛BAq˛BAԍ˛BA€˛BAr€˛BAՀ˛BAŽ˛BAsŽ˛BA֎˛BA€Ž˛BAt€Ž˛BA׀Ž˛BA˛BAu˛BA؏˛BA€˛BAv€˛BAـ˛BA˛BAw˛BAڐ˛BA€˛BAx€˛BAGۀ˛BA‘˛BAy‘˛BAܑ˛BA€‘˛BAz€‘˛BA݀‘˛BA’˛BA{’˛BAޒ˛BA€’˛BA|€’˛BA߀’˛BA“˛BA}“˛BAŕ“˛BA€“˛BA~€“˛BAဓ˛BA”˛BA”˛BA┲BA€”˛BA€€”˛BA〔˛BA•˛BA•˛BA䕲BA€•˛BA‚€•˛BA倕˛BAG –˛BAƒ–˛BA斲BA!€–˛BA„€–˛BA瀖˛BA"—˛BA…—˛BA藲BA#€—˛BA†€—˛BA逗˛BA$˜˛BA‡˜˛BA꘲BA%€˜˛BAˆ€˜˛BA뀘˛BA&™˛BA‰™˛BA왲BA'€™˛BAŠ€™˛BA퀙˛BA(š˛BA‹š˛BABA)€š˛BAŒ€š˛BA˛BA*›˛BAG›˛BAđ›˛BA+€›˛BAŽ€›˛BAń€›˛BA,œ˛BAœ˛BAňœ˛BA-€œ˛BA€œ˛BA󀜲BA.˛BA‘˛BAô˛BA/€˛BA’€˛BAő€˛BA0ž˛BA“ž˛BAöž˛BA1€ž˛BA”€ž˛BA÷€ž˛BA2Ÿ˛BA•Ÿ˛BAřŸ˛BA3€Ÿ˛BA–€Ÿ˛BAů€Ÿ˛BA4 ˛BA— ˛BAGú ˛BA5€ ˛BA˜€ ˛BAű€ ˛BA6Ą˛BA™Ą˛BAüĄ˛BA7€Ą˛BAš€Ą˛BAý€Ą˛BA8˘˛BA›˘˛BAţ˘˛BA9€˘˛BAœ€˘˛BA˙€˘˛BA:Ł˛BAŁ˛BAŁ˛BA;€Ł˛BAž€Ł˛BA€Ł˛BA<¤˛BAŸ¤˛BA¤˛BA=€¤˛BA €¤˛BA€¤˛BA>Ľ˛BAĄĽ˛BAĽ˛BAG?€Ľ˛BA˘€Ľ˛BA€Ľ˛BA@Ś˛BAŁŚ˛BAŚ˛BAA€Ś˛BA¤€Ś˛BA€Ś˛BAB§˛BAĽ§˛BA§˛BAC€§˛BAŚ€§˛BA €§˛BAD¨˛BA§¨˛BA ¨˛BAE€¨˛BA¨€¨˛BA €¨˛BAFŠ˛BAŠŠ˛BA Š˛BAG€Š˛BAŞ€Š˛BA €Š˛BAHŞ˛BAŤŞ˛BAŞ˛BAI€Ş˛BAGŹ€Ş˛BA€Ş˛BAJŤ˛BA­Ť˛BAŤ˛BAK€Ť˛BAŽ€Ť˛BA€Ť˛BALŹ˛BAŻŹ˛BAŹ˛BAM€Ź˛BA°€Ź˛BA€Ź˛BAN­˛BAą­˛BA­˛BAO€­˛BA˛€­˛BA€­˛BAPŽ˛BAłŽ˛BAŽ˛BAQ€Ž˛BA´€Ž˛BA€Ž˛BARŻ˛BAľŻ˛BAŻ˛BAS€Ż˛BAś€Ż˛BAG€Ż˛BAT°˛BAˇ°˛BA°˛BAU€°˛BA¸€°˛BA€°˛BAVą˛BAšą˛BAą˛BAW€ą˛BAş€ą˛BA€ą˛BAX˛˛BAť˛˛BA˛˛BAY€˛˛BAź€˛˛BA€˛˛BAZł˛BA˝ł˛BA ł˛BA[€ł˛BAž€ł˛BA!€ł˛BA\´˛BAż´˛BA"´˛BA]€´˛BAŔ€´˛BA#€´˛BAG^ľ˛BAÁľ˛BA$ľ˛BA_€ľ˛BA€ľ˛BA%€ľ˛BA`ś˛BAĂś˛BA&ś˛BAa€ś˛BAĀś˛BA'€ś˛BAbˇ˛BAš˛BA(ˇ˛BAc€ˇ˛BAƀˇ˛BA)€ˇ˛BA€˛˛BAZł˛BA˝ł˛BA ł˛BA[€ł˛BAž€ł˛BA!€ł˛BA\´˛BAż´˛BA"´˛BA]€´˛BAŔ€´˛BA#€´˛BAG €‹˛BA€˛BA€•˛BA›˛BA ˛BAĽ˛BA€Ş˛BA€Ż˛BA €´˛BA P@VT@WX@X\@Y`@Zd@[h@\l@]p@^t@_x@`|@a€@b„@cˆ@dŒ@e@f”@g˜@hœ@i @j¤@k¨@lŹ@m°@n´@o¸@pź@qŔ@rĐ@sDBD-XBase-1.08/t/6_attach_cdx.t0000644000175000017500000000305712521607341015656 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..7\n"; } END { print "not ok 1\n" unless $::XBaseloaded; } $XBase::Index::VERBOSE = 0; print "Load the module: use XBase\n"; use XBase; $::XBaseloaded = 1; print "ok 1\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems print "Unlink write.dbf and write.dbt, make a copy of test.dbf and test.dbt\n"; my @FILES = map { "$dir/$_" } qw! rooms1.dbf rooms1.cdx !; for (@FILES) { if (-f $_ and not unlink $_) { print "Error unlinking $_: $!\n"; } } use File::Copy; copy("$dir/rooms.dbf", "$dir/rooms1.dbf"); copy("$dir/rooms.cdx", "$dir/rooms1.cdx"); for (@FILES) { if (not -f $_) { die "The files to do the write tests were not created, aborting\n"; } # Does not make sense to continue } print "ok 2\n"; print "Open table $dir/rooms1\n"; my $table = new XBase "$dir/rooms1" or do { print XBase->errstr, "not ok 3\n"; exit }; print "ok 3\n"; print "Attach indexfile $dir/rooms1.cdx\n"; $table->attach_index("$dir/rooms1.cdx") or do { print XBase->errstr, "not ok 4\n"; exit }; print "ok 4\n"; print "Delete record 26: Dub:Main\n"; $table->delete_record(26) or print STDERR $table->errstr, 'not '; print "ok 5\n"; print "Undelete record 26: Dub:Main\n"; $table->undelete_record(26) or print STDERR $table->errstr, 'not '; print "ok 6\n"; print "Append record: Krtek:Jezek\n"; $table->set_record($table->last_record + 1, 'Krtek', 'Jezek') or print STDERR $table->errstr, 'not '; print "ok 7\n"; DBD-XBase-1.08/t/ntx-char.dbf0000644000175000017500000001247512520435413015345 0ustar adeltonadeltona DAOV1CÔON 10 8 6 1 3 5 15 7 2 4 10 9 8 7 6 5 4 3 2 1 3a 5b 8d 4e 6g 2h 1z 2z 10 8 6 1 3 5 15 7 2 4 10 9 8 7 6 5 4 3 2 1 3a 5b 8d 4e 6g 2h 1z 2z 1w 2w 3w 4w 5w 6w 7w 7w 8w 9g 9h 9w DBD-XBase-1.08/t/rooms.cdx0000644000175000017500000002500012521607341014771 0ustar adeltonadelton ŕ˙˙˙˙˙˙˙˙˝˙˙P $a` ROOMNAMEMAINILMFACILITYAUDIO ˙˙˙˙ `  roomname*˙˙˙˙˙˙˙˙ö˙˙* P(a)PAEE EEE E DE EEEEEEE$1%Pp@EEA 0&03QTTTT!T"T#T'T  TransferSCANNINGJHGFEDCBix Ah RmMacGrfxGigapixlambe32FILM 1DubCelcoullPen9876542110865432ay 1BAY 7VIDADR-Foley None `'  facility*˙˙˙˙˙˙˙˙]˙˙ * PUUUUUUUU!U"U#U'U`dd d$d%d`dddddd d d d d ddddddd&d(d)dMainFilmAudio h 2  roomnameTRIM(UPPER(facility))=="AUDIO" ˙˙˙˙˙˙˙˙`˙˙!"#'Transfer J H G F E D C B ix A Mach Rm Flambe ADR-Foley  h   roomnameTRIM(UPPER(facility))=="FILM"˙˙˙˙˙˙˙˙¤˙˙$% SCANNING 3 2 FILM 1 Celco BullPen " hh  roomnameTRIM(UPPER(facility))=="MAIN"˙˙˙˙˙˙˙˙"˙˙()     &MacGrfx Gigapix Dub 9 8 7 6 5 4 2 1 10 8 6 5 4 3 2 ay 1 BAY 7 AVID ( h   roomnameTRIM(UPPER(facility))=="FILM"˙˙˙˙˙˙˙˙¤˙˙$% SCANNING 3 2 FILM 1 Celco BullPen DBD-XBase-1.08/t/2_read_stream.t0000644000175000017500000000276212521607341016040 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..5\n"; } END { print "not ok 1\n" unless $::XBaseloaded; } $^W = 1; print "Load the module: use XBase\n"; use XBase; use IO::File; $::XBaseloaded = 1; print "ok 1\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems print "Set XBase::Base::SEEK_VIA_READ(1)\n"; XBase::Base::SEEK_VIA_READ(1); print "Load table test.dbf\n"; my $table = new XBase("$dir/test", 'ignorememo' => 1); print XBase->errstr(), 'not ' unless defined $table; print "ok 2\n"; exit unless defined $table; # It doesn't make sense to continue here ;-) print "Load the records, one by one\n"; my $records_expected = join "\n", '0:1:Record no 1:::19960813', '1:2:No 2::1:19960814', '0:3:Message no 3::0:19960102'; my $records = join "\n", map { join ":", map { defined $_ ? $_ : "" } $table->get_record($_) } ( 0 .. 2 ); if ($records_expected ne $records) { print "Expected:\n$records_expected\nGot:\n$records\nnot "; } print "ok 3\n"; print "And now will read a dbf from filehandle.\n"; XBase::Base::SEEK_VIA_READ(0); my $fh = new IO::File "$dir/test.dbf"; my $fhtable = new XBase("-", 'fh' => $fh, 'ignorememo' => 1); print XBase->errstr(), 'not ' unless defined $fhtable; print "ok 4\n"; my $fhrecords = join "\n", map { join ":", map { defined $_ ? $_ : "" } $table->get_record($_) } ( 0 .. 2 ); if ($records_expected ne $fhrecords) { print "Expected:\n$records_expected\nGot:\n$fhrecords\nnot "; } print "ok 5\n"; 1; DBD-XBase-1.08/t/ndx-num.dbf0000644000175000017500000001471012520435413015201 0ustar adeltonadeltona RA FIELD1NIJ  1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099DBD-XBase-1.08/t/1_header.t0000644000175000017500000000560512521607341015000 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..10\n"; } END { print "not ok 1\n" unless $::XBaseloaded; } BEGIN { print "Load the module: use XBase\n"; } use XBase; $::XBaseloaded = 1; print "ok 1\n"; print "This is XBase version $XBase::VERSION\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems print "Create the new XBase object, load the data from table test.dbf\n"; my $table = new XBase("$dir/test.dbf"); print XBase->errstr(), 'not ' unless defined $table; print "ok 2\n"; exit unless defined $table; # It doesn't make sense to continue here ;-) print "Now, look into the object and check, if it has been filled OK\n"; my $info = sprintf "Version: 0x%02x, last record: %d, last field: %d", $table->version, $table->last_record, $table->last_field; my $info_expect = 'Version: 0x83, last record: 2, last field: 4'; if ($info ne $info_expect) { print "Expected:\n$info_expect\nGot:\n$info\nnot "; } print "ok 3\n"; print "Check the field names\n"; my $names = join ' ', $table->field_names(); my $names_expect = 'ID MSG NOTE BOOLEAN DATES'; if ($names ne $names_expect) { print "Expected: $names_expect\nGot: $names\nnot "; } print "ok 4\n"; print "Get verbose header info (using header_info)\n"; $info = $table->get_header_info(); $info_expect = join '', ; if ($info ne $info_expect) { print "Expected: $info_expect\nGot: $info\nnot "; } print "ok 5\n"; $XBase::Base::DEBUG = 0; print "Check if loading table that doesn't exist will produce error\n"; my $badtable = new XBase("nonexistent.dbf"); print 'not ' if defined $badtable; print "ok 6\n"; print "Check the returned error message\n"; my $errstr = XBase->errstr(); my $errstr_expect = 'Error opening file nonexistent.dbf:'; if (index($errstr, $errstr_expect) != 0) { print "Expected: $errstr_expect\nGot: $errstr\nnot "; } print "ok 7\n"; $table->close(); print "Load table without specifying the .dbf suffix\n"; $table = new XBase("$dir/test"); print "not " unless defined $table; print "ok 8\n"; print < 1); print XBase->errstr(), 'not ' unless defined $table; print "ok 9\n"; my $last_record = $table->last_record; if ($last_record != 2) { print "recompute_lastrecno computed $last_record records\nnot "; } print "ok 10\n"; __DATA__ Filename: t/test.dbf Version: 0x83 (ver. 3 with DBT file) Num of records: 3 Header length: 193 Record length: 279 Last change: 1996/8/17 Num fields: 5 Field info: Num Name Type Len Decimal 1. ID N 5 0 2. MSG C 254 0 3. NOTE M 10 0 4. BOOLEAN L 1 0 5. DATES D 8 0 DBD-XBase-1.08/t/ndx-char.ndx0000644000175000017500000001300012520435413015344 0ustar adeltonadelton NXv1 h pack 1 1 10 10 2 3 3 3a 4 4 5 6 10 2 3 4 6 7 15 1z 2 2 2h 3 6 6g 7 7 8 9 8 8 8d 9 8 9 4e 5 5 5b 6 6 2 2h 2z 3 2h 3 4 6 7 4 6 7 3 6 7 4 6 7 DBD-XBase-1.08/t/lib.pl0000644000175000017500000001317012520436666014253 0ustar adeltonadelton# Hej, Emacs, give us -*- perl mode here! # # $Id: lib.pl 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # lib.pl is the file where database specific things should live, # whereever possible. For example, you define certain constants # here and the like. # require 5.003; use strict; use vars qw($mdriver $dbdriver $childPid $test_dsn $test_user $test_password $verbose); # # Driver names; EDIT THIS! # $mdriver = 'XBase'; $dbdriver = $mdriver; # $dbdriver is usually just the same as $mdriver. # The exception is DBD::pNET where we have to # to separate between local driver (pNET) and # the remote driver ($dbdriver) # # DSN being used; do not edit this, edit "$dbdriver.dbtest" instead # $test_dsn = $ENV{'DBI_DSN'} || "DBI:$dbdriver:t"; $test_user = $ENV{'DBI_USER'} || ""; $test_password = $ENV{'DBI_PASS'} || ""; $::COL_NULLABLE = 1; $::COL_KEY = 2; my $file; if (-f ($file = "t/$dbdriver.dbtest") || -f ($file = "$dbdriver.dbtest") || -f ($file = "../tests/$dbdriver.dbtest")) { eval { require $file; }; if ($@) { print STDERR "Cannot execute $file: $@.\n"; print "1..0\n"; exit 0; } } if (-f ($file = "t/$mdriver.mtest") || -f ($file = "$mdriver.mtest") || -f ($file = "../tests/$mdriver.mtest")) { eval { require $file; }; if ($@) { print STDERR "Cannot execute $file: $@.\n"; print "1..0\n"; exit 0; } } # # The Testing() function builds the frame of the test; it can be called # in many ways, see below. # # Usually there's no need for you to modify this function. # # Testing() (without arguments) indicates the beginning of the # main loop; it will return, if the main loop should be # entered (which will happen twice, once with $state = 1 and # once with $state = 0) # Testing('off') disables any further tests until the loop ends # Testing('group') indicates the begin of a group of tests; you # may use this, for example, if there's a certain test within # the group that should make all other tests fail. # Testing('disable') disables further tests within the group; must # not be called without a preceding Testing('group'); by default # tests are enabled # Testing('enabled') reenables tests after calling Testing('disable') # Testing('finish') terminates a group; any Testing('group') must # be paired with Testing('finish') # # You may nest test groups. # { # Note the use of the pairing {} in order to get local, but static, # variables. my (@stateStack, $count, $off); $count = 0; sub Testing(;$) { my ($command) = shift; if (!defined($command)) { @stateStack = (); $off = 0; if ($count == 0) { ++$count; $::state = 1; } elsif ($count == 1) { my($d); if ($off) { print "1..0\n"; exit 0; } ++$count; $::state = 0; print "1..$::numTests\n"; } else { return 0; } if ($off) { $::state = 1; } $::numTests = 0; } elsif ($command eq 'off') { $off = 1; $::state = 0; } elsif ($command eq 'group') { push(@stateStack, $::state); } elsif ($command eq 'disable') { $::state = 0; } elsif ($command eq 'enable') { if ($off) { $::state = 0; } else { my $s; $::state = 1; foreach $s (@stateStack) { if (!$s) { $::state = 0; last; } } } return; } elsif ($command eq 'finish') { $::state = pop(@stateStack); } else { die("Testing: Unknown argument\n"); } return 1; } # # Read a single test result # sub Test ($;$$) { my($result, $error, $diag) = @_; ++$::numTests; if ($count == 2) { if (defined($diag)) { printf("$diag%s", (($diag =~ /\n$/) ? "" : "\n")); } if ($::state || $result) { print "ok $::numTests\n"; return 1; } else { printf("not ok $::numTests%s\n", (defined($error) ? " $error" : "")); return 0; } } return 1; } } # # Print a DBI error message # sub DbiError ($$) { my($rc, $err) = @_; if ($::verbose) { print "Test $::numTests: DBI error $rc, $err\n"; } } # # This functions generates a list of possible DSN's aka # databases and returns a possible table name for a new # table being created. # # Problem is, we have two different situations here: Test scripts # call us by pasing a dbh, which is fine for most situations. # From within DBD::pNET, however, the dbh isn't that meaningful. # Thus we are working with the global variable $listTablesHook: # Once defined, we call &$listTablesHook instead of ListTables. # # See DBD::pNET/t/pNET.mtest for details. # { use vars qw($listTablesHook); my(@tables, $testtable, $listed); $testtable = "testaa"; $listed = 0; sub FindNewTable($) { my($dbh) = @_; if (!$listed) { if (defined($listTablesHook)) { @tables = &$listTablesHook($dbh); } elsif (defined(&ListTables)) { @tables = &ListTables($dbh); } else { die "Fatal: ListTables not implemented.\n"; } $listed = 1; } # A small loop to find a free test table we can use to mangle stuff in # and out of. This starts at testaa and loops until testaz, then testba # - testbz and so on until testzz. my $foundtesttable = 1; my $table; while ($foundtesttable) { $foundtesttable = 0; foreach $table (@tables) { if ($table eq $testtable) { $testtable++; $foundtesttable = 1; } } } $table = $testtable; $testtable++; $table; } } $verbose = 1; sub ErrMsg (@_) { if ($verbose) { print (@_); } } sub ErrMsgF (@_) { if ($verbose) { printf (@_); } } 1; DBD-XBase-1.08/t/5_ndx.t0000644000175000017500000001006712521607341014343 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..12\n"; } END { print "not ok 1\n" unless $::XBaseloaded; } $| = 1; print "Load the module: use XBase\n"; use XBase; $::XBaseloaded = 1; print "ok 1\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems print "Open table $dir/ndx-char\n"; my $table = new XBase "$dir/ndx-char" or do { print XBase->errstr, "not ok 2\n"; exit }; print "ok 2\n"; print "prepare_select_with_index\n"; my $cur = $table->prepare_select_with_index("$dir/ndx-char.ndx") or print $table->errstr, 'not '; print "ok 3\n"; my $result = ''; print "Fetch all data\n"; while (my @data = $cur->fetch) { $result .= "@data\n"; } my $expected_result = ''; my $line; while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 4\n"; print "find_eq('6g') and fetch\n"; $cur->find_eq('6g'); $result = ''; $expected_result = ''; while (my @data = $cur->fetch()) { $result .= "@data\n"; } while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 5\n"; print "find_eq('6e') and fetch (it doesn't exist, so the result should be the same)\n"; $cur->find_eq('6e'); $result = ''; while (my @data = $cur->fetch()) { $result .= "@data\n"; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 6\n"; print "Before we look at the numeric and data index files, let's check if it makes sense (because of the way we implement double floats ;-)\n"; my $doubleoneseven = pack 'd', 1.7; my $okoneseven = '3ffb333333333333'; if (join('', unpack 'H16', $doubleoneseven) ne $okoneseven and join('', unpack 'H16', reverse($doubleoneseven)) ne $okoneseven) { print "Number 1.7 encoded as natural double on your machine gives ", join('', unpack 'H16', $doubleoneseven), ",\nwhich is not what I would expect.\n"; print STDERR <errstr, 'not '; print "ok 7\n"; $cur = $table->prepare_select_with_index("$dir/ndx-num.ndx") or print $table->errstr, 'not '; print "ok 8\n"; print "find_eq(1042) and fetch results\n"; $cur->find_eq(1042); $result = ''; $expected_result = ''; while (my @data = $cur->fetch()) { last if $data[0] != 1042; $result .= "@data\n"; } while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 9\n"; print "Open ndx-date and index\n"; $table = new XBase "$dir/ndx-date.dbf" or print XBase->errstr, 'not '; print "ok 10\n"; $cur = $table->prepare_select_with_index("$dir/ndx-date.ndx") or print $table->errstr, 'not '; print "ok 11\n"; print "find_eq(2450795), which is Julian date for 1997/12/12 and fetch results\n"; ### use Data::Dumper; ### print Dumper $cur; $cur->find_eq(2450795); ### print Dumper $cur; $result = ''; $expected_result = ''; while (my @data = $cur->fetch()) { $result .= "@data\n"; } while (defined($line = )) { last if $line eq "__END_DATA__\n"; $expected_result .= $line; } if ($result ne $expected_result) { print "Expected:\n${expected_result}Got:\n${result}not "; } print "ok 12\n"; __END__ 1 1 10 10 15 1z 2 2 2h 2z 3 3 3a 4 4 4e 5 5 5b 6 6 6g 7 7 8 8 8d 9 __END_DATA__ 6g 7 7 8 8 8d 9 __END_DATA__ 1042 1042 1042 1042 1042 1042 __END_DATA__ 19971212 19971212 19971212 19971213 19971213 19971213 19971214 19971214 19971214 19971215 19971215 19971215 19971216 19971216 19971216 __END_DATA__ DBD-XBase-1.08/t/XBase.mtest0000644000175000017500000000025312520435413015213 0ustar adeltonadelton# Hej, Emacs, give us -*- perl -*- mode here! # # $Id: mysql.mtest 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # module specific definitions for a 'mysql' database 1; DBD-XBase-1.08/t/8_dbd_insert.t0000644000175000017500000000661712521607341015700 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; eval 'use DBI 1.00'; if ($@ ne '') { print "1..0 # SKIP No DBI module\n"; print "DBI couldn't be loaded, aborting test\n"; print "Error returned from eval was:\n", $@; exit; } print "1..9\n"; print "DBI loaded\n"; } END { print "not ok 1\n" unless $::DBIloaded; } ### DBI->trace(2); $::DBIloaded = 1; print "ok 1\n"; my $dir = ( -d './t' ? 't' : '.' ); print "Unlinking write.dbf write.dbt\n"; if (-f "$dir/write.dbf") { unlink "$dir/write.dbf" or print "Error unlinking $dir/write.dbf: $!\n"; } print "We will make a copy of database files rooms.dbf\n"; eval "use File::Copy;"; if ($@) { print "Look's like you do not have File::Copy, we will do cp\n"; system("cp", "$dir/rooms.dbf", "$dir/write.dbf"); } else { print "Will use File::Copy\n"; copy("$dir/rooms.dbf", "$dir/write.dbf"); } unless (-f "$dir/write.dbf") { print "not ok 2\n"; exit; } # Does not make sense to continue print "ok 2\n"; print "Connect to dbi:XBase:$dir\n"; my $dbh = DBI->connect("dbi:XBase:$dir") or do { print $DBI::errstr; print "not ok 3\n"; exit; }; print "ok 3\n"; my $command = 'insert into write values ("new room", "new facility")'; print "Prepare command `$command'\n"; my $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 4\n"; exit; }; print "ok 4\n"; print "Execute it\n"; $sth->execute() or do { print $sth->errstr(); print "not ok 5\n"; exit; }; print "ok 5\n"; $command = 'insert into write ( facility ) values ("Lights")'; print "Prepare command `$command'\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 6\n"; exit; }; print "ok 6\n"; print "Execute it\n"; $sth->execute() or do { print $sth->errstr(); print "not ok 7\n"; exit; }; print "ok 7\n"; print "And now we should check if it worked\n"; my $selcom = 'select * from write'; print "Prepare and execute '$selcom'\n"; my $select = $dbh->prepare($selcom) or do { print $dbh->errstr(); print "not ok 8\n"; exit; }; $select->execute() or do { print $select->errstr(); print "not ok 8\n"; exit; }; print "ok 8\n"; my $result = ''; my @data; while (@data = $select->fetchrow_array()) { $result .= "@data\n"; } my $expected_result = join '', ; if ($result ne $expected_result) { print "Expected:\n$expected_result"; print "Got:\n$result"; print "not "; } print "ok 9\n"; $sth->finish(); $command = 'insert into write(facility,roomname) values (?,?)'; print "Preparing $command\n"; $sth = $dbh->prepare($command) or do { print $dbh->errstr(); print "not ok 10\n"; exit; }; $sth->execute('krtek', 'jezek') or do { print $sth->errstr(); print "not ok 11\n"; exit; }; my @row = $dbh->selectrow_array("select roomname,facility from write where facility = 'krtek'"); if ("@row" ne 'jezek krtek') { print "Expected 'jezek krtek', got '@row'\nnot ok 12\n"; } $dbh->disconnect(); 1; __DATA__ None Bay 1 Main Bay 14 Main Bay 2 Main Bay 5 Main Bay 11 Main Bay 6 Main Bay 3 Main Bay 4 Main Bay 10 Main Bay 8 Main Gigapix Main Bay 12 Main Bay 15 Main Bay 16 Main Bay 17 Main Bay 18 Main Mix A Audio Mix B Audio Mix C Audio Mix D Audio Mix E Audio ADR-Foley Audio Mach Rm Audio Transfer Audio Bay 19 Main Dub Main Flambe Audio FILM 1 Film FILM 2 Film FILM 3 Film SCANNING Film Mix F Audio Mix G Audio Mix H Audio BullPen Film Celco Film MacGrfx Main Mix J Audio AVID Main BAY 7 Main new room new facili Lights DBD-XBase-1.08/t/5_ntx.t0000644000175000017500000000314512521607341014362 0ustar adeltonadelton#!/usr/bin/perl -w use strict; BEGIN { $| = 1; print "1..66\n"; } END { print "not ok 1\n" unless $::XBaseloaded; } $| = 1; print "Load the module: use XBase\n"; use XBase; $::XBaseloaded = 1; print "ok 1\n"; my $dir = ( -d "t" ? "t" : "." ); $XBase::Base::DEBUG = 1; # We want to see any problems print "Open table $dir/ntx-char\n"; my $table = new XBase "$dir/ntx-char" or do { print XBase->errstr, "not ok 2\n"; exit }; print "ok 2\n"; print "prepare_select\n"; my $cur = $table->prepare_select or print $table->errstr, 'not '; print "ok 3\n"; print "fetch all rows and sort them\n"; my @expected; while (my @row = $cur->fetch) { push @expected, @row; } my @sorted = sort @expected; my $expected = join "\n", @sorted, ''; print "ok 4\n"; print "prepare_select_with_index $dir/ntx-char.ntx\n"; $cur = $table->prepare_select_with_index("$dir/ntx-char.ntx") or print $table->errstr, 'not '; print "ok 5\n"; my $got = ''; while (my @row = $cur->fetch) { $got .= "@row\n"; } if ($got ne $expected) { print "Expected:\n${expected}Got:\n${got}not "; } print "ok 6\n"; my $test = 7; my $prev = ''; for (my $i = 0; $i < @sorted; $i++) { next if $sorted[$i] eq $prev; $prev = $sorted[$i]; print "find_eq($sorted[$i])\n"; $cur->find_eq($sorted[$i]) or print "not "; print "ok $test\n"; $test++; my $got = ''; while (my @row = $cur->fetch) { $got .= "@row\n"; } my $expected = join "\n", @sorted[$i .. $#sorted], ''; print "compare results\n"; if ($got ne $expected) { print "Index $i, find_eq($sorted[$i])\nExpected:\n${expected}Got:\n${got}not "; } print "ok $test\n"; $test++; } DBD-XBase-1.08/t/test.dbf0000644000175000017500000000200707143733103014570 0ustar adeltonadeltonƒ`ÁIDNÚ?MSGC Ú?ţNOTEM Ú? BOOLEANLÚ?DATESDÚ? 1Record no 1 1 19960813* 2No 2 2Y19960814 3Message no 3 3N19960102DBD-XBase-1.08/t/ndx-num.ndx0000644000175000017500000002600012520435413015232 0ustar adeltonadeltonfield1  ƒ~ütéd˙ƒ>äŞtšÜjFúPč!éM˙˙vúčr‰Fú@+Ŕë ‹Fú#Ŕué3˙‹ĺ]ĂU‹ěš`3Ä64&‹&‹T&ƒ&ƒT&Ä´Ť&‰D&‰Tšj+ŔPÄ64&˙´­&˙´Ť&˙tšç jÄv&‹€äţ&‰‹ĺ]ÂU‹ěƒěš 3˙6x‚š83šŹ 3Ä64&‹&‹T‰Fú‰Vü‹^YƒűvéËŃă.˙§ƒŚu–0ş2w^2Ű;Śu–0ƒF:–0Š2{  B B? –0Ž28WJ –0¸28VJ BA BA^u–0Ns–0Ć2ëQVJPVJ ü3ljVJ LJNDX-NUMIN5\AGENT\LCS\standard.zip˘uI3Á$3!? –043dŁa4Ű;@3Ű;J48Łe4Ű;30VJFIELD1H@dH@ÇH@*H@H@đH@P@eP@ČP@+P@ŽP@ńP@X@fX@ÉX@,X@X@ňX@`@g`@Ę`@-`@`@ó`@h@hh@Ëh@.h@‘h@ôh@p@°Yip@Ěp@/p@’p@őp@x@jx@Íx@0x@“x@öx@€@k€@΀@1€@”€@÷€@ ˆ@lˆ@ψ@2ˆ@•ˆ@řˆ@ @m@А@3@–@ů@ ˜@n˜@°Yј@4˜@—˜@ú˜@  @o @Ň @5 @˜ @ű @ ¨@p¨@Ó¨@6¨@™¨@ü¨@°@q°@Ô°@7°@š°@ý°@¸@r¸@Ő¸@8¸@›¸@ţ¸@Ŕ@sŔ@ÖŔ@°Y9Ŕ@œŔ@˙Ŕ@ȏ@tȏ@×ȏ@:ȏ@ȏ@ȏ@Џ@uЏ@ŘЏ@;Џ@žЏ@Џ@؏@v؏@Ů؏@<؏@Ÿ؏@؏@ŕ@wŕ@Úŕ@=ŕ@ ŕ@ŕ@č@xč@Űč@>č@°YĄč@č@đ@yđ@Üđ@?đ@˘đ@đ@ř@zř@Ýř@@ř@Łř@ř@@{@ސ@A@¤@@@|@ߐ@B@Ľ@@@}@ŕ@C@Ś@°Y @ @~ @á @D @§ @  @@@â@E@¨@ @@€@ă@F@Š@ @@@ä@G@ސ@ @@‚@ĺ@H@Ť@@°Y @ƒ @ć @I @Ź @ @!$@„$@ç$@J$@­$@$@"(@…(@č(@K(@Ž(@(@#,@†,@é,@L,@Ż,@,@$0@‡0@ę0@M0@°0@0@%4@°Yˆ4@ë4@N4@ą4@4@&8@‰8@ě8@O8@˛8@8@'<@Š<@í<@P<@ł<@<@(@@‹@@î@@Q@@´@@@@)D@ŒD@ďD@RD@ľD@D@*H@H@°YđH@SH@śH@H@+L@ŽL@ńL@TL@ˇL@L@,P@P@ňP@UP@¸P@P@-T@T@óT@VT@šT@T@.X@‘X@ôX@WX@şX@X@/\@’\@ő\@°YX\@ť\@\@0`@“`@ö`@Y`@ź`@`@1d@”d@÷d@Zd@˝d@ d@2h@•h@řh@[h@žh@!h@3l@–l@ůl@\l@żl@"l@4p@—p@úp@]p@°YŔp@#p@5t@˜t@űt@^t@Át@$t@6x@™x@üx@_x@Âx@%x@7|@š|@ý|@`|@Ă|@&|@8€@›€@ţ€@a€@Ä€@'€@9„@œ„@˙„@b„@Ĺ„@°Y(„@:ˆ@ˆ@ˆ@cˆ@Ćˆ@)ˆ@;Œ@žŒ@Œ@dŒ@ÇŒ@*Œ@<@Ÿ@@e@Ȑ@+@=”@ ”@”@f”@É”@,”@>˜@Ą˜@˜@g˜@Ę˜@-˜@°Y?œ@˘œ@œ@hœ@Ëœ@.œ@@ @Ł @ @i @Ě @/ @A¤@¤¤@¤@j¤@ͤ@0¤@B¨@Ľ¨@¨@k¨@ؐ@1¨@CŹ@ŚŹ@ Ź@lŹ@ĎŹ@2Ź@D°@°Y§°@ °@m°@Đ°@3°@E´@¨´@ ´@n´@Ń´@4´@F¸@Š¸@ ¸@o¸@Ҹ@5¸@Gź@Şź@ ź@pź@Óź@6ź@HŔ@ŤŔ@Ŕ@qŔ@ÔŔ@7Ŕ@IĐ@ŹÄ@°YĐ@rĐ@ŐĐ@8Đ@JȐ@­Č@Ȑ@sȐ@ÖȐ@9Ȑ@K̐@ŽĚ@̐@t̐@×̐@:̐@LА@ŻĐ@А@uА@ŘА@;А@MԐ@°Ô@Ԑ@vԐ@ŮԐ@<Ԑ@Nؐ@ąŘ@ؐ@°Ywؐ@Úؐ@=ؐ@Oܐ@˛Ü@ܐ@xܐ@Űܐ@>ܐ@Pŕ@łŕ@ŕ@yŕ@Üŕ@?ŕ@Qä@´ä@ä@zä@Ýä@@ä@Rč@ľč@č@{č@Ţč@Ač@Sě@śě@ě@|ě@°Yßě@Bě@Tđ@ˇđ@đ@}đ@ŕđ@Cđ@Uô@¸ô@ô@~ô@áô@Dô@Vř@šř@ř@ř@âř@Eř@Wü@şü@ü@€ü@ăü@Fü@X‘@ť‘@‘@‘@ä‘@°YG‘@Y‘@ź‘@‘@‚‘@ĺ‘@H‘@Z‘@˝‘@ ‘@ƒ‘@ć‘@I‘@[ ‘@ž ‘@! ‘@„ ‘@ç ‘@J ‘@\‘@ż‘@"‘@…‘@č‘@K‘@]‘@Ŕ‘@#‘@†‘@é‘@L‘@°Y^‘@Á‘@$‘@‡‘@ę‘@M‘@_‘@‘@%‘@ˆ‘@ë‘@N‘@` ‘@Ă ‘@& ‘@‰ ‘@ě ‘@O ‘@a$‘@Ä$‘@'$‘@Š$‘@í$‘@P$‘@b(‘@Ĺ(‘@((‘@‹(‘@î(‘@Q(‘@c,‘@°YĆ,‘@),‘@Œ,‘@ď,‘@R,‘@M‘@_‘@‘@%‘@ˆ‘@ë‘@N‘@` ‘@Ă ‘@& ‘@‰ ‘@ě ‘@O ‘@a$‘@Ä$‘@'$‘@Š$‘@í$‘@P$‘@b(‘@Ĺ(‘@((‘@‹(‘@î(‘@Q(‘@c,‘@°Yp@˜@Ŕ@č@@@4@H@ \@ p@ „@ ˜@ °@Đ@ؐ@ě@‘@‘@,‘@¤xmią‡žią‡ž_2ď@úRżD!H°\¨ @.ŔxýׁfđymiÁ‡ŐkÅÓ_2~2ô ŻÄ€H°]D2Ŕ˙˙xýׁbđDBD-XBase-1.08/META.yml0000664000175000017500000000103113037112723014136 0ustar adeltonadelton--- abstract: 'Reads and writes XBase (dbf) files, includes DBI support' author: - 'Jan Pazdziora' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: DBD-XBase no_index: directory: - t - inc version: '1.08' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' DBD-XBase-1.08/MANIFEST0000644000175000017500000000217612521607341014031 0ustar adeltonadeltonChanges INSTALL MANIFEST Makefile.PL README ToDo bin/dbfdump.PL bin/indexdump.PL dbit/00base.t dbit/10dsnlist.t dbit/20createdrop.t dbit/30insertfetch.t dbit/40bindparam.t dbit/40blobs.t dbit/40listfields.t dbit/40nulls.t dbit/40numrows.t dbit/50chopblanks.t dbit/50commit.t driver_characteristics eg/copy_table eg/create_table eg/use_index lib/DBD/XBase.pm lib/XBase.pm lib/XBase/Base.pm lib/XBase/FAQ.pod lib/XBase/Index.pm lib/XBase/Memo.pm lib/XBase/SDBM.pm lib/XBase/SQL.pm new-XBase t/1_header.t t/2_read.t t/2_read_stream.t t/2_write.t t/3_create_drop.t t/4_dbfdump.t t/5_cdx.t t/5_idx.t t/5_ndx.t t/5_ntx.t t/5_sdbm.t t/6_attach_cdx.t t/7_dbd_select.t t/7_dbd_select_func.t t/8_dbd_delete.t t/8_dbd_update.t t/8_dbd_insert.t t/9_dbd_create.t t/XBase.dbtest t/XBase.mtest t/afox5.FPT t/afox5.dbf t/lib.pl t/ndx-char.dbf t/ndx-char.ndx t/ndx-date.dbf t/ndx-date.ndx t/ndx-num.dbf t/ndx-num.ndx t/ntx-char.dbf t/ntx-char.ntx t/rooms.cdx t/rooms.dbf t/test.dbf t/test.dbt t/types.dbf META.yml Module meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) DBD-XBase-1.08/eg/0000755000175000017500000000000013037112723013263 5ustar adeltonadeltonDBD-XBase-1.08/eg/create_table0000755000175000017500000000131207143733104015623 0ustar adeltonadelton#!/usr/bin/perl -w # # This is an example how to create new table, if you have field # specification. # use strict; use XBase; my @fieldnames = ( 'ID', 'NAME', 'ACTIVE' ); my @fieldtypes = ( 'N', 'C', 'L' ); my @fieldlengths = ( '6', '30', '1' ); my @fielddecimals = ( '0', '0', '0' ); my $krtek; $krtek = create XBase('name' => 'krtek', 'field_names' => \@fieldnames, 'field_types' => \@fieldtypes, 'field_lengths' => \@fieldlengths, 'field_decimals' => \@fielddecimals) or die XBase->errstr(); print STDERR $krtek->get_header_info(); $krtek->set_record(0, 1, 'Alexis', 1) or die $krtek->errstr(); $krtek->set_record(1, 51, 'Bob', 0) or die $krtek->errstr(); $krtek->dump_records(); $krtek->close(); DBD-XBase-1.08/eg/use_index0000644000175000017500000000544712521607341015205 0ustar adeltonadelton #!/usr/bin/perl -w use strict; use XBase; my $table = new XBase "ndx-num.dbf"; my $cur = $table->prepare_select_with_index("ndx-num.ndx"); $cur->find_eq(1097); while (my @data = $cur->fetch()) { print "@data\n"; } __END__ Since the 0.063 version of the XBase module, there is a new support for ndx index files, since 0.0693 we have support for ntx, since 0.13* we more or less supprot mdx, idx and cdx. The first example shows how to find all rows equal or greater than 1097. The order is taken from the index file ndx-num.ndx. Note that at the moment there is not check made that the index really belongs to the dbf (and the check is impossible, so there will be none in the future). If you have different index format, just specify different file name -- the index format is derived from the file extension. The values in the index (AFAIK) can be character strings, numeric and dates. There is probably no problem when using strings and numeric, but when you want to do find_eq for date, you have to convert it to Julian format first: #!/usr/bin/perl -w use strict; use XBase; use Time::JulianDay; my $table = new XBase "ndx-date.dbf" or die XBase->errstr; my $cur = $table->prepare_select_with_index("ndx-date.ndx") or die $table->errstr; $cur->find_eq(julian_day(1997, 12, 12)); while (my @data = $cur->fetch) { print "@data\n"; } __END__ If you want to test if the XBase::Index part works fine on your data, you can call it directly: #!/usr/bin/perl -w use strict; use XBase::Index; my $index = new XBase::Index "klantnum.ndx"; $index->prepare_select; while (my @data = $index->fetch()) { print "@data\n"; } __END__ Note that we explicitely create object XBase::Index, not XBase, and call methods of this object, not of cursor object. This will list the keys from the ndx file, together with their corresponding values, which are the record numbers in the dbf file. If the results are not those you would expect, email me. If you have an index format that can hold more index structures in one file (mdx, cdx), you have to specify the tag in the file: my $index = new XBase::Index "cust.cdx", 'tag' => 'addr'; With the XBase and prepare_select_with_index, you would specify an arrayref instead of the index file name, holding file name and tag name: my $cur = $table->prepare_select_with_index( [ "cust.cdx", 'addr' ], 'field1', 'field2'); There is a script indexdump that does the dump for you. If you have an compound index, with an expression instead of just plain field name, chances are that XBase.pm won't be able to recognize the type of the index. You can specify the type of the index as the third parameter in the first anonymous array, like my $cur = $table->prepare_select_with_index( [ "cust.cdx", 'addr+zip', 'char' ], 'field1', 'field2'); -- Jan Pazdziora DBD-XBase-1.08/eg/copy_table0000755000175000017500000000167007143733104015341 0ustar adeltonadelton#!/usr/bin/perl -w # # This example shows how to copy a table to a new one. Note the new # and drop that will ensure delete on previous copy. Then you use # create as the method of the old table, so that you do not need to # specify the fields. Then get_record and set_record in the new # table in the while loop, skipping (next) those with _DELETED flag # set. # use strict; use XBase; my $dir = ( -d 't/' ? 't/' : '' ); my $table = new XBase("${dir}test") or die XBase->errstr(); my $newtable; $newtable = new XBase("jezek"); $newtable->drop() if defined $newtable; $newtable = $table->create("name" => "jezek") or die $table->errstr(); my $outno = 0; for my $recno (0 .. $table->last_record()) { my @data = $table->get_record($recno) or die $table->errstr(); next if shift @data; $newtable->set_record($outno++, @data) or die $newtable->errstr(); } $table->close() or die $table->errstr(); $newtable->close() or die $newtable->errstr(); DBD-XBase-1.08/Makefile.PL0000644000175000017500000000256712521607341014656 0ustar adeltonadelton use 5.010; { local $SIG{__WARN__} = sub {}; eval 'use XBase;'; } if (Xbase->can("open_dbf")) { print < 'XBase', 'DISTNAME' => 'DBD-XBase', 'VERSION_FROM' => 'lib/DBD/XBase.pm', ($] >= 5.005 ? ( 'AUTHOR' => 'Jan Pazdziora', 'ABSTRACT' => 'Reads and writes XBase (dbf) files, includes DBI support', ) : ()), 'PL_FILES' => { 'bin/dbfdump.PL' => 'bin/dbfdump', 'bin/indexdump.PL' => 'bin/indexdump' }, 'EXE_FILES' => [ 'bin/dbfdump', ' bin/indexdump' ], 'dist' => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', POSTOP => 'mv $(DISTNAME)-$(VERSION).tar.gz ../' }, 'clean' => { FILES => 'bin/dbfdump bin/indexdump t/newtable.* t/write*.* t/rooms.sdbm* t/rooms1.* t/tstidx* '}, ); DBD-XBase-1.08/INSTALL0000644000175000017500000001016612521607341013727 0ustar adeltonadelton ------------------------------------ Installation of XBase and DBD::XBase ------------------------------------ To use the XBase.pm module, perl version 5.004 is required. To use the DBD::XBase driver, you need a DBI module version 1.0 or higher. Installation is the same as for any Perl module, so if you have some obscure platform, check instructions that came with perl for that platform -- I won't be able to help you because I probably do not use your platform. The generic way is: download the DBD-XBase-x.xxx.tar.gz, unpack it, change to the DBD-XBase-x.xxx directory. Then do perl Makefile.PL make make test make install You can also use the CPAN.pm module to do these steps for you $ perl -MCPAN -e shell cpan> install DBD::XBase If you do not have root access on that machine and/or cannot install into standard Perl library directories, you can specify alternate location with $ perl Makefile.PL LIB=/your/directory \ INSTALLMAN1DIR=/path/for/man1 \ INSTALLMAN3DIR=/path/for/man3 instead of just perl Makefile.PL, and in your scripts do use lib '/your/directory'; use XBase; or use lib '/your/directory'; use DBI; If you do not have make or you cannot run it (do you really want to use Perl on that machine?), just copy the content of the DBD-XBase-x.xxx/lib directory to wherever you want to have it. That should work, even if it won't give you man pages and dbfdump/indexdump scripts. If you use a platform supported by ActiveState and run ActiveState perl, you can use ppm to install the module. Please note that I have no way of influencing what version of XBase.pm/DBD::XBase ActiveState offers on their site -- contact them if you need newer version which is only on CPAN. Cygwin does a good job of providing make on Windows platform, so you can always install any needed version using the generic approach described above. If you have case insensitive filesystem, make sure you do not have an old module named Xbase.pm installed -- remove it prior to using XBase.pm, otherwise bad things will happen. ------------------------------------ Problems and bug reporting for XBase ------------------------------------ If anything goes wrong when installing/make test, please send me output of your installation messages and of $ make test TEST_VERBOSE=1 Each version of the module is tested on multiple systems and multiple versions of perl before releasing but surely there might be situation where something is corrupted on other platforms. So please, send me reasonable output and it is a bug of XBase.pm/DBD::XBase, I'll try to get it fixed. If there are errors when actually using the module on your data, please check first that it's really a XBase/DBD::XBase problem (for example, did you FTP your files using binary mode?). If so, please send me example of your script, the errstr messages you get and (if possible) your data files that cause the problems and description of what output you expected. If there is problem with writing the data, send me the file before and after the action and also describe what you expect and what you got. Add info about your OS, version of Perl and other modules that might be relevant. You can of course also send patches to actual bugs. I may respond with requests for particular tests and actions to try on your machine. Mention the word "XBase" in the Subject line, otherwise your post will probably just slip through my xxx MB daily email load without even being read. Please note that I'm _very_ busy, so try to help me to help you by using the latest version of the module, minimalizing the script code that causes you problems, providing me with tiny sample datafile, anything that might be related. Detailed description and small examples are the best. For general Perl issues, use the comp.lang.perl.* newsgroups, for DBI issues, look at http://dbi.perl.org/ or use dbi-users-help@perl.org. Available: http://www.adelton.com/perl/DBD-XBase/ and from your favorite CPAN site in the authors/id/JANPAZ/ directory. Copyright: (c) 1997--2011 Jan Pazdziora. All rights reserved. This package is free software; you can redistribute it and/or modify it under the same terms as Perl itself. DBD-XBase-1.08/driver_characteristics0000644000175000017500000003701212521607341017346 0ustar adeltonadelton=head1 Database and Driver Characteristics This document is designed to give you a flavour of the functionality and quirks of the different DBI drivers and their databases. The line between the functionality and quirks of a given driver and the functionality and quirks of its corresponding database is blurred. In some cases the database has functionality that the driver can't or doesn't access, in others the driver may emulate functionality that the database doesn't support, like placeholders. So when you see the terms driver and database below, take them with a pinch of salt. We don't attempt to describe the drivers and database in full detail here, we're only interested in the key features that are most commonly used. And for those features we're just providing an outline guide. Consult the database documentation for full details. The primary goals are: - to provide a simple overview of each driver and database. - to help you initially select a suitable DBI driver and database. - to help you quickly identify potential issues if you need to port an application from one driver and database to another. =head2 Driver Name, Version, Author and Contact Details This driver summary is for DBD::XBase version 0.130. The driver author is Jan Pazdziora and he can be contacted at jpx dash perl at adelton dot com. =head2 Supported Database Versions and Options The DBD::XBase module supports dBaseIII and IV and Fox* flavors of dbf files, including their dbt and fpt memo files. =head2 Connect Syntax Details of the syntax of the dsn including any optional parts. The DBI->connect Data Source Name (DSN) should include the directory where the dbf files are located as the third part. dbi:XBase:/path/to/directory It defaults to current directory. Details of any driver specific attributes applicable to the connect method. There are no driver specific attributes for the DBI->connect method. =head2 Numeric Data Handling What numeric data types do the database and driver support? (INTEGER, FLOAT, NUMBER(p,s) etc). What is the maximum scale and precision for each type? DBD::XBase supports generic NUMBER(p,s), FLOAT(p,s) and INTEGER(l) types. Maximul scale and precision unknown, limited by Perl's handling of numbers. In the dbf files, the numbers are stored as ASCII strings, or binary integers or floats. Existing dbf files come with the field types defined in the dbf file header. Numeric types can be either stored as ASCII string or in some binary format. DBD::XBase (via XBase.pm) parses this information and reads and writes the fields in that format. When you create a I dbf file (via CREATE TABLE), the numeric fields are always created in the traditional XBase way, as an ASCII string. (The XBase.pm module offer more control over this.) Does the database and driver support numbers outside the valid range for perl numbers? Are numbers returned as strings in this case? Numeric fields are always returned as perl numeric values, not strings, so numbers outside of Perl's valid range are not possible (this restriction might be withdrawn in the future). =head2 String Data Handling What string data types does the database support? (CHAR, VARCHAR, etc) DBD::XBase knows CHAR(length) and VARCHAR(length), both are stored as fixed length chars however. These can contain any binary values. What is the maximum size for each type? The maximum length is 65535 characters for both types (even if the older dBase's only allowed 255 characters, so created dbf might not be portable to other xbase compatible software). Are any types blank padded? If so which, e.g., CHAR. Both CHAR and VARCHAR are blank padded (unless ChopBlanks set). How does the database handle data with the 8th bit set (national language character sets etc)? Data with the 8th bit set are handles transparently, no national language character set conversions are done. Is Unicode supported? Since the string types can store binary data, Unicode strings can be stored. =head2 Date Data Handling What date, time and date+time data types are supported and what is their valid range and resolution? What is the default output format for each? What is the default input format for each? Are multiple input format recognised? DBD::XBase supports these date and time types: DATE DATETIME TIME The DATE type holds an eight character string in the format `YYYYMMDD'. Only that format can be used for input and output. DBD::XBase doesn't check for validity of the values. The DATETIME and TIME types store (internally) a 4 byte integer day value (Julian Day System) and a 4 byte integer seconds value (that counts 1/1000's of a second since midnight). DBD::XBase inputs and outputs these types using a floating point unix-style seconds-since-epoch value (possibly with decimal part and possibly negative). This might change in the future. If only part of a date is specified, how does the rest default? If two digit years can be used, how is the century determined? N/A Can the default format be changed? If so, how (both for a single expression in an sql statement, and as a database connection default)? No. How can I get the current date+time in an SQL expression? There is no way to get the current date/time. How can I input date and date+time values in other formats? How can I output date and date+time values in other formats? N/A What kinds of date and time arithmetic and functions are supported? None. What SQL expression can be used to convert from an integer "seconds since 1-jan-1970 GMT" value to the corresponding database date+time? If not possible, then what perl expression can be used? N/A What SQL expression can be used to convert from a database date+time value into the corresponding "seconds since 1-jan-1970 GMT" value? If not possible, then what perl expression can be used? N/A How does the database deal with time zones, especially where the client inserting a date, the server and a client reading the date are all in different time zones? There is no time zone handling. =head2 LONG/BLOB Data Handling What LONG/BLOB data types does the database support? (LONG, LONG RAW, CLOB, BLOB, BFILE etc) DBD::XBase supports a MEMO data type. BLOB can be used as an alias for MEMO. With dBaseIII dbt files, the memo field cannot contain \x1a byte, with dBaseIV and Fox* dbt/fpt's any value can be stored. What are their maximum sizes? At least 2 GB are possible for all types of memo files. Which types, if any, must be passed to and from the database as pairs of hex digits? N/A Do the LongReadLen and LongTruncOk attributes work as defined? What is the maximum value, if any, for LongReadLen? The LongReadLen and LongTruncOk attributes are ignored/are broken (will be fixed). Is special handling required for some or all LONG/BLOB data types? N/A =head2 Other Data Handling issues Does the driver support type_info method? The DBD::XBase driver supports the type_info method. =head2 Transactions and Transaction Isolation Does the database support transactions? DBD::XBase does not support transactions. If so, what is the default transaction isolation level? N/A What other isolation levels are supported and how can they be enabled per-connection or per-transaction? N/A =head2 Explicit Locks What is the default locking behaviour for reading and writing? DBD::XBase does not lock the tables (files) it is working on. (Hopefully some mechanism will be provided in the future.) What statements can be used to explicitly lock a table with various types/levels of lock? E.g., "lock table ...". N/A How can a select statement be modified to lock the selected rows from being changed by another transaction. E.g., "select ... for update". N/A =head2 No-Table Expression Select Syntax What syntax is used for 'selecting' a constant expression from the database? E.g., "select 42 from dual" (Oracle). You can't select a constant expression using DBD::XBase. Only table field names, or * for all, can be selected. =head2 Table Join Syntax If equi-joins are supported but don't use the standard "WHERE a.field = b.field" syntax, then describe the syntax. DBD::XBase does not support table joins. Are 'outer joins' supported, if so with what syntax? N/A =head2 Table and Column Names What is the max size of table names? And column names? The XBase format stores each table as a distinct file. The table names are limited by filesystem's maximum filename length. Column names are limited to 11 characters. What characters are valid without quoting? Table and field names have to start with letter, a combination of letters, digits and underscores may follow. Can table and field names be quoted? If so, how? What characters are valid with quoting? DBD::XBase does not support putting quotes around table or column names. Are table/column names stored as uppercase, lowercase or as-entered? Are table/column names case sensitive? Table names are stored and treated as entered. The case sensitivity depends on the filesystem that the file is stored on. Column names are stored as uppercase and are not case sensitive. Can national character sets (with the 8th bit set) be used? National character sets can be used. =head2 Case sensivity of like operator Is the LIKE operator case sensitive? If so, how can case insensitive LIKE operations be performed? The LIKE operator is not case sensitive. There is (currently) no case sensitive operator. =head2 Row ID If the database supports a 'row id' pseudocolumn, what is it called? E.g., 'rowid' in Oracle, 'tid' in Ingres. DBD::XBase does not support a 'row id' pseudocolumn. Can it be treated as a string when fetching and reusing in later statements? If not, what special handling is required? N/A =head2 Automatic Key or Sequence Generation Does the database offer automatic key generation such as 'auto increment' or 'system generated' keys? Does the database support sequence generators? If so, what syntax is used? DBD::XBase does not support automatic key generation or sequence generators owing to the limitations of the XBase format. =head2 Automatic Row Numbering and Row Count Limiting Can you select a row-numbering pseudocolumn and if so, what is it called? DBD::XBase does not support a row-numbering pseudocolumn. =head2 Parameter binding Is parameter binding supported by the database, emulated by the driver or not supported at all? Parameter binding is implemented in the driver. If parameter binding is supported, is the :1 placeholder style also supported? The :1 placeholder style is not (yet) supported. Does the driver support the TYPE attribute do bind_param? If so, which types are supported and how do they affect the bind? No. Do unsupported values of the TYPE attribute generate a warning? N/A =head2 Stored procedures What syntax is used to call stored procedures and, where possible, get results? Stored procedures are not applicable in the XBase format. =head2 Table Metadata Does the driver support table_info method? DBD::XBase supports the table_info method. How can detailed information about the columns of a table be fetched? There si no way to get that information (at the moment). How can detailed information about the indexes of a table be fetched? Indexes are not supported. How can detailed information about the keys of a table be fetched? Keys are not supported. =head2 Driver-specific database handle attributes xbase_ignorememo. XXX expand description =head2 Driver-specific statement handle attributes xbase_ignorememo. =head2 Default local row cache size and behaviour Does the driver or database implement a local row cache when fetching rows from a select statement? What is the default size? DBD::XBase doesn't maintain a row cache (not applicable since the data file is local to the driver). =head2 Positioned updates and deletes Does the driver support positioned updates and deletes (also called updatable cursors)? If so, what syntax is used? E.g, "update ... where current of $cursor_name". DBD::XBase does not support positioned updates or deletes. =head2 Differences from the DBI specification List any significant differences in behaviour from the current DBI specification. DBD::XBase has no known significant differences in behaviour from the current DBI specification. =head2 URLs to more database/driver specific information http://www.clicketyclick.dk/databases/xbase/format/ =head2 Multiple concurrent database connections Does the driver allow multiple concurrent database connections to the same database? DBD::XBase supports an unlimited number of concurrent database connections to one or more databases. =head2 Concurrent use of multiple statement handles from same $dbh. Does the driver allow a new statement handle to be prepared and used while still fetching data from another statment handle associated with the same database handle? DBD::XBase supports the preparation and execution of a new statement handle while still fetching data from another statment handle associated with the same database handle. =head2 Driver specific methods What generally useful private ($h->func(...)) methods are provided? DBD::XBase has no generally useful private methods. =head2 Future Changes Planned for the Driver Adding :1 style of placeholders; handling numbers outside of Perl's numeric range. =head2 How to get value of auto-increment field If your database supports some kind of auto-increment key then how can a script get the value of the key used for the most recent insert statement? DBD::XBase does not support auto-increment keys. =head2 Auto conversion of numbers to strings and strings to numbers? Does your database automatically convert strings to numbers and number to strings as needed? E.g. does INSERT INTO foo (num_field, str_field) VALUES ('42',42) work? If not, what type conversion functions are needed. Yes, DBD::XBase automatically converts between strings and numbers. =head2 And strings to date and dates to strings? Does your database automatically convert strings to dates and dates to strings as needed? E.g. does INSERT INTO foo (date_field) VALUES ('...date string...') work? If not, what type conversion functions are needed. Yes, DBD::XBase automatically converts between dates and strings. =head2 Which character types can store embedded nulls? Any? None? Any. =head2 Does commit close/finish all prepared statements? Yes? No? Yes but the driver hides this by re-preparing as needed? N/A, only AutoCommit mode is supported. =head2 Are any emulations of other interfaces supplied? Like Ingperl, Oraperl etc No emulation layers are supported. =head2 String concatenation operator || or + or CONCAT() or what? String concatenation is not supported. =head2 NUM_OF_FIELDS set by prepare or execute? Which? NUM_OF_FIELDS is set by execute. =head2 Other Significant Database Features This is where you get a chance to 'sell' your database and driver. What's most important to most potential perl DBI users? It's a lovely piece of software, especially when you have to deal with dbf files. =cut DBD-XBase-1.08/bin/0000755000175000017500000000000013037112723013440 5ustar adeltonadeltonDBD-XBase-1.08/bin/dbfdump.PL0000755000175000017500000001065212521607341015327 0ustar adeltonadelton use Config; my $filename = $0; $filename =~ s/\.PL$//; open OUT,">$filename" or die "Can't create $filename: $!"; chmod(0755, $filename); print "Extracting $filename (with #! and variable substitution)\n"; print OUT <<"EOHEADER"; $Config{'startperl'} -w EOHEADER print OUT <<'EOBODY'; use XBase; use Getopt::Long; use strict; $^W = 1; my $stdin = 0; if (defined $ARGV[$#ARGV] and $ARGV[$#ARGV] eq '-') { $stdin = 1; pop @ARGV; } my %options; Getopt::Long::GetOptions( \%options, 'help', 'version', 'info', 'rs=s', 'fs=s', 'undef=s', 'fields=s', 'nomemo', 'memofile=s', 'memosep=s', 'table', 'SQL', ) or exit; if (defined $options{'version'}) { print "This is dbfdump version $XBase::VERSION.\n"; exit; } if ($stdin) { push @ARGV, '-'; $options{'nomemo'} = 1; } if (@ARGV == 0 or defined $options{'help'}) { die <<'EOF'; Usage: dbfdump [ options ] files where the options specify --rs output record separator (default newline) --fs output field separator (default colon) --fields comma separated list of fields to print (default all) --undef what to print for NULL values (default empty string) --memofile specifies unstandard name of attached memo file --memosep separator for dBase III dbt's (default \x1a\x1a) --table output in nice table format (needs Data::ShowTable) all having as parameter a string; and also --nomemo do not try to read the memo (dbt/fpt) file --info only print info about the file and fields --version print version of the XBase library EOF } my %addopts = (); if (defined $options{'nomemo'} or defined $options{'info'}) { $addopts{'ignorememo'} = 1; } $addopts{'memosep'} = $options{'memosep'}; $addopts{'memofile'} = $options{'memofile'}; if (defined $options{'info'}) { $addopts{'ignorebadheader'} = 1; } my $file; for $file (@ARGV) { my $table = new XBase 'name' => $file, %addopts; if (not defined $table) { print STDERR XBase->errstr; next; } if (defined $options{'info'}) { if (not defined $options{'SQL'}) { print $table->header_info; } else { my $name = $file; $name =~ s!^.*/|\.dbf$!!ig; print "create table $name (\n"; my @names = $table->field_names; my %conv = qw! C varchar N numeric F numeric L boolean M blob D date T time !; my @types = map { $conv{$_} } $table->field_types; my @lengths = $table->field_lengths; my @decimals = $table->field_decimals; for (my $i = 0; $i < @names; $i++) { print "\t$names[$i] $types[$i]"; if ($types[$i] eq 'blob') { $lengths[$i] = $decimals[$i] = undef; } if ($lengths[$i] or $decimals[$i]) { print "($lengths[$i]"; print ", $decimals[$i]" if $decimals[$i]; print ")"; } if (defined $names[$i+1]) { print ','; } print "\n"; } print ")\n"; } } else { $table->dump_records(%options) or print STDERR $table->errstr; } $table->close; } 1; __END__ =head1 NAME dbfdump - Dump the record of the dbf file =head1 FORMAT dbfdump [options] files where options are --rs output record separator (default newline) --fs output field separator (default colon) --fields comma separated list of fields to print (default all) --undef string to print for NULL values (default empty) --memofile specifies unstandard name of attached memo file --memosep separator for dBase III dbt's (default \x1a\x1a) --nomemo do not try to read the memo (dbt/fpt) file --info print info about the file and fields with additional --SQL parameter, outputs the SQL create table --version print version of the XBase library --table output in nice table format (only available when Data::ShowTable is installed, overrides rs and fs) =head1 SYNOPSIS dbfdump -fields id,msg table.dbf dbfdump -fs=' : ' table dbfdump --nomemo file.dbf ssh user@host 'cat file.dbf.gz' | gunzip - | dbfdump - =head1 DESCRIPTION Dbfdump prints to standard output the content of dbf files listed. By default, it prints all fields, separated by colons, one record on a line. The output record and column separators can be changed by switches on the command line. You can also ask only for some fields to be printed. The content of associated memo files (dbf, fpt) is printed for memo fields, unless you use the C<--nomemo> option. You can specify reading the standard input by putting dash (-) instead of file name. =head1 AVAILABLE FROM http://www.adelton.com/perl/DBD-XBase/ =head1 AUTHOR (c) 1998--2011 Jan Pazdziora. =head1 SEE ALSO perl(1); XBase(3) =cut EOBODY DBD-XBase-1.08/bin/indexdump.PL0000755000175000017500000000533212521607341015702 0ustar adeltonadelton use Config; my $filename = $0; $filename =~ s/\.PL$//; open OUT,">$filename" or die "Can't create $filename: $!"; chmod(0755, $filename); print "Extracting $filename (with #! and variable substitution)\n"; print OUT <<"EOHEADER"; $Config{'startperl'} -w EOHEADER print OUT <<'EOBODY'; #!/usr/bin/perl -w use strict; use XBase::Index; use Getopt::Long; my %opts = (); my $type; my $startvalue; my $showtotal; GetOptions('debug:i' => sub { my $key = shift; my $val = shift; $val = 1 if $val eq '0'; $XBase::Index::DEBUG = $val }, 'type=s' => sub { my $key = shift; my $val = shift; if ($val eq 'num') { $type = 'N'; } elsif ($val eq 'date') { $type = 'D'; } elsif ($val eq 'char') { $type = 'C'; } elsif ($val eq 'string') { $type = 'C'; } else { die "Unknown index type `$val'\n"; } }, 'start=s' => \$startvalue, 'tag=s' => sub { $opts{'tag'} = $_[1]; }, 'n' => sub { $showtotal = 1; }, ); $opts{'type'} = $type if defined $type; # AUDIO 4608 # FACILITY 3072 # FILM 9216 # MAIN 7680 # ROOMNAME 1536 my $file = shift; if (@ARGV and not defined $opts{'tag'}) { $opts{'tag'} = shift; } my $index = new XBase::Index $file, %opts or die XBase::Index->errstr; if (not defined $opts{'tag'}) { my @tags = $index->tags; if (@tags) { print map "$_\n", @tags; my $numtags = @tags; print "Number of tags: $numtags\n" if $showtotal; exit; } } if (defined $startvalue) { $index->prepare_select_eq($startvalue) or die $index->errstr; } else { $index->prepare_select or die $index->errstr; } my $i = 0; while (my @data = $index->fetch()) { print "@data\n"; $i++; } if ($index->errstr) { die $index->errstr; } print "Total records: $i\n" if $showtotal; =head1 NAME indexdump - Show the content of the index file =head1 FORMAT indexdump [options] file [ tag ] where options are --debug output record separator (default newline) --type specifies the num/date/char type of the index --start defines the value to start dump from --n prints also the total number of records in the file =head1 SYNOPSIS indexdump rooms.cdx FACILITY indexdump --debug=14 --start=Dub rooms.cdx ROOMNAME =head1 DESCRIPTION Indexdump prints to standard output the content of the index file. The type of the index is one of those supported by the XBase::Index Perl module (cdx, idx, ntx, ndx, mdx). The output contains the index key and the value, which is the record number in the correcponding dbf file. For mulitag index files (like cdx), you need to specify the tag name to get the actual data. =head1 AVAILABLE FROM http://www.adelton.com/perl/DBD-XBase/ =head1 AUTHOR (c) 1999--2013 Jan Pazdziora. =head1 SEE ALSO perl(1); XBase::Index(3) =cut __END__ EOBODY DBD-XBase-1.08/Changes0000644000175000017500000005046513037112657014203 0ustar adeltonadelton Revision history for Perl extension XBase and DBD::XBase. 1.08 Fri Jan 13 21:20:15 CET 2017 Add support for dBASE IV memo type B. 1.07 Tue May 3 19:45:23 CEST 2016 Resolving the xbase_lines regression of 1.06. 1.06 Sun Mar 6 20:48:11 CET 2016 Add support for W column type (byte array by Visual FoxPro). Fixed overload arg warning. Restore the table_info functionality. Fix for type B little endian issue, reported by Andres Thomas. 1.05 Wed Apr 24 19:37:09 CEST 2013 Fix for prepare_select_eq and empty MDX indexes, patch by Julian Bridle. 1.04 Wed Apr 17 19:47:21 CEST 2013 Fix for handling MDX indexes, patch by Julian Bridle. 1.03 Sun Mar 6 07:32:21 CET 2011 Fixing output of tests when DBI is not available. 1.02 Thu Mar 3 20:40:54 CET 2011 Added the URL to the AVAILABLE FROM sections. 1.01 Wed Feb 9 21:22:07 CET 2011 Updated the Changes file. 1.00 Wed Feb 9 21:19:35 CET 2011 Changed the location of the distribution to http://www.adelton.com/perl/DBD-XBase/ Changed author's email address. Require perl 5.10 and use O_BINARY from Fcntl. Updated the clean target to make distclean clean. Updated URL of Erik's documentation. 0.241 Thu Nov 20 21:12:56 MET 2003 XBase: codepage option to XBase->create added, suggested by Chris Greenhill. 0.240 Mon Aug 25 15:03:57 MEST 2003 XBase: delete_record/undelete_record now corrctly returns false when the delete fails, problem reported by Boris Kocak. 0.234 Mon Jul 7 20:41:14 CEST 2003 Added test to Makefile.PL and note to INSTALL about case insensitive clash with Xbase.pm, suggested by Michael Higgins and Jan from AS. Added documentation / comments about datetime, suggested by John Freed. Xbase: Added the recompute_lastrecno parameter, suggested by Kevin J. Rice. Added EOF to create, suggested by Ilya Sandler. 0.232 Thu Apr 3 17:47:39 CEST 2003 XBase::SQL: Fieldname can contain the table name (silently dropped), suggested by Michael Semich, and table name now matches [^\(\s]+ to allow paren immediately following it, problem reported by belg4mit. 0.231 Thu Oct 31 17:48:19 MET 2002 t/9_dbd_create.t: patched a test failure on Windows platform, path by Yves Orton. 0.230 Wed Oct 9 11:05:28 MET DST 2002 DBD::XBase: added docs about xbase_ignorememo. DBD::XBase: fixed dropping table so that the driver forgets the table, patch by Mike P. Mikhailov. 0.220 Mon Sep 2 12:26:34 MET DST 2002 XBase::Index::ntx: type option has higher priority than dbf. XBase::read_header: fail if the header is not valid. XBase::Memo::read_header: allow length 512 and 24. XBase::FAQ: reformatted, slightly. XBase, XBase::SQL: added support for type money (Y). Code and indentation cleanup. 0.210 Fri Dec 7 12:56:37 MET 2001 README and INSTALL made uptodate. Fixed attributes (TYPE) handling, problem reported by Jacek Ciolek. 0.200 Sun Aug 19 13:48:27 MET DST 2001 Source code reformated to unified indentation. 0.190 Sat Aug 18 18:02:04 MEST 2001 XBase::SDBM: documentation added. DBD::XBase: order by with more fields supported. 0.177 Thu May 10 17:19:07 MET DST 2001 XBase: retry with nolongchars if the char lengths do not match the record length. Memo field not written when empty, suggested by Sascha Knific. XBase::Base::open: now allows option 'fh' to point to IO::Scalar or generally any filehandle to be passed in. 0.176 Thu Feb 8 13:19:16 MET 2001 DBD::XBase: select * with order by was failing, reported by Filipe Luis Geschaeft 0.173 Tue Feb 6 11:18:46 MET 2001 XBase: year encoding not correct in dbf header, reported by Helmut Jarausch. 0.172 Tue Feb 6 10:22:11 MET 2001 XBase::Memo: creating of fpt supported; bug pointed out by Massimo Matteuzzi. 0.170 Fri Jan 26 18:35:01 MET 2001 XBase::idx: create support and better reading support. XBase: password protection explored 0.165 Mon Jan 22 19:33:01 MET 2001 XBase: better sanity checks in dump_records. XBase::SQL: added support for not in SQL command. 0.162 Sun Jan 21 17:53:05 MET 2001 XBase::IndexCursor: error by one in last_fetched. XBase: Y2K problem fixed, patch by Phillip Millman. XBase::Index, XBase::SDBM: added support for SDBM index files. XBase, XBase::cdx: added support for type specification of cdx files even when called via prepare_select_with_index, to allow use even if we don't support expressions. XBase::SQL: multiplication support added, patch by Thoren Johne and Stuart Lemmen. 0.161 Sat May 20 12:52:35 MET DST 2000 indexdump: had bug in option handling. XBase::Index: minor tweaks, bug reporting fixed, support for cdx dates added, reported by Dan Albertsson. XBase: long numeric values weren't truncated correctly, reported by Dan Albertsson. 0.160 Sat Feb 12 20:03:56 MET 2000 XBase::Index: cdx now supports the delete, insert and write_header methods for updating the index file. Handling of negative integers fixed, as well as trailing nulls. XBase: preliminary support for attach_index. Code for making the module happy with _NULLFLAGS/0 type (we do not interpret this at the moment, we just correctly ignore) provided by Sebastien Nameche. XBase::SQL: like operator now matches multiline strings as well, problem reported by Petr Nalevka. DBD::XBase: stump DBD::XBase::db::DESTROY added, to silence DBI, patch by Gregory McCann. 0.1551 Sat Jan 9 19:21:16 CET 2000 dbfdump: Accepts --SQL modifier to --info, prints structure of the table as a create table SQL. 0.155 Sun Nov 7 15:43:59 CET 1999 XBase::SQL and DBD::XBase: arbitraty arithmetic expression possible in the select list. NAME attribute works fine for them. SQL functions length, *trim, concat and substr supported. Fixed bug in XBase::SQL causing bad division results. The DBD::XBase documentation revised. t/5_dbd_select* tests extended. 0.147 Mon Aug 16 10:48:37 MET DST 1999 XBase::SQL and DBD::XBase: fixed broken handling of NAME attribute, introduced in 0.145 by an attempt to support arbitrary expressions in the selected part. So I rolled back that change and it's (again) only possible to select * or select list of field names -- problem reported by adelton, William McKee and Martin Treusch. XBase::Index: fixed handling of indexes with 32-bit record number -- patch by Jon Bloom. XBase::Base: fixed typo _unlockex, pointed by Mike Sanders. 0.145 Mon Jun 21 12:49:19 MET DST 1999 DBD::XBase: updated TYPE_INFO for BOOLEAN and BLOB. t/5_dbd_select.t: added tests for the named bind params. 0.144 Fri May 14 07:50:23 CEST 1999 XBase::SQL, DBD::XBase: added support for named bind parameters; added comments. 0.141 Thu Apr 29 23:17:25 CEST 1999 XBase::Index: added code for multiple page cdx and fix for big endian. Added code for negative ntx numeric values. 0.140 Thu Apr 29 10:50:58 MET DST 1999 XBase: the -1 memo records handle the 4 byte fields as well, patch by Zbigniew Malinowski. XBase::Index: support for cdx files improved (numeric fields), subindexes. XBase::SQL: code properly commented. DBD::XBase: added the time type, aptch by Nikolai Saoukh. 0.132 Sun Apr 18 17:35:10 MET DST 1999 XBase::Base: dealing of openoptions fixed, problem spotted by Zbigniew Malinowski. XBase::SQL: added type numeric, patch by Nikolai Saoukh. XBase::Index: added support for cdx (one page index so far), added support for idx (untested). DBD::XBase: added attributes PRECISION and SCALE, changed SQL type for NUMERIC, patch by Nikolai Saoukh. driver_characteristics now includes Tim's additions of Apr 4, 1999. Created new XBase::FAQ.pod. 0.131 Sun Apr 18 8:47:12 MET DST 1999 XBase: memo records marked -1 are returned empty now, spotted by Zbigniew Malinowski. XBase::SQL: added possibility to have expression to the left from the relational operator, suggested by Nikolai Saoukh. DBD::XBase: fixed type_info to return array, bug spotted by Alan Grover. 0.130 Sat Feb 27 18:09:04 MET 1999 DBD::XBase: fixed handling of the rows method. Added driver_characteristics.pod to list characteristics of DBD::XBase according to the draft by Tim Bunce. 0.129 Fri Feb 26 22:02:12 MET 1999 XBase.pm: added support for datetime fields T, testing data provided by William McKee. Fix for ignorememo. XBase::SQL: added time and datetime names to the SQL parser. XBase::Memo and XBase.pm: added support for Apollo SMT memo files, code based on that provided by Dirk Tostmann. O_BINARY is only loaded on evil systems now. 0.127 Mon Feb 22 10:56:23 MET 1999 XBase::Base: opening readonly files fixed, patch by Petr Machacek. _unlockex fixed to _unlock. locksh, lockex and unlock now return true/false based on result. DBD::XBase::disconnect now closes the tables, patch by Martin Treusch von Buttlar. Fixed typo in delete code. t/2_write.t: added $table->close before size check, patch by Ilya Chelpanov. 0.121 Thu Jan 21 20:07:04 MET 1999 XBase::Memo: fixed a typo in measuring the next_for_append, pointed out by Dan Albertsson. t/2_write.t: added afox5.dbf/FPT and a Fox* test. 0.120 Wed Jan 13 13:24:15 MET 1999 XBase.pm: added XBase::Cursor::rewind, names, prepare_select_nf. Added readonly option. Added option 'table' for dump -- using Data::ShowTable. XBase.pm, XBase::Base.pm: open method now accepts hash of options. XBase::Memo: we now reset next_for_append to point behind the end of the file, problem pointed out by Artem Belevich. dbfdump: option --table, --fields now handles intervals. t/2_read.t: fixed problem with order of fields in hash, patch by Andreas J. Koenig. t/4_dbfdump.t: added quotes for Win* systems, patch by Randy Kobes. 0.115 Wed Jan 6 17:02:28 MET 1999 XBase::Memo: tries to find out which format (\x1a versus \x1a\x1a) to use for dBaseIII memo files. It also writes back this separator. 0.110 Sun Dec 20 21:29:05 MET 1998 XBase::SQL: added LIKE clause to WHERE part of SQL commands. 0.105 Sun Dec 20 17:09:43 MET 1998 XBase::Base: added workaround for systems that not only write to files something else than they are told to, but also damage the files by merely opening it. XBase::Memo: fixed problem with fpt files -- thanks to Dan Albertsson for providing many test files. XBase::SQL: fix of handling of double quoted strings. dbfdump: memosep and memofile options fixed. t/4_dbfdump.t: avoided using cat. t/*_dbd_*.t: forcing use of DBI version at least 1.0. 0.100 Mon Dec 7 11:00:23 MET 1998 DBD::XBase: capitalized AND/OR in SQL commands now work, method rows implemented, reported by cybertoast. Updated to use _set_fbav. Unpolished support to *info* methods. XBase::SQL: fixed the primary key/key parsing problem, patch by Bill Brinkley & Joe Johnston. A quick fix to avoid bug in Perl with long blobs. XBase::Memo: fixed appending record to dBaseIV memo used to corrupt the data -- reported by Dan Albertsson. 0.0696 Mon Oct 26 11:57:01 MET 1998 DBD::XBase: added bug reporting by INSERT command and fixed example in man page, spotted by Dmitry Dorofeev. Added DESC part of ORDER BY clause, requested by Dmitry Dorofeev. Fixed number of fields returned with ORDER BY clause, patch by Paul Lindner. If the directory is not specified in call to connect, it now defaults to current directory, not to root. Fixed the fetch method -- it doesn't deadlock anymore, problem reported by Ken Yamaguchi. XBase::Index: added some MDX code. XBase::Memo: header_len is now set to block_size, not 512, patch by Fergus Lee. XBase.pm: The type B is Fox double, not memo, spotted by George F. Frazier. Added support for Fox* 4 byte memo fields, data provided by William McKee. All of the reads/tells rewritten to allow stream-lined processing, suggested by Sergey Lukashevich. Use with caution, however. Added autoflush to each opened file, so it's safe to read the table with other process before closing the table in the first one, spotted by Thomas Hahn. 0.0694 Tue Aug 25 23:24:35 MET DST 1998 XBase::Memo: Fixed error by 8 in dBaseIV reading/writing code, bug reported by Kendal Van Dyke. t/5_dbd_select.t changed to be non-unique-key in sort independent, reported by Larry W. Virden. 0.0693 Tue Aug 25 10:25:20 MET DST 1998 DBD::XBase: Fixed handling ORDER BY with WHERE clauses, reported by Kendal Van Dyke. XBase: added nolongchars -- omitted from 0.068. XBase::Index: added ro support for Clipper's ntx, the whole module reworked. Thanks to Frans van Loon for providing example ntx files and code that helped me to understand the format. Also thanks to Robert Geer for his C code that also helps me to check the expected results. XBase::Base: last_record can be -1, meaning unknown -- disables checks. Added t/3_ntx.t and added ORDER BY test to t/5_dbd_select.t. Some documentation improvements. 0.068 Thu Aug 20 18:43:17 MET DST 1998 DBD::XBase: added support for ORDER BY, defined using substh. Fixed error by 1 in deleting all records. Added support for NULLABLE, NUM_OF_PARAMS and TYPE in FETCH. Defined data_sources to dbi:XBase:.; disconnect_all returns 1; defined tables, disconnect and DESTROY; quote adds support for NULL. XBase: create now marks presence of a dbt file in dbf. Added attribute nolongchars to disable character fields longer than 255. Erik Bachmann's homepage moved. XBase::Memo: added suport for memosep attribute, default \x1a\x1a. Correct header is now written for dBaseIV memo files. Fix of handling dBaseIV memo records, patch by Barry Fishman. XBase::SQL: added ORDER BY support, recognizes VARCHAR. In dbit/40blobs.t we only try blob size 64 -- fix for bug in Perl regexp engine. Change in dbit/40bindparam.t, quick fix for missing NULL chars. In dbit/50chopblanks.t swapped $$ref[1] and $name. 0.065 Sun Jun 7 15:18:57 MET DST 1998 Added table specific ChopBlanks. Added fetch_hashref to XBase::Cursor. Docs updated. 0.064 Sun May 31 18:56:26 MET DST 1998 (*****) Major rewrite of the DBD and SQL part. New features: support for bind parameters in where, insert and update. Support for NULL and IS NULL tests. The XBase::SQL is faster and hopefully clearer. The DBD::XBase supports (among others) bind_col. The DBD driver now passes 98.39 % of the standard DBD tests. Added support for data type 'I' for Fox* into XBase.pm. 0.0632 Wed May 27 12:27:04 MET DST 1998 Added --nomemo option to dbfdump. The list of entires is made longer in any non-leaf page in ndx. Added check for the magic "FFFF0800" tag in dBaseIV dbt file when reading it. 0.0631 Fri May 22 22:24:02 CEST 1998 Fixed handling big endian in numeric fields in ndx, fixe problem with key/record length. 0.063 Sun May 17 21:46:08 CEST 1998 Added first support for ndx index files. From XBase module it's available using prepare_select_with_index. It's very alpha but it seems to handle character and numeric (not date yet) types. And yes, it's read only. Added FETCH('NAME') and _ListTables to DBD::XBase, added drop table, integer type and dummy not null to XBase::SQL. The generic DBI test suite now goes well up until bind params, put on ToDo list. 0.062 Thu May 14 15:11:32 MET DST 1998 Field and table names in XBase::SQL now accept digits and underscores, in XBase::Memo, we check for ($dbf_version & 15), patches by Jens Quade. Fixed handling of Fox* fpt files and a problem with memo files that have record length different than 512, patches by Thomas Grueter. 0.061 Tue Apr 7 21:52:07 MET DST 1998 Fixed writing undefined values in numeric fields. Fixed dealing with uppercase extensions. XBase::SQL fixed to support int, found by Chris Winters. Offset in the record headers in dbf now set properly, patch by Dave Frascone. Added ignorememo option to new XBase call. Use this if you have a memo field in dbt but do not have the memo file. Otherwise you will get an error, request by Martin Jost. Other fixes by Martin Jost included. 0.060 Fri Mar 20 10:20:45 MET 1998 Added method prepare_select and XBase::Cursor to implement long selects. Method dump_records now prints directly, doesn't use get_all_records. Added parameter --info into the script dbfdump to print the header info. Changed way of determining the type of the dbt file after discussion with Sergey Lukashevich. 0.0599 Wed Mar 11 22:58:45 MET 1998 Option to specify the memo file in call to XBase::new added. Dump_records made customizable. 0.0598 Tue Mar 10 22:40:00 MET 1998 Fixed bug when finding a name for the memo file in XBase; in dBaseIII memo field we will only check for one \x1a to allow as many formats possible, we still write two of them; typo in init_memo fixed -- patches by Martin Jost. 0.0597 Tue Mar 3 23:40:56 MET 1998 (*****) Major code revision and check: Error handling fixed, locking added. Rewritten process_* to rproc and wproc arrays. Added read_all_records. Minor typos and bugs fixed. Test suite extended. 0.0584 Mon Mar 2 10:04:00 MET 1998 Fix of XBase::Memo::dBaseIV::read_record for memo fields longer than record length by Jochen Friedrich. 0.0583 Thu Feb 12 00:08:07 MET 1998 Bug fix for floating fields, patch by Carlos Augusto de Almeida. 0.058 Mon Feb 9 19:15:03 MET 1998 (*****) XBase::SQL rewritten, DBD::XBase now supports select, delete, insert, update and create table. Documentation for DBD::XBase extended. DBD::XBase is still alpha but rather stable. Added support for fpt memo files. Fixed bug with dBase IV memo files, the block length is stored somewhere else, patch by James LewisMoss. Fixed bug with field names in newer dbf files, terminated by zero byte, patch by Petr Olsak. Added binmode for the OSes that write to disk something else that they are told to, reported by Robert Bauer. Removed the test that caused read to fail on read-only files, reported by Stewart Russell. The error handling reviewed, most of the error messages are now local to the object ($table->errstr()). 0.039 Wed Dec 17 19:53:49 MET 1997 (*****) DBD::XBase supports select where and delete where. 0.0352 Mon Dec 15 11:29:46 MET 1997 Fixed bug with long memo fields, reported by Tejinderpal Singh. 0.0345 Mon Dec 8 13:02:46 MET 1997 Fixed bug with "\0" at the end of field names in header, spotted by Roberto Congiu. 0.0343 Thu Dec 4 10:52:41 MET 1997 Column names are converted to uppercase. SQL parsing moved to XBase::SQL module. Added require XBase::Memo when creating new Memo file. Added test for create and drop. 0.0342 Fri Nov 28 18:30:31 MET 1997 Fixed bug when creating new file, spotted by Roberto Congiu. $XBase::errstr depreciated, using XBase->errstr instead. Minor changes in the documentation. 0.03301 Thu Nov 20 17:32:53 MET 1997 Handling null numeric fields (John D Groenveld). Changed "look for error" test in header.t to be OS portable. Fixed bug in decode_version_info (dbtflag). Fixed bug with field length in XBase::create, spotted by Risto Wichman. 0.032 Thu Nov 6 16:27:10 MET 1997 Fixed bugs: test on "\r" in read_header; check of record number in delete and undelete (spotted by Frans van Loon). Added methods field_lengths and field_decimals and changed *_on_read in [NF] section (spotted by John D Groenveld). 0.031 Thu Oct 30 19:47:37 MET 1997 Fixed bug in docs about write_record. Changed format of get_field_info to include field number. Fixed bug with decimals. 0.03 Mon Oct 27 23:23:17 MET 1997 (*****) Minor bug fixes. XBase::create added. Tests extended. Module released on CPAN. 0.029 Fri Oct 24 19:34:32 MET DST 1997 Bug fixes. Added methods for writing dbt files. The writing methods are now set_record, set_record_hash and update_record. 0.024 Mon Oct 20 22:17:44 MET DST 1997 The original release. Includes XBase that reads dbf and dbt and writes dbf (but not dbt). Put on CPAN mainly for other people to test and comment. --- Note: Versions tagged (*****) were major updates and code changes. I have been using the Xbase(3) module by Pratap Pereira for quite a time to read the dbf files, but it had no writing capabilities, it was not use strict clean and the author did not support the module behind the version 1.07. So I started to make my own patches and thought it would be nice if other people could make use of them. I thought about taking over the development of the original Xbase package, but the interface seemed rather complicated to me. So with the help of article XBase File Format Description by Erik Bachmann on URL http://www.clicketyclick.dk/databases/xbase/format/ formerly http://www.e-bachmann.dk/docs/xbase.htm I have written a new module. It doesn't use any code from Xbase-1.07 and you are free to use and distribute it under the same terms as Perl itself. DBD-XBase-1.08/dbit/0000755000175000017500000000000013037112723013612 5ustar adeltonadeltonDBD-XBase-1.08/dbit/40nulls.t0000644000175000017500000000510512520437237015307 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 40nulls.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This is a test for correctly handling NULL values. # # # Make -w happy # $test_dsn = ''; $test_user = ''; $test_password = ''; # # Include lib.pl # use DBI; use vars qw($COL_NULLABLE); $mdriver = ""; foreach $file ("lib.pl", "t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($mdriver ne '') { last; } } sub ServerError() { print STDERR ("Cannot connect: ", $DBI::errstr, "\n", "\tEither your server is not up and running or you have no\n", "\tpermissions for acessing the DSN $test_dsn.\n", "\tThis test requires a running server and write permissions.\n", "\tPlease make sure your server is running and you have\n", "\tpermissions, then retry.\n"); exit 10; } # # Main loop; leave this untouched, put tests after creating # the new table. # while (Testing()) { # # Connect to the database Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password)) or ServerError(); # # Find a possible new table name # Test($state or $table = FindNewTable($dbh)) or DbiError($dbh->err, $dbh->errstr); # # Create a new table; EDIT THIS! # Test($state or ($def = TableDefinition($table, ["id", "INTEGER", 4, $COL_NULLABLE], ["name", "CHAR", 64, 0]), $dbh->do($def))) or DbiError($dbh->err, $dbh->errstr); # # Test whether or not a field containing a NULL is returned correctly # as undef, or something much more bizarre # Test($state or $dbh->do("INSERT INTO $table VALUES" . " ( NULL, 'NULL-valued id' )")) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor = $dbh->prepare("SELECT * FROM $table" . " WHERE " . IsNull("id"))) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute) or DbiError($dbh->err, $dbh->errstr); Test($state or ($rv = $cursor->fetchrow_arrayref) or $dbdriver eq 'CSV' or $dbdriver eq 'ConfFile') or DbiError($dbh->err, $dbh->errstr); Test($state or (!defined($$rv[0]) and defined($$rv[1])) or $dbdriver eq 'CSV' or $dbdriver eq 'ConfFile') or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->finish) or DbiError($dbh->err, $dbh->errstr); Test($state or undef $cursor || 1); # # Finally drop the test table. # Test($state or $dbh->do("DROP TABLE $table")) or DbiError($dbh->err, $dbh->errstr); } DBD-XBase-1.08/dbit/50chopblanks.t0000644000175000017500000000756112520437237016307 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 50chopblanks.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This driver should check whether 'ChopBlanks' works. # # # Make -w happy # use vars qw($test_dsn $test_user $test_password $mdriver $verbose $state $dbdriver); use vars qw($COL_NULLABLE $COL_KEY); $test_dsn = ''; $test_user = ''; $test_password = ''; # # Include lib.pl # use DBI; use strict; $mdriver = ""; { my $file; foreach $file ("lib.pl", "t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($mdriver ne '') { last; } } } sub ServerError() { print STDERR ("Cannot connect: ", $DBI::errstr, "\n", "\tEither your server is not up and running or you have no\n", "\tpermissions for acessing the DSN $test_dsn.\n", "\tThis test requires a running server and write permissions.\n", "\tPlease make sure your server is running and you have\n", "\tpermissions, then retry.\n"); exit 10; } # # Main loop; leave this untouched, put tests after creating # the new table. # while (Testing()) { my ($dbh, $sth, $query); # # Connect to the database Test($state or ($dbh = DBI->connect($test_dsn, $test_user, $test_password))) or ServerError(); # # Find a possible new table name # my $table = ''; Test($state or $table = FindNewTable($dbh)) or ErrMsgF("Cannot determine a legal table name: Error %s.\n", $dbh->errstr); # # Create a new table; EDIT THIS! # Test($state or ($query = TableDefinition($table, ["id", "INTEGER", 4, $COL_NULLABLE], ["name", "CHAR", 64, $COL_NULLABLE]), $dbh->do($query))) or ErrMsgF("Cannot create table: Error %s.\n", $dbh->errstr); # # and here's the right place for inserting new tests: # my @rows = ([1, ''], [2, ' '], [3, ' a b c ']); my $ref; foreach $ref (@rows) { my ($id, $name) = @$ref; if (!$state) { $query = sprintf("INSERT INTO $table (id, name) VALUES ($id, %s)", $dbh->quote($name)); } Test($state or $dbh->do($query)) or ErrMsgF("INSERT failed: query $query, error %s.\n", $dbh->errstr); $query = "SELECT id, name FROM $table WHERE id = $id\n"; Test($state or ($sth = $dbh->prepare($query))) or ErrMsgF("prepare failed: query $query, error %s.\n", $dbh->errstr); # First try to retreive without chopping blanks. $sth->{'ChopBlanks'} = 0; Test($state or $sth->execute) or ErrMsgF("execute failed: query %s, error %s.\n", $query, $sth->errstr); Test($state or defined($ref = $sth->fetchrow_arrayref)) or ErrMsgF("fetch failed: query $query, error %s.\n", $sth->errstr); Test($state or ($$ref[1] eq $name) or ($$ref[1] =~ /^$name\s+$/ && ($dbdriver eq 'XBase' || $dbdriver eq 'mysql' || $dbdriver eq 'ODBC'))) or ErrMsgF("problems with ChopBlanks = 0:" . " expected '%s', got '%s'.\n", $name, $$ref[1]); Test($state or $sth->finish()); # Now try to retreive with chopping blanks. $sth->{'ChopBlanks'} = 1; Test($state or $sth->execute) or ErrMsg("execute failed: query $query, error %s.\n", $sth->errstr); my $n = $name; $n =~ s/\s+$//; Test($state or ($ref = $sth->fetchrow_arrayref)) or ErrMsgF("fetch failed: query $query, error %s.\n", $sth->errstr); Test($state or ($$ref[1] eq $n)) or ErrMsgF("problems with ChopBlanks = 1:" . " expected '%s', got '%s'.\n", $n, $$ref[1]); Test($state or $sth->finish) or ErrMsgF("Cannot finish: %s.\n", $sth->errstr); } # # Finally drop the test table. # Test($state or $dbh->do("DROP TABLE $table")) or ErrMsgF("Cannot DROP test table $table: %s.\n", $dbh->errstr); # ... and disconnect Test($state or $dbh->disconnect) or ErrMsgF("Cannot disconnect: %s.\n", $dbh->errmsg); } DBD-XBase-1.08/dbit/40listfields.t0000644000175000017500000000637712520437237016330 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 40listfields.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This is a test for statement attributes being present appropriately. # # # Make -w happy # $test_dsn = ''; $test_user = ''; $test_password = ''; $COL_KEY = ''; # # Include lib.pl # use DBI; use vars qw($verbose); $dbdriver = ""; foreach $file ("lib.pl", "t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($dbdriver ne '') { last; } } @table_def = ( ["id", "INTEGER", 4, $COL_KEY], ["name", "CHAR", 64, $COL_NULLABLE] ); sub ServerError() { print STDERR ("Cannot connect: ", $DBI::errstr, "\n", "\tEither your server is not up and running or you have no\n", "\tpermissions for acessing the DSN $test_dsn.\n", "\tThis test requires a running server and write permissions.\n", "\tPlease make sure your server is running and you have\n", "\tpermissions, then retry.\n"); exit 10; } # # Main loop; leave this untouched, put tests after creating # the new table. # while (Testing()) { # # Connect to the database Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password)) or ServerError(); # # Find a possible new table name # Test($state or $table = FindNewTable($dbh)) or DbiError($dbh->err, $dbh->errstr); # # Create a new table # Test($state or ($def = TableDefinition($table, @table_def), $dbh->do($def))) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor = $dbh->prepare("SELECT * FROM $table")) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute) or DbiError($cursor->err, $cursor->errstr); my $res; Test($state or (($res = $cursor->{'NUM_OF_FIELDS'}) == @table_def)) or DbiError($cursor->err, $cursor->errstr); if (!$state && $verbose) { printf("Number of fields: %s\n", defined($res) ? $res : "undef"); } Test($state or ($ref = $cursor->{'NAME'}) && @$ref == @table_def && (lc $$ref[0]) eq $table_def[0][0] && (lc $$ref[1]) eq $table_def[1][0]) or DbiError($cursor->err, $cursor->errstr); if (!$state && $verbose) { print "Names:\n"; for ($i = 0; $i < @$ref; $i++) { print " ", $$ref[$i], "\n"; } } Test($state or ($dbdriver eq 'CSV') or ($dbdriver eq 'ConfFile') or ($ref = $cursor->{'NULLABLE'}) && @$ref == @table_def && !($$ref[0] xor ($table_def[0][3] & $COL_NULLABLE)) && !($$ref[1] xor ($table_def[1][3] & $COL_NULLABLE))) or DbiError($cursor->err, $cursor->errstr); if (!$state && $verbose) { print "Nullable:\n"; for ($i = 0; $i < @$ref; $i++) { print " ", ($$ref[$i] & $COL_NULLABLE) ? "yes" : "no", "\n"; } } Test($state or undef $cursor || 1); # # Drop the test table # Test($state or ($cursor = $dbh->prepare("DROP TABLE $table"))) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute) or DbiError($cursor->err, $cursor->errstr); # NUM_OF_FIELDS should be zero (Non-Select) Test($state or ($cursor->{'NUM_OF_FIELDS'} == 0)) or !$verbose or printf("NUM_OF_FIELDS is %s, not zero.\n", $cursor->{'NUM_OF_FIELDS'}); Test($state or (undef $cursor) or 1); } DBD-XBase-1.08/dbit/10dsnlist.t0000755000175000017500000000375612520437237015644 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 10dsnlist.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This test creates a database and drops it. Should be executed # after listdsn. # # # Include lib.pl # require DBI; $mdriver = ""; foreach $file ("lib.pl", "t/lib.pl", "DBD-~DBD_DRIVER~/t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($mdriver ne '') { last; } } if ($mdriver eq 'pNET' || $mdriver eq 'Adabas') { print "1..0\n"; exit 0; } print "Driver is $mdriver\n"; sub ServerError() { print STDERR ("Cannot connect: ", $DBI::errstr, "\n", "\tEither your server is not up and running or you have no\n", "\tpermissions for acessing the DSN $test_dsn.\n", "\tThis test requires a running server and write permissions.\n", "\tPlease make sure your server is running and you have\n", "\tpermissions, then retry.\n"); exit 10; } # # Main loop; leave this untouched, put tests into the loop # while (Testing()) { # Check if the server is awake. $dbh = undef; Test($state or ($dbh = DBI->connect($test_dsn, $test_user, $test_password))) or ServerError(); Test($state or defined(@dsn = DBI->data_sources($mdriver))); if (!$state) { my $d; print "List of $mdriver data sources:\n"; foreach $d (@dsn) { print " $d\n"; } print "List ends.\n"; } Test($state or $dbh->disconnect()); # # Try different DSN's # my(@dsnList); if (($mdriver eq 'mysql' or $mdriver eq 'mSQL') and $test_dsn eq "DBI:$mdriver:test") { @dsnList = ("DBI:$mdriver:test:localhost", "DBI:$mdriver:test;localhost", "DBI:$mdriver:database=test;host=localhost"); } my($dsn); foreach $dsn (@dsnList) { Test($state or ($dbh = DBI->connect($dsn, $test_user, $test_password))) or print "Cannot connect to DSN $dsn: ${DBI::errstr}\n"; Test($state or $dbh->disconnect()); } } exit 0; # Hate -w :-) $test_dsn = $test_user = $test_password = $DBI::errstr; DBD-XBase-1.08/dbit/40blobs.t0000644000175000017500000000670712520437237015264 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 40blobs.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This is a test for correct handling of BLOBS; namely $dbh->quote # is expected to work correctly. # $^W = 1; # # Make -w happy # $test_dsn = ''; $test_user = ''; $test_password = ''; # # Include lib.pl # require DBI; $mdriver = ""; foreach $file ("lib.pl", "t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($mdriver ne '') { last; } } if ($dbdriver eq 'mSQL' || $dbdriver eq 'mSQL1') { print "1..0\n"; exit 0; } sub ServerError() { my $err = $DBI::errstr; # Hate -w ... print STDERR ("Cannot connect: ", $DBI::errstr, "\n", "\tEither your server is not up and running or you have no\n", "\tpermissions for acessing the DSN $test_dsn.\n", "\tThis test requires a running server and write permissions.\n", "\tPlease make sure your server is running and you have\n", "\tpermissions, then retry.\n"); exit 10; } sub ShowBlob($) { my ($blob) = @_; for($i = 0; $i < 8; $i++) { if (defined($blob) && length($blob) > $i) { $b = substr($blob, $i*32); } else { $b = ""; } printf("%08lx %s\n", $i*32, unpack("H64", $b)); } } # # Main loop; leave this untouched, put tests after creating # the new table. # while (Testing()) { # # Connect to the database Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password)) or ServerError(); # # Find a possible new table name # Test($state or $table = FindNewTable($dbh)) or DbiError($dbh->error, $dbh->errstr); my($def); foreach $size (128) { # # Create a new table # if (!$state) { $def = TableDefinition($table, ["id", "INTEGER", 4, 0], ["name", "BLOB", $size, 0]); print "Creating table:\n$def\n"; } Test($state or $dbh->do($def)) or DbiError($dbh->err, $dbh->errstr); # # Create a blob # my ($blob, $qblob) = ""; if (!$state) { my $b = ""; for ($j = 0; $j < 256; $j++) { $b .= chr($j); } for ($i = 0; $i < $size; $i++) { $blob .= $b; } if ($mdriver eq 'pNET') { # Quote manually, no remote quote $qblob = eval "DBD::" . $dbdriver . "::db->quote(\$blob)"; } else { $qblob = $dbh->quote($blob); } } # # Insert a row into the test table....... # my($query); if (!$state) { $query = "INSERT INTO $table VALUES(1, $qblob)"; if ($ENV{'SHOW_BLOBS'} && open(OUT, ">" . $ENV{'SHOW_BLOBS'})) { print OUT $query; close(OUT); } } Test($state or $dbh->do($query)) or DbiError($dbh->err, $dbh->errstr); # # Now, try SELECT'ing the row out. # Test($state or $cursor = $dbh->prepare("SELECT * FROM $table" . " WHERE id = 1")) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute) or DbiError($dbh->err, $dbh->errstr); Test($state or (defined($row = $cursor->fetchrow_arrayref))) or DbiError($cursor->err, $cursor->errstr); Test($state or (@$row == 2 && $$row[0] == 1 && $$row[1] eq $blob)) or (ShowBlob($blob), ShowBlob(defined($$row[1]) ? $$row[1] : "")); Test($state or $cursor->finish) or DbiError($cursor->err, $cursor->errstr); Test($state or undef $cursor || 1) or DbiError($cursor->err, $cursor->errstr); # # Finally drop the test table. # next; Test($state or $dbh->do("DROP TABLE $table")) or DbiError($dbh->err, $dbh->errstr); } } DBD-XBase-1.08/dbit/50commit.t0000644000175000017500000001444212520437237015447 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 50commit.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This is testing the transaction support. # $^W = 1; # # Include lib.pl # require DBI; $mdriver = ""; foreach $file ("lib.pl", "t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($mdriver ne '') { last; } } if ($mdriver eq 'whatever') { print "1..0\n"; exit 0; } use vars qw($gotWarning); sub CatchWarning ($) { $gotWarning = 1; } sub NumRows($$$) { my($dbh, $table, $num) = @_; my($sth, $got); if (!($sth = $dbh->prepare("SELECT * FROM $table"))) { return "Failed to prepare: err " . $dbh->err . ", errstr " . $dbh->errstr; } if (!$sth->execute) { return "Failed to execute: err " . $dbh->err . ", errstr " . $dbh->errstr; } $got = 0; while ($sth->fetchrow_arrayref) { ++$got; } if ($got ne $num) { return "Wrong result: Expected $num rows, got $got.\n"; } return ''; } # # Main loop; leave this untouched, put tests after creating # the new table. # while (Testing()) { # # Connect to the database Test($state or ($dbh = DBI->connect($test_dsn, $test_user, $test_password)), 'connect', "Attempting to connect.\n") or ErrMsgF("Cannot connect: Error %s.\n\n" . "Make sure, your database server is up and running.\n" . "Check that '$test_dsn' references a valid database" . " name.\nDBI error message: %s\n", $DBI::err, $DBI::errstr); # # Find a possible new table name # Test($state or $table = FindNewTable($dbh)) or ErrMsgF("Cannot determine a legal table name: Error %s.\n", $dbh->errstr); # # Create a new table # Test($state or ($def = TableDefinition($table, ["id", "INTEGER", 4, 0], ["name", "CHAR", 64, 0]), $dbh->do($def))) or ErrMsgF("Cannot create table: Error %s.\n", $dbh->errstr); Test($state or $dbh->{AutoCommit}) or ErrMsg("AutoCommit is off\n", 'AutoCommint on'); # # Tests for databases that do support transactions # if (HaveTransactions()) { # Turn AutoCommit off $dbh->{AutoCommit} = 0; Test($state or (!$dbh->err && !$dbh->errstr && !$dbh->{AutoCommit})) or ErrMsgF("Failed to turn AutoCommit off: err %s, errstr %s\n", $dbh->err, $dbh->errstr); # Check rollback Test($state or $dbh->do("INSERT INTO $table VALUES (1, 'Jochen')")) or ErrMsgF("Failed to insert value: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); my $msg; Test($state or !($msg = NumRows($dbh, $table, 1))) or ErrMsg($msg); Test($state or $dbh->rollback) or ErrMsgF("Failed to rollback: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); Test($state or !($msg = NumRows($dbh, $table, 0))) or ErrMsg($msg); # Check commit Test($state or $dbh->do("DELETE FROM $table WHERE id = 1")) or ErrMsgF("Failed to insert value: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); Test($state or !($msg = NumRows($dbh, $table, 0))) or ErrMsg($msg); Test($state or $dbh->commit) or ErrMsgF("Failed to rollback: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); Test($state or !($msg = NumRows($dbh, $table, 0))) or ErrMsg($msg); # Check auto rollback after disconnect Test($state or $dbh->do("INSERT INTO $table VALUES (1, 'Jochen')")) or ErrMsgF("Failed to insert: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); Test($state or !($msg = NumRows($dbh, $table, 1))) or ErrMsg($msg); Test($state or $dbh->disconnect) or ErrMsgF("Failed to disconnect: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); Test($state or ($dbh = DBI->connect($test_dsn, $test_user, $test_password))) or ErrMsgF("Failed to reconnect: err %s, errstr %s.\n", $DBI::err, $DBI::errstr); Test($state or !($msg = NumRows($dbh, $table, 0))) or ErrMsg($msg); # Check whether AutoCommit is on again Test($state or $dbh->{AutoCommit}) or ErrMsg("AutoCommit is off\n"); # # Tests for databases that don't support transactions # } else { if (!$state) { $@ = ''; eval { $dbh->{AutoCommit} = 0; } } Test($state or $@) or ErrMsg("Expected fatal error for AutoCommit => 0\n", 'AutoCommit off -> error'); } # Check whether AutoCommit mode works. Test($state or $dbh->do("INSERT INTO $table VALUES (1, 'Jochen')")) or ErrMsgF("Failed to delete: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); Test($state or !($msg = NumRows($dbh, $table, 1)), 'NumRows') or ErrMsg($msg); Test($state or $dbh->disconnect, 'disconnect') or ErrMsgF("Failed to disconnect: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); Test($state or ($dbh = DBI->connect($test_dsn, $test_user, $test_password))) or ErrMsgF("Failed to reconnect: err %s, errstr %s.\n", $DBI::err, $DBI::errstr); Test($state or !($msg = NumRows($dbh, $table, 1))) or ErrMsg($msg); # Check whether commit issues a warning in AutoCommit mode Test($state or $dbh->do("INSERT INTO $table VALUES (2, 'Tim')")) or ErrMsgF("Failed to insert: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); my $result; if (!$state) { $@ = ''; $SIG{__WARN__} = \&CatchWarning; $gotWarning = 0; eval { $result = $dbh->commit; }; $SIG{__WARN__} = 'DEFAULT'; } Test($state or $gotWarning) or ErrMsg("Missing warning when committing in AutoCommit mode"); # Check whether rollback issues a warning in AutoCommit mode # We accept error messages as being legal, because the DBI # requirement of just issueing a warning seems scary. Test($state or $dbh->do("INSERT INTO $table VALUES (3, 'Alligator')")) or ErrMsgF("Failed to insert: err %s, errstr %s.\n", $dbh->err, $dbh->errstr); if (!$state) { $@ = ''; $SIG{__WARN__} = \&CatchWarning; $gotWarning = 0; eval { $result = $dbh->rollback; }; $SIG{__WARN__} = 'DEFAULT'; } Test($state or $gotWarning or $dbh->err) or ErrMsg("Missing warning when rolling back in AutoCommit mode"); # # Finally drop the test table. # Test($state or $dbh->do("DROP TABLE $table")) or ErrMsgF("Cannot DROP test table $table: %s.\n", $dbh->errstr); Test($state or $dbh->disconnect()) or ErrMsgF("Cannot DROP test table $table: %s.\n", $dbh->errstr); } DBD-XBase-1.08/dbit/40bindparam.t0000644000175000017500000001214712520437237016113 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 40bindparam.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This is a skeleton test. For writing new tests, take this file # and modify/extend it. # $^W = 1; # # Make -w happy # $test_dsn = ''; $test_user = ''; $test_password = ''; # # Include lib.pl # require DBI; use vars qw($COL_NULLABLE); $mdriver = ""; foreach $file ("lib.pl", "t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($mdriver ne '') { last; } } if ($mdriver eq 'pNET') { print "1..0\n"; exit 0; } sub ServerError() { my $err = $DBI::errstr; # Hate -w ... print STDERR ("Cannot connect: ", $DBI::errstr, "\n", "\tEither your server is not up and running or you have no\n", "\tpermissions for acessing the DSN $test_dsn.\n", "\tThis test requires a running server and write permissions.\n", "\tPlease make sure your server is running and you have\n", "\tpermissions, then retry.\n"); exit 10; } if (!defined(&SQL_VARCHAR)) { eval "sub SQL_VARCHAR { 12 }"; } if (!defined(&SQL_INTEGER)) { eval "sub SQL_INTEGER { 4 }"; } # # Main loop; leave this untouched, put tests after creating # the new table. # while (Testing()) { # # Connect to the database Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password), 'connect') or ServerError(); # # Find a possible new table name # Test($state or $table = FindNewTable($dbh), 'FindNewTable') or DbiError($dbh->err, $dbh->errstr); # # Create a new table; EDIT THIS! # Test($state or ($def = TableDefinition($table, ["id", "INTEGER", 4, 0], ["name", "CHAR", 64, $COL_NULLABLE]) and $dbh->do($def)), 'create', $def) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor = $dbh->prepare("INSERT INTO $table" . " VALUES (?, ?)"), 'prepare') or DbiError($dbh->err, $dbh->errstr); # # Insert some rows # # Automatic type detection my $numericVal = 1; my $charVal = "Alligator Descartes"; Test($state or $cursor->execute($numericVal, $charVal), 'execute insert 1') or DbiError($dbh->err, $dbh->errstr); # Does the driver remember the automatically detected type? Test($state or $cursor->execute("3", "Jochen Wiedmann"), 'execute insert num as string') or DbiError($dbh->err, $dbh->errstr); $numericVal = 2; $charVal = "Tim Bunce"; Test($state or $cursor->execute($numericVal, $charVal), 'execute insert 2') or DbiError($dbh->err, $dbh->errstr); # Now try the explicit type settings Test($state or $cursor->bind_param(1, " 4", SQL_INTEGER()), 'bind 1') or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->bind_param(2, "Andreas König"), 'bind 2') or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute, 'execute binds') or DbiError($dbh->err, $dbh->errstr); # Works undef -> NULL? Test($state or $cursor->bind_param(1, 5, SQL_INTEGER())) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->bind_param(2, undef)) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor -> finish, 'finish'); Test($state or undef $cursor || 1, 'undef cursor'); Test($state or $dbh -> disconnect, 'disconnect'); Test($state or undef $dbh || 1, 'undef dbh'); # # And now retreive the rows using bind_columns # # # Connect to the database # Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password), 'connect for read') or ServerError(); Test($state or $cursor = $dbh->prepare("SELECT * FROM $table" . " ORDER BY id")) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->bind_columns(undef, \$id, \$name)) or DbiError($dbh->err, $dbh->errstr); Test($state or ($ref = $cursor->fetch) && $id == 1 && $name eq 'Alligator Descartes') or printf("Query returned id = %s, name = %s, ref = %s, %d\n", $id, $name, $ref, scalar(@$ref)); Test($state or (($ref = $cursor->fetch) && $id == 2 && $name eq 'Tim Bunce')) or printf("Query returned id = %s, name = %s, ref = %s, %d\n", $id, $name, $ref, scalar(@$ref)); Test($state or (($ref = $cursor->fetch) && $id == 3 && $name eq 'Jochen Wiedmann')) or printf("Query returned id = %s, name = %s, ref = %s, %d\n", $id, $name, $ref, scalar(@$ref)); Test($state or (($ref = $cursor->fetch) && $id == 4 && $name eq 'Andreas König')) or printf("Query returned id = %s, name = %s, ref = %s, %d\n", $id, $name, $ref, scalar(@$ref)); Test($state or (($ref = $cursor->fetch) && $id == 5 && (!defined($name) or $name eq ''))) or printf("Query returned id = %s, name = %s, ref = %s, %d\n", $id, $name, $ref, scalar(@$ref)); Test($state or undef $cursor or 1); # # Finally drop the test table. # Test($state or $dbh->do("DROP TABLE $table")) or DbiError($dbh->err, $dbh->errstr); } DBD-XBase-1.08/dbit/30insertfetch.t0000644000175000017500000000732312520437237016473 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 30insertfetch.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This is a simple insert/fetch test. # $^W = 1; # # Make -w happy # $test_dsn = ''; $test_user = ''; $test_password = ''; # # Include lib.pl # use DBI; $mdriver = ""; foreach $file ("lib.pl", "t/lib.pl", "DBD-~DBD_DRIVER~/t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($mdriver ne '') { last; } } sub ServerError() { print STDERR ("Cannot connect: ", $DBI::errstr, "\n", "\tEither your server is not up and running or you have no\n", "\tpermissions for acessing the DSN $test_dsn.\n", "\tThis test requires a running server and write permissions.\n", "\tPlease make sure your server is running and you have\n", "\tpermissions, then retry.\n"); exit 10; } # # Main loop; leave this untouched, put tests after creating # the new table. # while (Testing()) { # # Connect to the database Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password), 'connect') or ServerError(); # # Find a possible new table name # Test($state or $table = FindNewTable($dbh), 'FindNewTable') or DbiError($dbh->err, $dbh->errstr); # # Create a new table; EDIT THIS! # Test($state or ($def = TableDefinition($table, ["id", "INTEGER", 4, 0], ["name", "CHAR", 64, 0], ["val", "INTEGER", 4, 0], ["txt", "CHAR", 64, 0]) and $dbh->do($def)), 'create', $def) or DbiError($dbh->err, $dbh->errstr); # # Insert a row into the test table....... # Test($state or $dbh->do("INSERT INTO $table" . " VALUES(1, 'Alligator Descartes', 1111," . " 'Some Text')"), 'insert') or DbiError($dbh->err, $dbh->errstr); # # Now, try SELECT'ing the row out. # Test($state or $cursor = $dbh->prepare("SELECT * FROM $table" . " WHERE id = 1"), 'prepare select') or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute, 'execute select') or DbiError($cursor->err, $cursor->errstr); my ($row, $errstr); Test($state or (defined($row = $cursor->fetchrow_arrayref) && !($cursor->errstr)), 'fetch select') or DbiError($cursor->err, $cursor->errstr); Test($state or ($row->[0] == 1 && $row->[1] eq 'Alligator Descartes' && $row->[2] == 1111 && $row->[3] eq 'Some Text'), 'compare select') or DbiError($cursor->err, $cursor->errstr); Test($state or $cursor->finish, 'finish select') or DbiError($cursor->err, $cursor->errstr); Test($state or undef $cursor || 1, 'undef select'); # # ...and delete it........ # Test($state or $dbh->do("DELETE FROM $table WHERE id = 1"), 'delete') or DbiError($dbh->err, $dbh->errstr); # # Now, try SELECT'ing the row out. This should fail. # Test($state or $cursor = $dbh->prepare("SELECT * FROM $table" . " WHERE id = 1"), 'prepare select deleted') or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute, 'execute select deleted') or DbiError($cursor->err, $cursor->errstr); Test($state or (!defined($row = $cursor->fetchrow_arrayref) && (!defined($errstr = $cursor->errstr) || $cursor->errstr eq '')), 'fetch select deleted') or DbiError($cursor->err, $cursor->errstr); Test($state or $cursor->finish, 'finish select deleted') or DbiError($cursor->err, $cursor->errstr); Test($state or undef $cursor || 1, 'undef select deleted'); # # Finally drop the test table. # Test($state or $dbh->do("DROP TABLE $table"), 'drop') or DbiError($dbh->err, $dbh->errstr); } DBD-XBase-1.08/dbit/40numrows.t0000644000175000017500000001024312520437237015663 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 40numrows.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This tests, whether the number of rows can be retrieved. # $^W = 1; $| = 1; # # Make -w happy # $test_dsn = ''; $test_user = ''; $test_password = ''; # # Include lib.pl # use DBI; $mdriver = ""; foreach $file ("lib.pl", "t/lib.pl", "DBD-~DBD_DRIVER~/t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($mdriver ne '') { last; } } sub ServerError() { print STDERR ("Cannot connect: ", $DBI::errstr, "\n", "\tEither your server is not up and running or you have no\n", "\tpermissions for acessing the DSN $test_dsn.\n", "\tThis test requires a running server and write permissions.\n", "\tPlease make sure your server is running and you have\n", "\tpermissions, then retry.\n"); exit 10; } sub TrueRows($) { my ($sth) = @_; my $count = 0; while ($sth->fetchrow_arrayref) { ++$count; } $count; } # # Main loop; leave this untouched, put tests after creating # the new table. # while (Testing()) { # # Connect to the database Test($state or ($dbh = DBI->connect($test_dsn, $test_user, $test_password))) or ServerError(); # # Find a possible new table name # Test($state or ($table = FindNewTable($dbh))) or DbiError($dbh->err, $dbh->errstr); # # Create a new table; EDIT THIS! # Test($state or ($def = TableDefinition($table, ["id", "INTEGER", 4, 0], ["name", "CHAR", 64, 0]), $dbh->do($def))) or DbiError($dbh->err, $dbh->errstr); # # This section should exercise the sth->rows # method by preparing a statement, then finding the # number of rows within it. # Prior to execution, this should fail. After execution, the # number of rows affected by the statement will be returned. # Test($state or $dbh->do("INSERT INTO $table" . " VALUES( 1, 'Alligator Descartes' )")) or DbiError($dbh->err, $dbh->errstr); Test($state or ($cursor = $dbh->prepare("SELECT * FROM $table" . " WHERE id = 1"))) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute) or DbiError($dbh->err, $dbh->errstr); Test($state or ($numrows = $cursor->rows) == 1 or ($numrows == -1)) or ErrMsgF("Expected 1 rows, got %s.\n", $numrows); Test($state or ($numrows = TrueRows($cursor)) == 1) or ErrMsgF("Expected to fetch 1 rows, got %s.\n", $numrows); Test($state or $cursor->finish) or DbiError($dbh->err, $dbh->errstr); Test($state or undef $cursor or 1); Test($state or $dbh->do("INSERT INTO $table" . " VALUES( 2, 'Jochen Wiedmann' )")) or DbiError($dbh->err, $dbh->errstr); Test($state or ($cursor = $dbh->prepare("SELECT * FROM $table" . " WHERE id >= 1"))) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute) or DbiError($dbh->err, $dbh->errstr); Test($state or ($numrows = $cursor->rows) == 2 or ($numrows == -1)) or ErrMsgF("Expected 2 rows, got %s.\n", $numrows); Test($state or ($numrows = TrueRows($cursor)) == 2) or ErrMsgF("Expected to fetch 2 rows, got %s.\n", $numrows); Test($state or $cursor->finish) or DbiError($dbh->err, $dbh->errstr); Test($state or undef $cursor or 1); Test($state or $dbh->do("INSERT INTO $table" . " VALUES(3, 'Tim Bunce')")) or DbiError($dbh->err, $dbh->errstr); Test($state or ($cursor = $dbh->prepare("SELECT * FROM $table" . " WHERE id >= 2"))) or DbiError($dbh->err, $dbh->errstr); Test($state or $cursor->execute) or DbiError($dbh->err, $dbh->errstr); Test($state or ($numrows = $cursor->rows) == 2 or ($numrows == -1)) or ErrMsgF("Expected 2 rows, got %s.\n", $numrows); Test($state or ($numrows = TrueRows($cursor)) == 2) or ErrMsgF("Expected to fetch 2 rows, got %s.\n", $numrows); Test($state or $cursor->finish) or DbiError($dbh->err, $dbh->errstr); Test($state or undef $cursor or 1); # # Finally drop the test table. # Test($state or $dbh->do("DROP TABLE $table")) or DbiError($dbh->err, $dbh->errstr); } DBD-XBase-1.08/dbit/20createdrop.t0000644000175000017500000000352112520437237016300 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 20createdrop.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This is a skeleton test. For writing new tests, take this file # and modify/extend it. # use strict; use vars qw($test_dsn $test_user $test_password $mdriver $dbdriver); $DBI::errstr = ''; # Make -w happy require DBI; # # Include lib.pl # $mdriver = ""; my $file; foreach $file ("lib.pl", "t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($mdriver ne '') { last; } } sub ServerError() { print STDERR ("Cannot connect: ", $DBI::errstr, "\n", "\tEither your server is not up and running or you have no\n", "\tpermissions for acessing the DSN $test_dsn.\n", "\tThis test requires a running server and write permissions.\n", "\tPlease make sure your server is running and you have\n", "\tpermissions, then retry.\n"); exit 10; } # # Main loop; leave this untouched, put tests into the loop # use vars qw($state); while (Testing()) { # # Connect to the database my $dbh; Test($state or $dbh = DBI->connect($test_dsn, $test_user, $test_password)) or ServerError(); # # Find a possible new table name # my $table; Test($state or $table = FindNewTable($dbh)) or DbiError($dbh->err, $dbh->errstr); # # Create a new table # my $def; if (!$state) { ($def = TableDefinition($table, ["id", "INTEGER", 4, 0], ["name", "CHAR", 64, 0])); print "Creating table:\n$def\n"; } Test($state or $dbh->do($def)) or DbiError($dbh->err, $dbh->errstr); # # ... and drop it. # Test($state or $dbh->do("DROP TABLE $table")) or DbiError($dbh->err, $dbh->errstr); # # Finally disconnect. # Test($state or $dbh->disconnect()) or DbiError($dbh->err, $dbh->errstr); } DBD-XBase-1.08/dbit/00base.t0000644000175000017500000000163212520437237015061 0ustar adeltonadelton#!/usr/local/bin/perl # # $Id: 00base.t 1.1 Tue, 30 Sep 1997 01:28:08 +0200 joe $ # # This is the base test, tries to install the drivers. Should be # executed as the very first test. # # # Include lib.pl # $mdriver = ""; foreach $file ("lib.pl", "t/lib.pl") { do $file; if ($@) { print STDERR "Error while executing lib.pl: $@\n"; exit 10; } if ($mdriver ne '') { last; } } # Base DBD Driver Test print "1..$tests\n"; require DBI; print "ok 1\n"; import DBI; print "ok 2\n"; $switch = DBI->internal; (ref $switch eq 'DBI::dr') ? print "ok 3\n" : print "not ok 3\n"; # This is a special case. install_driver should not normally be used. $drh = DBI->install_driver($mdriver); (ref $drh eq 'DBI::dr') ? print "ok 4\n" : print "not ok 4\n"; if ($drh->{Version}) { print "ok 5\n"; print "Driver version is ", $drh->{Version}, "\n"; } BEGIN { $tests = 5 } exit 0; # end. DBD-XBase-1.08/README0000644000175000017500000000722312712070132013550 0ustar adeltonadelton ------------------------------------ XBase and DBD::XBase ------------------------------------ This is the README file for the XBase and DBD::XBase packages for work with *.dbf files. Please read it if you install this module for the first time or if there are any problems with the module. What is this module for: Module XBase provides access to XBase (dBase, Fox*) dbf files. It also handles memo files (dbt, fpt) and to certain extend index files (ndx, ntx, mdx, idx and cdx). The DBD::XBase is a database driver for DBI and provides simple SQL interface for reading and writing the database files. So this package offers two ways of accessing your beloved data in dbf files: XBase.pm and DBD::XBase. I recommend using DBD::XBase and only resort to XBase.pm if you need something special which is not supported by the DBI interface. You do not need any other servers/software, these modules directly read and write the dbf (and other) files. The main goal was to create a parser, mainly to work with data from your legacy applications. If you are looking for something more powerfull, check real relation database servers, such as Oracle, MySQL or PostgreSQL. How does the code look like: The DBI (DBD::XBase) way of doing things is use DBI; my $dbh = DBI->connect('dbi:XBase:/directory', undef, undef, { RaiseError => 1 }); my $data = $dbh->selectall_arrayref(q! select * from table !); which is the same as would be with any other database. Remember, this is only a simple parser, so no joins or subselecects are supported. If you want to use the base XBase.pm interface, you'd use code like use XBase; my $table = new XBase 'table.dbf'; my @data = $table->get_record(0); The distribution also includes a dbfdump script that prints the content of the table in readable form. Index support: The support for ndx/ntx/idx/mdx/cdx index files still needs quite a lot of work. It currently allows you to search directly to the record you want, using the prepare_select_with_index method of the XBase table object. But you cannot create the index, nor is the index updated when you change the dbf. Check the XBase::Index(3) man page and the eg/ directory for how you can help to make it better. Recently, support for SDBM index files was added. I hope to make it a fully working and reference implementation before attacking the world of undocumented mess of XBase index types again. Support, documentation: This module is provided in a hope you might find it useful. My intent is to support as many variations of formats as possible, but I do not have dBase/Fox* and do not plan to have, so send me examples of your data files if you feel your native XBase engines produce data incompatible with this module. Man pages for XBase, DBD::XBase, dbfdump, XBase::Index and XBase::SDBM are included, examples of little scripts can also be found in eg/ directory of the distribution. Read the DBI man page for DBI specific issues, and the XBase::FAQ page. Installation: For installation and problem and bug reporting, please read the INSTALL file. If it works for you: I'd appreciate any message if you use the module and find it usefull -- I'm just curious what tasks people use the module for and what they expect from it. You can of course also send something more valuable. Available: http://www.adelton.com/perl/DBD-XBase/ and from your favorite CPAN site in the authors/id/JANPAZ/ directory. Contact the author at jpx dash perl at adelton dot com. Copyright: (c) 1997--2016 Jan Pazdziora. All rights reserved. This package is free software; you can redistribute it and/or modify it under the same terms as Perl itself. DBD-XBase-1.08/META.json0000664000175000017500000000151713037112723014317 0ustar adeltonadelton{ "abstract" : "Reads and writes XBase (dbf) files, includes DBI support", "author" : [ "Jan Pazdziora" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "DBD-XBase", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } } }, "release_status" : "stable", "version" : "1.08", "x_serialization_backend" : "JSON::PP version 2.27400" } DBD-XBase-1.08/new-XBase0000644000175000017500000004266112521607341014417 0ustar adeltonadelton =head1 NAME XBase - Perl module for reading and writing the dbf files =head1 POZOR! This is suggestion for new interface. Not current documentation, see normal perldoc XBase. =head1 SYNOPSIS use XBase; my $table = new XBase "dbase.dbf" or die XBase->errstr; for (0 .. $table->last_record) { my ($deleted, $id, $msg) = $table->get_record($_, "ID", "MSG"); print "$id:\t$msg\n" unless $deleted; } $table->{'RaiseError'} = 1; # new my $cur = $table->prepare_select_with_index("dbaseid.ndx", "id", "msg"); $cur->find_eq(156) or do { print "Value 156 not found.\n"; exit; }; my ($id, $msg) = $cur->fetch; =head1 DESCRIPTION This module can read and write XBase database files, known as dbf in dBase and FoxPro world. It also transparently reads memo fields from the dbt, fpt and smt files and works with index files (ndx, ntx, mdx, idx, cdx and SDBM). This module XBase.pm provides simple native interface to XBase files. For DBI compliant database access, see DBD::XBase and DBI modules and their man pages. To work with dbf and associated files, you first need to open the dbf file using my $table = new XBase 'dbase.dbf' or die XBase->errstr; type of call. This gives you an object to interact with the table. You can then access the records using their position in the file my ($deleted, $id, $name, $born) = $table->get_record($num, 'ID', 'NAME', 'DO_BIRTH'); if ($id == 436) { $table->update_record_hash($num, 'NAME' => 'Peter') } or via cursors that allow you to walk through the file my $cur = $table->prepare_select('ID', 'NAME', 'DO_BIRTH'); while (my ($id, $name, $born) = $cur->fetch) { # do some work } If there are index files for given table, they can be used to speedup the searches. You can either use them explicitely to open cursor based on the index my $cur = $table->prepare_select_with_index('dbaseid.ndx' 'ID', 'NAME', 'DO_BIRTH'); if ($cur->find_eq(436)) { my ($id, $name, $born) = $cur->fetch; } or you can attach the indexes to the table and they will be used when needed and also updated when the dbf table changes my $table = new XBase 'file' => 'dbase.dbf', 'RaiseError' => 1, 'index' => [ 'dbaseid.ndx', 'dbasename.ndx' ]; my $cur = $table->prepare_select_where('id = 436', 'NAME'); while (my ($name) = $cur->fetch) { print "Old value $name, new value 'Peter'\n"; $table->update_record_hash($cur->last_fetched, 'name' => 'Peter'); } The cdx, mdx and SDBM index files (with the same base name as the dbf) are attached by default. =head1 LIST OF METHODS The following methods are available for XBase.pm tables and their cursors, their meaning and parameters are in more detail described below: =over 4 =item General methods working with the table new close create drop attach_index pack errstr =item Methods returning information about the file last_record field_names last_field field_types header_info field_lengths field_type field_decimals field_length field_decimal =item Accessing and modifying the records get_record set_record get_record_nf set_record_hash get_record_as_hash update_record_hash get_all_records delete_record dump_records undelete_record =item Creating cursors and working with them prepare_select fetch prepare_select_with_index fetch_hashref prepare_select_where last_fetched find_eq cursor_uses_index =back =head1 General methods The general methods working with the whole files or tables. =head2 new Opens the existing dbf file and provides an object to interact with the table. Memo and index files are also opened transparently. If opening of the dbf file or any other needed file (memo, index) fails, C returns undef and the error message may be retrieved via Berrstr>. The parameters to B are passed as hash: =over 4 =item name Name of the dbf file (dbf table). The C<.dbf> suffix may be omitted. The name of the file may also be passed as the very first single parameter. =item memofile Specifies non standard name for the associated memo file. By default it's the name of the dbf file, with suffix C<.dbt>, C<.fpt> or C<.smt>. =item ignorememo Makes B and all subsequent operation to ignore memo file at all. This is usefull if you've lost the dbt file and you do not need it. The default is undef, not ignoring the memo file. =item memosep Separator of memo records in the dBase III memo files. The standard says it should be C<"\x1a\x1a">. There are however implementations that only put in one C<"\x1a">. XBase.pm tries hard to guess which is the case for your dbt but if it fails, you can tell it yourself. =item nolongchars Prevents B to treat the decimal value of character fields as high byte of the length -- there are some broken products around producing character fields with decimal values set. XBase.pm tries hard to guess which is the case for your dbf, so again you need this option only if it fails. =item index Name of arrayref of names of index files to attach to the opened object. The cdx, mdx and SDBM indexes are attached by default. =item noindex Prevents any index file to be attached automatically (cdx, mdx, SDBM). Default is undef. =item PrintError If the B or any subsequent call to the object fail, they generate a warning using warn. The default is undef (but future versions may default to 1). =item RaiseError If the B or any subsequent call to the object fail, they raise an exception (die). The default is undef. =back Examples: my $table = new XBase "table.dbf" or die XBase->errstr; my $table = new XBase 'name' => 'table.dbf', 'index' => 'table.ndx', 'PrintError' => 1; =head2 create Creates new empty dbf file on disk; memo file will be also created if the table contains some memo fields. Parameters to create are passed as hash. =over 4 =item name Name of the new dbf file. =back You can call this method as method of another XBase object and then you only need to pass B value of the hash; the structure (fields) of the new file will be the same as of the original object. If you call B using class name (XBase), you have to (besides B) also specify the structure of the file: =over 4 =item field_names Arrayref to list of field name. =item field_types Arrayref to list of field types, specified either by one letter strings (C, N, L, D, ...) or by long versions (char, numeric, date, ...) =item field_lengths Arrayref to list of field widths. =item field_decimals Arrayref to list of precissions, for numeric columns. =item version Force different version of the dbf or memo file. The default is version of the source table (if you call B on an object), 3 (dBase III compatible) otherwise. =item memofile Specify nonstandard memo file name or location. =back If you keep some value undefined, B will make it into some reasonable default. The new dbf file (nor memo file) mustn't exist yet -- B will not allow you to overwrite existing table. Use B (or unlink) to delete it first. my $newtable = $table->create("name" => "copy.dbf"); my $newtable = XBase->create("name" => "new.dbf", "field_names" => [ "ID", "MSG" ], "field_types" => [ "N", "C" ], "field_lengths" => [ 6, 40 ], "field_decimals" => [ 0, undef ]); =head2 attach_index The index file may be attached during the B call or additionally with this call. =head2 pack All records that were marked deleted in the table, will be purged from the file. Effectively does a fresh copy to new file and then moves it to original location, so is not aimed at efficiency. Also recreates all attached index files. =head2 close Closes the object and associated memo file and attached index files, no arguments. =head2 drop This method closes the table and deletes it on disk (including associated memo file and attached index files, if there are any). =head2 errstr Called either as a class method (after B or B) or on a table object, it returns error string describing the last error of previous failed method call. =head1 Information about dbf file =head2 last_record Returns number of the last record in the file. The records marked deleted but present in the file are included in this number. =head2 last_field Returns number of the last field in the file, number of fields minus 1. =head2 header_info Returns string with formated information about the file and about the fields. =head2 field_names, field_types, field_lengths, field_decimals Return list of field names and so on for the dbf file. =head2 field_type, field_length, field_decimal For a field name, returns the appropriate value. Returns undef if the field doesn't exist in the table. =head1 Accessing the records When dealing with the records one by one, reading or writing, you have to specify the number of the record in the file as the first argument. The valid range is from 0 to C<$table-Elast_record> and C<$table-Elast_record+1> to insert new record to the file. =head2 get_record Returns list of field values from the specified record. The first parameter in the call is the number of the record. If you do not specify any other parameters, all fields are returned in the same order as they appear in the file. You can also put list of field names after the record number and then only those will be returned. The first value of the returned list is always the 1/0 C<_DELETED> value saying whether the record is marked deleted or not, so on success, B never returns empty list. =head2 get_record_as_hash Like B, but returns the values as hash (in list context) or reference to hash (in scalar context) containing field values indexed by field names. The name of the deleted flag is C<_DELETED>. The field names are returned as uppercase. =head2 get_record_nf Like B but instead if the names of the fields, you can pass list of numbers of the fields to read. =head2 get_all_records Returns reference to an array containing array of values for each undeleted record at once. As parameters, pass list of fields to return for each record. =head2 dump_records Prints to currently selected filehandle all non-deleted records from the file. By default, all fields are printed, separated by colons, one record on a row. The method can have parameters in a form of a hash with the following keys: =over 4 =item rs Record separator, string, newline by default. =item fs Field separator, string, one colon by default. =item fields Reference to a list of names of the fields to print. By default it's undef, meaning all fields. You can also pass in scalar where the field names are separated by commas, or by dashes to denote intervals. =item undef What to print for undefined (NULL) values, empty string by default. =back Example of use is use XBase; my $table = new XBase "table" or die XBase->errstr; $table->dump_records("fs" => " | ", "rs" => " <-+\n", "fields" => [ "id", "msg" ]);' Also note that there is a command line script dbfdump(1) that does the printing. =head1 Writing the data All three writing methods always undelete the record. On success they return true -- the record number actually written. =head2 set_record As parameters, takes the number of the record and the list of values of the fields. It writes the record to the file. Unspecified fields (if you pass less than you should) are set to undef/empty. =head2 set_record_hash Takes number of the record and hash as parameters, sets the fields, unspecified fields are undefed/emptied. =head2 update_record_hash Like B but fields that do not have value specified in the hash retain their original value. =head2 delete_record, undelete_record Marks the specified record in the file deleted/undeleted. =head1 Sequentially reading the file If you plan to sequentially walk through the file, you can create a cursor first and then repeatedly call B to get next record. =head2 prepare_select Creates and returns an cursor to walk through the file. As parameters, pass list of field names to return, by default all fields. =head2 prepare_select_with_index The first parameter is the file name of the index file, the rest is optional list of field names. For index types that can hold more index structures in one file (have tags), instead of file name use arrayref with the file name, the tag name and optionaly the index type (at the moment, expressions are not supported, so XBase.pm won't be able to determine type of the index unless you tell it). The B will then return records in the ascending order, according to the index. =head2 prepare_select_where The first parameter is a string with boolean expression, the rest is optional list of field names. The Bes on the returned cursor will return only records matching the expression. If there are attached index files, they may be used to speed the search. The previous methods on the table object will return cursor object, the following methods are to be called on the cursor, not on the table. =head2 fetch Returns the fields of the next available undeleted record from the cursor. The list thus doesn't contain the C<_DELETED> flag since you are guaranteed that the record is not deleted. =item fetch_hashref Returns a hash reference of fields for the next undeleted record from the cursor. =item last_fetched Returns the record number of the record last fetched. =item find_eq This only works with cursor created via B or B that uses index. As a parameter it takes the cursor value to find. It returns 1 if there is matching record, or 0 otherwise. If there is a match, the next Bes will fetch the records matching, and continue with records greater than the specified value (walk the index). If there isn't match, B returns next greater record. =item cursor_uses_index Returns true if the cursor created with B uses index. =head1 EXAMPLES Assorted examples of reading and writing: my @data = $table->get_record(3, "jezek", "krtek"); my $hashref = $table->get_record_as_hash(38); $table->set_record_hash(8, "jezek" => "jezecek", "krtek" => 5); $table->undelete_record(4); This is a code to update field MSG in record where ID is 123. use XBase; my $table = new XBase "test.dbf" or die XBase->errstr; for (0 .. $table->last_record) { my ($deleted, $id) = $table->get_record($_, "ID") die $table->errstr unless defined $deleted; next if $deleted; $table->update_record_hash($_, "MSG" => "New message") if $id == 123; } Examples of using cursors: my $table = new XBase "names.dbf" or die XBase->errstr; my $cursor = $table->prepare_select("ID", "NAME", "STREET"); while (my @data = $cursor->fetch) { ### do something here, like print "@data\n"; } my $table = new XBase "employ.dbf"; my $cur = $table->prepare_select_with_index("empid.ndx"); ## my $cur = $table->prepare_select_with_index( ["empid.cdx", "ADDRES"], "id", "address"); $cur->find_eq(1097); while (my $hashref = $cur->fetch_hashref and $hashref->{"ID"} == 1097) { ### do something here with $hashref } The second example shows that after you have done B, the Bes continue untill the end of the index, so you have to check whether you are still on records with given value. And if there is no record with value 1097 in the indexed field, you will just get the next record in the order. The updating example can be rewritten to: use XBase; my $table = new XBase "test.dbf" or die XBase->errstr; my $cursor = $table->prepare_select("ID") while (my ($id) = $cursor->fetch) { $table->update_record_hash($cursor->last_fetched, "MSG" => "New message") if $id == 123 } =head1 DATA TYPES The character fields are returned "as is". No charset or other translation is done. The numbers are converted to Perl numbers. The date fields are returned as 8 character string of the 'YYYYMMDD' form and when inserting the date, you again have to provide it in this form. No checking for the validity of the date is done. The datetime field is returned in the number of seconds since 1970/1/1, possibly with decimal part (since it allows precision up to 1/1000 s). To get the fields, use the gmtime (or similar) Perl function. If there is a memo field in the dbf file, the module tries to open file with the same name but extension dbt, fpt or smt. It uses module XBase::Memo(3) for this. It reads and writes this memo field transparently (you do not know about it) and returns the data as normal scalar. =head1 INFORMATION SOURCE This module is built using information from and article XBase File Format Description by Erik Bachmann, URL http://www.clicketyclick.dk/databases/xbase/format/ Thanks a lot. =head1 VERSION 1.00 =head1 AUTHOR (c) 1997--2011 Jan Pazdziora. All rights reserved. This package is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 THANKS Many people have provided information, test files, test results and patches. This project would not be so great without them. See the Changes file for (I hope) complete list. Thank you all! Special thanks go to Erik Bachmann for his great page about the file structures; to Frans van Loon, William McKee, Randy Kobes and Dan Albertsson for longtime cooperation and many emails we've exchanged when fixing and polishing the module's behaviour; and to Dan Albertsson for providing support for the project. =head1 SEE ALSO XBase::FAQ(3); XBase::Index(3); DBD::XBase(3) and DBI(3) for DBI interface; dbfdump(1); perl(1) =cut