DBD-XBase-1.05/0000755000076500007650000000000012136014167012701 5ustar adeltonadeltonDBD-XBase-1.05/new-XBase0000644000076500007650000004266111524572601014430 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 DBD-XBase-1.05/INSTALL0000644000076500007650000001016611524572640013743 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.05/lib/0000755000076500007650000000000012136014167013447 5ustar adeltonadeltonDBD-XBase-1.05/lib/XBase.pm0000644000076500007650000011667111533767056015037 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.02'; $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') { # Fox double $rproc = sub { unpack 'd', reverse scalar shift; }; $wproc = sub { reverse scalar pack 'd', shift; }; } elsif ($type =~ /^[MGP]$/) { # 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.02 =head1 AVAILABLE FROM http://www.adelton.com/perl/DBD-XBase/ =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. 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.05/lib/XBase/0000755000076500007650000000000012136014167014451 5ustar adeltonadeltonDBD-XBase-1.05/lib/XBase/SDBM.pm0000644000076500007650000002315111533767042015545 0ustar adeltonadelton =head1 NAME XBase::SDBM - SDBM index support for dbf =head1 DESCRIPTION When developing the XBase.pm/DBD::XBase module, I was trying to support as many existing variants of file formats as possible. The module thus accepts wide range of dbf files and their versions from various producers. But with index files, the task is much, much harder. First, there is little or no documentation of index files formats, so the development is based on reverse engineering. None if the index formats support is finalized. That made it hard to integrate them into one consistent API. That is why I decided to write my own index support, and as I wanted to avoid inventing yet another way of storing records in pages and similar things, I used SDBM. It comes with Perl, so you already have it, and it's proven and it works. Now, SDBM is a module that aims at other task than to do supporting indexes for a dbf. But equality tests are fast with it and I have creted a structure in each index file to enable "walk" though the index file. =head1 VERSION 1.02 =head1 AVAILABLE FROM http://www.adelton.com/perl/DBD-XBase/ =head1 AUTHOR (c) 2001--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. =cut package XBase::SDBM; use SDBM_File; use Fcntl; sub fetch { my $self = shift; my $current = $self->{'current'}; # current pointer return unless defined $current; my $hash = $self->{'sdbmhash'}; my $value = $hash->{$current}; if (not defined $value) { delete $self->{'current'}; return; } my ($key, $num) = ($current =~ /^(.*):(\d+)$/s); $num++; if (defined $hash->{"$key:$num"}) { # next record for the same key $self->{'current'} = "$key:$num"; } else { my $newkey = $hash->{"$key:next"}; # next key if (defined $newkey) { $self->{'current'} = "$newkey:1"; } else { delete $self->{'current'}; } } return ($key, $value); } sub fetch_current { my $self = shift; my $current = $self->{'current'}; return unless defined $current; my $value = $self->{'sdbmhash'}{$current}; return unless defined $value; my ($key) = ($current =~ /^(.*):\d+$/s); return ($key, $value); } sub tags { my $self = shift; return map { if (s/:file$//) { ( $_ ) } else { () } } keys %{$self->{'definition'}}; } sub prepare_select { my $self = shift; $self->{'current'} = $self->{'sdbmhash'}{':first'}; $self->{'current'} .= ':1' if defined $self->{'current'}; 1; } sub prepare_select_eq { my ($self, $eq, $recno) = @_; delete $self->{'current'}; my $hash = $self->{'sdbmhash'}; my $start = $eq; my $value = $hash->{"$start:1"}; if (not defined $value) { # not exact match $start = $hash->{':first'}; if (not defined $start) { # no records, jsut return return 1; } # move throught the chain while (defined $start and $start lt $eq) { $start = $hash->{"$start:next"}; } if (not defined $start) { return 1; } if ($start gt $eq) { $self->{'current'} = "$start:1"; return 1; } # we shouldn't have never got here, but nevermind $value = $hash->{"$start:1"}; } # here we've found exact match of the key if (not defined $recno) { # if not requested exact match of the recno, return $self->{'current'} = "$start:1"; return 1; } my $num = 1; while (defined $value and $value != $recno) { $num++; $value = $hash->{"$start:$num"}; } if (defined $value) { $self->{'current'} = "$start:$num"; } else { $start = $hash->{"$start:next"}; $self->{'current'} = "$start:1" if defined $start; } 1; } # method new (open) will open the named SDBM index for given dbf sub new { my ($class, $filename, %opts) = @_; my $dbf = $opts{'dbf'}; my $tag = $opts{'tag'}; # return immediatelly if the index file was already opened return $dbf->{'sdbm_definition'}{'tags'}{$tag} if defined $dbf->{'sdbm_definition'} and defined $dbf->{'sdbm_definition'}{'tags'}{$tag}; my $dbffile = $dbf->{'filename'}; my $file = $dbffile; $file =~ s/\.dbf$/.sdbmd/i; # some of the SDBM indexes were already touched # the definitionhash is a SDBM that lists the content of the # actual SDBM index files my $definitionhash = {}; if (defined $dbf->{'sdbm_definition'}) { $definitionhash = $dbf->{'sdbm_definition'}{'definitionhash'}; } else { # if it wasn't opened yet, open the definition file if (not tie(%$definitionhash, 'SDBM_File', $file, O_RDWR, 0666)) { die "SDBM index definition file `$file' not found for `$dbffile': $!."; } $dbf->{'sdbm_definition'} = { 'filename' => $file, 'definitionhash' => $definitionhash }; } # check the definition file for tag requested my $sdbmfile = $definitionhash->{"$tag:file"}; if (not defined $sdbmfile) { # no such SDBM index exists, the definition SDBM says die "SDBM index `$tag' not known for `$dbffile'."; } # open the SDBM index file my $sdbmhash = {}; unless (tie(%$sdbmhash, 'SDBM_File', $sdbmfile, O_RDWR, 0666)) { die "SDBM index file `$sdbmfile' not found for `$dbffile': $!."; } my $self = bless { 'dbf' => $dbf, 'tag' => $tag, 'sdbmhash' => $sdbmhash, 'definition' => $definitionhash }, $class; $dbf->{'sdbm_definition'}{'tags'}{$tag} = $self; return $self; } *open = \&new; # method create will create SDBM index with given name and expression # for the dbf table sub create { my ($class, $dbf, $tag, $expression) = @_; my $dbffile = $dbf->{'filename'}; my $file; my $definitionhash; if (defined $dbf->{'sdbm_definition'}) { # the definition SDBM was already opened $definitionhash = $dbf->{'sdbm_definition'}{'definitionhash'}; } else { $file = $dbffile; $file =~ s/\.dbf$/.sdbmd/i; $definitionhash = {}; # open or create the definition SDBM file if (not tie(%$definitionhash, 'SDBM_File', $file, O_RDWR|O_CREAT, 0666)) { die "SDBM index definition file `$file' not found/created for `$dbffile': $!."; } $dbf->{'sdbm_definition'} = { 'filename' => $file, 'definitionhash' => $definitionhash }; } if (defined $definitionhash->{"$tag:file"}) { die "SDBM index `$tag' already exists for `$dbfffile'."; } my $maxindexnumber = ++$definitionhash->{'tagnumber'}; my $sdbmfile = $dbffile; $sdbmfile =~ s/\.dbf$/.sdbm$maxindexnumber/i; my $sdbmhash = {}; if (not tie(%$sdbmhash, 'SDBM_File', $sdbmfile, O_CREAT|O_EXCL|O_RDWR, 0666)) { die "SDBM index file `$sdbmfile' couldn't be created for `$dbffile': $!." } my $self = bless { 'dbf' => $dbf, 'tag' => $tag, 'sdbmhash' => $sdbmhash, 'definition' => $definitionhash}, $class; $dbf->{'sdbm_definition'}{'tags'}{$tag} = $self; $definitionhash->{"$tag:file"} = $sdbmfile; if (defined $dbf->field_type(uc $expression)) { $expression = uc $expression; } if (not defined $dbf->field_type($expression)) { $self->drop; die "SDBM index `$expression' couldn't be created for `$dbffile': no such column name."; } $definitionhash->{"$tag:expression"} = $expression; my $i = 0; while ($i <= $dbf->last_record) { my ($deleted, $value) = $dbf->get_record($i); if (not $deleted) { $self->insert($value, $i + 1); } $i++; } return $self; } # method drop will drop the SDBM index sub drop { my ($self) = @_; my $tag = $self->{'tag'}; my $definitionhash = $self->{'definition'}; my $sdbmfile = $definitionhash->{"$tag:file"}; delete $definitionhash->{"$tag:file"}; delete $definitionhash->{"$tag:definition"}; delete $self->{'dbf'}{'sdbm_definition'}{'tags'}{$tag}; unlink "$sdbmfile.pag", "$sdbmfile.dir"; } sub insert { my ($self, $key, $value) = @_; ### print "Adding $key $value\n"; my $hash = $self->{'sdbmhash'}; my $key_maxid = $hash->{"$key:0"}; $key_maxid++; $hash->{"$key:$key_maxid"} = $value; $hash->{"$key:0"} = $key_maxid; return 1 if $key_maxid > 1; # no need to change the chain my $prev = undef; my $prev_next = ':first'; my $next; while (defined($next = $hash->{$prev_next}) and $key gt $next) { $prev = $next; $prev_next = "$prev:next"; $next = undef; } if (not defined $next) { $hash->{':last'} = $key; # we reached the last record } else { $hash->{"$key:next"} = $next; $hash->{"$next:prev"} = $key; } if (not defined $prev) { $hash->{':first'} = $key; } else { $hash->{"$prev:next"} = $key; $hash->{"$key:prev"} = $prev; } return 1; } sub delete { my ($self, $key, $value) = @_; ### print "Deleting $key $value\n"; my $hash = $self->{'sdbmhash'}; my $key_maxid = $hash->{"$key:0"}; my $number = 1; while ($number <= $key_maxid) { if ($hash->{"$key:$number"} == $value) { last; } $number++; } if ($number > $key_maxid) { # such a record was not found return 0; } if ($key_maxid > 1) { $hash->{"$key:$number"} = $hash->{"$key:$key_maxid"} if $number != $key_maxid; delete $hash->{"$key:$key_maxid"}; $hash->{"$key:0"} = $key_maxid - 1; } else { my $next = $hash->{"$key:next"}; my $prev = $hash->{"$key:prev"}; if (defined $next) { if (not defined $prev) { $hash->{':first'} = $next; delete $hash->{"$next:prev"}; } else { $hash->{"$prev:next"} = $next; $hash->{"$next:prev"} = $prev; delete $hash->{"$key:prev"}; } delete $hash->{"$key:next"}; } else { if (not defined $prev) { delete $hash->{':first'}; delete $hash->{':last'}; } else { $hash->{':last'} = $prev; delete $hash->{"$prev:next"}; delete $hash->{"$key:prev"}; } } delete $hash->{"$key:0"}; delete $hash->{"$key:1"}; } return 1; } sub delete_current { my $self = shift; my ($key, $value) = $self->fetch_current; if (defined $value) { $self->delete($key, $value); } } sub insert_before_current { die "SDBM index doesn't support backward rolling yet.\n"; } sub dump { my $self = shift; my $hash = $self->{'sdbmhash'}; for (sort keys %$hash) { print "$_ $hash->{$_}\n"; } } 1; DBD-XBase-1.05/lib/XBase/FAQ.pod0000644000076500007650000002162711533766666015616 0ustar adeltonadelton =head1 NAME XBase::FAQ - Frequently asked questions about the XBase.pm/DBD::XBase modules =head1 DESCRIPTION This is a list of questions people asked since the module has been announced in fall 1997, and my answers to them. =head1 AUTHOR Jan Pazdziora =head1 Questions and answers =over 2 =item What Perl version do I need? What other modules? You need perl 5.10 or newer. You need B module version 1.00 or higher, if you want to use the DBD driver (which you should). =item Can I use B under Windows 95/NT? Yes. It's a standard Perl module so there is no reason it shouldn't. Or, actually, there are a lot of reasons why standard thing do not work on systems that are broken, but I'm trying hard to workaround these bugs. If you find a problem on these platform, send me a description and I'll try to find yet another workaround. =item Is there a choice of the format of the date? The only possible format in which you can get the date and that the module expect for inserts and updates is a 8 char string 'YYYYMMDD'. It is not possible to change this format. I prefer to do the formating myself since you have more control over it. =item The C also returns deleted records. Why? Because. You get the _DELETED flag as the first value of the array. This gives you a possibility to decide what to do -- undelete, ignore... It's a feature -- you say you want a record of given number, you get it and get additional information, if the record is or isn't marked deleted. =item But with B, I do not see the deleted records. That's correct: B only gives you records that are positively in the file and not deleted. Which shows that B is a lower level tool because you can touch records that are marked deleted, while B is higher level -- it gives you SQL interface and let's you work with the file more naturaly (what is deleted should stay deleted). =item B cannot read files created with [your favorite tool]. Describe exactly, what you expect and what you get. Send me the file (I understand attachments, uuencode, tar, gzip and zip) so that I can check what it going on and make B undestand your file. A small sample (three rows, or so) are generally enough but you can send the whole file if it doesn't have megabytes. Please understand =item How to install the module when I do not have B? On Win* platform and with ActiveState port, use ppm to install B from ActiveState's site. You can also just copy the files from the lib directory of the distribution to where perl can find them. Also check whether your make doesn't hide under different names (nmake, gmake). See C. =item I have make but I cannot install into default directory. Ask your sysadmin to do it for your. If he refuses, fire the sysadmin. See C for how to install into and use nonstandard place for the module. =item Can I access one dbf file both from Perl and (say) Clipper? For reading -- yes. For writing -- B has a locksh and lockex method to lock the file. The question is to what extend Clipper (or Fox* or whatever) uses the same system calls, documentation of native XBase applications doesn't tell this. So the answer is that for multiple updates you should probably consider real RDBMS system (PostgreSQL, MySQL, Oracle, to name a few). =item B breaks my accented characters. No, it doesn't. The character data is returned exactly as it appears in the dbf/dbt file. You probably brought the file from different system that uses differend character encodings. So some bytes in the strings have different meaning on that system. You also probably have fonts in different encoding on that system. In the Czech language, we have about 6 different encoding that affect possition at which accented characters appear. So what you really want to do is to use some external utility to convert the strings to encoding you need -- for example, when I bring the dbf from Win*, it often is in the Windows-1250 or PC-Latin-2 encoding, while the standard is ISO-8859-2. I use my utility B to do the conversion, you maight also try GNU program B or use B Perl module. =item How do I access the fields in the memo file? Just read the memo field, it will fetch the data from the memo file for you transparently. =item Matching with C doesn't work. If you want to match wildcards with B, you have to use C: select * from table where field like '%str%' =item Can I sue you if B corrupts my data? No. At least, I hope no. The software is provided without any warranty, in a hope you might find is usefull. Which is by the way the same as with most other software, even if you pay for that. What is different with B is the fact that if you find out that the results are different from those expected, you are welcome to contact me, describe the problem and send me the files that give troubles to the module, and I'll try to find fix the module. =item What dbf/other files standard does the module support? I try to support any file that looks reasonably as dbf/dbt/fpt/smt/ndx/ntx/mdx/idx/cdx. There are many clones of XBase-like software, each adding its own extension. The module tries to accept all different variations. To do that, I need your cooperation however -- usually good description of the problem, file sample and expected results lead to rather fast patch. =item What SQL standard does the B support? If supports a reasonable subset of the SQL syntax, IMHO. So you can do select, delete, insert and update, create and drop table. If there is something that should be added, let me know and I will consider it. Having said that, I do not expect to ever support joins, for example. This module is more a parser to read files from your legacy applications that a RDBMS -- you can find plenty of them around -- use them. =item I downloaded you module I do not know how to install it. Did you follow the steps in the C and C files? Where did it fail? This module uses a standard way modules in Perl are installed. If you've never installed a module on your system and your system is so non-standard that the general instruction do not help, you should contact your system administrator or the support for your system. =item C. Examples: delete from jobs ## emties the table delete from jobs where companyid = "ISW" delete from jobs where id < ? =head2 insert insert into table [ ( fields ) ] values ( list of values ) Here fields is a (optional) comma separated list of fields to set, list of values is a list of constants to assign. If the fields are not specified, sets the fields in the natural order of the table. You can use bind parameters in the list of values. Examples: insert into accounts (login, uid) values ("guest", 65534) insert into accounts (login, uid) values (?, ?) insert into passwd values ("user","*",4523,100,"Nice user", "/home/user","/bin/bash") =head2 update update table set field = new value [ , set more fields ] [ where condition ] Example: update passwd set uid = 65534 where login = "guest" update zvirata set name = "Jezek", age = 4 where id = 17 Again, the value can also be specified as bind parameter. update zvirata set name = ?, age = ? where id = ? =head2 create table create table table name ( columns specification ) Columns specification is a comma separated list of column names and types. Example: create table rooms ( roomid int, cat char(10), balcony boolean ) The allowed types are char num numeric int integer float boolean blob memo date time datetime Some of them are synonyms. They are of course converted to appropriate XBase types. =head2 drop table drop table table name Example: drop table passwd =head1 ATTRIBUTES Besides standard DBI attribudes, DBD::XBase supports database handle attribute xbase_ignorememo: $dbh->{'xbase_ignorememo'} = 1; Setting it to 1 will cause subsequent tables to be opened while ignoring the memo files (dbt, fpt). So you can read dbf files for which you don't have (you have lost them, for example) the memo files. The memo fields will come out as nulls. =head1 VERSION 1.05 =head1 AVAILABLE FROM http://www.adelton.com/perl/DBD-XBase/ =head1 AUTHOR (c) 1997--2013 Jan Pazdziora. Contact the author at jpx dash perl at adelton dot com. =head1 SEE ALSO perl(1); DBI(3), XBase(3); dbish(1) Translation into Japanese (older version) at http://member.nifty.ne.jp/hippo2000/perltips/DBD/XBase.htm by Kawai Takanori. =cut DBD-XBase-1.05/ToDo0000644000076500007650000000275511517041124013475 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.05/README0000644000076500007650000000722311524572640013572 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--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.05/META.yml0000664000076500007650000000074612136014167014163 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 6.6302, CPAN::Meta::Converter version 2.120921' 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 requires: {} version: 1.05 DBD-XBase-1.05/dbit/0000755000076500007650000000000012136014167013623 5ustar adeltonadeltonDBD-XBase-1.05/dbit/40blobs.t0000644000076500007650000000670707143733103015267 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.05/dbit/30insertfetch.t0000644000076500007650000000732307143733103016476 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.05/dbit/50chopblanks.t0000644000076500007650000000756107143733103016312 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.05/dbit/00base.t0000644000076500007650000000163207143733103015064 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.05/dbit/50commit.t0000644000076500007650000001444207143733103015452 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.05/dbit/40listfields.t0000644000076500007650000000637707143733103016333 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.05/dbit/40nulls.t0000644000076500007650000000510507143733103015312 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.05/dbit/40bindparam.t0000644000076500007650000001214707143733103016116 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.05/dbit/10dsnlist.t0000755000076500007650000000375607143733103015647 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.05/dbit/20createdrop.t0000644000076500007650000000352107143733103016303 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.05/dbit/40numrows.t0000644000076500007650000001024307143733104015667 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.05/MANIFEST0000644000076500007650000000217612133563245014043 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.05/eg/0000755000076500007650000000000012136014167013274 5ustar adeltonadeltonDBD-XBase-1.05/eg/use_index0000644000076500007650000000544711517041124015207 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.05/eg/copy_table0000755000076500007650000000167007143733104015350 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.05/eg/create_table0000755000076500007650000000131207143733104015632 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.05/Changes0000644000076500007650000004766012136014147014207 0ustar adeltonadelton Revision history for Perl extension XBase and DBD::XBase. 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.05/bin/0000755000076500007650000000000012136014167013451 5ustar adeltonadeltonDBD-XBase-1.05/bin/dbfdump.PL0000755000076500007650000001065211533766760015353 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.05/bin/indexdump.PL0000755000076500007650000000533212133564625015717 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.05/META.json0000664000076500007650000000151412136014167014325 0ustar adeltonadelton{ "abstract" : "Reads and writes XBase (dbf) files, includes DBI support", "author" : [ "Jan Pazdziora" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120921", "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" } }, "runtime" : { "requires" : {} } }, "release_status" : "stable", "version" : "1.05" } DBD-XBase-1.05/Makefile.PL0000644000076500007650000000256711524572572014676 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.05/t/0000755000076500007650000000000012136014167013144 5ustar adeltonadeltonDBD-XBase-1.05/t/test.dbf0000644000076500007650000000200707143733103014577 0ustar adeltonadeltonƒ`ÁIDNÚ?MSGC Ú?þNOTEM Ú? BOOLEANLÚ?DATESDÚ? 1Record no 1 1 19960813* 2No 2 2Y19960814 3Message no 3 3N19960102DBD-XBase-1.05/t/8_dbd_delete.t0000644000076500007650000000436711534625065015653 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.05/t/5_idx.t0000644000076500007650000000407507237743311014355 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.05/t/ntx-char.dbf0000644000076500007650000001247507143733103015356 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.05/t/types.dbf0000644000076500007650000000034607643327474015007 0ustar adeltonadeltonIDN PAYMENTYTT 1'Œ=% 2ÿÿÿÿþl%Øùz 3îØÿÿÿÿÿÿŒ=% 4þÿÿÿþl%8g{DBD-XBase-1.05/t/ndx-num.dbf0000644000076500007650000001471007143733103015212 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.05/t/ndx-char.dbf0000644000076500007650000000434607143733103015334 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.05/t/2_read_stream.t0000644000076500007650000000276207274227522016057 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.05/t/XBase.mtest0000644000076500007650000000025307143733103015224 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.05/t/1_header.t0000644000076500007650000000560507643065735015025 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.05/t/3_create_drop.t0000644000076500007650000000605107757417606016066 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.05/t/XBase.dbtest0000644000076500007650000000473407143733103015365 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.05/t/5_ntx.t0000644000076500007650000000314507143733103014371 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.05/t/afox5.FPT0000644000076500007650000000140007143733103014534 0ustar adeltonadelton @ first desc. first mess. second desc. second mess.DBD-XBase-1.05/t/afox5.dbf0000644000076500007650000000105507143733103014644 0ustar adeltonadelton0cÈ2IDC PRICEN NAMECDESCM*MESSAGEM. b20 10John  c21 5Bill DBD-XBase-1.05/t/ndx-date.ndx0000644000076500007650000001400007143733103015356 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€‰²BAÍ€‰²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.05/t/ndx-num.ndx0000644000076500007650000002600007143733103015243 0ustar adeltonadeltonfield1  ƒ~ütédÿƒ>äªtšÜjFú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.05/t/5_sdbm.t0000644000076500007650000000772107226655102014515 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.05/t/8_dbd_insert.t0000644000076500007650000000661711534625070015711 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.05/t/2_read.t0000644000076500007650000000662707143733103014500 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 <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.05/t/ndx-date.dbf0000644000076500007650000000526307143733103015333 0ustar adeltonadeltona )A FIELD1DaB 19970909 19970910 19970911 19970912 19970913 19970914 19970915 19970916 19970917 19970918 19970919 19970920 19970921 19970922 19970923 19970924 19970925 19970926 19970927 19970928 19970929 19970930 19971001 19971002 19971003 19971004 19971005 19971006 19971007 19971008 19971009 19971010 19971011 19971012 19971013 19971014 19971015 19971016 19971017 19971018 19971019 19971020 19971021 19971022 19971023 19971024 19971025 19971026 19971027 19971028 19971029 19971030 19971031 19971101 19971102 19971103 19971104 19971105 19971106 19971107 19971108 19971109 19971110 19971111 19971112 19971113 19971114 19971115 19971116 19971117 19971118 19971119 19971120 19971121 19971122 19971123 19971124 19971125 19971126 19971127 19971128 19971129 19971130 19971201 19971202 19971203 19971204 19971205 19971206 19971207 19971208 19971209 19971210 19971211 19971212 19971213 19971214 19971215 19971216 19970909 19970910 19970911 19970912 19970913 19970914 19970915 19970916 19970917 19970918 19970919 19970920 19970921 19970922 19970923 19970924 19970925 19970926 19970927 19970928 19970929 19970930 19971001 19971002 19971003 19971004 19971005 19971006 19971007 19971008 19971009 19971010 19971011 19971012 19971013 19971014 19971015 19971016 19971017 19971018 19971019 19971020 19971021 19971022 19971023 19971024 19971025 19971026 19971027 19971028 19971029 19971030 19971031 19971101 19971102 19971103 19971104 19971105 19971106 19971107 19971108 19971109 19971110 19971111 19971112 19971113 19971114 19971115 19971116 19971117 19971118 19971119 19971120 19971121 19971122 19971123 19971124 19971125 19971126 19971127 19971128 19971129 19971130 19971201 19971202 19971203 19971204 19971205 19971206 19971207 19971208 19971209 19971210 19971211 19971212 19971213 19971214 19971215 19971216 19970909 19970910 19970911 19970912 19970913 19970914 19970915 19970916 19970917 19970918 19970919 19970920 19970921 19970922 19970923 19970924 19970925 19970926 19970927 19970928 19970929 19970930 19971001 19971002 19971003 19971004 19971005 19971006 19971007 19971008 19971009 19971010 19971011 19971012 19971013 19971014 19971015 19971016 19971017 19971018 19971019 19971020 19971021 19971022 19971023 19971024 19971025 19971026 19971027 19971028 19971029 19971030 19971031 19971101 19971102 19971103 19971104 19971105 19971106 19971107 19971108 19971109 19971110 19971111 19971112 19971113 19971114 19971115 19971116 19971117 19971118 19971119 19971120 19971121 19971122 19971123 19971124 19971125 19971126 19971127 19971128 19971129 19971130 19971201 19971202 19971203 19971204 19971205 19971206 19971207 19971208 19971209 19971210 19971211 19971212 19971213 19971214 19971215 19971216DBD-XBase-1.05/t/7_dbd_select_func.t0000644000076500007650000001300711534625060016664 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.05/t/4_dbfdump.t0000644000076500007650000000232607470505101015176 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.05/t/5_cdx.t0000644000076500007650000000734207143733103014341 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.05/t/test.dbt0000644000076500007650000000303507234231211014611 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.05/t/6_attach_cdx.t0000644000076500007650000000305707143733103015665 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.05/t/ntx-char.ntx0000644000076500007650000002400007143733103015417 0ustar adeltonadeltonVN ntx_char->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.05/t/8_dbd_update.t0000644000076500007650000000761411534625075015672 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.05/t/2_write.t0000644000076500007650000000637307143733103014715 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.05/t/lib.pl0000644000076500007650000001317007143733103014251 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.05/t/7_dbd_select.t0000644000076500007650000002742311534625050015657 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..45\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"; $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 45\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__ Message no 3 __END_DATA__ DBD-XBase-1.05/t/rooms.cdx0000644000076500007650000002500007143733103015000 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.05/t/9_dbd_create.t0000644000076500007650000000563211534625100015637 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..12\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"; $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.05/t/ndx-char.ndx0000644000076500007650000001300007143733103015355 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.05/t/rooms.dbf0000644000076500007650000000172507143733103014765 0ustar adeltonadeltona*aROOMNAMEC FACILITYC 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.05/driver_characteristics0000644000076500007650000003701211524572640017362 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