diff options
author | Todd C. Miller <millert@cvs.openbsd.org> | 1997-11-30 08:00:32 +0000 |
---|---|---|
committer | Todd C. Miller <millert@cvs.openbsd.org> | 1997-11-30 08:00:32 +0000 |
commit | 3d06de7fcff1d605886d3c63220956f7260ddb84 (patch) | |
tree | da5aa4b971926e3ef1f9263bbdeb714053206d02 /gnu/usr.bin/perl/ext | |
parent | c54c74271308a8fd18f1bc3a193343d079ebe481 (diff) |
perl 5.004_04
Diffstat (limited to 'gnu/usr.bin/perl/ext')
46 files changed, 3181 insertions, 4924 deletions
diff --git a/gnu/usr.bin/perl/ext/DB_File/DB_File.pm b/gnu/usr.bin/perl/ext/DB_File/DB_File.pm index 61ac26aafed..df1593fd657 100644 --- a/gnu/usr.bin/perl/ext/DB_File/DB_File.pm +++ b/gnu/usr.bin/perl/ext/DB_File/DB_File.pm @@ -1,181 +1,143 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 14th November 1995 -# version 1.01 +# last modified 29th Jun 1997 +# version 1.15 +# +# Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + package DB_File::HASHINFO ; +require 5.003 ; + use strict; -use vars qw(%elements); use Carp; +require Tie::Hash; +@DB_File::HASHINFO::ISA = qw(Tie::Hash); + +sub new +{ + my $pkg = shift ; + my %x ; + tie %x, $pkg ; + bless \%x, $pkg ; +} + sub TIEHASH { - bless {} ; + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( bsize ffactor nelem cachesize hash lorder) + }, + GOT => {} + }, $pkg ; } -%elements = ( 'bsize' => 0, - 'ffactor' => 0, - 'nelem' => 0, - 'cachesize' => 0, - 'hash' => 0, - 'lorder' => 0 - ) ; sub FETCH { - return $_[0]{$_[1]} if defined $elements{$_[1]} ; + my $self = shift ; + my $key = shift ; - croak "DB_File::HASHINFO::FETCH - Unknown element '$_[1]'" ; + return $self->{GOT}{$key} if exists $self->{VALID}{$key} ; + + my $pkg = ref $self ; + croak "${pkg}::FETCH - Unknown element '$key'" ; } sub STORE { - if ( defined $elements{$_[1]} ) + my $self = shift ; + my $key = shift ; + my $value = shift ; + + if ( exists $self->{VALID}{$key} ) { - $_[0]{$_[1]} = $_[2] ; + $self->{GOT}{$key} = $value ; return ; } - croak "DB_File::HASHINFO::STORE - Unknown element '$_[1]'" ; + my $pkg = ref $self ; + croak "${pkg}::STORE - Unknown element '$key'" ; } sub DELETE { - if ( defined $elements{$_[1]} ) + my $self = shift ; + my $key = shift ; + + if ( exists $self->{VALID}{$key} ) { - delete ${$_[0]}{$_[1]} ; + delete $self->{GOT}{$key} ; return ; } - croak "DB_File::HASHINFO::DELETE - Unknown element '$_[1]'" ; + my $pkg = ref $self ; + croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ; } - -sub DESTROY {undef %{$_[0]} } -sub FIRSTKEY { croak "DB_File::HASHINFO::FIRSTKEY is not implemented" } -sub NEXTKEY { croak "DB_File::HASHINFO::NEXTKEY is not implemented" } -sub EXISTS { croak "DB_File::HASHINFO::EXISTS is not implemented" } -sub CLEAR { croak "DB_File::HASHINFO::CLEAR is not implemented" } - -package DB_File::BTREEINFO ; - -use strict; -use vars qw(%elements); -use Carp; - -sub TIEHASH +sub EXISTS { - bless {} ; -} + my $self = shift ; + my $key = shift ; -%elements = ( 'flags' => 0, - 'cachesize' => 0, - 'maxkeypage' => 0, - 'minkeypage' => 0, - 'psize' => 0, - 'compare' => 0, - 'prefix' => 0, - 'lorder' => 0 - ) ; - -sub FETCH -{ - return $_[0]{$_[1]} if defined $elements{$_[1]} ; - - croak "DB_File::BTREEINFO::FETCH - Unknown element '$_[1]'" ; + exists $self->{VALID}{$key} ; } - -sub STORE +sub NotHere { - if ( defined $elements{$_[1]} ) - { - $_[0]{$_[1]} = $_[2] ; - return ; - } - - croak "DB_File::BTREEINFO::STORE - Unknown element '$_[1]'" ; -} + my $self = shift ; + my $method = shift ; -sub DELETE -{ - if ( defined $elements{$_[1]} ) - { - delete ${$_[0]}{$_[1]} ; - return ; - } - - croak "DB_File::BTREEINFO::DELETE - Unknown element '$_[1]'" ; + croak ref($self) . " does not define the method ${method}" ; } - -sub DESTROY {undef %{$_[0]} } -sub FIRSTKEY { croak "DB_File::BTREEINFO::FIRSTKEY is not implemented" } -sub NEXTKEY { croak "DB_File::BTREEINFO::NEXTKEY is not implemented" } -sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" } -sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" } +sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") } +sub NEXTKEY { my $self = shift ; $self->NotHere("NEXTKEY") } +sub CLEAR { my $self = shift ; $self->NotHere("CLEAR") } package DB_File::RECNOINFO ; -use strict; -use vars qw(%elements); -use Carp; +use strict ; + +@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ; sub TIEHASH { - bless {} ; -} + my $pkg = shift ; -%elements = ( 'bval' => 0, - 'cachesize' => 0, - 'psize' => 0, - 'flags' => 0, - 'lorder' => 0, - 'reclen' => 0, - 'bfname' => 0 - ) ; -sub FETCH -{ - return $_[0]{$_[1]} if defined $elements{$_[1]} ; - - croak "DB_File::RECNOINFO::FETCH - Unknown element '$_[1]'" ; + bless { VALID => { map {$_, 1} + qw( bval cachesize psize flags lorder reclen bfname ) + }, + GOT => {}, + }, $pkg ; } +package DB_File::BTREEINFO ; -sub STORE -{ - if ( defined $elements{$_[1]} ) - { - $_[0]{$_[1]} = $_[2] ; - return ; - } - - croak "DB_File::RECNOINFO::STORE - Unknown element '$_[1]'" ; -} +use strict ; -sub DELETE +@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ; + +sub TIEHASH { - if ( defined $elements{$_[1]} ) - { - delete ${$_[0]}{$_[1]} ; - return ; - } - - croak "DB_File::RECNOINFO::DELETE - Unknown element '$_[1]'" ; + my $pkg = shift ; + + bless { VALID => { map {$_, 1} + qw( flags cachesize maxkeypage minkeypage psize + compare prefix lorder ) + }, + GOT => {}, + }, $pkg ; } -sub DESTROY {undef %{$_[0]} } -sub FIRSTKEY { croak "DB_File::RECNOINFO::FIRSTKEY is not implemented" } -sub NEXTKEY { croak "DB_File::RECNOINFO::NEXTKEY is not implemented" } -sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" } -sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" } - - - package DB_File ; use strict; @@ -183,12 +145,12 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO) ; use Carp; -$VERSION = "1.01" ; +$VERSION = "1.15" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; -$DB_BTREE = TIEHASH DB_File::BTREEINFO ; -$DB_HASH = TIEHASH DB_File::HASHINFO ; -$DB_RECNO = TIEHASH DB_File::RECNOINFO ; +$DB_BTREE = new DB_File::BTREEINFO ; +$DB_HASH = new DB_File::HASHINFO ; +$DB_RECNO = new DB_File::RECNOINFO ; require Tie::Hash; require Exporter; @@ -197,6 +159,7 @@ require DynaLoader; @ISA = qw(Tie::Hash Exporter DynaLoader); @EXPORT = qw( $DB_BTREE $DB_HASH $DB_RECNO + BTREEMAGIC BTREEVERSION DB_LOCK @@ -225,6 +188,7 @@ require DynaLoader; R_SETCURSOR R_SNAPSHOT __R_UNUSED + ); sub AUTOLOAD { @@ -246,16 +210,82 @@ sub AUTOLOAD { goto &$AUTOLOAD; } + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + bootstrap DB_File $VERSION; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. +sub tie_hash_or_array +{ + my (@arg) = @_ ; + my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ; + + $arg[4] = tied %{ $arg[4] } + if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; + + DoTie_($tieHASH, @arg) ; +} + +sub TIEHASH +{ + tie_hash_or_array(@_) ; +} + +sub TIEARRAY +{ + tie_hash_or_array(@_) ; +} + +sub get_dup +{ + croak "Usage: \$db->get_dup(key [,flag])\n" + unless @_ == 2 or @_ == 3 ; + + my $db = shift ; + my $key = shift ; + my $flag = shift ; + my $value = 0 ; + my $origkey = $key ; + my $wantarray = wantarray ; + my %values = () ; + my @values = () ; + my $counter = 0 ; + my $status = 0 ; + + # iterate through the database until either EOF ($status == 0) + # or a different key is encountered ($key ne $origkey). + for ($status = $db->seq($key, $value, R_CURSOR()) ; + $status == 0 and $key eq $origkey ; + $status = $db->seq($key, $value, R_NEXT()) ) { + + # save the value or count number of matches + if ($wantarray) { + if ($flag) + { ++ $values{$value} } + else + { push (@values, $value) } + } + else + { ++ $counter } + + } + + return ($wantarray ? ($flag ? %values : @values) : $counter) ; +} + + 1; __END__ -=cut - =head1 NAME DB_File - Perl5 access to Berkeley DB @@ -263,18 +293,30 @@ DB_File - Perl5 access to Berkeley DB =head1 SYNOPSIS use DB_File ; - - [$X =] tie %hash, DB_File, $filename [, $flags, $mode, $DB_HASH] ; - [$X =] tie %hash, DB_File, $filename, $flags, $mode, $DB_BTREE ; - [$X =] tie @array, DB_File, $filename, $flags, $mode, $DB_RECNO ; - + + [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ; + [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ; + [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ; + $status = $X->del($key [, $flags]) ; $status = $X->put($key, $value [, $flags]) ; $status = $X->get($key, $value [, $flags]) ; - $status = $X->seq($key, $value [, $flags]) ; + $status = $X->seq($key, $value, $flags) ; $status = $X->sync([$flags]) ; $status = $X->fd ; - + + # BTREE only + $count = $X->get_dup($key) ; + @list = $X->get_dup($key) ; + %list = $X->get_dup($key, 1) ; + + # RECNO only + $a = $X->length; + $a = $X->pop ; + $X->push(list); + $a = $X->shift; + $X->unshift(list); + untie %hash ; untie @array ; @@ -282,10 +324,14 @@ DB_File - Perl5 access to Berkeley DB B<DB_File> is a module which allows Perl programs to make use of the facilities provided by Berkeley DB. If you intend to use this -module you should really have a copy of the Berkeley DB manualpage at +module you should really have a copy of the Berkeley DB manual pages at hand. The interface defined here mirrors the Berkeley DB interface closely. +Please note that this module will only work with version 1.x of +Berkeley DB. Once Berkeley DB version 2 is released, B<DB_File> will be +upgraded to work with it. + Berkeley DB is a C library which provides a consistent interface to a number of database formats. B<DB_File> provides an interface to all three of the database types currently supported by Berkeley DB. @@ -294,9 +340,9 @@ The file types are: =over 5 -=item DB_HASH +=item B<DB_HASH> -This database type allows arbitrary key/data pairs to be stored in data +This database type allows arbitrary key/value pairs to be stored in data files. This is equivalent to the functionality provided by other hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, the files created using DB_HASH are not compatible with any of the @@ -307,16 +353,16 @@ applications, is built into Berkeley DB. If you do need to use your own hashing algorithm it is possible to write your own in Perl and have B<DB_File> use it instead. -=item DB_BTREE +=item B<DB_BTREE> -The btree format allows arbitrary key/data pairs to be stored in a +The btree format allows arbitrary key/value pairs to be stored in a sorted, balanced binary tree. As with the DB_HASH format, it is possible to provide a user defined Perl routine to perform the comparison of keys. By default, though, the keys are stored in lexical order. -=item DB_RECNO +=item B<DB_RECNO> DB_RECNO allows both fixed-length and variable-length flat text files to be manipulated using the same key/value pair interface as in DB_HASH @@ -325,7 +371,7 @@ number. =back -=head2 How does DB_File interface to Berkeley DB? +=head2 Interface to Berkeley DB B<DB_File> allows access to Berkeley DB files using the tie() mechanism in Perl 5 (for full details, see L<perlfunc/tie()>). This facility @@ -333,13 +379,14 @@ allows B<DB_File> to access Berkeley DB files using either an associative array (for DB_HASH & DB_BTREE file types) or an ordinary array (for the DB_RECNO file type). -In addition to the tie() interface, it is also possible to use most of -the functions provided in the Berkeley DB API. +In addition to the tie() interface, it is also possible to access most +of the functions provided in the Berkeley DB API directly. +See L<THE API INTERFACE>. -=head2 Differences with Berkeley DB +=head2 Opening a Berkeley DB Database File Berkeley DB uses the function dbopen() to open or create a database. -Below is the C prototype for dbopen(). +Here is the C prototype for dbopen(): DB* dbopen (const char * file, int flags, int mode, @@ -352,35 +399,133 @@ I<openinfo> points to a data structure which allows tailoring of the specific interface method. This interface is handled slightly differently in B<DB_File>. Here is -an equivalent call using B<DB_File>. +an equivalent call using B<DB_File>: - tie %array, DB_File, $filename, $flags, $mode, $DB_HASH ; + tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ; The C<filename>, C<flags> and C<mode> parameters are the direct equivalent of their dbopen() counterparts. The final parameter $DB_HASH performs the function of both the C<type> and C<openinfo> parameters in dbopen(). -In the example above $DB_HASH is actually a reference to a hash -object. B<DB_File> has three of these pre-defined references. Apart -from $DB_HASH, there is also $DB_BTREE and $DB_RECNO. +In the example above $DB_HASH is actually a pre-defined reference to a +hash object. B<DB_File> has three of these pre-defined references. +Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO. The keys allowed in each of these pre-defined references is limited to the names used in the equivalent C structure. So, for example, the $DB_HASH reference will only allow keys called C<bsize>, C<cachesize>, -C<ffactor>, C<hash>, C<lorder> and C<nelem>. +C<ffactor>, C<hash>, C<lorder> and C<nelem>. + +To change one of these elements, just assign to it like this: + + $DB_HASH->{'cachesize'} = 10000 ; + +The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are +usually adequate for most applications. If you do need to create extra +instances of these objects, constructors are available for each file +type. + +Here are examples of the constructors and the valid options available +for DB_HASH, DB_BTREE and DB_RECNO respectively. + + $a = new DB_File::HASHINFO ; + $a->{'bsize'} ; + $a->{'cachesize'} ; + $a->{'ffactor'}; + $a->{'hash'} ; + $a->{'lorder'} ; + $a->{'nelem'} ; + + $b = new DB_File::BTREEINFO ; + $b->{'flags'} ; + $b->{'cachesize'} ; + $b->{'maxkeypage'} ; + $b->{'minkeypage'} ; + $b->{'psize'} ; + $b->{'compare'} ; + $b->{'prefix'} ; + $b->{'lorder'} ; + + $c = new DB_File::RECNOINFO ; + $c->{'bval'} ; + $c->{'cachesize'} ; + $c->{'psize'} ; + $c->{'flags'} ; + $c->{'lorder'} ; + $c->{'reclen'} ; + $c->{'bfname'} ; + +The values stored in the hashes above are mostly the direct equivalent +of their C counterpart. Like their C counterparts, all are set to a +default values - that means you don't have to set I<all> of the +values when you only want to change one. Here is an example: + + $a = new DB_File::HASHINFO ; + $a->{'cachesize'} = 12345 ; + tie %y, 'DB_File', "filename", $flags, 0777, $a ; + +A few of the options need extra discussion here. When used, the C +equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers +to C functions. In B<DB_File> these keys are used to store references +to Perl subs. Below are templates for each of the subs: + + sub hash + { + my ($data) = @_ ; + ... + # return the hash value for $data + return $hash ; + } + + sub compare + { + my ($key, $key2) = @_ ; + ... + # return 0 if $key1 eq $key2 + # -1 if $key1 lt $key2 + # 1 if $key1 gt $key2 + return (-1 , 0 or 1) ; + } + + sub prefix + { + my ($key, $key2) = @_ ; + ... + # return number of bytes of $key2 which are + # necessary to determine that it is greater than $key1 + return $bytes ; + } + +See L<Changing the BTREE sort order> for an example of using the +C<compare> template. + +If you are using the DB_RECNO interface and you intend making use of +C<bval>, you should check out L<The 'bval' Option>. + +=head2 Default Parameters -To change one of these elements, just assign to it like this +It is possible to omit some or all of the final 4 parameters in the +call to C<tie> and let them take default values. As DB_HASH is the most +common file format used, the call: - $DB_HASH->{cachesize} = 10000 ; + tie %A, "DB_File", "filename" ; +is equivalent to: -=head2 RECNO + tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ; +It is also possible to omit the filename parameter as well, so the +call: -In order to make RECNO more compatible with Perl the array offset for all -RECNO arrays begins at 0 rather than 1 as in Berkeley DB. + tie %A, "DB_File" ; +is equivalent to: + + tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0666, $DB_HASH ; + +See L<In Memory Databases> for a discussion on the use of C<undef> +in place of a filename. =head2 In Memory Databases @@ -388,153 +533,751 @@ Berkeley DB allows the creation of in-memory databases by using NULL (that is, a C<(char *)0> in C) in place of the filename. B<DB_File> uses C<undef> instead of NULL to provide this functionality. +=head1 DB_HASH + +The DB_HASH file format is probably the most commonly used of the three +file formats that B<DB_File> supports. It is also very straightforward +to use. + +=head2 A Simple Example + +This example shows how to create a database, add key/value pairs to the +database, delete keys/value pairs and finally how to enumerate the +contents of the database. + + use strict ; + use DB_File ; + use vars qw( %h $k $v ) ; + + tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH + or die "Cannot open file 'fruit': $!\n"; + + # Add a few key/value pairs to the file + $h{"apple"} = "red" ; + $h{"orange"} = "orange" ; + $h{"banana"} = "yellow" ; + $h{"tomato"} = "red" ; + + # Check for existence of a key + print "Banana Exists\n\n" if $h{"banana"} ; + + # Delete a key/value pair. + delete $h{"apple"} ; + + # print the contents of the file + while (($k, $v) = each %h) + { print "$k -> $v\n" } + + untie %h ; + +here is the output: + + Banana Exists + + orange -> orange + tomato -> red + banana -> yellow + +Note that the like ordinary associative arrays, the order of the keys +retrieved is in an apparently random order. + +=head1 DB_BTREE + +The DB_BTREE format is useful when you want to store data in a given +order. By default the keys will be stored in lexical order, but as you +will see from the example shown in the next section, it is very easy to +define your own sorting function. + +=head2 Changing the BTREE sort order + +This script shows how to override the default sorting algorithm that +BTREE uses. Instead of using the normal lexical ordering, a case +insensitive compare function will be used. + + use strict ; + use DB_File ; + + my %h ; + + sub Compare + { + my ($key1, $key2) = @_ ; + "\L$key1" cmp "\L$key2" ; + } + + # specify the Perl sub that will do the comparison + $DB_BTREE->{'compare'} = \&Compare ; + + tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open file 'tree': $!\n" ; + + # Add a key/value pair to the file + $h{'Wall'} = 'Larry' ; + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + $h{'duck'} = 'donald' ; + + # Delete + delete $h{"duck"} ; + + # Cycle through the keys printing them in order. + # Note it is not necessary to sort the keys as + # the btree will have kept them in order automatically. + foreach (keys %h) + { print "$_\n" } + + untie %h ; + +Here is the output from the code above. + + mouse + Smith + Wall + +There are a few point to bear in mind if you want to change the +ordering in a BTREE database: + +=over 5 + +=item 1. + +The new compare function must be specified when you create the database. + +=item 2. + +You cannot change the ordering once the database has been created. Thus +you must use the same compare function every time you access the +database. + +=back + +=head2 Handling Duplicate Keys + +The BTREE file type optionally allows a single key to be associated +with an arbitrary number of values. This option is enabled by setting +the flags element of C<$DB_BTREE> to R_DUP when creating the database. + +There are some difficulties in using the tied hash interface if you +want to manipulate a BTREE database with duplicate keys. Consider this +code: + + use strict ; + use DB_File ; + + use vars qw($filename %h ) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the associative array + # and print each key/value pair. + foreach (keys %h) + { print "$_ -> $h{$_}\n" } + + untie %h ; + +Here is the output: + + Smith -> John + Wall -> Larry + Wall -> Larry + Wall -> Larry + mouse -> mickey + +As you can see 3 records have been successfully created with key C<Wall> +- the only thing is, when they are retrieved from the database they +I<seem> to have the same value, namely C<Larry>. The problem is caused +by the way that the associative array interface works. Basically, when +the associative array interface is used to fetch the value associated +with a given key, it will only ever retrieve the first value. + +Although it may not be immediately obvious from the code above, the +associative array interface can be used to write values with duplicate +keys, but it cannot be used to read them back from the database. + +The way to get around this problem is to use the Berkeley DB API method +called C<seq>. This method allows sequential access to key/value +pairs. See L<THE API INTERFACE> for details of both the C<seq> method +and the API in general. + +Here is the script above rewritten using the C<seq> API method. + + use strict ; + use DB_File ; + + use vars qw($filename $x %h $status $key $value) ; + + $filename = "tree" ; + unlink $filename ; + + # Enable duplicate records + $DB_BTREE->{'flags'} = R_DUP ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'Wall'} = 'Larry' ; + $h{'Wall'} = 'Brick' ; # Note the duplicate key + $h{'Wall'} = 'Brick' ; # Note the duplicate key and value + $h{'Smith'} = 'John' ; + $h{'mouse'} = 'mickey' ; + + # iterate through the btree using seq + # and print each key/value pair. + $key = $value = 0 ; + for ($status = $x->seq($key, $value, R_FIRST) ; + $status == 0 ; + $status = $x->seq($key, $value, R_NEXT) ) + { print "$key -> $value\n" } + + undef $x ; + untie %h ; + +that prints: + + Smith -> John + Wall -> Brick + Wall -> Brick + Wall -> Larry + mouse -> mickey + +This time we have got all the key/value pairs, including the multiple +values associated with the key C<Wall>. + +=head2 The get_dup() Method + +B<DB_File> comes with a utility method, called C<get_dup>, to assist in +reading duplicate values from BTREE databases. The method can take the +following forms: + + $count = $x->get_dup($key) ; + @list = $x->get_dup($key) ; + %list = $x->get_dup($key, 1) ; + +In a scalar context the method returns the number of values associated +with the key, C<$key>. + +In list context, it returns all the values which match C<$key>. Note +that the values will be returned in an apparently random order. + +In list context, if the second parameter is present and evaluates +TRUE, the method returns an associative array. The keys of the +associative array correspond to the values that matched in the BTREE +and the values of the array are a count of the number of times that +particular value occurred in the BTREE. + +So assuming the database created above, we can use C<get_dup> like +this: + + my $cnt = $x->get_dup("Wall") ; + print "Wall occurred $cnt times\n" ; + + my %hash = $x->get_dup("Wall", 1) ; + print "Larry is there\n" if $hash{'Larry'} ; + print "There are $hash{'Brick'} Brick Walls\n" ; + + my @list = $x->get_dup("Wall") ; + print "Wall => [@list]\n" ; + + @list = $x->get_dup("Smith") ; + print "Smith => [@list]\n" ; + + @list = $x->get_dup("Dog") ; + print "Dog => [@list]\n" ; + + +and it will print: + + Wall occurred 3 times + Larry is there + There are 2 Brick Walls + Wall => [Brick Brick Larry] + Smith => [John] + Dog => [] + +=head2 Matching Partial Keys + +The BTREE interface has a feature which allows partial keys to be +matched. This functionality is I<only> available when the C<seq> method +is used along with the R_CURSOR flag. + + $x->seq($key, $value, R_CURSOR) ; + +Here is the relevant quote from the dbopen man page where it defines +the use of the R_CURSOR flag with seq: + + Note, for the DB_BTREE access method, the returned key is not + necessarily an exact match for the specified key. The returned key + is the smallest key greater than or equal to the specified key, + permitting partial key matches and range searches. + +In the example script below, the C<match> sub uses this feature to find +and print the first matching key/value pair given a partial key. + + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw($filename $x %h $st $key $value) ; + + sub match + { + my $key = shift ; + my $value = 0; + my $orig_key = $key ; + $x->seq($key, $value, R_CURSOR) ; + print "$orig_key\t-> $key\t-> $value\n" ; + } + + $filename = "tree" ; + unlink $filename ; + + $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE + or die "Cannot open $filename: $!\n"; + + # Add some key/value pairs to the file + $h{'mouse'} = 'mickey' ; + $h{'Wall'} = 'Larry' ; + $h{'Walls'} = 'Brick' ; + $h{'Smith'} = 'John' ; + + + $key = $value = 0 ; + print "IN ORDER\n" ; + for ($st = $x->seq($key, $value, R_FIRST) ; + $st == 0 ; + $st = $x->seq($key, $value, R_NEXT) ) + + { print "$key -> $value\n" } + + print "\nPARTIAL MATCH\n" ; + + match "Wa" ; + match "A" ; + match "a" ; + + undef $x ; + untie %h ; + +Here is the output: + + IN ORDER + Smith -> John + Wall -> Larry + Walls -> Brick + mouse -> mickey + + PARTIAL MATCH + Wa -> Wall -> Larry + A -> Smith -> John + a -> mouse -> mickey + +=head1 DB_RECNO + +DB_RECNO provides an interface to flat text files. Both variable and +fixed length records are supported. + +In order to make RECNO more compatible with Perl the array offset for +all RECNO arrays begins at 0 rather than 1 as in Berkeley DB. + +As with normal Perl arrays, a RECNO array can be accessed using +negative indexes. The index -1 refers to the last element of the array, +-2 the second last, and so on. Attempting to access an element before +the start of the array will raise a fatal run-time error. + +=head2 The 'bval' Option + +The operation of the bval option warrants some discussion. Here is the +definition of bval from the Berkeley DB 1.85 recno manual page: + + The delimiting byte to be used to mark the end of a + record for variable-length records, and the pad charac- + ter for fixed-length records. If no value is speci- + fied, newlines (``\n'') are used to mark the end of + variable-length records and fixed-length records are + padded with spaces. + +The second sentence is wrong. In actual fact bval will only default to +C<"\n"> when the openinfo parameter in dbopen is NULL. If a non-NULL +openinfo parameter is used at all, the value that happens to be in bval +will be used. That means you always have to specify bval when making +use of any of the options in the openinfo parameter. This documentation +error will be fixed in the next release of Berkeley DB. + +That clarifies the situation with regards Berkeley DB itself. What +about B<DB_File>? Well, the behavior defined in the quote above is +quite useful, so B<DB_File> conforms it. + +That means that you can specify other options (e.g. cachesize) and +still have bval default to C<"\n"> for variable length records, and +space for fixed length records. + +=head2 A Simple Example + +Here is a simple example that uses RECNO. + + use strict ; + use DB_File ; + + my @h ; + tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file 'text': $!\n" ; + + # Add a few key/value pairs to the file + $h[0] = "orange" ; + $h[1] = "blue" ; + $h[2] = "yellow" ; + + # Check for existence of a key + print "Element 1 Exists with value $h[1]\n" if $h[1] ; + + # use a negative index + print "The last element is $h[-1]\n" ; + print "The 2nd last element is $h[-2]\n" ; + + untie @h ; + +Here is the output from the script: + + + Element 1 Exists with value blue + The last element is yellow + The 2nd last element is blue + +=head2 Extra Methods + +As you can see from the example above, the tied array interface is +quite limited. To make the interface more useful, a number of methods +are supplied with B<DB_File> to simulate the standard array operations +that are not currently implemented in Perl's tied array interface. All +these methods are accessed via the object returned from the tie call. + +Here are the methods: + +=over 5 + +=item B<$X-E<gt>push(list) ;> + +Pushes the elements of C<list> to the end of the array. + +=item B<$value = $X-E<gt>pop ;> + +Removes and returns the last element of the array. + +=item B<$X-E<gt>shift> + +Removes and returns the first element of the array. + +=item B<$X-E<gt>unshift(list) ;> -=head2 Using the Berkeley DB Interface Directly +Pushes the elements of C<list> to the start of the array. + +=item B<$X-E<gt>length> + +Returns the number of elements in the array. + +=back + +=head2 Another Example + +Here is a more complete example that makes use of some of the methods +described above. It also makes use of the API interface directly (see +L<THE API INTERFACE>). + + use strict ; + use vars qw(@h $H $file $i) ; + use DB_File ; + use Fcntl ; + + $file = "text" ; + + unlink $file ; + + $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO + or die "Cannot open file $file: $!\n" ; + + # first create a text file to play with + $h[0] = "zero" ; + $h[1] = "one" ; + $h[2] = "two" ; + $h[3] = "three" ; + $h[4] = "four" ; + + + # Print the records in order. + # + # The length method is needed here because evaluating a tied + # array in a scalar context does not return the number of + # elements in the array. + + print "\nORIGINAL\n" ; + foreach $i (0 .. $H->length - 1) { + print "$i: $h[$i]\n" ; + } + + # use the push & pop methods + $a = $H->pop ; + $H->push("last") ; + print "\nThe last record was [$a]\n" ; + + # and the shift & unshift methods + $a = $H->shift ; + $H->unshift("first") ; + print "The first record was [$a]\n" ; + + # Use the API to add a new record after record 2. + $i = 2 ; + $H->put($i, "Newbie", R_IAFTER) ; + + # and a new record before record 1. + $i = 1 ; + $H->put($i, "New One", R_IBEFORE) ; + + # delete record 3 + $H->del(3) ; + + # now print the records in reverse order + print "\nREVERSE\n" ; + for ($i = $H->length - 1 ; $i >= 0 ; -- $i) + { print "$i: $h[$i]\n" } + + # same again, but use the API functions instead + print "\nREVERSE again\n" ; + my ($s, $k, $v) = (0, 0, 0) ; + for ($s = $H->seq($k, $v, R_LAST) ; + $s == 0 ; + $s = $H->seq($k, $v, R_PREV)) + { print "$k: $v\n" } + + undef $H ; + untie @h ; + +and this is what it outputs: + + ORIGINAL + 0: zero + 1: one + 2: two + 3: three + 4: four + + The last record was [four] + The first record was [zero] + + REVERSE + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + + REVERSE again + 5: last + 4: three + 3: Newbie + 2: one + 1: New One + 0: first + +Notes: + +=over 5 + +=item 1. + +Rather than iterating through the array, C<@h> like this: + + foreach $i (@h) + +it is necessary to use either this: + + foreach $i (0 .. $H->length - 1) + +or this: + + for ($a = $H->get($k, $v, R_FIRST) ; + $a == 0 ; + $a = $H->get($k, $v, R_NEXT) ) + +=item 2. + +Notice that both times the C<put> method was used the record index was +specified using a variable, C<$i>, rather than the literal value +itself. This is because C<put> will return the record number of the +inserted line via that parameter. + +=back + +=head1 THE API INTERFACE As well as accessing Berkeley DB using a tied hash or array, it is also -possible to make direct use of most of the functions defined in the +possible to make direct use of most of the API functions defined in the Berkeley DB documentation. +To do this you need to store a copy of the object returned from the tie. -To do this you need to remember the return value from the tie. - - $db = tie %hash, DB_File, "filename" + $db = tie %hash, "DB_File", "filename" ; Once you have done that, you can access the Berkeley DB API functions -directly. +as B<DB_File> methods directly like this: $db->put($key, $value, R_NOOVERWRITE) ; -All the functions defined in L<dbx(3X)> are available except for -close() and dbopen() itself. The B<DB_File> interface to these -functions have been implemented to mirror the the way Berkeley DB -works. In particular note that all the functions return only a status -value. Whenever a Berkeley DB function returns data via one of its -parameters, the B<DB_File> equivalent does exactly the same. +B<Important:> If you have saved a copy of the object returned from +C<tie>, the underlying database file will I<not> be closed until both +the tied variable is untied and all copies of the saved object are +destroyed. -All the constants defined in L<dbopen> are also available. + use DB_File ; + $db = tie %hash, "DB_File", "filename" + or die "Cannot tie filename: $!" ; + ... + undef $db ; + untie %hash ; -Below is a list of the functions available. +See L<The untie() Gotcha> for more details. + +All the functions defined in L<dbopen> are available except for +close() and dbopen() itself. The B<DB_File> method interface to the +supported functions have been implemented to mirror the way Berkeley DB +works whenever possible. In particular note that: =over 5 -=item get +=item * -Same as in C<recno> except that the flags parameter is optional. -Remember the value associated with the key you request is returned in -the $value parameter. +The methods return a status value. All return 0 on success. +All return -1 to signify an error and set C<$!> to the exact +error code. The return code 1 generally (but not always) means that the +key specified did not exist in the database. -=item put +Other return codes are defined. See below and in the Berkeley DB +documentation for details. The Berkeley DB documentation should be used +as the definitive source. -As usual the flags parameter is optional. +=item * -If you use either the R_IAFTER or R_IBEFORE flags, the key parameter -will have the record number of the inserted key/value pair set. +Whenever a Berkeley DB function returns data via one of its parameters, +the equivalent B<DB_File> method does exactly the same. + +=item * -=item del +If you are careful, it is possible to mix API calls with the tied +hash/array interface in the same piece of code. Although only a few of +the methods used to implement the tied interface currently make use of +the cursor, you should always assume that the cursor has been changed +any time the tied hash/array interface is used. As an example, this +code will probably not do what you expect: -The flags parameter is optional. + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; -=item fd + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; -As in I<recno>. + # this line will modify the cursor + $count = scalar keys %x ; -=item seq + # Get the second key/value pair. + # oops, it didn't, it got the last key/value pair! + $X->seq($key, $value, R_NEXT) ; -The flags parameter is optional. +The code above can be rearranged to get around the problem, like this: -Both the key and value parameters will be set. + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; -=item sync + # this line will modify the cursor + $count = scalar keys %x ; -The flags parameter is optional. + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; + + # Get the second key/value pair. + # worked this time. + $X->seq($key, $value, R_NEXT) ; =back -=head1 EXAMPLES +All the constants defined in L<dbopen> for use in the flags parameters +in the methods defined below are also available. Refer to the Berkeley +DB documentation for the precise meaning of the flags values. -It is always a lot easier to understand something when you see a real -example. So here are a few. +Below is a list of the methods available. -=head2 Using HASH +=over 5 - use DB_File ; - use Fcntl ; - - tie %h, "DB_File", "hashed", O_RDWR|O_CREAT, 0640, $DB_HASH ; - - # Add a key/value pair to the file - $h{"apple"} = "orange" ; - - # Check for existence of a key - print "Exists\n" if $h{"banana"} ; - - # Delete - delete $h{"apple"} ; - - untie %h ; +=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;> -=head2 Using BTREE +Given a key (C<$key>) this method reads the value associated with it +from the database. The value read from the database is returned in the +C<$value> parameter. -Here is sample of code which used BTREE. Just to make life more -interesting the default comparision function will not be used. Instead -a Perl sub, C<Compare()>, will be used to do a case insensitive -comparison. +If the key does not exist the method returns 1. - use DB_File ; - use Fcntl ; - - sub Compare - { - my ($key1, $key2) = @_ ; - - "\L$key1" cmp "\L$key2" ; - } - - $DB_BTREE->{compare} = 'Compare' ; - - tie %h, 'DB_File', "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE ; - - # Add a key/value pair to the file - $h{'Wall'} = 'Larry' ; - $h{'Smith'} = 'John' ; - $h{'mouse'} = 'mickey' ; - $h{'duck'} = 'donald' ; - - # Delete - delete $h{"duck"} ; - - # Cycle through the keys printing them in order. - # Note it is not necessary to sort the keys as - # the btree will have kept them in order automatically. - foreach (keys %h) - { print "$_\n" } - - untie %h ; +No flags are currently defined for this method. -Here is the output from the code above. +=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;> - mouse - Smith - Wall +Stores the key/value pair in the database. +If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter +will have the record number of the inserted key/value pair set. -=head2 Using RECNO +Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and +R_SETCURSOR. - use DB_File ; - use Fcntl ; - - $DB_RECNO->{psize} = 3000 ; - - tie @h, DB_File, "text", O_RDWR|O_CREAT, 0640, $DB_RECNO ; - - # Add a key/value pair to the file - $h[0] = "orange" ; - - # Check for existence of a key - print "Exists\n" if $h[1] ; - - untie @h ; +=item B<$status = $X-E<gt>del($key [, $flags]) ;> + +Removes all key/value pairs with key C<$key> from the database. + +A return code of 1 means that the requested key was not in the +database. + +R_CURSOR is the only valid flag at present. + +=item B<$status = $X-E<gt>fd ;> + +Returns the file descriptor for the underlying database. + +See L<Locking Databases> for an example of how to make use of the +C<fd> method to lock your database. + +=item B<$status = $X-E<gt>seq($key, $value, $flags) ;> + +This interface allows sequential retrieval from the database. See +L<dbopen> for full details. + +Both the C<$key> and C<$value> parameters will be set to the key/value +pair read from the database. + +The flags parameter is mandatory. The valid flag values are R_CURSOR, +R_FIRST, R_LAST, R_NEXT and R_PREV. + +=item B<$status = $X-E<gt>sync([$flags]) ;> + +Flushes any cached buffers to disk. + +R_RECNOSYNC is the only valid flag at present. + +=back + +=head1 HINTS AND TIPS =head2 Locking Databases @@ -545,7 +1288,6 @@ uses the I<fd> method to get the file descriptor, and then a careful open() to give something Perl will flock() for you. Run this repeatedly in the background to watch the locks granted in proper order. - use Fcntl; use DB_File; use strict; @@ -588,13 +1330,211 @@ in the background to watch the locks granted in proper order. print "$$: Write lock granted\n"; $db{$key} = $value; + $db->sync; # to flush sleep 10; flock(DB_FH, LOCK_UN); + undef $db; untie %db; close(DB_FH); print "$$: Updated db to $key=$value\n"; +=head2 Sharing Databases With C Applications + +There is no technical reason why a Berkeley DB database cannot be +shared by both a Perl and a C application. + +The vast majority of problems that are reported in this area boil down +to the fact that C strings are NULL terminated, whilst Perl strings are +not. + +Here is a real example. Netscape 2.0 keeps a record of the locations you +visit along with the time you last visited them in a DB_HASH database. +This is usually stored in the file F<~/.netscape/history.db>. The key +field in the database is the location string and the value field is the +time the location was last visited stored as a 4 byte binary value. + +If you haven't already guessed, the location string is stored with a +terminating NULL. This means you need to be careful when accessing the +database. + +Here is a snippet of code that is loosely based on Tom Christiansen's +I<ggh> script (available from your nearest CPAN archive in +F<authors/id/TOMC/scripts/nshist.gz>). + + use strict ; + use DB_File ; + use Fcntl ; + + use vars qw( $dotdir $HISTORY %hist_db $href $binary_time $date ) ; + $dotdir = $ENV{HOME} || $ENV{LOGNAME}; + + $HISTORY = "$dotdir/.netscape/history.db"; + + tie %hist_db, 'DB_File', $HISTORY + or die "Cannot open $HISTORY: $!\n" ;; + + # Dump the complete database + while ( ($href, $binary_time) = each %hist_db ) { + + # remove the terminating NULL + $href =~ s/\x00$// ; + + # convert the binary time into a user friendly string + $date = localtime unpack("V", $binary_time); + print "$date $href\n" ; + } + + # check for the existence of a specific key + # remember to add the NULL + if ( $binary_time = $hist_db{"http://mox.perl.com/\x00"} ) { + $date = localtime unpack("V", $binary_time) ; + print "Last visited mox.perl.com on $date\n" ; + } + else { + print "Never visited mox.perl.com\n" + } + + untie %hist_db ; + +=head2 The untie() Gotcha + +If you make use of the Berkeley DB API, it is I<very> strongly +recommended that you read L<perltie/The untie Gotcha>. + +Even if you don't currently make use of the API interface, it is still +worth reading it. + +Here is an example which illustrates the problem from a B<DB_File> +perspective: + + use DB_File ; + use Fcntl ; + + my %x ; + my $X ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_TRUNC + or die "Cannot tie first time: $!" ; + + $x{123} = 456 ; + + untie %x ; + + tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT + or die "Cannot tie second time: $!" ; + + untie %x ; + +When run, the script will produce this error message: + + Cannot tie second time: Invalid argument at bad.file line 14. + +Although the error message above refers to the second tie() statement +in the script, the source of the problem is really with the untie() +statement that precedes it. + +Having read L<perltie> you will probably have already guessed that the +error is caused by the extra copy of the tied object stored in C<$X>. +If you haven't, then the problem boils down to the fact that the +B<DB_File> destructor, DESTROY, will not be called until I<all> +references to the tied object are destroyed. Both the tied variable, +C<%x>, and C<$X> above hold a reference to the object. The call to +untie() will destroy the first, but C<$X> still holds a valid +reference, so the destructor will not get called and the database file +F<tst.fil> will remain open. The fact that Berkeley DB then reports the +attempt to open a database that is alreday open via the catch-all +"Invalid argument" doesn't help. + +If you run the script with the C<-w> flag the error message becomes: + + untie attempted while 1 inner references still exist at bad.file line 12. + Cannot tie second time: Invalid argument at bad.file line 14. + +which pinpoints the real problem. Finally the script can now be +modified to fix the original problem by destroying the API object +before the untie: + + ... + $x{123} = 456 ; + + undef $X ; + untie %x ; + + $X = tie %x, 'DB_File', 'tst.fil' , O_RDWR|O_CREAT + ... + + +=head1 COMMON QUESTIONS + +=head2 Why is there Perl source in my database? + +If you look at the contents of a database file created by DB_File, +there can sometimes be part of a Perl script included in it. + +This happens because Berkeley DB uses dynamic memory to allocate +buffers which will subsequently be written to the database file. Being +dynamic, the memory could have been used for anything before DB +malloced it. As Berkeley DB doesn't clear the memory once it has been +allocated, the unused portions will contain random junk. In the case +where a Perl script gets written to the database, the random junk will +correspond to an area of dynamic memory that happened to be used during +the compilation of the script. + +Unless you don't like the possibility of there being part of your Perl +scripts embedded in a database file, this is nothing to worry about. + +=head2 How do I store complex data structures with DB_File? + +Although B<DB_File> cannot do this directly, there is a module which +can layer transparently over B<DB_File> to accomplish this feat. + +Check out the MLDBM module, available on CPAN in the directory +F<modules/by-module/MLDBM>. + +=head2 What does "Invalid Argument" mean? + +You will get this error message when one of the parameters in the +C<tie> call is wrong. Unfortunately there are quite a few parameters to +get wrong, so it can be difficult to figure out which one it is. + +Here are a couple of possibilities: + +=over 5 + +=item 1. + +Attempting to reopen a database without closing it. + +=item 2. + +Using the O_WRONLY flag. + +=back + +=head2 What does "Bareword 'DB_File' not allowed" mean? + +You will encounter this particular error message when you have the +C<strict 'subs'> pragma (or the full strict pragma) in your script. +Consider this script: + + use strict ; + use DB_File ; + use vars qw(%x) ; + tie %x, DB_File, "filename" ; + +Running it produces the error in question: + + Bareword "DB_File" not allowed while "strict subs" in use + +To get around the error, place the word C<DB_File> in either single or +double quotes, like this: + + tie %x, "DB_File", "filename" ; + +Although it might seem like a real pain, it is really worth the effort +of having a C<use strict> in all your scripts. + =head1 HISTORY =over @@ -631,14 +1571,112 @@ Fixed a core dump problem with SunOS. The return value from TIEHASH wasn't set to NULL when dbopen returned an error. -=head1 WARNINGS +=item 1.02 + +Merged OS/2 specific code into DB_File.xs + +Removed some redundant code in DB_File.xs. + +Documentation update. + +Allow negative subscripts with RECNO interface. + +Changed the default flags from O_RDWR to O_CREAT|O_RDWR. + +The example code which showed how to lock a database needed a call to +C<sync> added. Without it the resultant database file was empty. -If you happen find any other functions defined in the source for this -module that have not been mentioned in this document -- beware. I may -drop them at a moments notice. +Added get_dup method. -If you cannot find any, then either you didn't look very hard or the -moment has passed and I have dropped them. +=item 1.03 + +Documentation update. + +B<DB_File> now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl +automatically. + +The standard hash function C<exists> is now supported. + +Modified the behavior of get_dup. When it returns an associative +array, the value is the count of the number of matching BTREE values. + +=item 1.04 + +Minor documentation changes. + +Fixed a bug in hash_cb. Patches supplied by Dave Hammen, +E<lt>hammen@gothamcity.jsc.nasa.govE<gt>. + +Fixed a bug with the constructors for DB_File::HASHINFO, +DB_File::BTREEINFO and DB_File::RECNOINFO. Also tidied up the +constructors to make them C<-w> clean. + +Reworked part of the test harness to be more locale friendly. + +=item 1.05 + +Made all scripts in the documentation C<strict> and C<-w> clean. + +Added logic to F<DB_File.xs> to allow the module to be built after Perl +is installed. + +=item 1.06 + +Minor namespace cleanup: Localized C<PrintBtree>. + +=item 1.07 + +Fixed bug with RECNO, where bval wasn't defaulting to "\n". + +=item 1.08 + +Documented operation of bval. + +=item 1.09 + +Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and +DB_File::BTREEINFO. + +Changed default mode to 0666. + +=item 1.10 + +Fixed fd method so that it still returns -1 for in-memory files when db +1.86 is used. + +=item 1.11 + +Documented the untie gotcha. + +=item 1.12 + +Documented the incompatibility with version 2 of Berkeley DB. + +=item 1.13 + +Minor changes to DB_FIle.xs and DB_File.pm + +=item 1.14 + +Made it illegal to tie an associative array to a RECNO database and an +ordinary array to a HASH or BTREE database. + +=item 1.15 + +Patch from Gisle Aas <gisle@aas.no> to suppress "use of undefined +value" warning with db_get and db_seq. + +Patch from Gisle Aas <gisle@aas.no> to make DB_File export only the O_* +constants from Fcntl. + +Removed the DESTROY method from the DB_File::HASHINFO module. + +Previously DB_File hard-wired the class name of any object that it +created to "DB_File". This makes sub-classing difficult. Now DB_File +creats objects in the namespace of the package it has been inherited +into. + +=back =head1 BUGS @@ -651,23 +1689,50 @@ suggest any enhancements, I would welcome your comments. =head1 AVAILABILITY -Berkeley DB is available at your nearest CPAN archive (see +B<DB_File> comes with the standard Perl source distribution. Look in +the directory F<ext/DB_File>. + +This version of B<DB_File> will only work with version 1.x of Berkeley +DB. It is I<not> yet compatible with version 2. + +Version 1 of Berkeley DB is available at your nearest CPAN archive (see L<perlmod/"CPAN"> for a list) in F<src/misc/db.1.85.tar.gz>, or via the -host F<ftp.cs.berkeley.edu> in F</ucb/4bsd/db.tar.gz>. It is I<not> under -the GPL. +host F<ftp.cs.berkeley.edu> in F</ucb/4bsd/db.tar.gz>. Alternatively, +check out the Berkeley DB home page at F<http://www.bostic.com/db>. It +is I<not> under the GPL. + +If you are running IRIX, then get Berkeley DB from +F<http://reality.sgi.com/ariel>. It has the patches necessary to +compile properly on IRIX 5.3. + +As of January 1997, version 1.86 of Berkeley DB is available from the +Berkeley DB home page. Although this release does fix a number of bugs +that were present in 1.85 you should be aware of the following +information (taken from the Berkeley DB home page) before you consider +using it: + + DB version 1.86 includes a new implementation of the hash access + method that fixes a variety of hashing problems found in DB version + 1.85. We are making it available as an interim solution until DB + 2.0 is available. + + PLEASE NOTE: the underlying file format for the hash access method + changed between version 1.85 and version 1.86, so you will have to + dump and reload all of your databases to convert from version 1.85 + to version 1.86. If you do not absolutely require the fixes from + version 1.86, we strongly urge you to wait until DB 2.0 is released + before upgrading from 1.85. + =head1 SEE ALSO L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)> -Berkeley DB is available from F<ftp.cs.berkeley.edu> in the directory -F</ucb/4bsd>. - =head1 AUTHOR The DB_File interface was written by Paul Marquess -<pmarquess@bfsec.bt.co.uk>. -Questions about the DB system itself may be addressed to Keith Bostic -<bostic@cs.berkeley.edu>. +E<lt>pmarquess@bfsec.bt.co.ukE<gt>. +Questions about the DB system itself may be addressed to +E<lt>db@sleepycat.com<gt>. =cut diff --git a/gnu/usr.bin/perl/ext/DB_File/DB_File.xs b/gnu/usr.bin/perl/ext/DB_File/DB_File.xs index dd9e03d0d09..d2c7e6c645b 100644 --- a/gnu/usr.bin/perl/ext/DB_File/DB_File.xs +++ b/gnu/usr.bin/perl/ext/DB_File/DB_File.xs @@ -3,11 +3,15 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) - last modified 14th November 1995 - version 1.01 + last modified 29th Jun 1997 + version 1.15 All comments/suggestions/problems are welcome + Copyright (c) 1995, 1996, 1997 Paul Marquess. All rights reserved. + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + Changes: 0.1 - Initial Release 0.2 - No longer bombs out if dbopen returns an error. @@ -17,6 +21,31 @@ 1.01 - Fixed a SunOS core dump problem. The return value from TIEHASH wasn't set to NULL when dbopen returned an error. + 1.02 - Use ALIAS to define TIEARRAY. + Removed some redundant commented code. + Merged OS2 code into the main distribution. + Allow negative subscripts with RECNO interface. + Changed the default flags to O_CREAT|O_RDWR + 1.03 - Added EXISTS + 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by + Dave Hammen, hammen@gothamcity.jsc.nasa.gov + 1.05 - Added logic to allow prefix & hash types to be specified via + Makefile.PL + 1.06 - Minor namespace cleanup: Localized PrintBtree. + 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n". + 1.08 - No change to DB_File.xs + 1.09 - Default mode for dbopen changed to 0666 + 1.10 - Fixed fd method so that it still returns -1 for + in-memory files when db 1.86 is used. + 1.11 - No change to DB_File.xs + 1.12 - No change to DB_File.xs + 1.13 - Tidied up a few casts. + 1.14 - Made it illegal to tie an associative array to a RECNO + database and an ordinary array to a HASH or BTREE database. + 1.15 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of + undefined value" warning with db_get and db_seq. + + */ #include "EXTERN.h" @@ -24,28 +53,47 @@ #include "XSUB.h" #include <db.h> +/* #ifdef DB_VERSION_MAJOR */ +/* #include <db_185.h> */ +/* #endif */ #include <fcntl.h> +#ifdef mDB_Prefix_t +#ifdef DB_Prefix_t +#undef DB_Prefix_t +#endif +#define DB_Prefix_t mDB_Prefix_t +#endif + +#ifdef mDB_Hash_t +#ifdef DB_Hash_t +#undef DB_Hash_t +#endif +#define DB_Hash_t mDB_Hash_t +#endif + +union INFO { + HASHINFO hash ; + RECNOINFO recno ; + BTREEINFO btree ; + } ; + typedef struct { DBTYPE type ; DB * dbp ; SV * compare ; SV * prefix ; SV * hash ; + int in_memory ; + union INFO info ; } DB_File_type; typedef DB_File_type * DB_File ; typedef DBT DBTKEY ; -union INFO { - HASHINFO hash ; - RECNOINFO recno ; - BTREEINFO btree ; - } ; - -/* #define TRACE */ +/* #define TRACE */ #define db_DESTROY(db) ((db->dbp)->close)(db->dbp) #define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) @@ -54,21 +102,27 @@ union INFO { #define db_close(db) ((db->dbp)->close)(db->dbp) #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) -#define db_fd(db) ((db->dbp)->fd)(db->dbp) +#define db_fd(db) (db->in_memory \ + ? -1 \ + : ((db->dbp)->fd)(db->dbp) ) #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags) #define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags) #define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags) -#define OutputValue(arg, name) \ - { if (RETVAL == 0) sv_setpvn(arg, name.data, name.size) ; } +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + sv_setpvn(arg, name.data, name.size) ; \ + } \ + } #define OutputKey(arg, name) \ { if (RETVAL == 0) \ { \ - if (db->type != DB_RECNO) \ + if (db->type != DB_RECNO) { \ sv_setpvn(arg, name.data, name.size); \ + } \ else \ sv_setiv(arg, (I32)*(I32*)name.data - 1); \ } \ @@ -117,7 +171,7 @@ const DBT * key2 ; SPAGAIN ; if (count != 1) - croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ; + croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ; retval = POPi ; @@ -164,7 +218,7 @@ const DBT * key2 ; SPAGAIN ; if (count != 1) - croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ; + croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; retval = POPi ; @@ -187,7 +241,12 @@ size_t size ; if (size == 0) data = "" ; + /* DGH - Next two lines added to fix corrupted stack problem */ + ENTER ; + SAVETMPS; + PUSHMARK(sp) ; + XPUSHs(sv_2mortal(newSVpv((char*)data,size))); PUTBACK ; @@ -196,7 +255,7 @@ size_t size ; SPAGAIN ; if (count != 1) - croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ; + croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ; retval = POPi ; @@ -212,44 +271,45 @@ size_t size ; static void PrintHash(hash) -HASHINFO hash ; +HASHINFO * hash ; { printf ("HASH Info\n") ; - printf (" hash = %s\n", (hash.hash != NULL ? "redefined" : "default")) ; - printf (" bsize = %d\n", hash.bsize) ; - printf (" ffactor = %d\n", hash.ffactor) ; - printf (" nelem = %d\n", hash.nelem) ; - printf (" cachesize = %d\n", hash.cachesize) ; - printf (" lorder = %d\n", hash.lorder) ; + printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ; + printf (" bsize = %d\n", hash->bsize) ; + printf (" ffactor = %d\n", hash->ffactor) ; + printf (" nelem = %d\n", hash->nelem) ; + printf (" cachesize = %d\n", hash->cachesize) ; + printf (" lorder = %d\n", hash->lorder) ; } static void PrintRecno(recno) -RECNOINFO recno ; +RECNOINFO * recno ; { printf ("RECNO Info\n") ; - printf (" flags = %d\n", recno.flags) ; - printf (" cachesize = %d\n", recno.cachesize) ; - printf (" psize = %d\n", recno.psize) ; - printf (" lorder = %d\n", recno.lorder) ; - printf (" reclen = %d\n", recno.reclen) ; - printf (" bval = %d\n", recno.bval) ; - printf (" bfname = %s\n", recno.bfname) ; + printf (" flags = %d\n", recno->flags) ; + printf (" cachesize = %d\n", recno->cachesize) ; + printf (" psize = %d\n", recno->psize) ; + printf (" lorder = %d\n", recno->lorder) ; + printf (" reclen = %lu\n", (unsigned long)recno->reclen) ; + printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ; + printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ; } +static void PrintBtree(btree) -BTREEINFO btree ; +BTREEINFO * btree ; { printf ("BTREE Info\n") ; - printf (" compare = %s\n", (btree.compare ? "redefined" : "default")) ; - printf (" prefix = %s\n", (btree.prefix ? "redefined" : "default")) ; - printf (" flags = %d\n", btree.flags) ; - printf (" cachesize = %d\n", btree.cachesize) ; - printf (" psize = %d\n", btree.psize) ; - printf (" maxkeypage = %d\n", btree.maxkeypage) ; - printf (" minkeypage = %d\n", btree.minkeypage) ; - printf (" lorder = %d\n", btree.lorder) ; + printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ; + printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ; + printf (" flags = %d\n", btree->flags) ; + printf (" cachesize = %d\n", btree->cachesize) ; + printf (" psize = %d\n", btree->psize) ; + printf (" maxkeypage = %d\n", btree->maxkeypage) ; + printf (" minkeypage = %d\n", btree->minkeypage) ; + printf (" lorder = %d\n", btree->lorder) ; } #else @@ -275,147 +335,194 @@ DB * db ; else if (RETVAL == 1) /* No key means empty file */ RETVAL = 0 ; - return (RETVAL) ; + return ((I32)RETVAL) ; +} + +static recno_t +GetRecnoKey(db, value) +DB_File db ; +I32 value ; +{ + if (value < 0) { + /* Get the length of the array */ + I32 length = GetArrayLength(db->dbp) ; + + /* check for attempt to write before start of array */ + if (length + value + 1 <= 0) + croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; + + value = length + value + 1 ; + } + else + ++ value ; + + return value ; } static DB_File -ParseOpenInfo(name, flags, mode, sv, string) +ParseOpenInfo(isHASH, name, flags, mode, sv) +int isHASH ; char * name ; int flags ; int mode ; SV * sv ; -char * string ; { SV ** svp; HV * action ; - union INFO info ; DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; void * openinfo = NULL ; - /* DBTYPE type = DB_HASH ; */ + union INFO * info = &RETVAL->info ; + /* Default to HASH */ RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; RETVAL->type = DB_HASH ; + /* DGH - Next line added to avoid SEGV on existing hash DB */ + CurrentDB = RETVAL; + + /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ + RETVAL->in_memory = (name == NULL) ; + if (sv) { if (! SvROK(sv) ) croak ("type parameter is not a reference") ; - action = (HV*)SvRV(sv); + svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; + if (svp && SvOK(*svp)) + action = (HV*) SvRV(*svp) ; + else + croak("internal error") ; + if (sv_isa(sv, "DB_File::HASHINFO")) { + + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_HASH database") ; + RETVAL->type = DB_HASH ; - openinfo = (void*)&info ; + openinfo = (void*)info ; svp = hv_fetch(action, "hash", 4, FALSE); if (svp && SvOK(*svp)) { - info.hash.hash = hash_cb ; + info->hash.hash = hash_cb ; RETVAL->hash = newSVsv(*svp) ; } else - info.hash.hash = NULL ; + info->hash.hash = NULL ; svp = hv_fetch(action, "bsize", 5, FALSE); - info.hash.bsize = svp ? SvIV(*svp) : 0; + info->hash.bsize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "ffactor", 7, FALSE); - info.hash.ffactor = svp ? SvIV(*svp) : 0; + info->hash.ffactor = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "nelem", 5, FALSE); - info.hash.nelem = svp ? SvIV(*svp) : 0; + info->hash.nelem = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); - info.hash.cachesize = svp ? SvIV(*svp) : 0; + info->hash.cachesize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); - info.hash.lorder = svp ? SvIV(*svp) : 0; + info->hash.lorder = svp ? SvIV(*svp) : 0; PrintHash(info) ; } else if (sv_isa(sv, "DB_File::BTREEINFO")) { + if (!isHASH) + croak("DB_File can only tie an associative array to a DB_BTREE database"); + RETVAL->type = DB_BTREE ; - openinfo = (void*)&info ; + openinfo = (void*)info ; svp = hv_fetch(action, "compare", 7, FALSE); if (svp && SvOK(*svp)) { - info.btree.compare = btree_compare ; + info->btree.compare = btree_compare ; RETVAL->compare = newSVsv(*svp) ; } else - info.btree.compare = NULL ; + info->btree.compare = NULL ; svp = hv_fetch(action, "prefix", 6, FALSE); if (svp && SvOK(*svp)) { - info.btree.prefix = btree_prefix ; + info->btree.prefix = btree_prefix ; RETVAL->prefix = newSVsv(*svp) ; } else - info.btree.prefix = NULL ; + info->btree.prefix = NULL ; svp = hv_fetch(action, "flags", 5, FALSE); - info.btree.flags = svp ? SvIV(*svp) : 0; + info->btree.flags = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "cachesize", 9, FALSE); - info.btree.cachesize = svp ? SvIV(*svp) : 0; + info->btree.cachesize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "minkeypage", 10, FALSE); - info.btree.minkeypage = svp ? SvIV(*svp) : 0; + info->btree.minkeypage = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "maxkeypage", 10, FALSE); - info.btree.maxkeypage = svp ? SvIV(*svp) : 0; + info->btree.maxkeypage = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "psize", 5, FALSE); - info.btree.psize = svp ? SvIV(*svp) : 0; + info->btree.psize = svp ? SvIV(*svp) : 0; svp = hv_fetch(action, "lorder", 6, FALSE); - info.btree.lorder = svp ? SvIV(*svp) : 0; + info->btree.lorder = svp ? SvIV(*svp) : 0; PrintBtree(info) ; } else if (sv_isa(sv, "DB_File::RECNOINFO")) { + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + RETVAL->type = DB_RECNO ; - openinfo = (void *)&info ; + openinfo = (void *)info ; svp = hv_fetch(action, "flags", 5, FALSE); - info.recno.flags = (u_long) svp ? SvIV(*svp) : 0; + info->recno.flags = (u_long) (svp ? SvIV(*svp) : 0); svp = hv_fetch(action, "cachesize", 9, FALSE); - info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0; + info->recno.cachesize = (u_int) (svp ? SvIV(*svp) : 0); svp = hv_fetch(action, "psize", 5, FALSE); - info.recno.psize = (int) svp ? SvIV(*svp) : 0; + info->recno.psize = (u_int) (svp ? SvIV(*svp) : 0); svp = hv_fetch(action, "lorder", 6, FALSE); - info.recno.lorder = (int) svp ? SvIV(*svp) : 0; + info->recno.lorder = (int) (svp ? SvIV(*svp) : 0); svp = hv_fetch(action, "reclen", 6, FALSE); - info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0; + info->recno.reclen = (size_t) (svp ? SvIV(*svp) : 0); svp = hv_fetch(action, "bval", 4, FALSE); if (svp && SvOK(*svp)) { if (SvPOK(*svp)) - info.recno.bval = (u_char)*SvPV(*svp, na) ; + info->recno.bval = (u_char)*SvPV(*svp, na) ; else - info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ; + info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ; } else { - if (info.recno.flags & R_FIXEDLEN) - info.recno.bval = (u_char) ' ' ; + if (info->recno.flags & R_FIXEDLEN) + info->recno.bval = (u_char) ' ' ; else - info.recno.bval = (u_char) '\n' ; + info->recno.bval = (u_char) '\n' ; } svp = hv_fetch(action, "bfname", 6, FALSE); - info.recno.bfname = (char *) svp ? SvPV(*svp,na) : 0; + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,na) ; + info->recno.bfname = (char*) (na ? ptr : NULL) ; + } + else + info->recno.bfname = NULL ; PrintRecno(info) ; } @@ -424,17 +531,14 @@ char * string ; } - RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; - -#if 0 - /* kludge mode on: RETVAL->type for DB_RECNO is set to DB_BTREE - so remember a DB_RECNO by saving the address - of one of it's internal routines - */ - if (RETVAL->dbp && type == DB_RECNO) - DB_recno_close = RETVAL->dbp->close ; -#endif + /* OS2 Specific Code */ +#ifdef OS2 +#ifdef __EMX__ + flags |= O_BINARY; +#endif /* __EMX__ */ +#endif /* OS2 */ + RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; return (RETVAL) ; } @@ -695,7 +799,8 @@ constant(name,arg) DB_File -db_TIEHASH(dbtype, name=undef, flags=O_RDWR, mode=0640, type=DB_HASH) +db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH) + int isHASH char * dbtype int flags int mode @@ -704,22 +809,19 @@ db_TIEHASH(dbtype, name=undef, flags=O_RDWR, mode=0640, type=DB_HASH) char * name = (char *) NULL ; SV * sv = (SV *) NULL ; - if (items >= 2 && SvOK(ST(1))) - name = (char*) SvPV(ST(1), na) ; + if (items >= 3 && SvOK(ST(2))) + name = (char*) SvPV(ST(2), na) ; - if (items == 5) - sv = ST(4) ; + if (items == 6) + sv = ST(5) ; - RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ; + RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ; if (RETVAL->dbp == NULL) RETVAL = NULL ; } OUTPUT: RETVAL -BOOT: - newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file); - int db_DESTROY(db) DB_File db @@ -743,6 +845,21 @@ db_DELETE(db, key, flags=0) INIT: CurrentDB = db ; + +int +db_EXISTS(db, key) + DB_File db + DBTKEY key + CODE: + { + DBT value ; + + CurrentDB = db ; + RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ; + } + OUTPUT: + RETVAL + int db_FETCH(db, key, flags=0) DB_File db @@ -783,7 +900,7 @@ db_FIRSTKEY(db) ST(0) = sv_newmortal(); if (RETVAL == 0) { - if (Db->type != DB_RECNO) + if (db->type != DB_RECNO) sv_setpvn(ST(0), key.data, key.size); else sv_setiv(ST(0), (I32)*(I32*)key.data - 1); @@ -804,7 +921,7 @@ db_NEXTKEY(db, key) ST(0) = sv_newmortal(); if (RETVAL == 0) { - if (Db->type != DB_RECNO) + if (db->type != DB_RECNO) sv_setpvn(ST(0), key.data, key.size); else sv_setiv(ST(0), (I32)*(I32*)key.data - 1); @@ -859,9 +976,11 @@ pop(db) /* Now delete it */ if (RETVAL == 0) { + /* the call to del will trash value, so take a copy now */ + sv_setpvn(ST(0), value.data, value.size); RETVAL = (Db->del)(Db, &key, R_CURSOR) ; - if (RETVAL == 0) - sv_setpvn(ST(0), value.data, value.size); + if (RETVAL != 0) + sv_setsv(ST(0), &sv_undef); } } @@ -870,20 +989,22 @@ shift(db) DB_File db CODE: { - DBTKEY key ; DBT value ; + DBTKEY key ; DB * Db = db->dbp ; CurrentDB = db ; /* get the first value */ - RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ; + RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ; ST(0) = sv_newmortal(); /* Now delete it */ if (RETVAL == 0) { - RETVAL = (Db->del)(Db, &key, R_CURSOR) ; - if (RETVAL == 0) - sv_setpvn(ST(0), value.data, value.size); + /* the call to del will trash value, so take a copy now */ + sv_setpvn(ST(0), value.data, value.size); + RETVAL = (Db->del)(Db, &key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv (ST(0), &sv_undef) ; } } @@ -947,7 +1068,7 @@ int db_get(db, key, value, flags=0) DB_File db DBTKEY key - DBT value + DBT value = NO_INIT u_int flags INIT: CurrentDB = db ; @@ -983,10 +1104,11 @@ int db_seq(db, key, value, flags) DB_File db DBTKEY key - DBT value + DBT value = NO_INIT u_int flags INIT: CurrentDB = db ; OUTPUT: key value + diff --git a/gnu/usr.bin/perl/ext/DB_File/Makefile.PL b/gnu/usr.bin/perl/ext/DB_File/Makefile.PL index 4cda63507d2..39b8bc70303 100644 --- a/gnu/usr.bin/perl/ext/DB_File/Makefile.PL +++ b/gnu/usr.bin/perl/ext/DB_File/Makefile.PL @@ -1,11 +1,16 @@ -use ExtUtils::MakeMaker; +use ExtUtils::MakeMaker 5.16 ; +use Config ; + +# OS2 is a special case, so check for it now. +my $OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ; WriteMakefile( - NAME => 'DB_File', - LIBS => ["-L/usr/local/lib -ldb"], - MAN3PODS => ' ', # Pods will be built by installman. - #INC => '-I/usr/local/include', + NAME => 'DB_File', + LIBS => ["-L/usr/local/lib -ldb"], + MAN3PODS => ' ', # Pods will be built by installman. + #INC => '-I/usr/local/include', VERSION_FROM => 'DB_File.pm', - XSPROTOARG => '-noprototypes', # XXX remove later? -); + XSPROTOARG => '-noprototypes', + DEFINE => "$OS2", + ); diff --git a/gnu/usr.bin/perl/ext/DB_File/typemap b/gnu/usr.bin/perl/ext/DB_File/typemap index 4acc65e0781..a6212243de2 100644 --- a/gnu/usr.bin/perl/ext/DB_File/typemap +++ b/gnu/usr.bin/perl/ext/DB_File/typemap @@ -1,8 +1,8 @@ # typemap for Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 23rd June 1994 -# version 0.1 +# last modified 28th June 1996 +# version 0.2 # #################################### DB SECTION # @@ -15,15 +15,12 @@ DBTKEY T_dbtkeydatum INPUT T_dbtkeydatum - if (db->type != DB_RECNO) - { + if (db->type != DB_RECNO) { $var.data = SvPV($arg, na); $var.size = (int)na; } - else - { - Value = SvIV($arg) ; - ++ Value ; + else { + Value = GetRecnoKey(db, SvIV($arg)) ; $var.data = & Value; $var.size = (int)sizeof(recno_t); } @@ -37,3 +34,5 @@ T_dbtkeydatum OutputKey($arg, $var) T_dbtdatum OutputValue($arg, $var) +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader.pm b/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader.pm index 282d364372e..712d575e38b 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader.pm +++ b/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader.pm @@ -12,21 +12,39 @@ package DynaLoader; # # Tim.Bunce@ig.co.uk, August 1994 -use vars qw($VERSION @ISA) ; +$VERSION = $VERSION = "1.03"; # avoid typo warning -require Carp; require Config; -require AutoLoader; -@ISA=qw(AutoLoader); +require AutoLoader; +*AUTOLOAD = \&AutoLoader::AUTOLOAD; -$VERSION = "1.00" ; +# The following require can't be removed during maintenance +# releases, sadly, because of the risk of buggy code that does +# require Carp; Carp::croak "..."; without brackets dying +# if Carp hasn't been loaded in earlier compile time. :-( +# We'll let those bugs get found on the development track. +require Carp if $] < 5.00450; -sub import { } # override import inherited from AutoLoader # enable debug/trace messages from DynaLoader perl code $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; +# +# Flags to alter dl_load_file behaviour. Assigned bits: +# 0x01 make symbols available for linking later dl_load_file's. +# (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) +# (ignored under VMS; effect is built-in to image linking) +# +# This is called as a class method $module->dl_load_flags. The +# definition here will be inherited and result on "default" loading +# behaviour unless a sub-class of DynaLoader defines its own version. +# + +sub dl_load_flags { 0x00 } + +# + ($dl_dlext, $dlsrc) = @Config::Config{'dlext', 'dlsrc'}; @@ -39,6 +57,8 @@ $do_expand = $Is_VMS = $^O eq 'VMS'; @dl_require_symbols = (); # names of symbols we need @dl_resolve_using = (); # names of files to link with @dl_library_path = (); # path to look for files +@dl_librefs = (); # things we have loaded +@dl_modules = (); # Modules we have loaded # This is a fix to support DLD's unfortunate desire to relink -lc @dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs"; @@ -67,6 +87,8 @@ if ($dl_debug) { 1; # End of main code +sub croak { require Carp; Carp::croak(@_) } + # The bootstrap function cannot be autoloaded (without complications) # so we define it here: @@ -76,11 +98,14 @@ sub bootstrap { local($module) = $args[0]; local(@dirs, $file); - Carp::confess("Usage: DynaLoader::bootstrap(module)") unless $module; + unless ($module) { + require Carp; + Carp::confess("Usage: DynaLoader::bootstrap(module)"); + } # A common error on platforms which don't support dynamic loading. # Since it's fatal and potentially confusing we give a detailed message. - Carp::croak("Can't load module $module, dynamic loading not available in this perl.\n". + croak("Can't load module $module, dynamic loading not available in this perl.\n". " (You may need to build a new perl executable which either supports\n". " dynamic loading or has the $module module statically linked into it.)\n") unless defined(&dl_load_file); @@ -104,16 +129,17 @@ sub bootstrap { next unless -d $dir; # skip over uninteresting directories # check for common cases to avoid autoload of dl_findfile - last if ($file=_check_file("$dir/$modfname.$dl_dlext")); + my $try = "$dir/$modfname.$dl_dlext"; + last if $file = ($do_expand) ? dl_expandspec($try) : (-f $try && $try); # no luck here, save dir for possible later dl_findfile search - push(@dirs, "-L$dir"); + push @dirs, $dir; } # last resort, let dl_findfile have a go in all known locations - $file = dl_findfile(@dirs, map("-L$_",@INC), $modfname) unless $file; + $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file; - Carp::croak("Can't find loadable object for module $module in \@INC (@INC)") - unless $file; + croak("Can't locate loadable object for module $module in \@INC (\@INC contains: @INC)") + unless $file; # wording similar to error from 'require' my $bootname = "boot_$module"; $bootname =~ s/\W/_/g; @@ -137,29 +163,35 @@ sub bootstrap { # in this perl code simply because this was the last perl code # it executed. - my $libref = dl_load_file($file) or - Carp::croak("Can't load '$file' for module $module: ".dl_error()."\n"); + my $libref = dl_load_file($file, $module->dl_load_flags) or + croak("Can't load '$file' for module $module: ".dl_error()."\n"); + + push(@dl_librefs,$libref); # record loaded object my @unresolved = dl_undef_symbols(); - Carp::carp("Undefined symbols present after loading $file: @unresolved\n") - if @unresolved; + if (@unresolved) { + require Carp; + Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); + } my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or - Carp::croak("Can't find '$bootname' symbol in $file\n"); + croak("Can't find '$bootname' symbol in $file\n"); my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + push(@dl_modules, $module); # record loaded module + # See comment block above &$xs(@args); } -sub _check_file { # private utility to handle dl_expandspec vs -f tests - my($file) = @_; - return $file if (!$do_expand && -f $file); # the common case - return $file if ( $do_expand && ($file=dl_expandspec($file))); - return undef; -} +#sub _check_file { # private utility to handle dl_expandspec vs -f tests +# my($file) = @_; +# return $file if (!$do_expand && -f $file); # the common case +# return $file if ( $do_expand && ($file=dl_expandspec($file))); +# return undef; +#} # Let autosplit and the autoloader deal with these functions: @@ -224,7 +256,8 @@ sub dl_findfile { foreach $name (@names) { my($file) = "$dir/$name"; print STDERR " checking in $dir for $name\n" if $dl_debug; - $file = _check_file($file); + $file = ($do_expand) ? dl_expandspec($file) : (-f $file && $file); + #$file = _check_file($file); if ($file) { push(@found, $file); next arg; # no need to look any further @@ -260,6 +293,7 @@ sub dl_expandspec { my $file = $spec; # default output to input if ($Is_VMS) { # dl_expandspec should be defined in dl_vms.xs + require Carp; Carp::croak("dl_expandspec: should be defined in XS file!\n"); } else { return undef unless -f $file; @@ -268,12 +302,22 @@ sub dl_expandspec { $file; } +sub dl_find_symbol_anywhere +{ + my $sym = shift; + my $libref; + foreach $libref (@dl_librefs) { + my $symref = dl_find_symbol($libref,$sym); + return $symref if $symref; + } + return undef; +} =head1 NAME DynaLoader - Dynamically load C libraries into Perl code -dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl_undef_symbols(), dl_install_xsub(), boostrap() - routines used by DynaLoader modules +dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(), dl_load_flags(), bootstrap() - routines used by DynaLoader modules =head1 SYNOPSIS @@ -282,6 +326,9 @@ dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl @ISA = qw(... DynaLoader ...); bootstrap YourPackage; + # optional method for 'global' loading + sub dl_load_flags { 0x01 } + =head1 DESCRIPTION @@ -303,9 +350,9 @@ etc and also allow pseudo-dynamic linking (using C<ld -A> at runtime). It must be stressed that the DynaLoader, by itself, is practically useless for accessing non-Perl libraries because it provides almost no Perl-to-C 'glue'. There is, for example, no mechanism for calling a C -library function or supplying arguments. It is anticipated that any -glue that may be developed in the future will be implemented in a -separate dynamically loaded module. +library function or supplying arguments. A ExtUtils::DynaLib module +is available from CPAN sites which performs that function for some +common system types. DynaLoader Interface Summary @@ -313,11 +360,15 @@ DynaLoader Interface Summary @dl_resolve_using @dl_require_symbols $dl_debug + @dl_librefs + @dl_modules Implemented in: bootstrap($modulename) Perl @filepaths = dl_findfile(@names) Perl + $flags = $modulename->dl_load_flags Perl + $symref = dl_find_symbol_anywhere($symbol) Perl - $libref = dl_load_file($filename) C + $libref = dl_load_file($filename, $flags) C $symref = dl_find_symbol($libref, $symbol) C @symbols = dl_undef_symbols() C dl_install_xsub($name, $symref [, $filename]) C @@ -357,12 +408,13 @@ used to resolve any undefined symbols that might be generated by a later call to load_file(). This is only required on some platforms which do not handle dependent -libraries automatically. For example the Socket Perl extension library -(F<auto/Socket/Socket.so>) contains references to many socket functions -which need to be resolved when it's loaded. Most platforms will -automatically know where to find the 'dependent' library (e.g., -F</usr/lib/libsocket.so>). A few platforms need to to be told the location -of the dependent library explicitly. Use @dl_resolve_using for this. +libraries automatically. For example the Socket Perl extension +library (F<auto/Socket/Socket.so>) contains references to many socket +functions which need to be resolved when it's loaded. Most platforms +will automatically know where to find the 'dependent' library (e.g., +F</usr/lib/libsocket.so>). A few platforms need to be told the +location of the dependent library explicitly. Use @dl_resolve_using +for this. Example usage: @@ -373,6 +425,17 @@ Example usage: A list of one or more symbol names that are in the library/object file to be dynamically loaded. This is only required on some platforms. +=item @dl_librefs + +An array of the handles returned by successful calls to dl_load_file(), +made by bootstrap, in the order in which they were loaded. +Can be used with dl_find_symbol() to look for a symbol in any of +the loaded files. + +=item @dl_modules + +An array of module (package) names that have been bootstrap'ed. + =item dl_error() Syntax: @@ -452,19 +515,26 @@ more information. Syntax: - $libref = dl_load_file($filename) + $libref = dl_load_file($filename, $flags) Dynamically load $filename, which must be the path to a shared object or library. An opaque 'library reference' is returned as a handle for the loaded object. Returns undef on error. +The $flags argument to alters dl_load_file behaviour. +Assigned bits: + + 0x01 make symbols available for linking later dl_load_file's. + (only known to work on Solaris 2 using dlopen(RTLD_GLOBAL)) + (ignored under VMS; this is a normal part of image linking) + (On systems that provide a handle for the loaded object such as SunOS and HPUX, $libref will be that handle. On other systems $libref will typically be $filename or a pointer to a buffer containing $filename. The application should not examine or alter $libref in any way.) -This is function that does the real work. It should use the current -values of @dl_require_symbols and @dl_resolve_using if required. +This is the function that does the real work. It should use the +current values of @dl_require_symbols and @dl_resolve_using if required. SunOS: dlopen($filename) HP-UX: shl_load($filename) @@ -472,6 +542,20 @@ values of @dl_require_symbols and @dl_resolve_using if required. NeXT: rld_load($filename, @dl_resolve_using) VMS: lib$find_image_symbol($filename,$dl_require_symbols[0]) +(The dlopen() function is also used by Solaris and some versions of +Linux, and is a common choice when providing a "wrapper" on other +mechanisms as is done in the OS/2 port.) + +=item dl_loadflags() + +Syntax: + + $flags = dl_loadflags $modulename; + +Designed to be a method call, and to be overridden by a derived class +(i.e. a class which has DynaLoader in its @ISA). The definition in +DynaLoader itself returns 0, which produces standard behavior from +dl_load_file(). =item dl_find_symbol() @@ -495,6 +579,15 @@ be passed to, and understood by, dl_install_xsub(). VMS: lib$find_image_symbol($libref,$symbol) +=item dl_find_symbol_anywhere() + +Syntax: + + $symref = dl_find_symbol_anywhere($symbol) + +Applies dl_find_symbol() to the members of @dl_librefs and returns +the first match found. + =item dl_undef_symbols() Example @@ -523,7 +616,7 @@ the function if required by die(), caller() or the debugger. If $filename is not defined then "DynaLoader" will be used. -=item boostrap() +=item bootstrap() Syntax: @@ -555,6 +648,10 @@ are required to load the module on the current platform) =item * +calls dl_load_flags() to determine how to load the file. + +=item * + calls dl_load_file() to load the file =item * @@ -590,4 +687,7 @@ Siegel, Thomas Neumann, Paul Marquess, Charles Bailey, myself and others. Larry Wall designed the elegant inherited bootstrap mechanism and implemented the first Perl 5 dynamic loader using it. +Solaris global loading added by Nick Ing-Simmons with design/coding +assistance from Tim Bunce, January 1996. + =cut diff --git a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL index 64ee4d02598..9323935880b 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL +++ b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL @@ -1,21 +1,21 @@ use ExtUtils::MakeMaker; WriteMakefile( - NAME => 'DynaLoader', + NAME => 'DynaLoader', LINKTYPE => 'static', - DEFINE => '-DLIBC="$(LIBC)"', + DEFINE => '-DPERL_CORE -DLIBC="$(LIBC)"', MAN3PODS => ' ', # Pods will be built by installman. SKIP => [qw(dynamic dynamic_lib dynamic_bs)], XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'DynaLoader.pm', - clean => {FILES => 'DynaLoader.c'}, + clean => {FILES => 'DynaLoader.c DynaLoader.xs'}, ); sub MY::postamble { ' -DynaLoader.c: $(DLSRC) - $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $(DLSRC) >tmp && mv tmp $@ +DynaLoader.xs: $(DLSRC) + $(CP) $? $@ # Perform very simple tests just to check for major gaffs. # We can\'t do much more for platforms we are not executing on. diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs index f8bace13146..746666636ae 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs @@ -29,6 +29,12 @@ #include <a.out.h> #include <ldfcn.h> +/* If using PerlIO, redefine these macros from <ldfcn.h> */ +#ifdef USE_PERLIO +#define FSEEK(ldptr,o,p) PerlIO_seek(IOPTR(ldptr),(p==BEGINNING)?(OFFSET(ldptr)+o):o,p) +#define FREAD(p,s,n,ldptr) PerlIO_read(IOPTR(ldptr),p,s*n) +#endif + /* * We simulate dlopen() et al. through a call to load. Because AIX has * no call to find an exported symbol we read the loader section of the @@ -389,7 +395,13 @@ static int readExports(ModulePtr mp) ; return -1; } +/* This first case is a hack, since it assumes that the 3rd parameter to + FREAD is 1. See the redefinition of FREAD above to see how this works. */ +#ifdef USE_PERLIO + if (FREAD(ldbuf, sh.s_size, 1, ldp) != sh.s_size) { +#else if (FREAD(ldbuf, sh.s_size, 1, ldp) != 1) { +#endif errvalid++; strcpy(errbuf, "readExports: cannot read loader section"); safefree(ldbuf); @@ -524,12 +536,15 @@ BOOT: void * -dl_load_file(filename) - char * filename +dl_load_file(filename, flags=0) + char * filename + int flags CODE: - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + warn("Can't make loaded symbols global on this platform while loading %s",filename); RETVAL = dlopen(filename, 1) ; - DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -542,10 +557,10 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -567,7 +582,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs index a0028a1f7ad..44933ec92ca 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs @@ -62,7 +62,7 @@ dl_private_init() if (dlderr) { char *msg = dld_strerror(dlderr); SaveError("dld_init(%s) failed: %s", origargv[0], msg); - DLDEBUG(1,fprintf(stderr,"%s", LastError)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "%s", LastError)); } #ifdef __linux__ } @@ -77,18 +77,21 @@ BOOT: char * -dl_load_file(filename) +dl_load_file(filename, flags=0) char * filename - CODE: + int flags + PREINIT: int dlderr,x,max; GV *gv; + CODE: RETVAL = filename; - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s)\n", filename)); - + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + croak("Can't make loaded symbols global on this platform while loading %s",filename); max = AvFILL(dl_require_symbols); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0)); - DLDEBUG(1,fprintf(stderr, "dld_create_ref(%s)\n", sym)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_create_ref(%s)\n", sym)); if (dlderr = dld_create_reference(sym)) { SaveError("dld_create_reference(%s): %s", sym, dld_strerror(dlderr)); @@ -96,7 +99,7 @@ dl_load_file(filename) } } - DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", filename)); if (dlderr = dld_link(filename)) { SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); goto haverror; @@ -105,13 +108,13 @@ dl_load_file(filename) max = AvFILL(dl_resolve_using); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0)); - DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", sym)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", sym)); if (dlderr = dld_link(sym)) { SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } - DLDEBUG(2,fprintf(stderr,"libref=%s\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "libref=%s\n", RETVAL)); haverror: ST(0) = sv_newmortal() ; if (dlderr == 0) @@ -123,11 +126,11 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = (void *)dld_get_func(symbolname); /* if RETVAL==NULL we should try looking for a non-function symbol */ - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ; @@ -157,7 +160,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs index 86643f6d3be..fef4530cfee 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs @@ -119,7 +119,7 @@ #endif #ifndef HAS_DLERROR -# if defined(__NetBSD__) || defined(__OpenBSD__) +# ifdef __NetBSD__ # define dlerror() strerror(errno) # else # define dlerror() "Unknown error - dlerror() not implemented" @@ -143,17 +143,25 @@ BOOT: void * -dl_load_file(filename) - char * filename - CODE: +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: int mode = RTLD_LAZY; + CODE: #ifdef RTLD_NOW if (dl_nonlazy) mode = RTLD_NOW; #endif - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + if (flags & 0x01) +#ifdef RTLD_GLOBAL + mode |= RTLD_GLOBAL; +#else + warn("Can't make loaded symbols global on this platform while loading %s",filename); +#endif + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -167,13 +175,14 @@ dl_find_symbol(libhandle, symbolname) char * symbolname CODE: #ifdef DLSYM_NEEDS_UNDERSCORE - char symbolname_buf[1024]; - symbolname = dl_add_underscore(symbolname, symbolname_buf); + symbolname = form("_%s", symbolname); #endif - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -195,8 +204,8 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n", + perl_name, (unsigned long) symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs index 0e146830ef3..51d464e6dea 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs @@ -3,6 +3,14 @@ * Version: 2.1, 1995/1/25 */ +/* o Added BIND_VERBOSE to dl_nonlazy condition to add names of missing + * symbols to stderr message on fatal error. + * + * o Added BIND_NONFATAL comment to default condition. + * + * Chuck Phillips (cdp@fc.hp.com) + * Version: 2.2, 1997/5/4 */ + #ifdef __hp9000s300 #define magic hpux_magic #define MAGIC HPUX_MAGIC @@ -38,31 +46,44 @@ BOOT: void * -dl_load_file(filename) - char * filename - CODE: +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: shl_t obj = NULL; int i, max, bind_type; - - if (dl_nonlazy) - bind_type = BIND_IMMEDIATE; - else - bind_type = BIND_DEFERRED; + CODE: + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + warn("Can't make loaded symbols global on this platform while loading %s",filename); + if (dl_nonlazy) { + bind_type = BIND_IMMEDIATE|BIND_VERBOSE; + } else { + bind_type = BIND_DEFERRED; + /* For certain libraries, like DCE, deferred binding often causes run + * time problems. Adding BIND_NONFATAL to BIND_IMMEDIATE still allows + * unresolved references in situations like this. */ + /* bind_type = BIND_IMMEDIATE|BIND_NONFATAL; */ + } +#ifdef DEBUGGING + if (dl_debug) + bind_type |= BIND_VERBOSE; +#endif /* DEBUGGING */ max = AvFILL(dl_resolve_using); for (i = 0; i <= max; i++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); - DLDEBUG(1,fprintf(stderr, "dl_load_file(%s) (dependent)\n", sym)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym)); obj = shl_load(sym, bind_type | BIND_NOSTART, 0L); if (obj == NULL) { goto end; } } - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s): ", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename)); obj = shl_load(filename, bind_type | BIND_NOSTART, 0L); - DLDEBUG(2,fprintf(stderr," libref=%x\n", obj)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj)); end: ST(0) = sv_newmortal() ; if (obj == NULL) @@ -80,20 +101,21 @@ dl_find_symbol(libhandle, symbolname) void *symaddr = NULL; int status; #ifdef __hp9000s300 - char symbolname_buf[MAXPATHLEN]; - symbolname = dl_add_underscore(symbolname, symbolname_buf); + symbolname = form("_%s", symbolname); #endif - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); + ST(0) = sv_newmortal() ; errno = 0; status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); - DLDEBUG(2,fprintf(stderr," symbolref(PROCEDURE) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(PROCEDURE) = %x\n", symaddr)); if (status == -1 && errno == 0) { /* try TYPE_DATA instead */ status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr); - DLDEBUG(2,fprintf(stderr," symbolref(DATA) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(DATA) = %x\n", symaddr)); } if (status == -1) { @@ -117,7 +139,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs index 33a41003eff..92d14bc81c2 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs @@ -31,9 +31,12 @@ Anno Siegel */ +#if NS_TARGET_MAJOR >= 4 +#else /* include these before perl headers */ #include <mach-o/rld.h> #include <streams/streams.h> +#endif #include "EXTERN.h" #include "perl.h" @@ -47,15 +50,102 @@ Anno Siegel static char * dl_last_error = (char *) 0; static AV *dl_resolve_using = Nullav; -NXStream * -OpenError() +static char *dlerror() +{ + return dl_last_error; +} + +int dlclose(handle) /* stub only */ +void *handle; +{ + return 0; +} + +#if NS_TARGET_MAJOR >= 4 +#import <mach-o/dyld.h> + +enum dyldErrorSource +{ + OFImage, +}; + +static void TranslateError + (const char *path, enum dyldErrorSource type, int number) +{ + char *error; + unsigned int index; + static char *OFIErrorStrings[] = + { + "%s(%d): Object Image Load Failure\n", + "%s(%d): Object Image Load Success\n", + "%s(%d): Not an recognisable object file\n", + "%s(%d): No valid architecture\n", + "%s(%d): Object image has an invalid format\n", + "%s(%d): Invalid access (permissions?)\n", + "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n", + }; +#define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0])) + + switch (type) + { + case OFImage: + index = number; + if (index > NUM_OFI_ERRORS - 1) + index = NUM_OFI_ERRORS - 1; + error = form(OFIErrorStrings[index], path, number); + break; + + default: + error = form("%s(%d): Totally unknown error type %d\n", + path, number, type); + break; + } + safefree(dl_last_error); + dl_last_error = savepv(error); +} + +static char *dlopen(char *path, int mode /* mode is ignored */) +{ + int dyld_result; + NSObjectFileImage ofile; + NSModule handle = NULL; + + dyld_result = NSCreateObjectFileImageFromFile(path, &ofile); + if (dyld_result != NSObjectFileImageSuccess) + TranslateError(path, OFImage, dyld_result); + else + { + // NSLinkModule will cause the run to abort on any link error's + // not very friendly but the error recovery functionality is limited. + handle = NSLinkModule(ofile, path, TRUE); + } + + return handle; +} + +void * +dlsym(handle, symbol) +void *handle; +char *symbol; +{ + void *addr; + + if (NSIsSymbolNameDefined(symbol)) + addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol)); + else + addr = NULL; + + return addr; +} + +#else /* NS_TARGET_MAJOR <= 3 */ + +static NXStream *OpenError(void) { return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY); } -void -TransferError( s) -NXStream *s; +static void TransferError(NXStream *s) { char *buffer; int len, maxlen; @@ -68,24 +158,14 @@ NXStream *s; strcpy(dl_last_error, buffer); } -void -CloseError( s) -NXStream *s; +static void CloseError(NXStream *s) { if ( s ) { NXCloseMemory( s, NX_FREEBUFFER); } } -char *dlerror() -{ - return dl_last_error; -} - -char * -dlopen(path, mode) -char * path; -int mode; /* mode is ignored */ +static char *dlopen(char *path, int mode /* mode is ignored */) { int rld_success; NXStream *nxerr; @@ -120,30 +200,22 @@ int mode; /* mode is ignored */ return result; } -int -dlclose(handle) /* stub only */ -void *handle; -{ - return 0; -} - void * dlsym(handle, symbol) void *handle; char *symbol; { NXStream *nxerr = OpenError(); - char symbuf[1024]; unsigned long symref = 0; - sprintf(symbuf, "_%s", symbol); - if (!rld_lookup(nxerr, symbuf, &symref)) { + if (!rld_lookup(nxerr, form("_%s", symbol), &symref)) TransferError(nxerr); - } CloseError(nxerr); return (void*) symref; } +#endif /* NS_TARGET_MAJOR >= 4 */ + /* ----- code from dl_dlopen.xs below here ----- */ @@ -163,13 +235,17 @@ BOOT: void * -dl_load_file(filename) +dl_load_file(filename, flags=0) char * filename - CODE: + int flags + PREINIT: int mode = 1; - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + CODE: + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + if (flags & 0x01) + warn("Can't make loaded symbols global on this platform while loading %s",filename); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -182,10 +258,15 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); +#if NS_TARGET_MAJOR >= 4 + symbolname = form("_%s", symbolname); +#endif + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + "dl_find_symbol(handle=%lx, symbol=%s)\n", + (unsigned long) libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -207,7 +288,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_os2.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_os2.xs deleted file mode 100644 index 2c72be23ed8..00000000000 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_os2.xs +++ /dev/null @@ -1,188 +0,0 @@ -/* dl_os2.xs - * - * Platform: OS/2. - * Author: Andreas Kaiser (ak@ananke.s.bawue.de) - * Created: 08th December 1994 - */ - -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#define INCL_BASE -#include <os2.h> - -#include "dlutils.c" /* SaveError() etc */ - -static ULONG retcode; - -static void * -dlopen(char *path, int mode) -{ - HMODULE handle; - char tmp[260], *beg, *dot; - char fail[300]; - ULONG rc; - - if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0) - return (void *)handle; - - retcode = rc; - - /* Not found. Check for non-FAT name and try truncated name. */ - /* Don't know if this helps though... */ - for (beg = dot = path + strlen(path); - beg > path && !strchr(":/\\", *(beg-1)); - beg--) - if (*beg == '.') - dot = beg; - if (dot - beg > 8) { - int n = beg+8-path; - memmove(tmp, path, n); - memmove(tmp+n, dot, strlen(dot)+1); - if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0) - return (void *)handle; - } - - return NULL; -} - -static void * -dlsym(void *handle, char *symbol) -{ - ULONG rc, type; - PFN addr; - - rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr); - if (rc == 0) { - rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type); - if (rc == 0 && type == PT_32BIT) - return (void *)addr; - rc = ERROR_CALL_NOT_IMPLEMENTED; - } - retcode = rc; - return NULL; -} - -static char * -dlerror(void) -{ - static char buf[300]; - ULONG len; - - if (retcode == 0) - return NULL; - if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len)) - sprintf(buf, "OS/2 system error code %d", retcode); - else - buf[len] = '\0'; - retcode = 0; - return buf; -} - - -static void -dl_private_init() -{ - (void)dl_generic_private_init(); -} - -static char * -mod2fname(sv) - SV *sv; -{ - static char fname[9]; - int pos = 7; - int len; - AV *av; - SV *svp; - char *s; - - if (!SvROK(sv)) croak("Not a reference given to mod2fname"); - sv = SvRV(sv); - if (SvTYPE(sv) != SVt_PVAV) - croak("Not array reference given to mod2fname"); - if (av_len((AV*)sv) < 0) - croak("Empty array reference given to mod2fname"); - s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na); - strncpy(fname, s, 8); - if ((len=strlen(s)) < 7) pos = len; - fname[pos] = '_'; - fname[pos + 1] = '\0'; - return (char *)fname; -} - -MODULE = DynaLoader PACKAGE = DynaLoader - -BOOT: - (void)dl_private_init(); - - -void * -dl_load_file(filename) - char * filename - CODE: - int mode = 1; /* Solaris 1 */ -#ifdef RTLD_LAZY - mode = RTLD_LAZY; /* Solaris 2 */ -#endif - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); - RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError("%s",dlerror()) ; - else - sv_setiv( ST(0), (IV)RETVAL); - - -void * -dl_find_symbol(libhandle, symbolname) - void * libhandle - char * symbolname - CODE: -#ifdef DLSYM_NEEDS_UNDERSCORE - char symbolname_buf[1024]; - symbolname = dl_add_underscore(symbolname, symbolname_buf); -#endif - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); - RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); - ST(0) = sv_newmortal() ; - if (RETVAL == NULL) - SaveError("%s",dlerror()) ; - else - sv_setiv( ST(0), (IV)RETVAL); - - -void -dl_undef_symbols() - PPCODE: - -char * -mod2fname(sv) - SV *sv; - - -# These functions should not need changing on any platform: - -void -dl_install_xsub(perl_name, symref, filename="$Package") - char * perl_name - void * symref - char * filename - CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", - perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs index 3f46ffc9408..0329ebd9cbd 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs @@ -126,7 +126,7 @@ findsym_handler(void *sig, void *mech) myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1; while (--args) myvec[args] = usig[args]; _ckvmssts(sys$putmsg(myvec,copy_errmsg,0,0)); - DLDEBUG(2,fprintf(stderr,"findsym_handler: received\n\t%s\n",LastError)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "findsym_handler: received\n\t%s\n",LastError)); return SS$_CONTINUE; } @@ -177,11 +177,11 @@ dl_expandspec(filespec) dlfab.fab$b_fns = strlen(vmsspec); dlfab.fab$l_dna = 0; dlfab.fab$b_dns = 0; - DLDEBUG(1,fprintf(stderr,"dl_expand_filespec(%s):\n",vmsspec)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_expand_filespec(%s):\n",vmsspec)); /* On the first pass, just parse the specification string */ dlnam.nam$b_nop = NAM$M_SYNCHK; sts = sys$parse(&dlfab); - DLDEBUG(2,fprintf(stderr,"\tSYNCHK sys$parse = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tSYNCHK sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; @@ -194,7 +194,7 @@ dl_expandspec(filespec) dlnam.nam$b_type + dlnam.nam$b_ver); deflen += dlnam.nam$b_type + dlnam.nam$b_ver; memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name); - DLDEBUG(2,fprintf(stderr,"\tsplit filespec: name = %.*s, default = %.*s\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsplit filespec: name = %.*s, default = %.*s\n", dlnam.nam$b_name,vmsspec,deflen,defspec)); /* . . . and go back to expand it */ dlnam.nam$b_nop = 0; @@ -202,7 +202,7 @@ dl_expandspec(filespec) dlfab.fab$b_dns = deflen; dlfab.fab$b_fns = dlnam.nam$b_name; sts = sys$parse(&dlfab); - DLDEBUG(2,fprintf(stderr,"\tname/default sys$parse = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tname/default sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; @@ -210,23 +210,24 @@ dl_expandspec(filespec) else { /* Now find the actual file */ sts = sys$search(&dlfab); - DLDEBUG(2,fprintf(stderr,"\tsys$search = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$search = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; } else { ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); - DLDEBUG(1,fprintf(stderr,"\tresult = \\%.*s\\\n", + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "\tresult = \\%.*s\\\n", dlnam.nam$b_rsl,dlnam.nam$l_rsa)); } } } void -dl_load_file(filespec) +dl_load_file(filespec, flags) char * filespec - CODE: + int flags + PREINIT: char vmsspec[NAM$C_MAXRSS]; SV *reqSV, **reqSVhndl; STRLEN deflen; @@ -241,17 +242,18 @@ dl_load_file(filespec) struct libref *dlptr; vmssts sts, failed = 0; void (*entry)(); + CODE: - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filespec,flags)); specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); - DLDEBUG(2,fprintf(stderr,"\tVMS-ified filespec is %s\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n", specdsc.dsc$a_pointer)); - New(7901,dlptr,1,struct libref); + New(1399,dlptr,1,struct libref); dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T; dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S; sts = sys$filescan(&specdsc,namlst,0); - DLDEBUG(2,fprintf(stderr,"\tsys$filescan: returns %d, name is %.*s\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$filescan: returns %d, name is %.*s\n", sts,namlst[0].len,namlst[0].string)); if (!(sts & 1)) { failed = 1; @@ -267,21 +269,21 @@ dl_load_file(filespec) memcpy(dlptr->defspec.dsc$a_pointer + deflen, namlst[0].string + namlst[0].len, dlptr->defspec.dsc$w_length - deflen); - DLDEBUG(2,fprintf(stderr,"\tlibref = name: %s, defspec: %.*s\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlibref = name: %s, defspec: %.*s\n", dlptr->name.dsc$a_pointer, dlptr->defspec.dsc$w_length, dlptr->defspec.dsc$a_pointer)); if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) { - DLDEBUG(2,fprintf(stderr,"\t@dl_require_symbols empty, returning untested libref\n")); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t@dl_require_symbols empty, returning untested libref\n")); } else { symdsc.dsc$w_length = SvCUR(reqSV); symdsc.dsc$a_pointer = SvPVX(reqSV); - DLDEBUG(2,fprintf(stderr,"\t$dl_require_symbols[0] = %.*s\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t$dl_require_symbols[0] = %.*s\n", symdsc.dsc$w_length, symdsc.dsc$a_pointer)); sts = my_find_image_symbol(&(dlptr->name),&symdsc, &entry,&(dlptr->defspec)); - DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); if (!(sts&1)) { failed = 1; dl_set_error(sts,0); @@ -311,13 +313,13 @@ dl_find_symbol(librefptr,symname) void (*entry)(); vmssts sts; - DLDEBUG(1,fprintf(stderr,"dl_find_dymbol(%.*s,%.*s):\n", + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_find_dymbol(%.*s,%.*s):\n", thislib.name.dsc$w_length, thislib.name.dsc$a_pointer, symdsc.dsc$w_length,symdsc.dsc$a_pointer)); sts = my_find_image_symbol(&(thislib.name),&symdsc, &entry,&(thislib.defspec)); - DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); - DLDEBUG(2,fprintf(stderr,"\tentry point is %d\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tentry point is %d\n", (unsigned long int) entry)); if (!(sts & 1)) { /* error message already saved by findsym_handler */ @@ -339,7 +341,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c b/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c index 67dea787cc7..58006789ef6 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c +++ b/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c @@ -35,7 +35,7 @@ dl_generic_private_init() /* called by dl_*.xs dl_private_init() */ if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) dl_nonlazy = atoi(perl_dl_nonlazy); if (dl_nonlazy) - DLDEBUG(1,fprintf(stderr,"DynaLoader bind mode is 'non-lazy'\n")); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "DynaLoader bind mode is 'non-lazy'\n")); #ifdef DL_LOADONCEONLY if (!dl_loaded_files) dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ @@ -75,22 +75,10 @@ SaveError(pat, va_alist) if (LastError) LastError = (char*)saferealloc(LastError, len) ; else - LastError = safemalloc(len) ; + LastError = (char *) safemalloc(len) ; /* Copy message into LastError (including terminating null char) */ strncpy(LastError, message, len) ; - DLDEBUG(2,fprintf(stderr,"DynaLoader: stored error msg '%s'\n",LastError)); -} - - -/* prepend underscore to s. write into buf. return buf. */ -char * -dl_add_underscore(s, buf) -char *s; -char *buf; -{ - *buf = '_'; - (void)strcpy(buf + 1, s); - return buf; + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError)); } diff --git a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm index 32a31943269..6214323c31c 100644 --- a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm +++ b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm @@ -7,6 +7,7 @@ Fcntl - load the C Fcntl.h defines =head1 SYNOPSIS use Fcntl; + use Fcntl qw(:DEFAULT :flock); =head1 DESCRIPTION @@ -21,28 +22,57 @@ far more likely chance of getting the numbers right. Only C<#define> symbols get translated; you must still correctly pack up your own arguments to pass as args for locking functions, etc. +=head1 EXPORTED SYMBOLS + +By default your system's F_* and O_* constants (eg, F_DUPFD and +O_CREAT) and the FD_CLOEXEC constant are exported into your namespace. + +You can request that the flock() constants (LOCK_SH, LOCK_EX, LOCK_NB +and LOCK_UN) be provided by using the tag C<:flock>. See L<Exporter>. + +You can request that the old constants (FAPPEND, FASYNC, FCREAT, +FDEFER, FEXCL, FNDELAY, FNONBLOCK, FSYNC, FTRUNC) be provided for +compatibility reasons by using the tag C<:Fcompat>. For new +applications the newer versions of these constants are suggested +(O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK, +O_SYNC, O_TRUNC). + +Please refer to your native fcntl() and open() documentation to see +what constants are implemented in your system. + =cut -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD); require Exporter; -use AutoLoader; require DynaLoader; @ISA = qw(Exporter DynaLoader); -$VERSION = "1.00"; +$VERSION = "1.03"; # Items to export into callers namespace by default # (move infrequently used names to @EXPORT_OK below) @EXPORT = qw( F_DUPFD F_GETFD F_GETLK F_SETFD F_GETFL F_SETFL F_SETLK F_SETLKW - FD_CLOEXEC F_RDLCK F_UNLCK F_WRLCK + FD_CLOEXEC F_RDLCK F_UNLCK F_WRLCK F_POSIX O_CREAT O_EXCL O_NOCTTY O_TRUNC O_APPEND O_NONBLOCK - O_NDELAY + O_NDELAY O_DEFER O_RDONLY O_RDWR O_WRONLY + O_BINARY O_TEXT + O_EXLOCK O_SHLOCK O_ASYNC O_DSYNC O_RSYNC O_SYNC + F_SETOWN F_GETOWN ); + # Other items we are prepared to export if requested @EXPORT_OK = qw( + LOCK_SH LOCK_EX LOCK_NB LOCK_UN + FAPPEND FASYNC FCREAT FDEFER FEXCL FNDELAY FNONBLOCK FSYNC FTRUNC +); +# Named groups of exports +%EXPORT_TAGS = ( + 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)], + 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FEXCL + FNDELAY FNONBLOCK FSYNC FTRUNC)], ); sub AUTOLOAD { @@ -66,8 +96,4 @@ sub AUTOLOAD { bootstrap Fcntl $VERSION; -# Preloaded methods go here. Autoload methods go after __END__, and are -# processed by the autosplit program. -package Fcntl; # return to package Fcntl so AutoSplit is happy 1; -__END__ diff --git a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs index 90f3af5028c..9034031c9ca 100644 --- a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs +++ b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs @@ -57,6 +57,12 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "F_GETOWN")) +#ifdef F_GETOWN + return F_GETOWN; +#else + goto not_there; +#endif if (strEQ(name, "F_SETFD")) #ifdef F_SETFD return F_SETFD; @@ -69,6 +75,12 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "F_POSIX")) +#ifdef F_POSIX + return F_POSIX; +#else + goto not_there; +#endif if (strEQ(name, "F_SETFL")) #ifdef F_SETFL return F_SETFL; @@ -87,6 +99,12 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "F_SETOWN")) +#ifdef F_SETOWN + return F_SETOWN; +#else + goto not_there; +#endif if (strEQ(name, "F_RDLCK")) #ifdef F_RDLCK return F_RDLCK; @@ -107,14 +125,93 @@ int arg; #endif errno = EINVAL; return 0; - } else - if (strEQ(name, "FD_CLOEXEC")) + } + if (strEQ(name, "FAPPEND")) +#ifdef FAPPEND + return FAPPEND; +#else + goto not_there; +#endif + if (strEQ(name, "FASYNC")) +#ifdef FASYNC + return FASYNC; +#else + goto not_there; +#endif + if (strEQ(name, "FCREAT")) +#ifdef FCREAT + return FCREAT; +#else + goto not_there; +#endif + if (strEQ(name, "FD_CLOEXEC")) #ifdef FD_CLOEXEC return FD_CLOEXEC; #else goto not_there; #endif + if (strEQ(name, "FEXCL")) +#ifdef FEXCL + return FEXCL; +#else + goto not_there; +#endif + if (strEQ(name, "FNDELAY")) +#ifdef FNDELAY + return FNDELAY; +#else + goto not_there; +#endif + if (strEQ(name, "FNONBLOCK")) +#ifdef FNONBLOCK + return FNONBLOCK; +#else + goto not_there; +#endif + if (strEQ(name, "FSYNC")) +#ifdef FSYNC + return FSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "FTRUNC")) +#ifdef FTRUNC + return FTRUNC; +#else + goto not_there; +#endif break; + case 'L': + if (strnEQ(name, "LOCK_", 5)) { + /* We support flock() on systems which don't have it, so + always supply the constants. */ + if (strEQ(name, "LOCK_SH")) +#ifdef LOCK_SH + return LOCK_SH; +#else + return 1; +#endif + if (strEQ(name, "LOCK_EX")) +#ifdef LOCK_EX + return LOCK_EX; +#else + return 2; +#endif + if (strEQ(name, "LOCK_NB")) +#ifdef LOCK_NB + return LOCK_NB; +#else + return 4; +#endif + if (strEQ(name, "LOCK_UN")) +#ifdef LOCK_UN + return LOCK_UN; +#else + return 8; +#endif + } else + goto not_there; + break; case 'O': if (strnEQ(name, "O_", 2)) { if (strEQ(name, "O_CREAT")) @@ -183,6 +280,48 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "O_EXLOCK")) +#ifdef O_EXLOCK + return O_EXLOCK; +#else + goto not_there; +#endif + if (strEQ(name, "O_SHLOCK")) +#ifdef O_SHLOCK + return O_SHLOCK; +#else + goto not_there; +#endif + if (strEQ(name, "O_ASYNC")) +#ifdef O_ASYNC + return O_ASYNC; +#else + goto not_there; +#endif + if (strEQ(name, "O_DSYNC")) +#ifdef O_DSYNC + return O_DSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "O_RSYNC")) +#ifdef O_RSYNC + return O_RSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "O_SYNC")) +#ifdef O_SYNC + return O_SYNC; +#else + goto not_there; +#endif + if (strEQ(name, "O_DEFER")) +#ifdef O_DEFER + return O_DEFER; +#else + goto not_there; +#endif } else goto not_there; break; diff --git a/gnu/usr.bin/perl/ext/FileHandle/FileHandle.pm b/gnu/usr.bin/perl/ext/FileHandle/FileHandle.pm deleted file mode 100644 index 2770b91c7fb..00000000000 --- a/gnu/usr.bin/perl/ext/FileHandle/FileHandle.pm +++ /dev/null @@ -1,467 +0,0 @@ -package FileHandle; - -=head1 NAME - -FileHandle - supply object methods for filehandles - -=head1 SYNOPSIS - - use FileHandle; - - $fh = new FileHandle; - if ($fh->open "< file") { - print <$fh>; - $fh->close; - } - - $fh = new FileHandle "> FOO"; - if (defined $fh) { - print $fh "bar\n"; - $fh->close; - } - - $fh = new FileHandle "file", "r"; - if (defined $fh) { - print <$fh>; - undef $fh; # automatically closes the file - } - - $fh = new FileHandle "file", O_WRONLY|O_APPEND; - if (defined $fh) { - print $fh "corge\n"; - undef $fh; # automatically closes the file - } - - $pos = $fh->getpos; - $fh->setpos $pos; - - $fh->setvbuf($buffer_var, _IOLBF, 1024); - - ($readfh, $writefh) = FileHandle::pipe; - - autoflush STDOUT 1; - -=head1 DESCRIPTION - -C<FileHandle::new> creates a C<FileHandle>, which is a reference to a -newly created symbol (see the C<Symbol> package). If it receives any -parameters, they are passed to C<FileHandle::open>; if the open fails, -the C<FileHandle> object is destroyed. Otherwise, it is returned to -the caller. - -C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does. -It requires two parameters, which are passed to C<FileHandle::fdopen>; -if the fdopen fails, the C<FileHandle> object is destroyed. -Otherwise, it is returned to the caller. - -C<FileHandle::open> accepts one parameter or two. With one parameter, -it is just a front end for the built-in C<open> function. With two -parameters, the first parameter is a filename that may include -whitespace or other special characters, and the second parameter is -the open mode in either Perl form (">", "+<", etc.) or POSIX form -("w", "r+", etc.). - -C<FileHandle::fdopen> is like C<open> except that its first parameter -is not a filename but rather a file handle name, a FileHandle object, -or a file descriptor number. - -If the C functions fgetpos() and fsetpos() are available, then -C<FileHandle::getpos> returns an opaque value that represents the -current position of the FileHandle, and C<FileHandle::setpos> uses -that value to return to a previously visited position. - -If the C function setvbuf() is available, then C<FileHandle::setvbuf> -sets the buffering policy for the FileHandle. The calling sequence -for the Perl function is the same as its C counterpart, including the -macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer -parameter specifies a scalar variable to use as a buffer. WARNING: A -variable used as a buffer by C<FileHandle::setvbuf> must not be -modified in any way until the FileHandle is closed or until -C<FileHandle::setvbuf> is called again, or memory corruption may -result! - -See L<perlfunc> for complete descriptions of each of the following -supported C<FileHandle> methods, which are just front ends for the -corresponding built-in functions: - - close - fileno - getc - gets - eof - clearerr - seek - tell - -See L<perlvar> for complete descriptions of each of the following -supported C<FileHandle> methods: - - autoflush - output_field_separator - output_record_separator - input_record_separator - input_line_number - format_page_number - format_lines_per_page - format_lines_left - format_name - format_top_name - format_line_break_characters - format_formfeed - -Furthermore, for doing normal I/O you might need these: - -=over - -=item $fh->print - -See L<perlfunc/print>. - -=item $fh->printf - -See L<perlfunc/printf>. - -=item $fh->getline - -This works like <$fh> described in L<perlop/"I/O Operators"> -except that it's more readable and can be safely called in an -array context but still returns just one line. - -=item $fh->getlines - -This works like <$fh> when called in an array context to -read all the remaining lines in a file, except that it's more readable. -It will also croak() if accidentally called in a scalar context. - -=back - -=head1 SEE ALSO - -L<perlfunc>, -L<perlop/"I/O Operators">, -L<POSIX/"FileHandle"> - -=head1 BUGS - -Due to backwards compatibility, all filehandles resemble objects -of class C<FileHandle>, or actually classes derived from that class. -They actually aren't. Which means you can't derive your own -class from C<FileHandle> and inherit those methods. - -=cut - -require 5.000; -use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD); -use Carp; -use Symbol; -use SelectSaver; - -require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); - -$VERSION = "1.00" ; - -@EXPORT = qw(_IOFBF _IOLBF _IONBF); - -@EXPORT_OK = qw( - autoflush - output_field_separator - output_record_separator - input_record_separator - input_line_number - format_page_number - format_lines_per_page - format_lines_left - format_name - format_top_name - format_line_break_characters - format_formfeed - - print - printf - getline - getlines -); - - -################################################ -## If the Fcntl extension is available, -## export its constants. -## - -sub import { - my $pkg = shift; - my $callpkg = caller; - Exporter::export $pkg, $callpkg; - eval { - require Fcntl; - Exporter::export 'Fcntl', $callpkg; - }; -}; - - -################################################ -## Interaction with the XS. -## - -eval { - bootstrap FileHandle; -}; -if ($@) { - *constant = sub { undef }; -} - -sub AUTOLOAD { - if ($AUTOLOAD =~ /::(_?[a-z])/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD - } - my $constname = $AUTOLOAD; - $constname =~ s/.*:://; - my $val = constant($constname); - defined $val or croak "$constname is not a valid FileHandle macro"; - *$AUTOLOAD = sub { $val }; - goto &$AUTOLOAD; -} - - -################################################ -## Constructors, destructors. -## - -sub new { - @_ >= 1 && @_ <= 3 or croak 'usage: new FileHandle [FILENAME [,MODE]]'; - my $class = shift; - my $fh = gensym; - if (@_) { - FileHandle::open($fh, @_) - or return undef; - } - bless $fh, $class; -} - -sub new_from_fd { - @_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE'; - my $class = shift; - my $fh = gensym; - FileHandle::fdopen($fh, @_) - or return undef; - bless $fh, $class; -} - -sub DESTROY { - my ($fh) = @_; - close($fh); -} - -################################################ -## Open and close. -## - -sub pipe { - @_ and croak 'usage: FileHandle::pipe()'; - my $readfh = new FileHandle; - my $writefh = new FileHandle; - pipe($readfh, $writefh) - or return undef; - ($readfh, $writefh); -} - -sub _open_mode_string { - my ($mode) = @_; - $mode =~ /^\+?(<|>>?)$/ - or $mode =~ s/^r(\+?)$/$1</ - or $mode =~ s/^w(\+?)$/$1>/ - or $mode =~ s/^a(\+?)$/$1>>/ - or croak "FileHandle: bad open mode: $mode"; - $mode; -} - -sub open { - @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; - my ($fh, $file) = @_; - if (@_ > 2) { - my ($mode, $perms) = @_[2, 3]; - if ($mode =~ /^\d+$/) { - defined $perms or $perms = 0666; - return sysopen($fh, $file, $mode, $perms); - } - $file = "./" . $file unless $file =~ m#^/#; - $file = _open_mode_string($mode) . " $file\0"; - } - open($fh, $file); -} - -sub fdopen { - @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)'; - my ($fh, $fd, $mode) = @_; - if (ref($fd) =~ /GLOB\(/) { - # It's a glob reference; remove the star from its name. - ($fd = "".$$fd) =~ s/^\*//; - } elsif ($fd =~ m#^\d+$#) { - # It's an FD number; prefix with "=". - $fd = "=$fd"; - } - open($fh, _open_mode_string($mode) . '&' . $fd); -} - -sub close { - @_ == 1 or croak 'usage: $fh->close()'; - close($_[0]); -} - -################################################ -## Normal I/O functions. -## - -sub fileno { - @_ == 1 or croak 'usage: $fh->fileno()'; - fileno($_[0]); -} - -sub getc { - @_ == 1 or croak 'usage: $fh->getc()'; - getc($_[0]); -} - -sub gets { - @_ == 1 or croak 'usage: $fh->gets()'; - my ($handle) = @_; - scalar <$handle>; -} - -sub eof { - @_ == 1 or croak 'usage: $fh->eof()'; - eof($_[0]); -} - -sub clearerr { - @_ == 1 or croak 'usage: $fh->clearerr()'; - seek($_[0], 0, 1); -} - -sub seek { - @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)'; - seek($_[0], $_[1], $_[2]); -} - -sub tell { - @_ == 1 or croak 'usage: $fh->tell()'; - tell($_[0]); -} - -sub print { - @_ or croak 'usage: $fh->print([ARGS])'; - my $this = shift; - print $this @_; -} - -sub printf { - @_ or croak 'usage: $fh->printf([ARGS])'; - my $this = shift; - printf $this @_; -} - -sub getline { - @_ == 1 or croak 'usage: $fh->getline'; - my $this = shift; - return scalar <$this>; -} - -sub getlines { - @_ == 1 or croak 'usage: $fh->getline()'; - my $this = shift; - wantarray or croak "Can't call FileHandle::getlines in a scalar context"; - return <$this>; -} - -################################################ -## State modification functions. -## - -sub autoflush { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $|; - $| = @_ > 1 ? $_[1] : 1; - $prev; -} - -sub output_field_separator { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $,; - $, = $_[1] if @_ > 1; - $prev; -} - -sub output_record_separator { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $\; - $\ = $_[1] if @_ > 1; - $prev; -} - -sub input_record_separator { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $/; - $/ = $_[1] if @_ > 1; - $prev; -} - -sub input_line_number { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $.; - $. = $_[1] if @_ > 1; - $prev; -} - -sub format_page_number { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $%; - $% = $_[1] if @_ > 1; - $prev; -} - -sub format_lines_per_page { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $=; - $= = $_[1] if @_ > 1; - $prev; -} - -sub format_lines_left { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $-; - $- = $_[1] if @_ > 1; - $prev; -} - -sub format_name { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $~; - $~ = qualify($_[1], caller) if @_ > 1; - $prev; -} - -sub format_top_name { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $^; - $^ = qualify($_[1], caller) if @_ > 1; - $prev; -} - -sub format_line_break_characters { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $:; - $: = $_[1] if @_ > 1; - $prev; -} - -sub format_formfeed { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $^L; - $^L = $_[1] if @_ > 1; - $prev; -} - -1; diff --git a/gnu/usr.bin/perl/ext/FileHandle/FileHandle.xs b/gnu/usr.bin/perl/ext/FileHandle/FileHandle.xs deleted file mode 100644 index 3a99cf1dc88..00000000000 --- a/gnu/usr.bin/perl/ext/FileHandle/FileHandle.xs +++ /dev/null @@ -1,177 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" -#include <stdio.h> - -typedef int SysRet; -typedef FILE * InputStream; -typedef FILE * OutputStream; - -static int -not_here(s) -char *s; -{ - croak("FileHandle::%s not implemented on this architecture", s); - return -1; -} - -static bool -constant(name, pval) -char *name; -IV *pval; -{ - switch (*name) { - case '_': - if (strEQ(name, "_IOFBF")) -#ifdef _IOFBF - { *pval = _IOFBF; return TRUE; } -#else - return FALSE; -#endif - if (strEQ(name, "_IOLBF")) -#ifdef _IOLBF - { *pval = _IOLBF; return TRUE; } -#else - return FALSE; -#endif - if (strEQ(name, "_IONBF")) -#ifdef _IONBF - { *pval = _IONBF; return TRUE; } -#else - return FALSE; -#endif - break; - } - - return FALSE; -} - - -MODULE = FileHandle PACKAGE = FileHandle PREFIX = f - -SV * -constant(name) - char * name - CODE: - IV i; - if (constant(name, &i)) - RETVAL = newSViv(i); - else - RETVAL = &sv_undef; - OUTPUT: - RETVAL - -SV * -fgetpos(handle) - InputStream handle - CODE: -#ifdef HAS_FGETPOS - if (handle) { - Fpos_t pos; - fgetpos(handle, &pos); - ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); - } - else { - ST(0) = &sv_undef; - errno = EINVAL; - } -#else - ST(0) = (SV *) not_here("fgetpos"); -#endif - -SysRet -fsetpos(handle, pos) - InputStream handle - SV * pos - CODE: -#ifdef HAS_FSETPOS - if (handle) - RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos)); - else { - RETVAL = -1; - errno = EINVAL; - } -#else - RETVAL = (SysRet) not_here("fsetpos"); -#endif - OUTPUT: - RETVAL - -int -ungetc(handle, c) - InputStream handle - int c - CODE: - if (handle) - RETVAL = ungetc(c, handle); - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -OutputStream -new_tmpfile(packname = "FileHandle") - char * packname - CODE: - RETVAL = tmpfile(); - OUTPUT: - RETVAL - -int -ferror(handle) - InputStream handle - CODE: - if (handle) - RETVAL = ferror(handle); - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -SysRet -fflush(handle) - OutputStream handle - CODE: - if (handle) - RETVAL = fflush(handle); - else { - RETVAL = -1; - errno = EINVAL; - } - OUTPUT: - RETVAL - -void -setbuf(handle, buf) - OutputStream handle - char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; - CODE: - if (handle) - setbuf(handle, buf); - - - -SysRet -setvbuf(handle, buf, type, size) - OutputStream handle - char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0; - int type - int size - CODE: -#ifdef _IOFBF /* Should be HAS_SETVBUF once Configure tests for that */ - if (handle) - RETVAL = setvbuf(handle, buf, type, size); - else { - RETVAL = -1; - errno = EINVAL; - } -#else - RETVAL = (SysRet) not_here("setvbuf"); -#endif /* _IOFBF */ - OUTPUT: - RETVAL - diff --git a/gnu/usr.bin/perl/ext/FileHandle/Makefile.PL b/gnu/usr.bin/perl/ext/FileHandle/Makefile.PL deleted file mode 100644 index 7efd382043f..00000000000 --- a/gnu/usr.bin/perl/ext/FileHandle/Makefile.PL +++ /dev/null @@ -1,7 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'FileHandle', - MAN3PODS => ' ', # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'FileHandle.pm', -); diff --git a/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm b/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm index 3f1d83e0049..9c7ae066b79 100644 --- a/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm +++ b/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm @@ -7,7 +7,7 @@ GDBM_File - Perl5 access to the gdbm library. =head1 SYNOPSIS use GDBM_File ; - tie %hash, GDBM_File, $filename, &GDBM_WRCREAT, 0640); + tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640); # Use the %hash array. untie %hash ; diff --git a/gnu/usr.bin/perl/ext/GDBM_File/typemap b/gnu/usr.bin/perl/ext/GDBM_File/typemap index a6b0e5faa86..a9b73d8b811 100644 --- a/gnu/usr.bin/perl/ext/GDBM_File/typemap +++ b/gnu/usr.bin/perl/ext/GDBM_File/typemap @@ -23,3 +23,5 @@ T_DATUM sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm b/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm index 6072e651fcc..47b1f5aa3c2 100644 --- a/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm +++ b/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm @@ -28,7 +28,7 @@ NDBM_File - Tied access to ndbm files use NDBM_File; - tie(%h,NDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640); + tie(%h, 'NDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); untie %h; diff --git a/gnu/usr.bin/perl/ext/NDBM_File/typemap b/gnu/usr.bin/perl/ext/NDBM_File/typemap index a6b0e5faa86..a9b73d8b811 100644 --- a/gnu/usr.bin/perl/ext/NDBM_File/typemap +++ b/gnu/usr.bin/perl/ext/NDBM_File/typemap @@ -23,3 +23,5 @@ T_DATUM sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm index e5386e853b7..923640ff348 100644 --- a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm +++ b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm @@ -24,7 +24,7 @@ ODBM_File - Tied access to odbm files use ODBM_File; - tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640); + tie(%h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); untie %h; diff --git a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs index c1b405ff89b..b57e560bd39 100644 --- a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs +++ b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs @@ -13,6 +13,21 @@ # endif #endif +#ifdef DBM_BUG_DUPLICATE_FREE +/* + * DBM on at least Ultrix and HPUX call dbmclose() from dbminit(), + * resulting in duplicate free() because dbmclose() does *not* + * check if it has already been called for this DBM. + * If some malloc/free calls have been done between dbmclose() and + * the next dbminit(), the memory might be used for something else when + * it is freed. + * Verified to work on ultrix4.3. Probably will work on HP/UX. + * Set DBM_BUG_DUPLICATE_FREE in the extension hint file. + */ +/* Close the previous dbm, and fail to open a new dbm */ +#define dbmclose() ((void) dbminit("/tmp/x/y/z/z/y")) +#endif + #include <fcntl.h> typedef void* ODBM_File; @@ -39,9 +54,11 @@ odbm_TIEHASH(dbtype, filename, flags, mode) int mode CODE: { - char tmpbuf[1025]; + char *tmpbuf; if (dbmrefcnt++) croak("Old dbm can only open one database"); + New(0, tmpbuf, strlen(filename) + 5, char); + SAVEFREEPV(tmpbuf); sprintf(tmpbuf,"%s.dir",filename); if (stat(tmpbuf, &statbuf) < 0) { if (flags & O_CREAT) { @@ -56,7 +73,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode) } RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); ST(0) = sv_mortalcopy(&sv_undef); - sv_setptrobj(ST(0), RETVAL, "ODBM_File"); + sv_setptrobj(ST(0), RETVAL, dbtype); } void diff --git a/gnu/usr.bin/perl/ext/ODBM_File/hints/dec_osf.pl b/gnu/usr.bin/perl/ext/ODBM_File/hints/dec_osf.pl index f041bf96c00..febb7cdb21a 100644 --- a/gnu/usr.bin/perl/ext/ODBM_File/hints/dec_osf.pl +++ b/gnu/usr.bin/perl/ext/ODBM_File/hints/dec_osf.pl @@ -3,3 +3,7 @@ # Sat Jan 13 16:29:52 EST 1996 $self->{LDDLFLAGS} = $Config{lddlflags}; $self->{LDDLFLAGS} =~ s/-hidden//; +# As long as we're hinting, note the known location of the dbm routines. +# Spider Boardman <spider@Orb.Nashua.NH.US> +# Fri Feb 21 14:50:31 EST 1997 +$self->{LIBS} = ['-ldbm']; diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.pm b/gnu/usr.bin/perl/ext/POSIX/POSIX.pm index 66b55c15651..2885c0d84c8 100644 --- a/gnu/usr.bin/perl/ext/POSIX/POSIX.pm +++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.pm @@ -11,7 +11,7 @@ require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); -$VERSION = "1.00" ; +$VERSION = "1.02" ; %EXPORT_TAGS = ( @@ -22,11 +22,19 @@ $VERSION = "1.00" ; dirent_h => [qw()], - errno_h => [qw(E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM - EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE - EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK - ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO - EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV errno)], + errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT + EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED + ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT + EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS + EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK + EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH + ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM + ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR + ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM + EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE + ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT + ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY + EUSERS EWOULDBLOCK EXDEV errno)], fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK @@ -72,12 +80,13 @@ $VERSION = "1.00" ; setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], - signal_h => [qw(SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE - SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV - SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 - SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK - raise sigaction signal sigpending sigprocmask - sigsuspend)], + signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK + SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM + SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL + SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN + SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR + SIG_IGN SIG_SETMASK SIG_UNBLOCK raise sigaction signal + sigpending sigprocmask sigsuspend)], stdarg_h => [qw()], @@ -96,7 +105,7 @@ $VERSION = "1.00" ; stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX abort atexit atof atoi atol bsearch calloc div free getenv labs ldiv malloc mblen mbstowcs mbtowc - qsort realloc strtod strtol stroul wcstombs wctomb)], + qsort realloc strtod strtol strtoul wcstombs wctomb)], string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat strchr strcmp strcoll strcpy strcspn strerror strlen @@ -194,7 +203,7 @@ sub AUTOLOAD { local $! = 0; my $constname = $AUTOLOAD; $constname =~ s/.*:://; - my $val = constant($constname, $_[0]); + my $val = constant($constname, @_ ? $_[0] : 0); if ($! == 0) { *$AUTOLOAD = sub { $val }; } @@ -231,7 +240,7 @@ sub unimpl { package POSIX::SigAction; sub new { - bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3]}; + bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0}, $_[0]; } ############################ @@ -377,7 +386,7 @@ sub kill { sub raise { usage "raise(sig)" if @_ != 1; - kill $$, $_[0]; # Is this good enough? + kill $_[0], $$; # Is this good enough? } sub offsetof { @@ -385,35 +394,35 @@ sub offsetof { } sub clearerr { - redef "FileHandle::clearerr()"; + redef "IO::Handle::clearerr()"; } sub fclose { - redef "FileHandle::close()"; + redef "IO::Handle::close()"; } sub fdopen { - redef "FileHandle::new_from_fd()"; + redef "IO::Handle::new_from_fd()"; } sub feof { - redef "FileHandle::eof()"; + redef "IO::Handle::eof()"; } sub fgetc { - redef "FileHandle::getc()"; + redef "IO::Handle::getc()"; } sub fgets { - redef "FileHandle::gets()"; + redef "IO::Handle::gets()"; } sub fileno { - redef "FileHandle::fileno()"; + redef "IO::Handle::fileno()"; } sub fopen { - redef "FileHandle::open()"; + redef "IO::File::open()"; } sub fprintf { @@ -441,27 +450,27 @@ sub fscanf { } sub fseek { - redef "FileHandle::seek()"; + redef "IO::Seekable::seek()"; } sub ferror { - redef "FileHandle::error()"; + redef "IO::Handle::error()"; } sub fflush { - redef "FileHandle::flush()"; + redef "IO::Handle::flush()"; } sub fgetpos { - redef "FileHandle::getpos()"; + redef "IO::Seekable::getpos()"; } sub fsetpos { - redef "FileHandle::setpos()"; + redef "IO::Seekable::setpos()"; } sub ftell { - redef "FileHandle::tell()"; + redef "IO::Seekable::tell()"; } sub fwrite { @@ -534,11 +543,11 @@ sub sscanf { } sub tmpfile { - redef "FileHandle::new_tmpfile()"; + redef "IO::File::new_tmpfile()"; } sub ungetc { - redef "FileHandle::ungetc()"; + redef "IO::Handle::ungetc()"; } sub vfprintf { @@ -628,18 +637,6 @@ sub srand { unimpl "srand()"; } -sub strtod { - unimpl "strtod() is C-specific, stopped"; -} - -sub strtol { - unimpl "strtol() is C-specific, stopped"; -} - -sub stroul { - unimpl "stroul() is C-specific, stopped"; -} - sub system { usage "system(command)" if @_ != 1; system($_[0]); diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.pod b/gnu/usr.bin/perl/ext/POSIX/POSIX.pod index 4b7585117c6..c781765a146 100644 --- a/gnu/usr.bin/perl/ext/POSIX/POSIX.pod +++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.pod @@ -155,7 +155,7 @@ This is identical to Perl's builtin C<chown()> function. =item clearerr -Use method C<FileHandle::clearerr()> instead. +Use method C<IO::Handle::clearerr()> instead. =item clock @@ -277,7 +277,7 @@ This is identical to Perl's builtin C<abs()> function. =item fclose -Use method C<FileHandle::close()> instead. +Use method C<IO::Handle::close()> instead. =item fcntl @@ -285,35 +285,35 @@ This is identical to Perl's builtin C<fcntl()> function. =item fdopen -Use method C<FileHandle::new_from_fd()> instead. +Use method C<IO::Handle::new_from_fd()> instead. =item feof -Use method C<FileHandle::eof()> instead. +Use method C<IO::Handle::eof()> instead. =item ferror -Use method C<FileHandle::error()> instead. +Use method C<IO::Handle::error()> instead. =item fflush -Use method C<FileHandle::flush()> instead. +Use method C<IO::Handle::flush()> instead. =item fgetc -Use method C<FileHandle::getc()> instead. +Use method C<IO::Handle::getc()> instead. =item fgetpos -Use method C<FileHandle::getpos()> instead. +Use method C<IO::Seekable::getpos()> instead. =item fgets -Use method C<FileHandle::gets()> instead. +Use method C<IO::Handle::gets()> instead. =item fileno -Use method C<FileHandle::fileno()> instead. +Use method C<IO::Handle::fileno()> instead. =item floor @@ -325,7 +325,7 @@ This is identical to the C function C<fmod()>. =item fopen -Use method C<FileHandle::open()> instead. +Use method C<IO::File::open()> instead. =item fork @@ -380,11 +380,11 @@ fscanf() is C-specific--use <> and regular expressions instead. =item fseek -Use method C<FileHandle::seek()> instead. +Use method C<IO::Seekable::seek()> instead. =item fsetpos -Use method C<FileHandle::setpos()> instead. +Use method C<IO::Seekable::setpos()> instead. =item fstat @@ -397,7 +397,7 @@ Perl's builtin C<stat> function. =item ftell -Use method C<FileHandle::tell()> instead. +Use method C<IO::Seekable::tell()> instead. =item fwrite @@ -606,7 +606,7 @@ longjmp() is C-specific: use die instead. =item lseek -Move the read/write file pointer. This uses file descriptors such as +Move the file's read/write position. This uses file descriptors such as those obtained by calling C<POSIX::open>. $fd = POSIX::open( "foo", &POSIX::O_RDONLY ); @@ -849,10 +849,30 @@ setjmp() is C-specific: use eval {} instead. Modifies and queries program's locale. -The following will set the traditional UNIX system locale behavior. +The following will set the traditional UNIX system locale behavior +(the second argument C<"C">). $loc = POSIX::setlocale( &POSIX::LC_ALL, "C" ); +The following will query (the missing second argument) the current +LC_CTYPE category. + + $loc = POSIX::setlocale( &POSIX::LC_CTYPE); + +The following will set the LC_CTYPE behaviour according to the locale +environment variables (the second argument C<"">). +Please see your systems L<setlocale(3)> documentation for the locale +environment variables' meaning or consult L<perllocale>. + + $loc = POSIX::setlocale( &POSIX::LC_CTYPE, ""); + +The following will set the LC_COLLATE behaviour to Argentinian +Spanish. B<NOTE>: The naming and availability of locales depends on +your operating system. Please consult L<perllocale> for how to find +out which locales are available in your system. + + $loc = POSIX::setlocale( &POSIX::LC_ALL, "es_AR.ISO8859-1" ); + =item setpgid This is similar to the C function C<setpgid()>. @@ -1040,7 +1060,26 @@ This is identical to Perl's builtin C<index()> function. =item strtod -strtod() is C-specific. +String to double translation. Returns the parsed number and the number +of characters in the unparsed portion of the string. Truly +POSIX-compliant systems set $! ($ERRNO) to indicate a translation +error, so clear $! before calling strtod. However, non-POSIX systems +may not check for overflow, and therefore will never set $!. + +strtod should respect any POSIX I<setlocale()> settings. + +To parse a string $str as a floating point number use + + $! = 0; + ($num, $n_unparsed) = POSIX::strtod($str); + +The second returned item and $! can be used to check for valid input: + + if (($str eq '') || ($n_unparsed != 0) || !$!) { + die "Non-numeric input $str" . $! ? ": $!\n" : "\n"; + } + +When called in a scalar context strtod returns the parsed number. =item strtok @@ -1048,7 +1087,42 @@ strtok() is C-specific. =item strtol -strtol() is C-specific. +String to (long) integer translation. Returns the parsed number and +the number of characters in the unparsed portion of the string. Truly +POSIX-compliant systems set $! ($ERRNO) to indicate a translation +error, so clear $! before calling strtol. However, non-POSIX systems +may not check for overflow, and therefore will never set $!. + +strtol should respect any POSIX I<setlocale()> settings. + +To parse a string $str as a number in some base $base use + + $! = 0; + ($num, $n_unparsed) = POSIX::strtol($str, $base); + +The base should be zero or between 2 and 36, inclusive. When the base +is zero or omitted strtol will use the string itself to determine the +base: a leading "0x" or "0X" means hexadecimal; a leading "0" means +octal; any other leading characters mean decimal. Thus, "1234" is +parsed as a decimal number, "01234" as an octal number, and "0x1234" +as a hexadecimal number. + +The second returned item and $! can be used to check for valid input: + + if (($str eq '') || ($n_unparsed != 0) || !$!) { + die "Non-numeric input $str" . $! ? ": $!\n" : "\n"; + } + +When called in a scalar context strtol returns the parsed number. + +=item strtoul + +String to unsigned (long) integer translation. strtoul is identical +to strtol except that strtoul only parses unsigned integers. See +I<strtol> for details. + +Note: Some vendors supply strtod and strtol but not strtoul. +Other vendors that do suply strtoul parse "-1" as a valid value. =item strxfrm @@ -1130,7 +1204,7 @@ seconds. =item tmpfile -Use method C<FileHandle::new_tmpfile()> instead. +Use method C<IO::File::new_tmpfile()> instead. =item tmpnam @@ -1173,7 +1247,7 @@ Get name of current operating system. =item ungetc -Use method C<FileHandle::ungetc()> instead. +Use method C<IO::Handle::ungetc()> instead. =item unlink @@ -1240,9 +1314,10 @@ Creates a new C<POSIX::SigAction> object which corresponds to the C C<struct sigaction>. This object will be destroyed automatically when it is no longer needed. The first parameter is the fully-qualified name of a sub which is a signal-handler. The second parameter is a C<POSIX::SigSet> -object. The third parameter contains the C<sa_flags>. +object, it defaults to the empty set. The third parameter contains the +C<sa_flags>, it defaults to 0. - $sigset = POSIX::SigSet->new; + $sigset = POSIX::SigSet->new(SIGINT, SIGQUIT); $sigaction = POSIX::SigAction->new( 'main::handler', $sigset, &POSIX::SA_NOCLDSTOP ); This C<POSIX::SigAction> object should be used with the C<POSIX::sigaction()> @@ -1393,7 +1468,7 @@ Returns C<undef> on failure. Set a value in the c_cc field of a termios object. The c_cc field is an array so an index must be specified. - $termios->setcc( 1, &POSIX::VEOF ); + $termios->setcc( &POSIX::VEOF, 1 ); =item setcflag @@ -1501,7 +1576,16 @@ _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_M =item Constants -E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV +E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF +EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ +EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS EINTR +EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE ENAMETOOLONG +ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODEV ENOENT ENOEXEC +ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR +ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE +EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART EROFS +ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS +ETXTBSY EUSERS EWOULDBLOCK EXDEV =back @@ -1561,7 +1645,11 @@ HUGE_VAL =item Constants -SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK +SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND SA_RESTART +SA_SIGINFO SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT +SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU +SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK +SIG_UNBLOCK =back diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs index 3ba3c5b4269..a09eafe37af 100644 --- a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs +++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs @@ -1,4 +1,5 @@ #include "EXTERN.h" +#define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" #include <ctype.h> @@ -32,7 +33,6 @@ #if defined(I_TERMIOS) #include <termios.h> #endif -#include <stdio.h> #ifdef I_STDLIB #include <stdlib.h> #endif @@ -40,60 +40,68 @@ #include <sys/stat.h> #include <sys/types.h> #include <time.h> -#include <unistd.h> +#include <unistd.h> /* see hints/sunos_4_1.sh */ +#include <fcntl.h> + #if defined(__VMS) && !defined(__POSIX_SOURCE) -# include <file.h> /* == fcntl.h for DECC; no fcntl.h for VAXC */ # include <libdef.h> /* LIB$_INVARG constant */ # include <lib$routines.h> /* prototype for lib$ediv() */ # include <starlet.h> /* prototype for sys$gettim() */ +# if DECC_VERSION < 50000000 +# define pid_t int /* old versions of DECC miss this in types.h */ +# endif # undef mkfifo /* #defined in perl.h */ # define mkfifo(a,b) (not_here("mkfifo"),-1) # define tzset() not_here("tzset") - /* The default VMS emulation of Unix signals isn't very POSIXish */ - typedef int sigset_t; -# define sigpending(a) (not_here("sigpending"),0) +#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000) +# define HAS_TZNAME /* shows up in VMS 7.0 or Dec C 5.6 */ +# include <utsname.h> +#else + /* The default VMS emulation of Unix signals isn't very POSIXish */ + typedef int sigset_t; +# define sigpending(a) (not_here("sigpending"),0) - /* sigset_t is atomic under VMS, so these routines are easy */ - int sigemptyset(sigset_t *set) { + /* sigset_t is atomic under VMS, so these routines are easy */ + int sigemptyset(sigset_t *set) { if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } *set = 0; return 0; - } - int sigfillset(sigset_t *set) { + } + int sigfillset(sigset_t *set) { int i; if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } for (i = 0; i < NSIG; i++) *set |= (1 << i); return 0; - } - int sigaddset(sigset_t *set, int sig) { + } + int sigaddset(sigset_t *set, int sig) { if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } *set |= (1 << (sig - 1)); return 0; - } - int sigdelset(sigset_t *set, int sig) { + } + int sigdelset(sigset_t *set, int sig) { if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } *set &= ~(1 << (sig - 1)); return 0; - } - int sigismember(sigset_t *set, int sig) { + } + int sigismember(sigset_t *set, int sig) { if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; } if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; } *set & (1 << (sig - 1)); - } - /* The tools for sigprocmask() are there, just not the routine itself */ -# ifndef SIG_UNBLOCK -# define SIG_UNBLOCK 1 -# endif -# ifndef SIG_BLOCK -# define SIG_BLOCK 2 -# endif -# ifndef SIG_SETMASK -# define SIG_SETMASK 3 -# endif - int sigprocmask(int how, sigset_t *set, sigset_t *oset) { + } + /* The tools for sigprocmask() are there, just not the routine itself */ +# ifndef SIG_UNBLOCK +# define SIG_UNBLOCK 1 +# endif +# ifndef SIG_BLOCK +# define SIG_BLOCK 2 +# endif +# ifndef SIG_SETMASK +# define SIG_SETMASK 3 +# endif + int sigprocmask(int how, sigset_t *set, sigset_t *oset) { if (!set || !oset) { set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO); return -1; @@ -114,12 +122,13 @@ return -1; } return 0; - } -# define sigaction sigvec -# define sa_flags sv_onstack -# define sa_handler sv_handler -# define sa_mask sv_mask -# define sigsuspend(set) sigpause(*set) + } +# define sigaction sigvec +# define sa_flags sv_onstack +# define sa_handler sv_handler +# define sa_mask sv_mask +# define sigsuspend(set) sigpause(*set) +# endif /* __VMS_VER >= 70000000 or Dec C 5.6 */ /* The POSIX notion of ttyname() is better served by getname() under VMS */ static char ttnambuf[64]; @@ -152,7 +161,6 @@ } # define times(t) vms_times(t) #else -# include <fcntl.h> # include <grp.h> # include <sys/times.h> # ifdef HAS_UNAME @@ -190,6 +198,9 @@ typedef struct termios* POSIX__Termios; /* Possibly needed prototypes */ char *cuserid _((char *)); +double strtod _((const char *, char **)); +long strtol _((const char *, char **, int)); +unsigned long strtoul _((const char *, char **, int)); #ifndef HAS_CUSERID #define cuserid(a) (char *) not_here("cuserid") @@ -226,6 +237,15 @@ char *cuserid _((char *)); #ifndef HAS_STRCOLL #define strcoll(s1,s2) not_here("strcoll") #endif +#ifndef HAS_STRTOD +#define strtod(s1,s2) not_here("strtod") +#endif +#ifndef HAS_STRTOL +#define strtol(s1,s2,b) not_here("strtol") +#endif +#ifndef HAS_STRTOUL +#define strtoul(s1,s2,b) not_here("strtoul") +#endif #ifndef HAS_STRXFRM #define strxfrm(s1,s2,n) not_here("strxfrm") #endif @@ -245,13 +265,6 @@ char *cuserid _((char *)); #define waitpid(a,b,c) not_here("waitpid") #endif -#ifndef HAS_FGETPOS -#define fgetpos(a,b) not_here("fgetpos") -#endif -#ifndef HAS_FSETPOS -#define fsetpos(a,b) not_here("fsetpos") -#endif - #ifndef HAS_MBLEN #ifndef mblen #define mblen(a,b) not_here("mblen") @@ -615,12 +628,36 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EADDRINUSE")) +#ifdef EADDRINUSE + return EADDRINUSE; +#else + goto not_there; +#endif + if (strEQ(name, "EADDRNOTAVAIL")) +#ifdef EADDRNOTAVAIL + return EADDRNOTAVAIL; +#else + goto not_there; +#endif + if (strEQ(name, "EAFNOSUPPORT")) +#ifdef EAFNOSUPPORT + return EAFNOSUPPORT; +#else + goto not_there; +#endif if (strEQ(name, "EAGAIN")) #ifdef EAGAIN return EAGAIN; #else goto not_there; #endif + if (strEQ(name, "EALREADY")) +#ifdef EALREADY + return EALREADY; +#else + goto not_there; +#endif break; case 'B': if (strEQ(name, "EBADF")) @@ -667,6 +704,24 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "ECONNABORTED")) +#ifdef ECONNABORTED + return ECONNABORTED; +#else + goto not_there; +#endif + if (strEQ(name, "ECONNREFUSED")) +#ifdef ECONNREFUSED + return ECONNREFUSED; +#else + goto not_there; +#endif + if (strEQ(name, "ECONNRESET")) +#ifdef ECONNRESET + return ECONNRESET; +#else + goto not_there; +#endif break; case 'D': if (strEQ(name, "EDEADLK")) @@ -675,12 +730,24 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EDESTADDRREQ")) +#ifdef EDESTADDRREQ + return EDESTADDRREQ; +#else + goto not_there; +#endif if (strEQ(name, "EDOM")) #ifdef EDOM return EDOM; #else goto not_there; #endif + if (strEQ(name, "EDQUOT")) +#ifdef EDQUOT + return EDQUOT; +#else + goto not_there; +#endif break; case 'E': if (strEQ(name, "EEXIST")) @@ -704,7 +771,27 @@ int arg; goto not_there; #endif break; + case 'H': + if (strEQ(name, "EHOSTDOWN")) +#ifdef EHOSTDOWN + return EHOSTDOWN; +#else + goto not_there; +#endif + if (strEQ(name, "EHOSTUNREACH")) +#ifdef EHOSTUNREACH + return EHOSTUNREACH; +#else + goto not_there; +#endif + break; case 'I': + if (strEQ(name, "EINPROGRESS")) +#ifdef EINPROGRESS + return EINPROGRESS; +#else + goto not_there; +#endif if (strEQ(name, "EINTR")) #ifdef EINTR return EINTR; @@ -723,12 +810,24 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EISCONN")) +#ifdef EISCONN + return EISCONN; +#else + goto not_there; +#endif if (strEQ(name, "EISDIR")) #ifdef EISDIR return EISDIR; #else goto not_there; #endif + if (strEQ(name, "ELOOP")) +#ifdef ELOOP + return ELOOP; +#else + goto not_there; +#endif break; case 'M': if (strEQ(name, "EMFILE")) @@ -743,29 +842,71 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EMSGSIZE")) +#ifdef EMSGSIZE + return EMSGSIZE; +#else + goto not_there; +#endif break; case 'N': + if (strEQ(name, "ENETDOWN")) +#ifdef ENETDOWN + return ENETDOWN; +#else + goto not_there; +#endif + if (strEQ(name, "ENETRESET")) +#ifdef ENETRESET + return ENETRESET; +#else + goto not_there; +#endif + if (strEQ(name, "ENETUNREACH")) +#ifdef ENETUNREACH + return ENETUNREACH; +#else + goto not_there; +#endif + if (strEQ(name, "ENOBUFS")) +#ifdef ENOBUFS + return ENOBUFS; +#else + goto not_there; +#endif + if (strEQ(name, "ENOEXEC")) +#ifdef ENOEXEC + return ENOEXEC; +#else + goto not_there; +#endif if (strEQ(name, "ENOMEM")) #ifdef ENOMEM return ENOMEM; #else goto not_there; #endif + if (strEQ(name, "ENOPROTOOPT")) +#ifdef ENOPROTOOPT + return ENOPROTOOPT; +#else + goto not_there; +#endif if (strEQ(name, "ENOSPC")) #ifdef ENOSPC return ENOSPC; #else goto not_there; #endif - if (strEQ(name, "ENOEXEC")) -#ifdef ENOEXEC - return ENOEXEC; + if (strEQ(name, "ENOTBLK")) +#ifdef ENOTBLK + return ENOTBLK; #else goto not_there; #endif - if (strEQ(name, "ENOTTY")) -#ifdef ENOTTY - return ENOTTY; + if (strEQ(name, "ENOTCONN")) +#ifdef ENOTCONN + return ENOTCONN; #else goto not_there; #endif @@ -781,6 +922,18 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "ENOTSOCK")) +#ifdef ENOTSOCK + return ENOTSOCK; +#else + goto not_there; +#endif + if (strEQ(name, "ENOTTY")) +#ifdef ENOTTY + return ENOTTY; +#else + goto not_there; +#endif if (strEQ(name, "ENFILE")) #ifdef ENFILE return ENFILE; @@ -831,6 +984,12 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EOPNOTSUPP")) +#ifdef EOPNOTSUPP + return EOPNOTSUPP; +#else + goto not_there; +#endif break; case 'P': if (strEQ(name, "EPERM")) @@ -839,12 +998,36 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EPFNOSUPPORT")) +#ifdef EPFNOSUPPORT + return EPFNOSUPPORT; +#else + goto not_there; +#endif if (strEQ(name, "EPIPE")) #ifdef EPIPE return EPIPE; #else goto not_there; #endif + if (strEQ(name, "EPROCLIM")) +#ifdef EPROCLIM + return EPROCLIM; +#else + goto not_there; +#endif + if (strEQ(name, "EPROTONOSUPPORT")) +#ifdef EPROTONOSUPPORT + return EPROTONOSUPPORT; +#else + goto not_there; +#endif + if (strEQ(name, "EPROTOTYPE")) +#ifdef EPROTOTYPE + return EPROTOTYPE; +#else + goto not_there; +#endif break; case 'R': if (strEQ(name, "ERANGE")) @@ -853,6 +1036,18 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EREMOTE")) +#ifdef EREMOTE + return EREMOTE; +#else + goto not_there; +#endif + if (strEQ(name, "ERESTART")) +#ifdef ERESTART + return ERESTART; +#else + goto not_there; +#endif if (strEQ(name, "EROFS")) #ifdef EROFS return EROFS; @@ -861,6 +1056,18 @@ int arg; #endif break; case 'S': + if (strEQ(name, "ESHUTDOWN")) +#ifdef ESHUTDOWN + return ESHUTDOWN; +#else + goto not_there; +#endif + if (strEQ(name, "ESOCKTNOSUPPORT")) +#ifdef ESOCKTNOSUPPORT + return ESOCKTNOSUPPORT; +#else + goto not_there; +#endif if (strEQ(name, "ESPIPE")) #ifdef ESPIPE return ESPIPE; @@ -873,7 +1080,49 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "ESTALE")) +#ifdef ESTALE + return ESTALE; +#else + goto not_there; +#endif break; + case 'T': + if (strEQ(name, "ETIMEDOUT")) +#ifdef ETIMEDOUT + return ETIMEDOUT; +#else + goto not_there; +#endif + if (strEQ(name, "ETOOMANYREFS")) +#ifdef ETOOMANYREFS + return ETOOMANYREFS; +#else + goto not_there; +#endif + if (strEQ(name, "ETXTBSY")) +#ifdef ETXTBSY + return ETXTBSY; +#else + goto not_there; +#endif + break; + case 'U': + if (strEQ(name, "EUSERS")) +#ifdef EUSERS + return EUSERS; +#else + goto not_there; +#endif + break; + case 'W': + if (strEQ(name, "EWOULDBLOCK")) +#ifdef EWOULDBLOCK + return EWOULDBLOCK; +#else + goto not_there; +#endif + break; case 'X': if (strEQ(name, "EXIT_FAILURE")) #ifdef EXIT_FAILURE @@ -1483,13 +1732,13 @@ int arg; goto not_there; #endif #ifdef SIG_DFL - if (strEQ(name, "SIG_DFL")) return (int)SIG_DFL; + if (strEQ(name, "SIG_DFL")) return (IV)SIG_DFL; #endif #ifdef SIG_ERR - if (strEQ(name, "SIG_ERR")) return (int)SIG_ERR; + if (strEQ(name, "SIG_ERR")) return (IV)SIG_ERR; #endif #ifdef SIG_IGN - if (strEQ(name, "SIG_IGN")) return (int)SIG_IGN; + if (strEQ(name, "SIG_IGN")) return (IV)SIG_IGN; #endif if (strEQ(name, "SIG_SETMASK")) #ifdef SIG_SETMASK @@ -1760,12 +2009,51 @@ int arg; #else goto not_there; #endif - if (strEQ(name, "SA_NOCLDSTOP")) + if (strnEQ(name, "SA_", 3)) { + if (strEQ(name, "SA_NOCLDSTOP")) #ifdef SA_NOCLDSTOP - return SA_NOCLDSTOP; + return SA_NOCLDSTOP; #else - goto not_there; + goto not_there; #endif + if (strEQ(name, "SA_NOCLDWAIT")) +#ifdef SA_NOCLDWAIT + return SA_NOCLDWAIT; +#else + goto not_there; +#endif + if (strEQ(name, "SA_NODEFER")) +#ifdef SA_NODEFER + return SA_NODEFER; +#else + goto not_there; +#endif + if (strEQ(name, "SA_ONSTACK")) +#ifdef SA_ONSTACK + return SA_ONSTACK; +#else + goto not_there; +#endif + if (strEQ(name, "SA_RESETHAND")) +#ifdef SA_RESETHAND + return SA_RESETHAND; +#else + goto not_there; +#endif + if (strEQ(name, "SA_RESTART")) +#ifdef SA_RESTART + return SA_RESTART; +#else + goto not_there; +#endif + if (strEQ(name, "SA_SIGINFO")) +#ifdef SA_SIGINFO + return SA_SIGINFO; +#else + goto not_there; +#endif + break; + } if (strEQ(name, "SCHAR_MAX")) #ifdef SCHAR_MAX return SCHAR_MAX; @@ -2511,11 +2799,11 @@ constant(name,arg) int isalnum(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!isalnum(*s)) RETVAL = 0; OUTPUT: @@ -2523,11 +2811,11 @@ isalnum(charstring) int isalpha(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!isalpha(*s)) RETVAL = 0; OUTPUT: @@ -2535,11 +2823,11 @@ isalpha(charstring) int iscntrl(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!iscntrl(*s)) RETVAL = 0; OUTPUT: @@ -2547,11 +2835,11 @@ iscntrl(charstring) int isdigit(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!isdigit(*s)) RETVAL = 0; OUTPUT: @@ -2559,11 +2847,11 @@ isdigit(charstring) int isgraph(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!isgraph(*s)) RETVAL = 0; OUTPUT: @@ -2571,11 +2859,11 @@ isgraph(charstring) int islower(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!islower(*s)) RETVAL = 0; OUTPUT: @@ -2583,11 +2871,11 @@ islower(charstring) int isprint(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!isprint(*s)) RETVAL = 0; OUTPUT: @@ -2595,11 +2883,11 @@ isprint(charstring) int ispunct(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!ispunct(*s)) RETVAL = 0; OUTPUT: @@ -2607,11 +2895,11 @@ ispunct(charstring) int isspace(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!isspace(*s)) RETVAL = 0; OUTPUT: @@ -2619,11 +2907,11 @@ isspace(charstring) int isupper(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!isupper(*s)) RETVAL = 0; OUTPUT: @@ -2631,11 +2919,11 @@ isupper(charstring) int isxdigit(charstring) - char * charstring + unsigned char * charstring CODE: - char *s; - RETVAL = 1; - for (s = charstring; *s && RETVAL; s++) + unsigned char *s = charstring; + unsigned char *e = s + na; /* "na" set by typemap side effect */ + for (RETVAL = 1; RETVAL && s < e; s++) if (!isxdigit(*s)) RETVAL = 0; OUTPUT: @@ -2660,6 +2948,7 @@ localeconv() #ifdef HAS_LOCALECONV struct lconv *lcbuf; RETVAL = newHV(); + SET_NUMERIC_LOCAL(); if (lcbuf = localeconv()) { /* the strings */ if (lcbuf->decimal_point && *lcbuf->decimal_point) @@ -2725,9 +3014,67 @@ localeconv() RETVAL char * -setlocale(category, locale) +setlocale(category, locale = 0) int category char * locale + CODE: + RETVAL = setlocale(category, locale); + if (RETVAL) { +#ifdef USE_LOCALE_CTYPE + if (category == LC_CTYPE +#ifdef LC_ALL + || category == LC_ALL +#endif + ) + { + char *newctype; +#ifdef LC_ALL + if (category == LC_ALL) + newctype = setlocale(LC_CTYPE, NULL); + else +#endif + newctype = RETVAL; + perl_new_ctype(newctype); + } +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (category == LC_COLLATE +#ifdef LC_ALL + || category == LC_ALL +#endif + ) + { + char *newcoll; +#ifdef LC_ALL + if (category == LC_ALL) + newcoll = setlocale(LC_COLLATE, NULL); + else +#endif + newcoll = RETVAL; + perl_new_collate(newcoll); + } +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (category == LC_NUMERIC +#ifdef LC_ALL + || category == LC_ALL +#endif + ) + { + char *newnum; +#ifdef LC_ALL + if (category == LC_ALL) + newnum = setlocale(LC_NUMERIC, NULL); + else +#endif + newnum = RETVAL; + perl_new_numeric(newnum); + } +#endif /* USE_LOCALE_NUMERIC */ + } + OUTPUT: + RETVAL + double acos(x) @@ -2949,8 +3296,7 @@ read(fd, buffer, nbytes) SvCUR(sv_buffer) = RETVAL; SvPOK_only(sv_buffer); *SvEND(sv_buffer) = '\0'; - if (tainting) - sv_magic(sv_buffer, 0, 't', 0, 0); + SvTAINTED_on(sv_buffer); } SysRet @@ -3033,6 +3379,66 @@ strcoll(s1, s2) char * s1 char * s2 +void +strtod(str) + char * str + PREINIT: + double num; + char *unparsed; + PPCODE: + SET_NUMERIC_LOCAL(); + num = strtod(str, &unparsed); + PUSHs(sv_2mortal(newSVnv(num))); + if (GIMME == G_ARRAY) { + EXTEND(sp, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&sv_undef); + } + +void +strtol(str, base = 0) + char * str + int base + PREINIT: + long num; + char *unparsed; + PPCODE: + num = strtol(str, &unparsed, base); + if (num >= IV_MIN && num <= IV_MAX) + PUSHs(sv_2mortal(newSViv((IV)num))); + else + PUSHs(sv_2mortal(newSVnv((double)num))); + if (GIMME == G_ARRAY) { + EXTEND(sp, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&sv_undef); + } + +void +strtoul(str, base = 0) + char * str + int base + PREINIT: + unsigned long num; + char *unparsed; + PPCODE: + num = strtoul(str, &unparsed, base); + if (num <= IV_MAX) + PUSHs(sv_2mortal(newSViv((IV)num))); + else + PUSHs(sv_2mortal(newSVnv((double)num))); + if (GIMME == G_ARRAY) { + EXTEND(sp, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&sv_undef); + } + SV * strxfrm(src) SV * src @@ -3128,11 +3534,11 @@ times() clock_t realtime; realtime = times( &tms ); EXTEND(sp,5); - PUSHs( sv_2mortal( newSVnv( realtime ) ) ); - PUSHs( sv_2mortal( newSVnv( tms.tms_utime ) ) ); - PUSHs( sv_2mortal( newSVnv( tms.tms_stime ) ) ); - PUSHs( sv_2mortal( newSVnv( tms.tms_cutime ) ) ); - PUSHs( sv_2mortal( newSVnv( tms.tms_cstime ) ) ); + PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) ); + PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) ); + PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) ); + PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) ); + PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) ); double difftime(time1, time2) diff --git a/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL b/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL index 8fc9411768a..02dfd7d84ff 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL +++ b/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL @@ -5,19 +5,22 @@ use ExtUtils::MakeMaker; # config, all, clean, realclean and sdbm/Makefile # which perform the corresponding actions in the subdirectory. +$define = ($^O eq 'MSWin32') ? '-DMSDOS' : ''; + WriteMakefile( NAME => 'SDBM_File', - MYEXTLIB => 'sdbm/libsdbm$(LIB_EXT)', + MYEXTLIB => 'sdbm'.($^O eq 'MSWin32' ? '\\' : '/').'libsdbm$(LIB_EXT)', MAN3PODS => ' ', # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'SDBM_File.pm', + DEFINE => $define, ); sub MY::postamble { ' $(MYEXTLIB): sdbm/Makefile - cd sdbm; $(MAKE) all + cd sdbm && $(MAKE) all '; } diff --git a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm index 9b7acc1e091..a2d4df85587 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm +++ b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm @@ -24,7 +24,7 @@ SDBM_File - Tied access to sdbm files use SDBM_File; - tie(%h,SDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640); + tie(%h, 'SDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); untie %h; diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL index b4bd6f9549f..50fd83eb253 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL @@ -1,28 +1,32 @@ use ExtUtils::MakeMaker; + +$define = '-DSDBM -DDUFF'; +$define .= ' -DWIN32' if ($^O eq 'MSWin32'); + WriteMakefile( - 'NAME' => 'SDBM_File', - 'LINKTYPE' => 'static', - 'DEFINE' => '-DSDBM -DDUFF', - 'SKIP' => [qw(static static_lib dynamic dynamic_lib)], - 'clean' - => {'FILES' => 'dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag'}, - 'H' => [qw(tune.h sdbm.h pair.h $(PERL_INC)/config.h)], - 'C' => [qw(sdbm.c pair.c hash.c)] + NAME => 'sdbm', # (doesn't matter what the name is here) oh yes it does + LINKTYPE => 'static', + DEFINE => $define, + INC => '-I$(PERL_INC)', # force PERL_INC dir ahead of system -I's + SKIP => [qw(dynamic dynamic_lib)], + OBJECT => '$(O_FILES)', + clean => {'FILES' => 'dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag'}, + H => [qw(tune.h sdbm.h pair.h $(PERL_INC)/config.h)], + C => [qw(sdbm.c pair.c hash.c)] ); +sub MY::post_constants { +' +INST_STATIC = libsdbm$(LIB_EXT) +' +} sub MY::top_targets { ' all :: static -static :: libsdbm$(LIB_EXT) - config :: -libsdbm$(LIB_EXT): $(O_FILES) - $(AR) cr libsdbm$(LIB_EXT) $(O_FILES) - $(RANLIB) libsdbm$(LIB_EXT) - lint: lint -abchx $(LIBSRCS) '; diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c index a02c73f28f6..23bbfe9a67c 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c @@ -231,7 +231,7 @@ register int siz; for (i = 1; i < n; i += 2) { if (siz == off - ino[i] && - memcmp(key, pag + ino[i], siz) == 0) + memEQ(key, pag + ino[i], siz)) return i; off = ino[i + 1]; } diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h index bd66d02fd24..8a675b90659 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h @@ -1,3 +1,13 @@ +/* Mini EMBED (pair.c) */ +#define chkpage sdbm__chkpage +#define delpair sdbm__delpair +#define duppair sdbm__duppair +#define fitpair sdbm__fitpair +#define getnkey sdbm__getnkey +#define getpair sdbm__getpair +#define putpair sdbm__putpair +#define splpage sdbm__splpage + extern int fitpair proto((char *, int)); extern void putpair proto((char *, datum, datum)); extern datum getpair proto((char *, datum)); diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ps b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ps deleted file mode 100644 index a2164459224..00000000000 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ps +++ /dev/null @@ -1,2225 +0,0 @@ -%!PS-Adobe-1.0 -%%Creator: yetti:oz (Ozan Yigit) -%%Title: stdin (ditroff) -%%CreationDate: Thu Dec 13 15:56:08 1990 -%%EndComments -% lib/psdit.pro -- prolog for psdit (ditroff) files -% Copyright (c) 1984, 1985 Adobe Systems Incorporated. All Rights Reserved. -% last edit: shore Sat Nov 23 20:28:03 1985 -% RCSID: $Header: /cvs/OpenBSD/src/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Attic/readme.ps,v 1.1 1996/08/19 10:12:13 downsj Exp $ - -/$DITroff 140 dict def $DITroff begin -/fontnum 1 def /fontsize 10 def /fontheight 10 def /fontslant 0 def -/xi {0 72 11 mul translate 72 resolution div dup neg scale 0 0 moveto - /fontnum 1 def /fontsize 10 def /fontheight 10 def /fontslant 0 def F - /pagesave save def}def -/PB{save /psv exch def currentpoint translate - resolution 72 div dup neg scale 0 0 moveto}def -/PE{psv restore}def -/arctoobig 90 def /arctoosmall .05 def -/m1 matrix def /m2 matrix def /m3 matrix def /oldmat matrix def -/tan{dup sin exch cos div}def -/point{resolution 72 div mul}def -/dround {transform round exch round exch itransform}def -/xT{/devname exch def}def -/xr{/mh exch def /my exch def /resolution exch def}def -/xp{}def -/xs{docsave restore end}def -/xt{}def -/xf{/fontname exch def /slotno exch def fontnames slotno get fontname eq not - {fonts slotno fontname findfont put fontnames slotno fontname put}if}def -/xH{/fontheight exch def F}def -/xS{/fontslant exch def F}def -/s{/fontsize exch def /fontheight fontsize def F}def -/f{/fontnum exch def F}def -/F{fontheight 0 le {/fontheight fontsize def}if - fonts fontnum get fontsize point 0 0 fontheight point neg 0 0 m1 astore - fontslant 0 ne{1 0 fontslant tan 1 0 0 m2 astore m3 concatmatrix}if - makefont setfont .04 fontsize point mul 0 dround pop setlinewidth}def -/X{exch currentpoint exch pop moveto show}def -/N{3 1 roll moveto show}def -/Y{exch currentpoint pop exch moveto show}def -/S{show}def -/ditpush{}def/ditpop{}def -/AX{3 -1 roll currentpoint exch pop moveto 0 exch ashow}def -/AN{4 2 roll moveto 0 exch ashow}def -/AY{3 -1 roll currentpoint pop exch moveto 0 exch ashow}def -/AS{0 exch ashow}def -/MX{currentpoint exch pop moveto}def -/MY{currentpoint pop exch moveto}def -/MXY{moveto}def -/cb{pop}def % action on unknown char -- nothing for now -/n{}def/w{}def -/p{pop showpage pagesave restore /pagesave save def}def -/abspoint{currentpoint exch pop add exch currentpoint pop add exch}def -/distance{dup mul exch dup mul add sqrt}def -/dstroke{currentpoint stroke moveto}def -/Dl{2 copy gsave rlineto stroke grestore rmoveto}def -/arcellipse{/diamv exch def /diamh exch def oldmat currentmatrix pop - currentpoint translate 1 diamv diamh div scale /rad diamh 2 div def - currentpoint exch rad add exch rad -180 180 arc oldmat setmatrix}def -/Dc{dup arcellipse dstroke}def -/De{arcellipse dstroke}def -/Da{/endv exch def /endh exch def /centerv exch def /centerh exch def - /cradius centerv centerv mul centerh centerh mul add sqrt def - /eradius endv endv mul endh endh mul add sqrt def - /endang endv endh atan def - /startang centerv neg centerh neg atan def - /sweep startang endang sub dup 0 lt{360 add}if def - sweep arctoobig gt - {/midang startang sweep 2 div sub def /midrad cradius eradius add 2 div def - /midh midang cos midrad mul def /midv midang sin midrad mul def - midh neg midv neg endh endv centerh centerv midh midv Da - currentpoint moveto Da} - {sweep arctoosmall ge - {/controldelt 1 sweep 2 div cos sub 3 sweep 2 div sin mul div 4 mul def - centerv neg controldelt mul centerh controldelt mul - endv neg controldelt mul centerh add endh add - endh controldelt mul centerv add endv add - centerh endh add centerv endv add rcurveto dstroke} - {centerh endh add centerv endv add rlineto dstroke}ifelse}ifelse}def - -/Barray 200 array def % 200 values in a wiggle -/D~{mark}def -/D~~{counttomark Barray exch 0 exch getinterval astore /Bcontrol exch def pop - /Blen Bcontrol length def Blen 4 ge Blen 2 mod 0 eq and - {Bcontrol 0 get Bcontrol 1 get abspoint /Ycont exch def /Xcont exch def - Bcontrol 0 2 copy get 2 mul put Bcontrol 1 2 copy get 2 mul put - Bcontrol Blen 2 sub 2 copy get 2 mul put - Bcontrol Blen 1 sub 2 copy get 2 mul put - /Ybi /Xbi currentpoint 3 1 roll def def 0 2 Blen 4 sub - {/i exch def - Bcontrol i get 3 div Bcontrol i 1 add get 3 div - Bcontrol i get 3 mul Bcontrol i 2 add get add 6 div - Bcontrol i 1 add get 3 mul Bcontrol i 3 add get add 6 div - /Xbi Xcont Bcontrol i 2 add get 2 div add def - /Ybi Ycont Bcontrol i 3 add get 2 div add def - /Xcont Xcont Bcontrol i 2 add get add def - /Ycont Ycont Bcontrol i 3 add get add def - Xbi currentpoint pop sub Ybi currentpoint exch pop sub rcurveto - }for dstroke}if}def -end -/ditstart{$DITroff begin - /nfonts 60 def % NFONTS makedev/ditroff dependent! - /fonts[nfonts{0}repeat]def - /fontnames[nfonts{()}repeat]def -/docsave save def -}def - -% character outcalls -/oc {/pswid exch def /cc exch def /name exch def - /ditwid pswid fontsize mul resolution mul 72000 div def - /ditsiz fontsize resolution mul 72 div def - ocprocs name known{ocprocs name get exec}{name cb} - ifelse}def -/fractm [.65 0 0 .6 0 0] def -/fraction - {/fden exch def /fnum exch def gsave /cf currentfont def - cf fractm makefont setfont 0 .3 dm 2 copy neg rmoveto - fnum show rmoveto currentfont cf setfont(\244)show setfont fden show - grestore ditwid 0 rmoveto} def -/oce {grestore ditwid 0 rmoveto}def -/dm {ditsiz mul}def -/ocprocs 50 dict def ocprocs begin -(14){(1)(4)fraction}def -(12){(1)(2)fraction}def -(34){(3)(4)fraction}def -(13){(1)(3)fraction}def -(23){(2)(3)fraction}def -(18){(1)(8)fraction}def -(38){(3)(8)fraction}def -(58){(5)(8)fraction}def -(78){(7)(8)fraction}def -(sr){gsave 0 .06 dm rmoveto(\326)show oce}def -(is){gsave 0 .15 dm rmoveto(\362)show oce}def -(->){gsave 0 .02 dm rmoveto(\256)show oce}def -(<-){gsave 0 .02 dm rmoveto(\254)show oce}def -(==){gsave 0 .05 dm rmoveto(\272)show oce}def -end - -% an attempt at a PostScript FONT to implement ditroff special chars -% this will enable us to -% cache the little buggers -% generate faster, more compact PS out of psdit -% confuse everyone (including myself)! -50 dict dup begin -/FontType 3 def -/FontName /DIThacks def -/FontMatrix [.001 0 0 .001 0 0] def -/FontBBox [-260 -260 900 900] def% a lie but ... -/Encoding 256 array def -0 1 255{Encoding exch /.notdef put}for -Encoding - dup 8#040/space put %space - dup 8#110/rc put %right ceil - dup 8#111/lt put %left top curl - dup 8#112/bv put %bold vert - dup 8#113/lk put %left mid curl - dup 8#114/lb put %left bot curl - dup 8#115/rt put %right top curl - dup 8#116/rk put %right mid curl - dup 8#117/rb put %right bot curl - dup 8#120/rf put %right floor - dup 8#121/lf put %left floor - dup 8#122/lc put %left ceil - dup 8#140/sq put %square - dup 8#141/bx put %box - dup 8#142/ci put %circle - dup 8#143/br put %box rule - dup 8#144/rn put %root extender - dup 8#145/vr put %vertical rule - dup 8#146/ob put %outline bullet - dup 8#147/bu put %bullet - dup 8#150/ru put %rule - dup 8#151/ul put %underline - pop -/DITfd 100 dict def -/BuildChar{0 begin - /cc exch def /fd exch def - /charname fd /Encoding get cc get def - /charwid fd /Metrics get charname get def - /charproc fd /CharProcs get charname get def - charwid 0 fd /FontBBox get aload pop setcachedevice - 2 setlinejoin 40 setlinewidth - newpath 0 0 moveto gsave charproc grestore - end}def -/BuildChar load 0 DITfd put -%/UniqueID 5 def -/CharProcs 50 dict def -CharProcs begin -/space{}def -/.notdef{}def -/ru{500 0 rls}def -/rn{0 840 moveto 500 0 rls}def -/vr{0 800 moveto 0 -770 rls}def -/bv{0 800 moveto 0 -1000 rls}def -/br{0 750 moveto 0 -1000 rls}def -/ul{0 -140 moveto 500 0 rls}def -/ob{200 250 rmoveto currentpoint newpath 200 0 360 arc closepath stroke}def -/bu{200 250 rmoveto currentpoint newpath 200 0 360 arc closepath fill}def -/sq{80 0 rmoveto currentpoint dround newpath moveto - 640 0 rlineto 0 640 rlineto -640 0 rlineto closepath stroke}def -/bx{80 0 rmoveto currentpoint dround newpath moveto - 640 0 rlineto 0 640 rlineto -640 0 rlineto closepath fill}def -/ci{500 360 rmoveto currentpoint newpath 333 0 360 arc - 50 setlinewidth stroke}def - -/lt{0 -200 moveto 0 550 rlineto currx 800 2cx s4 add exch s4 a4p stroke}def -/lb{0 800 moveto 0 -550 rlineto currx -200 2cx s4 add exch s4 a4p stroke}def -/rt{0 -200 moveto 0 550 rlineto currx 800 2cx s4 sub exch s4 a4p stroke}def -/rb{0 800 moveto 0 -500 rlineto currx -200 2cx s4 sub exch s4 a4p stroke}def -/lk{0 800 moveto 0 300 -300 300 s4 arcto pop pop 1000 sub - 0 300 4 2 roll s4 a4p 0 -200 lineto stroke}def -/rk{0 800 moveto 0 300 s2 300 s4 arcto pop pop 1000 sub - 0 300 4 2 roll s4 a4p 0 -200 lineto stroke}def -/lf{0 800 moveto 0 -1000 rlineto s4 0 rls}def -/rf{0 800 moveto 0 -1000 rlineto s4 neg 0 rls}def -/lc{0 -200 moveto 0 1000 rlineto s4 0 rls}def -/rc{0 -200 moveto 0 1000 rlineto s4 neg 0 rls}def -end - -/Metrics 50 dict def Metrics begin -/.notdef 0 def -/space 500 def -/ru 500 def -/br 0 def -/lt 416 def -/lb 416 def -/rt 416 def -/rb 416 def -/lk 416 def -/rk 416 def -/rc 416 def -/lc 416 def -/rf 416 def -/lf 416 def -/bv 416 def -/ob 350 def -/bu 350 def -/ci 750 def -/bx 750 def -/sq 750 def -/rn 500 def -/ul 500 def -/vr 0 def -end - -DITfd begin -/s2 500 def /s4 250 def /s3 333 def -/a4p{arcto pop pop pop pop}def -/2cx{2 copy exch}def -/rls{rlineto stroke}def -/currx{currentpoint pop}def -/dround{transform round exch round exch itransform} def -end -end -/DIThacks exch definefont pop -ditstart -(psc)xT -576 1 1 xr -1(Times-Roman)xf 1 f -2(Times-Italic)xf 2 f -3(Times-Bold)xf 3 f -4(Times-BoldItalic)xf 4 f -5(Helvetica)xf 5 f -6(Helvetica-Bold)xf 6 f -7(Courier)xf 7 f -8(Courier-Bold)xf 8 f -9(Symbol)xf 9 f -10(DIThacks)xf 10 f -10 s -1 f -xi -%%EndProlog - -%%Page: 1 1 -10 s 0 xH 0 xS 1 f -8 s -2 f -12 s -1778 672(sdbm)N -3 f -2004(\320)X -2124(Substitute)X -2563(DBM)X -2237 768(or)N -1331 864(Berkeley)N -2 f -1719(ndbm)X -3 f -1956(for)X -2103(Every)X -2373(UN*X)X -1 f -10 s -2628 832(1)N -3 f -12 s -2692 864(Made)N -2951(Simple)X -2 f -10 s -2041 1056(Ozan)N -2230(\(oz\))X -2375(Yigit)X -1 f -1658 1200(The)N -1803(Guild)X -2005(of)X -2092(PD)X -2214(Software)X -2524(Toolmakers)X -2000 1296(Toronto)N -2278(-)X -2325(Canada)X -1965 1488(oz@nexus.yorku.ca)N -2 f -555 1804(Implementation)N -1078(is)X -1151(the)X -1269(sincerest)X -1574(form)X -1745(of)X -1827(\257attery.)X -2094(\320)X -2185(L.)X -2269(Peter)X -2463(Deutsch)X -3 f -555 1996(A)N -633(The)X -786(Clone)X -1006(of)X -1093(the)X -2 f -1220(ndbm)X -3 f -1418(library)X -1 f -755 2120(The)N -903(sources)X -1167(accompanying)X -1658(this)X -1796(notice)X -2015(\320)X -2 f -2118(sdbm)X -1 f -2309(\320)X -2411(constitute)X -2744(the)X -2864(\256rst)X -3010(public)X -3232(release)X -3478(\(Dec.)X -3677(1990\))X -3886(of)X -3975(a)X -555 2216(complete)N -874(clone)X -1073(of)X -1165(the)X -1288(Berkeley)X -1603(UN*X)X -2 f -1842(ndbm)X -1 f -2045(library.)X -2304(The)X -2 f -2454(sdbm)X -1 f -2648(library)X -2887(is)X -2965(meant)X -3186(to)X -3273(clone)X -3472(the)X -3594(proven)X -3841(func-)X -555 2312(tionality)N -846(of)X -2 f -938(ndbm)X -1 f -1141(as)X -1233(closely)X -1485(as)X -1576(possible,)X -1882(including)X -2208(a)X -2268(few)X -2413(improvements.)X -2915(It)X -2988(is)X -3065(practical,)X -3386(easy)X -3553(to)X -3639(understand,)X -555 2408(and)N -691(compatible.)X -1107(The)X -2 f -1252(sdbm)X -1 f -1441(library)X -1675(is)X -1748(not)X -1870(derived)X -2131(from)X -2307(any)X -2443(licensed,)X -2746(proprietary)X -3123(or)X -3210(copyrighted)X -3613(software.)X -755 2532(The)N -2 f -910(sdbm)X -1 f -1109(implementation)X -1641(is)X -1723(based)X -1935(on)X -2044(a)X -2109(1978)X -2298(algorithm)X -2638([Lar78])X -2913(by)X -3022(P.-A.)X -3220(\(Paul\))X -3445(Larson)X -3697(known)X -3944(as)X -555 2628(``Dynamic)N -934(Hashing''.)X -1326(In)X -1424(the)X -1553(course)X -1794(of)X -1892(searching)X -2231(for)X -2355(a)X -2421(substitute)X -2757(for)X -2 f -2881(ndbm)X -1 f -3059(,)X -3109(I)X -3166(prototyped)X -3543(three)X -3734(different)X -555 2724(external-hashing)N -1119(algorithms)X -1490([Lar78,)X -1758(Fag79,)X -2007(Lit80])X -2236(and)X -2381(ultimately)X -2734(chose)X -2946(Larson's)X -3256(algorithm)X -3596(as)X -3692(a)X -3756(basis)X -3944(of)X -555 2820(the)N -2 f -680(sdbm)X -1 f -875(implementation.)X -1423(The)X -1574(Bell)X -1733(Labs)X -2 f -1915(dbm)X -1 f -2079(\(and)X -2248(therefore)X -2 f -2565(ndbm)X -1 f -2743(\))X -2796(is)X -2875(based)X -3084(on)X -3190(an)X -3292(algorithm)X -3629(invented)X -3931(by)X -555 2916(Ken)N -709(Thompson,)X -1091([Tho90,)X -1367(Tor87])X -1610(and)X -1746(predates)X -2034(Larson's)X -2335(work.)X -755 3040(The)N -2 f -903(sdbm)X -1 f -1095(programming)X -1553(interface)X -1857(is)X -1932(totally)X -2158(compatible)X -2536(with)X -2 f -2700(ndbm)X -1 f -2900(and)X -3038(includes)X -3327(a)X -3385(slight)X -3584(improvement)X -555 3136(in)N -641(database)X -942(initialization.)X -1410(It)X -1483(is)X -1560(also)X -1713(expected)X -2023(to)X -2109(be)X -2208(binary-compatible)X -2819(under)X -3025(most)X -3203(UN*X)X -3440(versions)X -3730(that)X -3873(sup-)X -555 3232(port)N -704(the)X -2 f -822(ndbm)X -1 f -1020(library.)X -755 3356(The)N -2 f -909(sdbm)X -1 f -1107(implementation)X -1638(shares)X -1868(the)X -1995(shortcomings)X -2455(of)X -2551(the)X -2 f -2678(ndbm)X -1 f -2885(library,)X -3148(as)X -3244(a)X -3309(side)X -3467(effect)X -3680(of)X -3775(various)X -555 3452(simpli\256cations)N -1046(to)X -1129(the)X -1248(original)X -1518(Larson)X -1762(algorithm.)X -2114(It)X -2183(does)X -2350(produce)X -2 f -2629(holes)X -1 f -2818(in)X -2900(the)X -3018(page)X -3190(\256le)X -3312(as)X -3399(it)X -3463(writes)X -3679(pages)X -3882(past)X -555 3548(the)N -680(end)X -823(of)X -917(\256le.)X -1066(\(Larson's)X -1400(paper)X -1605(include)X -1867(a)X -1929(clever)X -2152(solution)X -2435(to)X -2523(this)X -2664(problem)X -2957(that)X -3103(is)X -3182(a)X -3244(result)X -3448(of)X -3541(using)X -3740(the)X -3864(hash)X -555 3644(value)N -758(directly)X -1032(as)X -1128(a)X -1193(block)X -1400(address.\))X -1717(On)X -1844(the)X -1971(other)X -2165(hand,)X -2370(extensive)X -2702(tests)X -2873(seem)X -3067(to)X -3158(indicate)X -3441(that)X -2 f -3590(sdbm)X -1 f -3787(creates)X -555 3740(fewer)N -762(holes)X -954(in)X -1039(general,)X -1318(and)X -1456(the)X -1576(resulting)X -1878(page\256les)X -2185(are)X -2306(smaller.)X -2584(The)X -2 f -2731(sdbm)X -1 f -2922(implementation)X -3446(is)X -3521(also)X -3672(faster)X -3873(than)X -2 f -555 3836(ndbm)N -1 f -757(in)X -843(database)X -1144(creation.)X -1467(Unlike)X -1709(the)X -2 f -1831(ndbm)X -1 f -2009(,)X -2053(the)X -2 f -2175(sdbm)X -7 f -2396(store)X -1 f -2660(operation)X -2987(will)X -3134(not)X -3259(``wander)X -3573(away'')X -3820(trying)X -555 3932(to)N -642(split)X -804(its)X -904(data)X -1063(pages)X -1271(to)X -1358(insert)X -1561(a)X -1622(datum)X -1847(that)X -2 f -1992(cannot)X -1 f -2235(\(due)X -2403(to)X -2490(elaborate)X -2810(worst-case)X -3179(situations\))X -3537(be)X -3637(inserted.)X -3935(\(It)X -555 4028(will)N -699(fail)X -826(after)X -994(a)X -1050(pre-de\256ned)X -1436(number)X -1701(of)X -1788(attempts.\))X -3 f -555 4220(Important)N -931(Compatibility)X -1426(Warning)X -1 f -755 4344(The)N -2 f -904(sdbm)X -1 f -1097(and)X -2 f -1237(ndbm)X -1 f -1439(libraries)X -2 f -1726(cannot)X -1 f -1968(share)X -2162(databases:)X -2515(one)X -2654(cannot)X -2891(read)X -3053(the)X -3174(\(dir/pag\))X -3478(database)X -3778(created)X -555 4440(by)N -657(the)X -777(other.)X -984(This)X -1148(is)X -1222(due)X -1359(to)X -1442(the)X -1561(differences)X -1940(between)X -2229(the)X -2 f -2348(ndbm)X -1 f -2547(and)X -2 f -2684(sdbm)X -1 f -2874(algorithms)X -8 s -3216 4415(2)N -10 s -4440(,)Y -3289(and)X -3426(the)X -3545(hash)X -3713(functions)X -555 4536(used.)N -769(It)X -845(is)X -925(easy)X -1094(to)X -1182(convert)X -1449(between)X -1743(the)X -2 f -1867(dbm/ndbm)X -1 f -2231(databases)X -2565(and)X -2 f -2707(sdbm)X -1 f -2902(by)X -3008(ignoring)X -3305(the)X -3429(index)X -3633(completely:)X -555 4632(see)N -7 f -706(dbd)X -1 f -(,)S -7 f -918(dbu)X -1 f -1082(etc.)X -3 f -555 4852(Notice)N -794(of)X -881(Intellectual)X -1288(Property)X -2 f -555 4976(The)N -696(entire)X -1 f -904(sdbm)X -2 f -1118(library)X -1361(package,)X -1670(as)X -1762(authored)X -2072(by)X -2169(me,)X -1 f -2304(Ozan)X -2495(S.)X -2580(Yigit,)X -2 f -2785(is)X -2858(hereby)X -3097(placed)X -3331(in)X -3413(the)X -3531(public)X -3751(domain.)X -1 f -555 5072(As)N -670(such,)X -863(the)X -987(author)X -1218(is)X -1297(not)X -1425(responsible)X -1816(for)X -1936(the)X -2060(consequences)X -2528(of)X -2621(use)X -2754(of)X -2847(this)X -2988(software,)X -3310(no)X -3415(matter)X -3645(how)X -3808(awful,)X -555 5168(even)N -727(if)X -796(they)X -954(arise)X -1126(from)X -1302(defects)X -1550(in)X -1632(it.)X -1716(There)X -1924(is)X -1997(no)X -2097(expressed)X -2434(or)X -2521(implied)X -2785(warranty)X -3091(for)X -3205(the)X -2 f -3323(sdbm)X -1 f -3512(library.)X -8 s -10 f -555 5316(hhhhhhhhhhhhhhhhhh)N -6 s -1 f -635 5391(1)N -8 s -691 5410(UN*X)N -877(is)X -936(not)X -1034(a)X -1078(trademark)X -1352(of)X -1421(any)X -1529(\(dis\)organization.)X -6 s -635 5485(2)N -8 s -691 5504(Torek's)N -908(discussion)X -1194([Tor87])X -1411(indicates)X -1657(that)X -2 f -1772(dbm/ndbm)X -1 f -2061(implementations)X -2506(use)X -2609(the)X -2705(hash)X -2840(value)X -2996(to)X -3064(traverse)X -3283(the)X -3379(radix)X -3528(trie)X -3631(dif-)X -555 5584(ferently)N -772(than)X -2 f -901(sdbm)X -1 f -1055(and)X -1166(as)X -1238(a)X -1285(result,)X -1462(the)X -1559(page)X -1698(indexes)X -1912(are)X -2008(generated)X -2274(in)X -2 f -2343(different)X -1 f -2579(order.)X -2764(For)X -2872(more)X -3021(information,)X -3357(send)X -3492(e-mail)X -3673(to)X -555 5664(the)N -649(author.)X - -2 p -%%Page: 2 2 -8 s 0 xH 0 xS 1 f -10 s -2216 384(-)N -2263(2)X -2323(-)X -755 672(Since)N -971(the)X -2 f -1107(sdbm)X -1 f -1314(library)X -1566(package)X -1868(is)X -1959(in)X -2058(the)X -2193(public)X -2430(domain,)X -2727(this)X -2 f -2879(original)X -1 f -3173(release)X -3434(or)X -3538(any)X -3691(additional)X -555 768(public-domain)N -1045(releases)X -1323(of)X -1413(the)X -1534(modi\256ed)X -1841(original)X -2112(cannot)X -2348(possibly)X -2636(\(by)X -2765(de\256nition\))X -3120(be)X -3218(withheld)X -3520(from)X -3698(you.)X -3860(Also)X -555 864(by)N -659(de\256nition,)X -1009(You)X -1170(\(singular\))X -1505(have)X -1680(all)X -1783(the)X -1904(rights)X -2109(to)X -2194(this)X -2332(code)X -2507(\(including)X -2859(the)X -2980(right)X -3154(to)X -3239(sell)X -3373(without)X -3640(permission,)X -555 960(the)N -679(right)X -856(to)X -944(hoard)X -8 s -1127 935(3)N -10 s -1185 960(and)N -1327(the)X -1451(right)X -1628(to)X -1716(do)X -1821(other)X -2011(icky)X -2174(things)X -2394(as)X -2486(you)X -2631(see)X -2759(\256t\))X -2877(but)X -3004(those)X -3198(rights)X -3405(are)X -3529(also)X -3683(granted)X -3949(to)X -555 1056(everyone)N -870(else.)X -755 1180(Please)N -997(note)X -1172(that)X -1329(all)X -1446(previous)X -1759(distributions)X -2195(of)X -2298(this)X -2449(software)X -2762(contained)X -3110(a)X -3182(copyright)X -3525(\(which)X -3784(is)X -3873(now)X -555 1276(dropped\))N -868(to)X -953(protect)X -1199(its)X -1297(origins)X -1542(and)X -1681(its)X -1779(current)X -2030(public)X -2253(domain)X -2516(status)X -2721(against)X -2970(any)X -3108(possible)X -3392(claims)X -3623(and/or)X -3850(chal-)X -555 1372(lenges.)N -3 f -555 1564(Acknowledgments)N -1 f -755 1688(Many)N -966(people)X -1204(have)X -1380(been)X -1556(very)X -1723(helpful)X -1974(and)X -2114(supportive.)X -2515(A)X -2596(partial)X -2824(list)X -2944(would)X -3167(necessarily)X -3547(include)X -3806(Rayan)X -555 1784(Zacherissen)N -963(\(who)X -1152(contributed)X -1541(the)X -1663(man)X -1824(page,)X -2019(and)X -2158(also)X -2310(hacked)X -2561(a)X -2620(MMAP)X -2887(version)X -3146(of)X -2 f -3236(sdbm)X -1 f -3405(\),)X -3475(Arnold)X -3725(Robbins,)X -555 1880(Chris)N -763(Lewis,)X -1013(Bill)X -1166(Davidsen,)X -1523(Henry)X -1758(Spencer,)X -2071(Geoff)X -2293(Collyer,)X -2587(Rich)X -2772(Salz)X -2944(\(who)X -3143(got)X -3279(me)X -3411(started)X -3659(in)X -3755(the)X -3887(\256rst)X -555 1976(place\),)N -792(Johannes)X -1106(Ruschein)X -1424(\(who)X -1609(did)X -1731(the)X -1849(minix)X -2055(port\))X -2231(and)X -2367(David)X -2583(Tilbrook.)X -2903(I)X -2950(thank)X -3148(you)X -3288(all.)X -3 f -555 2168(Distribution)N -992(Manifest)X -1315(and)X -1463(Notes)X -1 f -555 2292(This)N -717(distribution)X -1105(of)X -2 f -1192(sdbm)X -1 f -1381(includes)X -1668(\(at)X -1773(least\))X -1967(the)X -2085(following:)X -7 f -747 2436(CHANGES)N -1323(change)X -1659(log)X -747 2532(README)N -1323(this)X -1563(file.)X -747 2628(biblio)N -1323(a)X -1419(small)X -1707(bibliography)X -2331(on)X -2475(external)X -2907(hashing)X -747 2724(dba.c)N -1323(a)X -1419(crude)X -1707(\(n/s\)dbm)X -2139(page)X -2379(file)X -2619(analyzer)X -747 2820(dbd.c)N -1323(a)X -1419(crude)X -1707(\(n/s\)dbm)X -2139(page)X -2379(file)X -2619(dumper)X -2955(\(for)X -3195(conversion\))X -747 2916(dbe.1)N -1323(man)X -1515(page)X -1755(for)X -1947(dbe.c)X -747 3012(dbe.c)N -1323(Janick's)X -1755(database)X -2187(editor)X -747 3108(dbm.c)N -1323(a)X -1419(dbm)X -1611(library)X -1995(emulation)X -2475(wrapper)X -2859(for)X -3051(ndbm/sdbm)X -747 3204(dbm.h)N -1323(header)X -1659(file)X -1899(for)X -2091(the)X -2283(above)X -747 3300(dbu.c)N -1323(a)X -1419(crude)X -1707(db)X -1851(management)X -2379(utility)X -747 3396(hash.c)N -1323(hashing)X -1707(function)X -747 3492(makefile)N -1323(guess.)X -747 3588(pair.c)N -1323(page-level)X -1851(routines)X -2283(\(posted)X -2667(earlier\))X -747 3684(pair.h)N -1323(header)X -1659(file)X -1899(for)X -2091(the)X -2283(above)X -747 3780(readme.ms)N -1323(troff)X -1611(source)X -1947(for)X -2139(the)X -2331(README)X -2667(file)X -747 3876(sdbm.3)N -1323(man)X -1515(page)X -747 3972(sdbm.c)N -1323(the)X -1515(real)X -1755(thing)X -747 4068(sdbm.h)N -1323(header)X -1659(file)X -1899(for)X -2091(the)X -2283(above)X -747 4164(tune.h)N -1323(place)X -1611(for)X -1803(tuning)X -2139(&)X -2235(portability)X -2811(thingies)X -747 4260(util.c)N -1323(miscellaneous)X -755 4432(dbu)N -1 f -924(is)X -1002(a)X -1063(simple)X -1301(database)X -1603(manipulation)X -2050(program)X -8 s -2322 4407(4)N -10 s -2379 4432(that)N -2524(tries)X -2687(to)X -2774(look)X -2941(like)X -3086(Bell)X -3244(Labs')X -7 f -3480(cbt)X -1 f -3649(utility.)X -3884(It)X -3958(is)X -555 4528(currently)N -867(incomplete)X -1245(in)X -1329(functionality.)X -1800(I)X -1849(use)X -7 f -2006(dbu)X -1 f -2172(to)X -2255(test)X -2387(out)X -2510(the)X -2629(routines:)X -2930(it)X -2995(takes)X -3181(\(from)X -3385(stdin\))X -3588(tab)X -3707(separated)X -555 4624(key/value)N -898(pairs)X -1085(for)X -1210(commands)X -1587(like)X -7 f -1765(build)X -1 f -2035(or)X -7 f -2160(insert)X -1 f -2478(or)X -2575(takes)X -2770(keys)X -2947(for)X -3071(commands)X -3448(like)X -7 f -3626(delete)X -1 f -3944(or)X -7 f -555 4720(look)N -1 f -(.)S -7 f -747 4864(dbu)N -939(<build|creat|look|insert|cat|delete>)X -2715(dbmfile)X -755 5036(dba)N -1 f -927(is)X -1008(a)X -1072(crude)X -1279(analyzer)X -1580(of)X -2 f -1675(dbm/sdbm/ndbm)X -1 f -2232(page)X -2412(\256les.)X -2593(It)X -2670(scans)X -2872(the)X -2998(entire)X -3209(page)X -3389(\256le,)X -3538(reporting)X -3859(page)X -555 5132(level)N -731(statistics,)X -1046(and)X -1182(totals)X -1375(at)X -1453(the)X -1571(end.)X -7 f -755 5256(dbd)N -1 f -925(is)X -1004(a)X -1066(crude)X -1271(dump)X -1479(program)X -1777(for)X -2 f -1897(dbm/ndbm/sdbm)X -1 f -2452(databases.)X -2806(It)X -2881(ignores)X -3143(the)X -3267(bitmap,)X -3534(and)X -3675(dumps)X -3913(the)X -555 5352(data)N -717(pages)X -928(in)X -1018(sequence.)X -1361(It)X -1437(can)X -1576(be)X -1679(used)X -1853(to)X -1942(create)X -2162(input)X -2353(for)X -2474(the)X -7 f -2627(dbu)X -1 f -2798(utility.)X -3055(Note)X -3238(that)X -7 f -3413(dbd)X -1 f -3584(will)X -3735(skip)X -3895(any)X -8 s -10 f -555 5432(hhhhhhhhhhhhhhhhhh)N -6 s -1 f -635 5507(3)N -8 s -691 5526(You)N -817(cannot)X -1003(really)X -1164(hoard)X -1325(something)X -1608(that)X -1720(is)X -1779(available)X -2025(to)X -2091(the)X -2185(public)X -2361(at)X -2423(large,)X -2582(but)X -2680(try)X -2767(if)X -2822(it)X -2874(makes)X -3053(you)X -3165(feel)X -3276(any)X -3384(better.)X -6 s -635 5601(4)N -8 s -691 5620(The)N -7 f -829(dbd)X -1 f -943(,)X -7 f -998(dba)X -1 f -1112(,)X -7 f -1167(dbu)X -1 f -1298(utilities)X -1508(are)X -1602(quick)X -1761(hacks)X -1923(and)X -2032(are)X -2126(not)X -2225(\256t)X -2295(for)X -2385(production)X -2678(use.)X -2795(They)X -2942(were)X -3081(developed)X -3359(late)X -3467(one)X -3575(night,)X -555 5700(just)N -664(to)X -730(test)X -835(out)X -2 f -933(sdbm)X -1 f -1068(,)X -1100(and)X -1208(convert)X -1415(some)X -1566(databases.)X - -3 p -%%Page: 3 3 -8 s 0 xH 0 xS 1 f -10 s -2216 384(-)N -2263(3)X -2323(-)X -555 672(NULLs)N -821(in)X -903(the)X -1021(key)X -1157(and)X -1293(data)X -1447(\256elds,)X -1660(thus)X -1813(is)X -1886(unsuitable)X -2235(to)X -2317(convert)X -2578(some)X -2767(peculiar)X -3046(databases)X -3374(that)X -3514(insist)X -3702(in)X -3784(includ-)X -555 768(ing)N -677(the)X -795(terminating)X -1184(null.)X -755 892(I)N -841(have)X -1052(also)X -1240(included)X -1575(a)X -1670(copy)X -1885(of)X -2011(the)X -7 f -2195(dbe)X -1 f -2397(\()X -2 f -2424(ndbm)X -1 f -2660(DataBase)X -3026(Editor\))X -3311(by)X -3449(Janick)X -3712(Bergeron)X -555 988([janick@bnr.ca])N -1098(for)X -1212(your)X -1379(pleasure.)X -1687(You)X -1845(may)X -2003(\256nd)X -2147(it)X -2211(more)X -2396(useful)X -2612(than)X -2770(the)X -2888(little)X -7 f -3082(dbu)X -1 f -3246(utility.)X -7 f -755 1112(dbm.[ch])N -1 f -1169(is)X -1252(a)X -2 f -1318(dbm)X -1 f -1486(library)X -1730(emulation)X -2079(on)X -2188(top)X -2319(of)X -2 f -2415(ndbm)X -1 f -2622(\(and)X -2794(hence)X -3011(suitable)X -3289(for)X -2 f -3412(sdbm)X -1 f -3581(\).)X -3657(Written)X -3931(by)X -555 1208(Robert)N -793(Elz.)X -755 1332(The)N -2 f -901(sdbm)X -1 f -1090(library)X -1324(has)X -1451(been)X -1623(around)X -1866(in)X -1948(beta)X -2102(test)X -2233(for)X -2347(quite)X -2527(a)X -2583(long)X -2745(time,)X -2927(and)X -3063(from)X -3239(whatever)X -3554(little)X -3720(feedback)X -555 1428(I)N -609(received)X -909(\(maybe)X -1177(no)X -1284(news)X -1476(is)X -1555(good)X -1741(news\),)X -1979(I)X -2032(believe)X -2290(it)X -2360(has)X -2493(been)X -2671(functioning)X -3066(without)X -3336(any)X -3478(signi\256cant)X -3837(prob-)X -555 1524(lems.)N -752(I)X -805(would,)X -1051(of)X -1144(course,)X -1400(appreciate)X -1757(all)X -1863(\256xes)X -2040(and/or)X -2271(improvements.)X -2774(Portability)X -3136(enhancements)X -3616(would)X -3841(espe-)X -555 1620(cially)N -753(be)X -849(useful.)X -3 f -555 1812(Implementation)N -1122(Issues)X -1 f -755 1936(Hash)N -944(functions:)X -1288(The)X -1437(algorithm)X -1772(behind)X -2 f -2014(sdbm)X -1 f -2207(implementation)X -2733(needs)X -2939(a)X -2998(good)X -3181(bit-scrambling)X -3671(hash)X -3841(func-)X -555 2032(tion)N -702(to)X -787(be)X -886(effective.)X -1211(I)X -1261(ran)X -1387(into)X -1534(a)X -1593(set)X -1705(of)X -1795(constants)X -2116(for)X -2233(a)X -2292(simple)X -2528(hash)X -2698(function)X -2988(that)X -3130(seem)X -3317(to)X -3401(help)X -2 f -3561(sdbm)X -1 f -3752(perform)X -555 2128(better)N -758(than)X -2 f -916(ndbm)X -1 f -1114(for)X -1228(various)X -1484(inputs:)X -7 f -747 2272(/*)N -795 2368(*)N -891(polynomial)X -1419(conversion)X -1947(ignoring)X -2379(overflows)X -795 2464(*)N -891(65599)X -1179(nice.)X -1467(65587)X -1755(even)X -1995(better.)X -795 2560(*/)N -747 2656(long)N -747 2752(dbm_hash\(char)N -1419(*str,)X -1707(int)X -1899(len\))X -2139({)X -939 2848(register)N -1371(unsigned)X -1803(long)X -2043(n)X -2139(=)X -2235(0;)X -939 3040(while)N -1227(\(len--\))X -1131 3136(n)N -1227(=)X -1323(n)X -1419(*)X -1515(65599)X -1803(+)X -1899(*str++;)X -939 3232(return)N -1275(n;)X -747 3328(})N -1 f -755 3500(There)N -975(may)X -1145(be)X -1253(better)X -1467(hash)X -1645(functions)X -1974(for)X -2099(the)X -2228(purposes)X -2544(of)X -2642(dynamic)X -2949(hashing.)X -3269(Try)X -3416(your)X -3594(favorite,)X -3895(and)X -555 3596(check)N -766(the)X -887(page\256le.)X -1184(If)X -1261(it)X -1328(contains)X -1618(too)X -1743(many)X -1944(pages)X -2150(with)X -2315(too)X -2440(many)X -2641(holes,)X -2853(\(in)X -2965(relation)X -3233(to)X -3318(this)X -3456(one)X -3595(for)X -3712(example\))X -555 3692(or)N -656(if)X -2 f -739(sdbm)X -1 f -942(simply)X -1193(stops)X -1391(working)X -1692(\(fails)X -1891(after)X -7 f -2101(SPLTMAX)X -1 f -2471(attempts)X -2776(to)X -2872(split\))X -3070(when)X -3278(you)X -3432(feed)X -3604(your)X -3784(NEWS)X -7 f -555 3788(history)N -1 f -912(\256le)X -1035(to)X -1118(it,)X -1203(you)X -1344(probably)X -1650(do)X -1751(not)X -1874(have)X -2047(a)X -2104(good)X -2285(hashing)X -2555(function.)X -2883(If)X -2958(you)X -3099(do)X -3200(better)X -3404(\(for)X -3545(different)X -3842(types)X -555 3884(of)N -642(input\),)X -873(I)X -920(would)X -1140(like)X -1280(to)X -1362(know)X -1560(about)X -1758(the)X -1876(function)X -2163(you)X -2303(use.)X -755 4008(Block)N -967(sizes:)X -1166(It)X -1236(seems)X -1453(\(from)X -1657(various)X -1914(tests)X -2077(on)X -2178(a)X -2235(few)X -2377(machines\))X -2727(that)X -2867(a)X -2923(page)X -3095(\256le)X -3217(block)X -3415(size)X -7 f -3588(PBLKSIZ)X -1 f -3944(of)X -555 4104(1024)N -738(is)X -814(by)X -917(far)X -1030(the)X -1150(best)X -1301(for)X -1417(performance,)X -1866(but)X -1990(this)X -2127(also)X -2278(happens)X -2563(to)X -2647(limit)X -2819(the)X -2939(size)X -3086(of)X -3175(a)X -3233(key/value)X -3567(pair.)X -3734(Depend-)X -555 4200(ing)N -681(on)X -785(your)X -956(needs,)X -1183(you)X -1327(may)X -1489(wish)X -1663(to)X -1748(increase)X -2035(the)X -2156(page)X -2331(size,)X -2499(and)X -2638(also)X -2790(adjust)X -7 f -3032(PAIRMAX)X -1 f -3391(\(the)X -3539(maximum)X -3886(size)X -555 4296(of)N -648(a)X -710(key/value)X -1048(pair)X -1199(allowed:)X -1501(should)X -1740(always)X -1989(be)X -2090(at)X -2173(least)X -2345(three)X -2531(words)X -2752(smaller)X -3013(than)X -7 f -3204(PBLKSIZ)X -1 f -(.\))S -3612(accordingly.)X -555 4392(The)N -706(system-wide)X -1137(version)X -1399(of)X -1492(the)X -1616(library)X -1856(should)X -2095(probably)X -2406(be)X -2508(con\256gured)X -2877(with)X -3044(1024)X -3229(\(distribution)X -3649(default\),)X -3944(as)X -555 4488(this)N -690(appears)X -956(to)X -1038(be)X -1134(suf\256cient)X -1452(for)X -1566(most)X -1741(common)X -2041(uses)X -2199(of)X -2 f -2286(sdbm)X -1 f -2455(.)X -3 f -555 4680(Portability)N -1 f -755 4804(This)N -917(package)X -1201(has)X -1328(been)X -1500(tested)X -1707(in)X -1789(many)X -1987(different)X -2284(UN*Xes)X -2585(even)X -2757(including)X -3079(minix,)X -3305(and)X -3441(appears)X -3707(to)X -3789(be)X -3885(rea-)X -555 4900(sonably)N -824(portable.)X -1127(This)X -1289(does)X -1456(not)X -1578(mean)X -1772(it)X -1836(will)X -1980(port)X -2129(easily)X -2336(to)X -2418(non-UN*X)X -2799(systems.)X -3 f -555 5092(Notes)N -767(and)X -915(Miscellaneous)X -1 f -755 5216(The)N -2 f -913(sdbm)X -1 f -1115(is)X -1201(not)X -1336(a)X -1405(very)X -1581(complicated)X -2006(package,)X -2323(at)X -2414(least)X -2594(not)X -2729(after)X -2910(you)X -3063(familiarize)X -3444(yourself)X -3739(with)X -3913(the)X -555 5312(literature)N -879(on)X -993(external)X -1286(hashing.)X -1589(There)X -1811(are)X -1944(other)X -2143(interesting)X -2514(algorithms)X -2889(in)X -2984(existence)X -3316(that)X -3469(ensure)X -3712(\(approxi-)X -555 5408(mately\))N -825(single-read)X -1207(access)X -1438(to)X -1525(a)X -1586(data)X -1745(value)X -1944(associated)X -2299(with)X -2466(any)X -2607(key.)X -2768(These)X -2984(are)X -3107(directory-less)X -3568(schemes)X -3864(such)X -555 5504(as)N -2 f -644(linear)X -857(hashing)X -1 f -1132([Lit80])X -1381(\(+)X -1475(Larson)X -1720(variations\),)X -2 f -2105(spiral)X -2313(storage)X -1 f -2575([Mar79])X -2865(or)X -2954(directory)X -3265(schemes)X -3558(such)X -3726(as)X -2 f -3814(exten-)X -555 5600(sible)N -731(hashing)X -1 f -1009([Fag79])X -1288(by)X -1393(Fagin)X -1600(et)X -1683(al.)X -1786(I)X -1838(do)X -1943(hope)X -2124(these)X -2314(sources)X -2579(provide)X -2848(a)X -2908(reasonable)X -3276(playground)X -3665(for)X -3783(experi-)X -555 5696(mentation)N -907(with)X -1081(other)X -1277(algorithms.)X -1690(See)X -1837(the)X -1966(June)X -2144(1988)X -2335(issue)X -2526(of)X -2624(ACM)X -2837(Computing)X -3227(Surveys)X -3516([Enb88])X -3810(for)X -3935(an)X -555 5792(excellent)N -865(overview)X -1184(of)X -1271(the)X -1389(\256eld.)X - -4 p -%%Page: 4 4 -10 s 0 xH 0 xS 1 f -2216 384(-)N -2263(4)X -2323(-)X -3 f -555 672(References)N -1 f -555 824([Lar78])N -875(P.-A.)X -1064(Larson,)X -1327(``Dynamic)X -1695(Hashing'',)X -2 f -2056(BIT)X -1 f -(,)S -2216(vol.)X -2378(18,)X -2518(pp.)X -2638(184-201,)X -2945(1978.)X -555 948([Tho90])N -875(Ken)X -1029(Thompson,)X -2 f -1411(private)X -1658(communication)X -1 f -2152(,)X -2192(Nov.)X -2370(1990)X -555 1072([Lit80])N -875(W.)X -992(Litwin,)X -1246(``)X -1321(Linear)X -1552(Hashing:)X -1862(A)X -1941(new)X -2096(tool)X -2261(for)X -2396(\256le)X -2539(and)X -2675(table)X -2851(addressing'',)X -2 f -3288(Proceedings)X -3709(of)X -3791(the)X -3909(6th)X -875 1168(Conference)N -1269(on)X -1373(Very)X -1548(Large)X -1782(Dabatases)X -2163(\(Montreal\))X -1 f -2515(,)X -2558(pp.)X -2701(212-223,)X -3031(Very)X -3215(Large)X -3426(Database)X -3744(Founda-)X -875 1264(tion,)N -1039(Saratoga,)X -1360(Calif.,)X -1580(1980.)X -555 1388([Fag79])N -875(R.)X -969(Fagin,)X -1192(J.)X -1284(Nievergelt,)X -1684(N.)X -1803(Pippinger,)X -2175(and)X -2332(H.)X -2451(R.)X -2544(Strong,)X -2797(``Extendible)X -3218(Hashing)X -3505(-)X -3552(A)X -3630(Fast)X -3783(Access)X -875 1484(Method)N -1144(for)X -1258(Dynamic)X -1572(Files'',)X -2 f -1821(ACM)X -2010(Trans.)X -2236(Database)X -2563(Syst.)X -1 f -2712(,)X -2752(vol.)X -2894(4,)X -2994(no.3,)X -3174(pp.)X -3294(315-344,)X -3601(Sept.)X -3783(1979.)X -555 1608([Wal84])N -875(Rich)X -1055(Wales,)X -1305(``Discussion)X -1739(of)X -1835("dbm")X -2072(data)X -2235(base)X -2406(system'',)X -2 f -2730(USENET)X -3051(newsgroup)X -3430(unix.wizards)X -1 f -3836(,)X -3884(Jan.)X -875 1704(1984.)N -555 1828([Tor87])N -875(Chris)X -1068(Torek,)X -1300(``Re:)X -1505(dbm.a)X -1743(and)X -1899(ndbm.a)X -2177(archives'',)X -2 f -2539(USENET)X -2852(newsgroup)X -3223(comp.unix)X -1 f -3555(,)X -3595(1987.)X -555 1952([Mar79])N -875(G.)X -974(N.)X -1073(Martin,)X -1332(``Spiral)X -1598(Storage:)X -1885(Incrementally)X -2371(Augmentable)X -2843(Hash)X -3048(Addressed)X -3427(Storage'',)X -2 f -3766(Techni-)X -875 2048(cal)N -993(Report)X -1231(#27)X -1 f -(,)S -1391(University)X -1749(of)X -1836(Varwick,)X -2153(Coventry,)X -2491(U.K.,)X -2687(1979.)X -555 2172([Enb88])N -875(R.)X -977(J.)X -1057(Enbody)X -1335(and)X -1480(H.)X -1586(C.)X -1687(Du,)X -1833(``Dynamic)X -2209(Hashing)X -2524(Schemes'',)X -2 f -2883(ACM)X -3080(Computing)X -3463(Surveys)X -1 f -3713(,)X -3761(vol.)X -3911(20,)X -875 2268(no.)N -995(2,)X -1075(pp.)X -1195(85-113,)X -1462(June)X -1629(1988.)X - -4 p -%%Trailer -xt - -xs diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 index f0f2d07c841..7e5c1764042 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 @@ -1,7 +1,7 @@ .\" $Id: sdbm.3,v 1.2 90/12/13 13:00:57 oz Exp $ .TH SDBM 3 "1 March 1990" .SH NAME -sdbm, dbm_open, dbm_prep, dbm_close, dbm_fetch, dbm_store, dbm_delete, dbm_firstkey, dbm_nextkey, dbm_hash, dbm_rdonly, dbm_error, dbm_clearerr, dbm_dirfno, dbm_pagfno \- data base subroutines +sdbm, sdbm_open, sdbm_prep, sdbm_close, sdbm_fetch, sdbm_store, sdbm_delete, sdbm_firstkey, sdbm_nextkey, sdbm_hash, sdbm_rdonly, sdbm_error, sdbm_clearerr, sdbm_dirfno, sdbm_pagfno \- data base subroutines .SH SYNOPSIS .nf .ft B @@ -14,60 +14,60 @@ typedef struct { .sp datum nullitem = { NULL, 0 }; .sp -\s-1DBM\s0 *dbm_open(char *file, int flags, int mode) +\s-1DBM\s0 *sdbm_open(char *file, int flags, int mode) .sp -\s-1DBM\s0 *dbm_prep(char *dirname, char *pagname, int flags, int mode) +\s-1DBM\s0 *sdbm_prep(char *dirname, char *pagname, int flags, int mode) .sp -void dbm_close(\s-1DBM\s0 *db) +void sdbm_close(\s-1DBM\s0 *db) .sp -datum dbm_fetch(\s-1DBM\s0 *db, key) +datum sdbm_fetch(\s-1DBM\s0 *db, key) .sp -int dbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags) +int sdbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags) .sp -int dbm_delete(\s-1DBM\s0 *db, datum key) +int sdbm_delete(\s-1DBM\s0 *db, datum key) .sp -datum dbm_firstkey(\s-1DBM\s0 *db) +datum sdbm_firstkey(\s-1DBM\s0 *db) .sp -datum dbm_nextkey(\s-1DBM\s0 *db) +datum sdbm_nextkey(\s-1DBM\s0 *db) .sp -long dbm_hash(char *string, int len) +long sdbm_hash(char *string, int len) .sp -int dbm_rdonly(\s-1DBM\s0 *db) -int dbm_error(\s-1DBM\s0 *db) -dbm_clearerr(\s-1DBM\s0 *db) -int dbm_dirfno(\s-1DBM\s0 *db) -int dbm_pagfno(\s-1DBM\s0 *db) +int sdbm_rdonly(\s-1DBM\s0 *db) +int sdbm_error(\s-1DBM\s0 *db) +sdbm_clearerr(\s-1DBM\s0 *db) +int sdbm_dirfno(\s-1DBM\s0 *db) +int sdbm_pagfno(\s-1DBM\s0 *db) .ft R .fi .SH DESCRIPTION .IX "database library" sdbm "" "\fLsdbm\fR" -.IX dbm_open "" "\fLdbm_open\fR \(em open \fLsdbm\fR database" -.IX dbm_prep "" "\fLdbm_prep\fR \(em prepare \fLsdbm\fR database" -.IX dbm_close "" "\fLdbm_close\fR \(em close \fLsdbm\fR routine" -.IX dbm_fetch "" "\fLdbm_fetch\fR \(em fetch \fLsdbm\fR database data" -.IX dbm_store "" "\fLdbm_store\fR \(em add data to \fLsdbm\fR database" -.IX dbm_delete "" "\fLdbm_delete\fR \(em remove data from \fLsdbm\fR database" -.IX dbm_firstkey "" "\fLdbm_firstkey\fR \(em access \fLsdbm\fR database" -.IX dbm_nextkey "" "\fLdbm_nextkey\fR \(em access \fLsdbm\fR database" -.IX dbm_hash "" "\fLdbm_hash\fR \(em string hash for \fLsdbm\fR database" -.IX dbm_rdonly "" "\fLdbm_rdonly\fR \(em return \fLsdbm\fR database read-only mode" -.IX dbm_error "" "\fLdbm_error\fR \(em return \fLsdbm\fR database error condition" -.IX dbm_clearerr "" "\fLdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition" -.IX dbm_dirfno "" "\fLdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descriptor" -.IX dbm_pagfno "" "\fLdbm_pagfno\fR \(em return \fLsdbm\fR database data file descriptor" -.IX "database functions \(em \fLsdbm\fR" dbm_open "" \fLdbm_open\fP -.IX "database functions \(em \fLsdbm\fR" dbm_prep "" \fLdbm_prep\fP -.IX "database functions \(em \fLsdbm\fR" dbm_close "" \fLdbm_close\fP -.IX "database functions \(em \fLsdbm\fR" dbm_fetch "" \fLdbm_fetch\fP -.IX "database functions \(em \fLsdbm\fR" dbm_store "" \fLdbm_store\fP -.IX "database functions \(em \fLsdbm\fR" dbm_delete "" \fLdbm_delete\fP -.IX "database functions \(em \fLsdbm\fR" dbm_firstkey "" \fLdbm_firstkey\fP -.IX "database functions \(em \fLsdbm\fR" dbm_nextkey "" \fLdbm_nextkey\fP -.IX "database functions \(em \fLsdbm\fR" dbm_rdonly "" \fLdbm_rdonly\fP -.IX "database functions \(em \fLsdbm\fR" dbm_error "" \fLdbm_error\fP -.IX "database functions \(em \fLsdbm\fR" dbm_clearerr "" \fLdbm_clearerr\fP -.IX "database functions \(em \fLsdbm\fR" dbm_dirfno "" \fLdbm_dirfno\fP -.IX "database functions \(em \fLsdbm\fR" dbm_pagfno "" \fLdbm_pagfno\fP +.IX sdbm_open "" "\fLsdbm_open\fR \(em open \fLsdbm\fR database" +.IX sdbm_prep "" "\fLsdbm_prep\fR \(em prepare \fLsdbm\fR database" +.IX sdbm_close "" "\fLsdbm_close\fR \(em close \fLsdbm\fR routine" +.IX sdbm_fetch "" "\fLsdbm_fetch\fR \(em fetch \fLsdbm\fR database data" +.IX sdbm_store "" "\fLsdbm_store\fR \(em add data to \fLsdbm\fR database" +.IX sdbm_delete "" "\fLsdbm_delete\fR \(em remove data from \fLsdbm\fR database" +.IX sdbm_firstkey "" "\fLsdbm_firstkey\fR \(em access \fLsdbm\fR database" +.IX sdbm_nextkey "" "\fLsdbm_nextkey\fR \(em access \fLsdbm\fR database" +.IX sdbm_hash "" "\fLsdbm_hash\fR \(em string hash for \fLsdbm\fR database" +.IX sdbm_rdonly "" "\fLsdbm_rdonly\fR \(em return \fLsdbm\fR database read-only mode" +.IX sdbm_error "" "\fLsdbm_error\fR \(em return \fLsdbm\fR database error condition" +.IX sdbm_clearerr "" "\fLsdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition" +.IX sdbm_dirfno "" "\fLsdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descriptor" +.IX sdbm_pagfno "" "\fLsdbm_pagfno\fR \(em return \fLsdbm\fR database data file descriptor" +.IX "database functions \(em \fLsdbm\fR" sdbm_open "" \fLsdbm_open\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_prep "" \fLsdbm_prep\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_close "" \fLsdbm_close\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_fetch "" \fLsdbm_fetch\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_store "" \fLsdbm_store\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_delete "" \fLsdbm_delete\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_firstkey "" \fLsdbm_firstkey\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_nextkey "" \fLsdbm_nextkey\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_rdonly "" \fLsdbm_rdonly\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_error "" \fLsdbm_error\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_clearerr "" \fLsdbm_clearerr\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_dirfno "" \fLsdbm_dirfno\fP +.IX "database functions \(em \fLsdbm\fR" sdbm_pagfno "" \fLsdbm_pagfno\fP .LP This package allows an application to maintain a mapping of <key,value> pairs in disk files. This is not to be considered a real database system, but is @@ -124,15 +124,15 @@ a .BR "DBM *" , to identify the database to be manipulated. Such a handle can be obtained from the only routines that do not require it, namely -.BR dbm_open (\|) +.BR sdbm_open (\|) or -.BR dbm_prep (\|). +.BR sdbm_prep (\|). Either of these will open or create the two necessary files. The difference is that the latter allows explicitly naming the bitmap and data files whereas -.BR dbm_open (\|) +.BR sdbm_open (\|) will take a base file name and call -.BR dbm_prep (\|) +.BR sdbm_prep (\|) with the default extensions. The .I flags @@ -142,18 +142,18 @@ parameters are the same as for .BR open (2). .LP To free the resources occupied while a database handle is active, call -.BR dbm_close (\|). +.BR sdbm_close (\|). .LP Given a handle, one can retrieve data associated with a key by using the -.BR dbm_fetch (\|) +.BR sdbm_fetch (\|) routine, and associate data with a key by using the -.BR dbm_store (\|) +.BR sdbm_store (\|) routine. .LP The values of the .I flags parameter for -.BR dbm_store (\|) +.BR sdbm_store (\|) can be either .BR \s-1DBM_INSERT\s0 , which will not change an existing entry with the same key, or @@ -162,14 +162,14 @@ which will replace an existing entry with the same key. Keys are unique within the database. .LP To delete a key and its associated value use the -.BR dbm_delete (\|) +.BR sdbm_delete (\|) routine. .LP To retrieve every key in the database, use a loop like: .sp .nf .ft B -for (key = dbm_firstkey(db); key.dptr != NULL; key = dbm_nextkey(db)) +for (key = sdbm_firstkey(db); key.dptr != NULL; key = sdbm_nextkey(db)) ; .ft R .fi @@ -180,27 +180,27 @@ If you determine that the performance of the database is inadequate or you notice clustering or other effects that may be due to the hashing algorithm used by this package, you can override it by supplying your own -.BR dbm_hash (\|) +.BR sdbm_hash (\|) routine. Doing so will make the database unintelligable to any other applications that do not use your specialized hash function. .sp .LP The following macros are defined in the header file: .IP -.BR dbm_rdonly (\|) +.BR sdbm_rdonly (\|) returns true if the database has been opened read\-only. .IP -.BR dbm_error (\|) +.BR sdbm_error (\|) returns true if an I/O error has occurred. .IP -.BR dbm_clearerr (\|) +.BR sdbm_clearerr (\|) allows you to clear the error flag if you think you know what the error was and insist on ignoring it. .IP -.BR dbm_dirfno (\|) +.BR sdbm_dirfno (\|) returns the file descriptor associated with the bitmap file. .IP -.BR dbm_pagfno (\|) +.BR sdbm_pagfno (\|) returns the file descriptor associated with the data file. .SH SEE ALSO .IR open (2). @@ -220,7 +220,7 @@ will return to indicate an error. .LP As a special case of -.BR dbm_store (\|), +.BR sdbm_store (\|), if it is called with the .B \s-1DBM_INSERT\s0 flag and the key already exists in the database, the return value will be 1. @@ -281,10 +281,10 @@ header file should be installed in The .B nullitem data item, and the -.BR dbm_prep (\|), -.BR dbm_hash (\|), -.BR dbm_rdonly (\|), -.BR dbm_dirfno (\|), +.BR sdbm_prep (\|), +.BR sdbm_hash (\|), +.BR sdbm_rdonly (\|), +.BR sdbm_dirfno (\|), and -.BR dbm_pagfno (\|) +.BR sdbm_pagfno (\|) functions are unique to this package. diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c index d4836be6710..c2d9cbd47de 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c @@ -32,6 +32,7 @@ static char rcsid[] = "$Id: sdbm.c,v 1.16 90/12/13 13:01:31 oz Exp $"; /* * externals */ +#ifndef WIN32 #ifndef sun extern int errno; #endif @@ -39,6 +40,7 @@ extern int errno; extern Malloc_t malloc proto((MEM_SIZE)); extern Free_t free proto((Malloc_t)); extern Off_t lseek(); +#endif /* * forward @@ -135,7 +137,7 @@ int mode; * open the files in sequence, and stat the dirfile. * If we fail anywhere, undo everything, return NULL. */ -# ifdef OS2 +#if defined(OS2) || defined(MSDOS) || defined(WIN32) flags |= O_BINARY; # endif if ((db->pagf = open(pagname, flags, mode)) > -1) { diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h index 4d6c8448902..fdd9165145c 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h @@ -79,15 +79,15 @@ extern DBM *sdbm_prep proto((char *, char *, int, int)); extern long sdbm_hash proto((char *, int)); #ifndef SDBM_ONLY -#define dbm_open sdbm_open; -#define dbm_close sdbm_close; -#define dbm_fetch sdbm_fetch; -#define dbm_store sdbm_store; -#define dbm_delete sdbm_delete; -#define dbm_firstkey sdbm_firstkey; -#define dbm_nextkey sdbm_nextkey; -#define dbm_error sdbm_error; -#define dbm_clearerr sdbm_clearerr; +#define dbm_open sdbm_open +#define dbm_close sdbm_close +#define dbm_fetch sdbm_fetch +#define dbm_store sdbm_store +#define dbm_delete sdbm_delete +#define dbm_firstkey sdbm_firstkey +#define dbm_nextkey sdbm_nextkey +#define dbm_error sdbm_error +#define dbm_clearerr sdbm_clearerr #endif /* Most of the following is stolen from perl.h. */ @@ -108,17 +108,6 @@ extern long sdbm_hash proto((char *, int)); # endif #endif -#ifdef MYMALLOC -# ifdef HIDEMYMALLOC -# define malloc Mymalloc -# define realloc Myremalloc -# define free Myfree -# endif -# define safemalloc malloc -# define saferealloc realloc -# define safefree free -#endif - #if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus) # define STANDARD_C 1 #endif @@ -131,7 +120,7 @@ extern long sdbm_hash proto((char *, int)); #include <unistd.h> #endif -#ifndef MSDOS +#if !defined(MSDOS) && !defined(WIN32) # ifdef PARAM_NEEDS_TYPES # include <sys/types.h> # endif @@ -161,6 +150,31 @@ extern long sdbm_hash proto((char *, int)); #define MEM_SIZE Size_t +/* This comes after <stdlib.h> so we don't try to change the standard + * library prototypes; we'll use our own instead. */ + +#if defined(MYMALLOC) && (defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)) + +# ifdef HIDEMYMALLOC +# define malloc Mymalloc +# define calloc Mycalloc +# define realloc Myremalloc +# define free Myfree +# endif +# ifdef EMBEDMYMALLOC +# define malloc Perl_malloc +# define calloc Perl_calloc +# define realloc Perl_realloc +# define free Perl_free +# endif + + Malloc_t malloc proto((MEM_SIZE nbytes)); + Malloc_t calloc proto((MEM_SIZE elements, MEM_SIZE size)); + Malloc_t realloc proto((Malloc_t where, MEM_SIZE nbytes)); + Free_t free proto((Malloc_t where)); + +#endif /* MYMALLOC && (HIDEMYMALLOC || EMBEDMYMALLOC) */ + #ifdef I_STRING #include <string.h> #else @@ -171,14 +185,10 @@ extern long sdbm_hash proto((char *, int)); #include <memory.h> #endif -#if defined(mips) && defined(ultrix) && !defined(__STDC__) -# undef HAS_MEMCMP -#endif - #ifdef HAS_MEMCPY # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcpy - extern char * memcpy _((char*, char*, int)); + extern char * memcpy proto((char*, char*, int)); # endif # endif #else @@ -194,7 +204,7 @@ extern long sdbm_hash proto((char *, int)); #ifdef HAS_MEMSET # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memset - extern char *memset _((char*, int, int)); + extern char *memset proto((char*, int, int)); # endif # endif # define memzero(d,l) memset(d,0,l) @@ -208,24 +218,44 @@ extern long sdbm_hash proto((char *, int)); # endif #endif /* HAS_MEMSET */ -#ifdef HAS_MEMCMP +#if defined(mips) && defined(ultrix) && !defined(__STDC__) +# undef HAS_MEMCMP +#endif + +#if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP) # if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY) # ifndef memcmp - extern int memcmp _((char*, char*, int)); + extern int memcmp proto((char*, char*, int)); # endif # endif +# ifdef BUGGY_MSC + # pragma function(memcmp) +# endif #else # ifndef memcmp -# define memcmp my_memcmp +# /* maybe we should have included the full embedding header... */ +# ifdef NO_EMBED +# define memcmp my_memcmp +# else +# define memcmp Perl_my_memcmp +# endif + extern int memcmp proto((char*, char*, int)); # endif #endif /* HAS_MEMCMP */ -/* we prefer bcmp slightly for comparisons that don't care about ordering */ #ifndef HAS_BCMP # ifndef bcmp # define bcmp(s1,s2,l) memcmp(s1,s2,l) # endif -#endif /* HAS_BCMP */ +#endif /* !HAS_BCMP */ + +#ifdef HAS_MEMCMP +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#else +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif #ifdef I_NETINET_IN # include <netinet/in.h> diff --git a/gnu/usr.bin/perl/ext/SDBM_File/typemap b/gnu/usr.bin/perl/ext/SDBM_File/typemap index a6b0e5faa86..a9b73d8b811 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/typemap +++ b/gnu/usr.bin/perl/ext/SDBM_File/typemap @@ -23,3 +23,5 @@ T_DATUM sv_setpvn($arg, $var.dptr, $var.dsize); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); +T_PTROBJ + sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/gnu/usr.bin/perl/ext/Safe/Makefile.PL b/gnu/usr.bin/perl/ext/Safe/Makefile.PL deleted file mode 100644 index 108109f61d4..00000000000 --- a/gnu/usr.bin/perl/ext/Safe/Makefile.PL +++ /dev/null @@ -1,7 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - NAME => 'Safe', - MAN3PODS => ' ', # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'Safe.pm', -); diff --git a/gnu/usr.bin/perl/ext/Safe/Safe.pm b/gnu/usr.bin/perl/ext/Safe/Safe.pm deleted file mode 100644 index 0fafcbe7411..00000000000 --- a/gnu/usr.bin/perl/ext/Safe/Safe.pm +++ /dev/null @@ -1,670 +0,0 @@ -package Safe; - -use vars qw($VERSION @ISA @EXPORT_OK); - -require Exporter; -require DynaLoader; -use Carp; -$VERSION = "1.00"; -@ISA = qw(Exporter DynaLoader); -@EXPORT_OK = qw(op_mask ops_to_mask mask_to_ops opcode opname opdesc - MAXO emptymask fullmask); - -=head1 NAME - -Safe - Safe extension module for Perl - -=head1 DESCRIPTION - -The Safe extension module allows the creation of compartments -in which perl code can be evaluated. Each compartment has - -=over 8 - -=item a new namespace - -The "root" of the namespace (i.e. "main::") is changed to a -different package and code evaluated in the compartment cannot -refer to variables outside this namespace, even with run-time -glob lookups and other tricks. Code which is compiled outside -the compartment can choose to place variables into (or share -variables with) the compartment's namespace and only that -data will be visible to code evaluated in the compartment. - -By default, the only variables shared with compartments are the -"underscore" variables $_ and @_ (and, technically, the much less -frequently used %_, the _ filehandle and so on). This is because -otherwise perl operators which default to $_ will not work and neither -will the assignment of arguments to @_ on subroutine entry. - -=item an operator mask - -Each compartment has an associated "operator mask". Recall that -perl code is compiled into an internal format before execution. -Evaluating perl code (e.g. via "eval" or "do 'file'") causes -the code to be compiled into an internal format and then, -provided there was no error in the compilation, executed. -Code evaulated in a compartment compiles subject to the -compartment's operator mask. Attempting to evaulate code in a -compartment which contains a masked operator will cause the -compilation to fail with an error. The code will not be executed. - -By default, the operator mask for a newly created compartment masks -out all operations which give "access to the system" in some sense. -This includes masking off operators such as I<system>, I<open>, -I<chown>, and I<shmget> but does not mask off operators such as -I<print>, I<sysread> and I<E<lt>HANDLE<gt>>. Those file operators -are allowed since for the code in the compartment to have access -to a filehandle, the code outside the compartment must have explicitly -placed the filehandle variable inside the compartment. - -Since it is only at the compilation stage that the operator mask -applies, controlled access to potentially unsafe operations can -be achieved by having a handle to a wrapper subroutine (written -outside the compartment) placed into the compartment. For example, - - $cpt = new Safe; - sub wrapper { - # vet arguments and perform potentially unsafe operations - } - $cpt->share('&wrapper'); - -=back - -=head2 Operator masks - -An operator mask exists at user-level as a string of bytes of length -MAXO, each of which is either 0x00 or 0x01. Here, MAXO is the number -of operators in the current version of perl. The subroutine MAXO() -(available for export by package Safe) returns the number of operators -in the current version of perl. Note that, unlike the beta versions of -the Safe extension, this is a reliable count of the number of -operators in the currently running perl executable. The presence of a -0x01 byte at offset B<n> of the string indicates that operator number -B<n> should be masked (i.e. disallowed). The Safe extension makes -available routines for converting from operator names to operator -numbers (and I<vice versa>) and for converting from a list of operator -names to the corresponding mask (and I<vice versa>). - -=head2 Methods in class Safe - -To create a new compartment, use - - $cpt = new Safe; - -Optional arguments are (NAMESPACE, MASK), where - -=over 8 - -=item NAMESPACE - -is the root namespace to use for the compartment (defaults to -"Safe::Root000000000", auto-incremented for each new compartment); and - -=item MASK - -is the operator mask to use (defaults to a fairly restrictive set). - -=back - -The following methods can then be used on the compartment -object returned by the above constructor. The object argument -is implicit in each case. - -=over 8 - -=item root (NAMESPACE) - -This is a get-or-set method for the compartment's namespace. With the -NAMESPACE argument present, it sets the root namespace for the -compartment. With no NAMESPACE argument present, it returns the -current root namespace of the compartment. - -=item mask (MASK) - -This is a get-or-set method for the compartment's operator mask. -With the MASK argument present, it sets the operator mask for the -compartment. With no MASK argument present, it returns the -current operator mask of the compartment. - -=item trap (OP, ...) - -This sets bits in the compartment's operator mask corresponding -to each operator named in the list of arguments. Each OP can be -either the name of an operation or its number. See opcode.h or -opcode.pl in the main perl distribution for a canonical list of -operator names. - -=item untrap (OP, ...) - -This resets bits in the compartment's operator mask corresponding -to each operator named in the list of arguments. Each OP can be -either the name of an operation or its number. See opcode.h or -opcode.pl in the main perl distribution for a canonical list of -operator names. - -=item share (VARNAME, ...) - -This shares the variable(s) in the argument list with the compartment. -Each VARNAME must be the B<name> of a variable with a leading type -identifier included. Examples of legal variable names are '$foo' for -a scalar, '@foo' for an array, '%foo' for a hash, '&foo' for a -subroutine and '*foo' for a glob (i.e. all symbol table entries -associated with "foo", including scalar, array, hash, sub and filehandle). - -=item varglob (VARNAME) - -This returns a glob for the symbol table entry of VARNAME in the package -of the compartment. VARNAME must be the B<name> of a variable without -any leading type marker. For example, - - $cpt = new Safe 'Root'; - $Root::foo = "Hello world"; - # Equivalent version which doesn't need to know $cpt's package name: - ${$cpt->varglob('foo')} = "Hello world"; - - -=item reval (STRING) - -This evaluates STRING as perl code inside the compartment. The code -can only see the compartment's namespace (as returned by the B<root> -method). Any attempt by code in STRING to use an operator which is -in the compartment's mask will cause an error (at run-time of the -main program but at compile-time for the code in STRING). The error -is of the form "%s trapped by operation mask operation...". If an -operation is trapped in this way, then the code in STRING will not -be executed. If such a trapped operation occurs or any other -compile-time or return error, then $@ is set to the error message, -just as with an eval(). If there is no error, then the method returns -the value of the last expression evaluated, or a return statement may -be used, just as with subroutines and B<eval()>. Note that this -behaviour differs from the beta distribution of the Safe extension -where earlier versions of perl made it hard to mimic the return -behaviour of the eval() command. - -=item rdo (FILENAME) - -This evaluates the contents of file FILENAME inside the compartment. -See above documentation on the B<reval> method for further details. - -=back - -=head2 Subroutines in package Safe - -The Safe package contains subroutines for manipulating operator -names and operator masks. All are available for export by the package. -The canonical list of operator names is the contents of the array -op_name defined and initialised in file F<opcode.h> of the Perl -source distribution. - -=over 8 - -=item ops_to_mask (OP, ...) - -This takes a list of operator names and returns an operator mask -with precisely those operators masked. - -=item mask_to_ops (MASK) - -This takes an operator mask and returns a list of operator names -corresponding to those operators which are masked in MASK. - -=item opcode (OP, ...) - -This takes a list of operator names and returns the corresponding -list of opcodes (which can then be used as byte offsets into a mask). - -=item opname (OP, ...) - -This takes a list of opcodes and returns the corresponding list of -operator names. - -=item fullmask - -This just returns a mask which has all operators masked. -It returns the string "\1" x MAXO(). - -=item emptymask - -This just returns a mask which has all operators unmasked. -It returns the string "\0" x MAXO(). This is useful if you -want a compartment to make use of the namespace protection -features but do not want the default restrictive mask. - -=item MAXO - -This returns the number of operators (and hence the length of an -operator mask). Note that, unlike the beta distributions of the -Safe extension, this is derived from a genuine integer variable -in the perl executable and not from a preprocessor constant. -This means that the Safe extension is more robust in the presence -of mismatched versions of the perl executable and the Safe extension. - -=item op_mask - -This returns the operator mask which is actually in effect at the -time the invocation to the subroutine is compiled. In general, -this is probably not terribly useful. - -=back - -=head2 AUTHOR - -Malcolm Beattie, mbeattie@sable.ox.ac.uk. - -=cut - -my $default_root = 'Root000000000'; - -my $default_mask; - -sub new { - my($class, $root, $mask) = @_; - my $obj = {}; - bless $obj, $class; - $obj->root(defined($root) ? $root : ("Safe::".$default_root++)); - $obj->mask(defined($mask) ? $mask : $default_mask); - # We must share $_ and @_ with the compartment or else ops such - # as split, length and so on won't default to $_ properly, nor - # will passing argument to subroutines work (via @_). In fact, - # for reasons I don't completely understand, we need to share - # the whole glob *_ rather than $_ and @_ separately, otherwise - # @_ in non default packages within the compartment don't work. - *{$obj->root . "::_"} = *_; - return $obj; -} - -sub DESTROY { - my($obj) = @_; - my $root = $obj->root(); - if ($root =~ /^Safe::(Root\d+)$/){ - $root = $1; - delete $ {"Safe::"}{"$root\::"}; - } -} - -sub root { - my $obj = shift; - if (@_) { - $obj->{Root} = $_[0]; - } else { - return $obj->{Root}; - } -} - -sub mask { - my $obj = shift; - if (@_) { - $obj->{Mask} = verify_mask($_[0]); - } else { - return $obj->{Mask}; - } -} - -sub verify_mask { - my($mask) = @_; - if (length($mask) != MAXO() || $mask !~ /^[\0\1]+$/) { - croak("argument is not a mask"); - } - return $mask; -} - -sub trap { - my $obj = shift; - $obj->setmaskel("\1", @_); -} - -sub untrap { - my $obj = shift; - $obj->setmaskel("\0", @_); -} - -sub emptymask { "\0" x MAXO() } -sub fullmask { "\1" x MAXO() } - -sub setmaskel { - my $obj = shift; - my $val = shift; - croak("bad value for mask element") unless $val eq "\0" || $val eq "\1"; - my $maskref = \$obj->{Mask}; - my ($op, $opcode); - foreach $op (@_) { - $opcode = ($op =~ /^\d/) ? $op : opcode($op); - substr($$maskref, $opcode, 1) = $val; - } -} - -sub share { - my $obj = shift; - my $root = $obj->root(); - my ($arg); - foreach $arg (@_) { - my $var; - ($var = $arg) =~ s/^(.)//; - my $caller = caller; - *{$root."::$var"} = ($1 eq '$') ? \${$caller."::$var"} - : ($1 eq '@') ? \@{$caller."::$var"} - : ($1 eq '%') ? \%{$caller."::$var"} - : ($1 eq '*') ? *{$caller."::$var"} - : ($1 eq '&') ? \&{$caller."::$var"} - : croak(qq(No such variable type for "$1$var")); - } -} - -sub varglob { - my ($obj, $var) = @_; - return *{$obj->root()."::$var"}; -} - -sub reval { - my ($obj, $expr) = @_; - my $root = $obj->{Root}; - my $mask = $obj->{Mask}; - verify_mask($mask); - - my $evalsub = eval sprintf(<<'EOT', $root); - package %s; - sub { - eval $expr; - } -EOT - return safe_call_sv($root, $mask, $evalsub); -} - -sub rdo { - my ($obj, $file) = @_; - my $root = $obj->{Root}; - my $mask = $obj->{Mask}; - verify_mask($mask); - - $file =~ s/"/\\"/g; # just in case the filename contains any double quotes - my $evalsub = eval sprintf(<<'EOT', $root, $file); - package %s; - sub { - do "%s"; - } -EOT - return safe_call_sv($root, $mask, $evalsub); -} - -bootstrap Safe $VERSION; - -$default_mask = fullmask; -my $name; -while (defined ($name = <DATA>)) { - chomp $name; - next if $name =~ /^#/; - my $code = opcode($name); - substr($default_mask, $code, 1) = "\0"; -} - -1; - -__DATA__ -null -stub -scalar -pushmark -wantarray -const -gvsv -gv -gelem -padsv -padav -padhv -padany -pushre -rv2gv -rv2sv -av2arylen -rv2cv -anoncode -prototype -refgen -srefgen -ref -bless -glob -readline -rcatline -regcmaybe -regcomp -match -subst -substcont -trans -sassign -aassign -chop -schop -chomp -schomp -defined -undef -study -pos -preinc -i_preinc -predec -i_predec -postinc -i_postinc -postdec -i_postdec -pow -multiply -i_multiply -divide -i_divide -modulo -i_modulo -repeat -add -i_add -subtract -i_subtract -concat -stringify -left_shift -right_shift -lt -i_lt -gt -i_gt -le -i_le -ge -i_ge -eq -i_eq -ne -i_ne -ncmp -i_ncmp -slt -sgt -sle -sge -seq -sne -scmp -bit_and -bit_xor -bit_or -negate -i_negate -not -complement -atan2 -sin -cos -rand -srand -exp -log -sqrt -int -hex -oct -abs -length -substr -vec -index -rindex -sprintf -formline -ord -chr -crypt -ucfirst -lcfirst -uc -lc -quotemeta -rv2av -aelemfast -aelem -aslice -each -values -keys -delete -exists -rv2hv -helem -hslice -split -join -list -lslice -anonlist -anonhash -splice -push -pop -shift -unshift -reverse -grepstart -grepwhile -mapstart -mapwhile -range -flip -flop -and -or -xor -cond_expr -andassign -orassign -method -entersub -leavesub -caller -warn -die -reset -lineseq -nextstate -dbstate -unstack -enter -leave -scope -enteriter -iter -enterloop -leaveloop -return -last -next -redo -goto -close -fileno -tie -untie -dbmopen -dbmclose -sselect -select -getc -read -enterwrite -leavewrite -prtf -print -sysread -syswrite -send -recv -eof -tell -seek -truncate -fcntl -ioctl -sockpair -bind -connect -listen -accept -shutdown -gsockopt -ssockopt -getsockname -ftrwrite -ftsvtx -open_dir -readdir -telldir -seekdir -rewinddir -kill -getppid -getpgrp -setpgrp -getpriority -setpriority -time -tms -localtime -alarm -dofile -entereval -leaveeval -entertry -leavetry -ghbyname -ghbyaddr -ghostent -gnbyname -gnbyaddr -gnetent -gpbyname -gpbynumber -gprotoent -gsbyname -gsbyport -gservent -shostent -snetent -sprotoent -sservent -ehostent -enetent -eprotoent -eservent -gpwnam -gpwuid -gpwent -spwent -epwent -ggrnam -ggrgid -ggrent -sgrent -egrent diff --git a/gnu/usr.bin/perl/ext/Safe/Safe.xs b/gnu/usr.bin/perl/ext/Safe/Safe.xs deleted file mode 100644 index 6b25924a334..00000000000 --- a/gnu/usr.bin/perl/ext/Safe/Safe.xs +++ /dev/null @@ -1,131 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -/* maxo should never differ from MAXO but leave some room anyway */ -#define OP_MASK_BUF_SIZE (MAXO + 100) - -MODULE = Safe PACKAGE = Safe - -void -safe_call_sv(package, mask, codesv) - char * package - SV * mask - SV * codesv - CODE: - int i; - char *str; - STRLEN len; - char op_mask_buf[OP_MASK_BUF_SIZE]; - - assert(maxo < OP_MASK_BUF_SIZE); - ENTER; - SAVETMPS; - save_hptr(&defstash); - save_aptr(&endav); - SAVEPPTR(op_mask); - op_mask = &op_mask_buf[0]; - str = SvPV(mask, len); - if (maxo != len) - croak("Bad mask length"); - for (i = 0; i < maxo; i++) - op_mask[i] = str[i]; - defstash = gv_stashpv(package, TRUE); - endav = (AV*)sv_2mortal((SV*)newAV()); /* Ignore END blocks for now */ - GvHV(gv_fetchpv("main::", TRUE, SVt_PVHV)) = defstash; - PUSHMARK(sp); - i = perl_call_sv(codesv, G_SCALAR|G_EVAL|G_KEEPERR); - SPAGAIN; - ST(0) = i ? newSVsv(POPs) : &sv_undef; - PUTBACK; - FREETMPS; - LEAVE; - sv_2mortal(ST(0)); - -void -op_mask() - CODE: - ST(0) = sv_newmortal(); - if (op_mask) - sv_setpvn(ST(0), op_mask, maxo); - -void -mask_to_ops(mask) - SV * mask - PPCODE: - STRLEN len; - char *maskstr = SvPV(mask, len); - int i; - if (maxo != len) - croak("Bad mask length"); - for (i = 0; i < maxo; i++) - if (maskstr[i]) - XPUSHs(sv_2mortal(newSVpv(op_name[i], 0))); - -void -ops_to_mask(...) - CODE: - int i, j; - char mask[OP_MASK_BUF_SIZE], *op; - Zero(mask, sizeof mask, char); - for (i = 0; i < items; i++) - { - op = SvPV(ST(i), na); - for (j = 0; j < maxo && strNE(op, op_name[j]); j++) /* nothing */ ; - if (j < maxo) - mask[j] = 1; - else - { - Safefree(mask); - croak("bad op name \"%s\" in mask", op); - } - } - ST(0) = sv_2mortal(newSVpv(mask,maxo)); - -void -opname(...) - PPCODE: - int i, myopcode; - for (i = 0; i < items; i++) - { - myopcode = SvIV(ST(i)); - if (myopcode < 0 || myopcode >= maxo) - croak("opcode out of range"); - XPUSHs(sv_2mortal(newSVpv(op_name[myopcode], 0))); - } - -void -opdesc(...) - PPCODE: - int i, myopcode; - for (i = 0; i < items; i++) - { - myopcode = SvIV(ST(i)); - if (myopcode < 0 || myopcode >= maxo) - croak("opcode out of range"); - XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); - } - -void -opcode(...) - PPCODE: - int i, j; - char *op; - for (i = 0; i < items; i++) - { - op = SvPV(ST(i), na); - for (j = 0; j < maxo; j++) { - if (strEQ(op, op_name[j]) || strEQ(op, op_desc[j])) - break; - } - if (j == maxo) - croak("bad op name \"%s\"", op); - XPUSHs(sv_2mortal(newSViv(j))); - } - -int -MAXO() - CODE: - RETVAL = maxo; - OUTPUT: - RETVAL diff --git a/gnu/usr.bin/perl/ext/Socket/Socket.pm b/gnu/usr.bin/perl/ext/Socket/Socket.pm index 43c3c404bc4..51dce5939e0 100644 --- a/gnu/usr.bin/perl/ext/Socket/Socket.pm +++ b/gnu/usr.bin/perl/ext/Socket/Socket.pm @@ -1,7 +1,7 @@ package Socket; use vars qw($VERSION @ISA @EXPORT); -$VERSION = "1.5"; +$VERSION = "1.6"; =head1 NAME @@ -47,12 +47,15 @@ all of the commonly used pound-defines like AF_INET, SOCK_STREAM, etc. In addition, some structure manipulation functions are available: +=over + =item inet_aton HOSTNAME Takes a string giving the name of a host, and translates that to the 4-byte string (structure). Takes arguments of both the 'rtfm.mit.edu' type and '18.181.0.24'. If the host name -cannot be resolved, returns undef. +cannot be resolved, returns undef. For multi-homed hosts (hosts +with more than one address), the first address found is returned. =item inet_ntoa IP_ADDRESS @@ -72,6 +75,15 @@ a particular network interface. This wildcard address allows you to bind to all of them simultaneously.) Normally equivalent to inet_aton('0.0.0.0'). +=item INADDR_BROADCAST + +Note: does not return a number, but a packed string. + +Returns the 4-byte 'this-lan' ip broadcast address. +This can be useful for some protocols to solicit information +from all servers on the same LAN cable. +Normally equivalent to inet_aton('255.255.255.255'). + =item INADDR_LOOPBACK Note - does not return a number. @@ -83,7 +95,7 @@ to inet_aton('localhost'). Note - does not return a number. -Returns the 4-byte invalid ip address. Normally equivalent +Returns the 4-byte 'invalid' ip address. Normally equivalent to inet_aton('255.255.255.255'). =item sockaddr_in PORT, ADDRESS @@ -115,10 +127,10 @@ Will croak if the structure does not have AF_INET in the right place. =item sockaddr_un SOCKADDR_UN In an array context, unpacks its SOCKADDR_UN argument and returns an array -consisting of (PATHNAME). In a scalar context, packs its PATHANE +consisting of (PATHNAME). In a scalar context, packs its PATHNAME arguments as a SOCKADDR_UN and returns it. If this is confusing, use pack_sockaddr_un() and unpack_sockaddr_un() explicitly. -These are only supported if your system has <sys/un.h>. +These are only supported if your system has E<lt>F<sys/un.h>E<gt>. =item pack_sockaddr_un PATH @@ -134,19 +146,20 @@ Takes a sockaddr_un structure (as returned by pack_sockaddr_un()) and returns the pathname. Will croak if the structure does not have AF_UNIX in the right place. +=back + =cut use Carp; require Exporter; -use AutoLoader; require DynaLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw( inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in pack_sockaddr_un unpack_sockaddr_un sockaddr_in sockaddr_un - INADDR_ANY INADDR_LOOPBACK INADDR_NONE + INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT @@ -256,14 +269,8 @@ sub AUTOLOAD { ($constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - my ($pack,$file,$line) = caller; - croak "Your vendor has not defined Socket macro $constname, used"; - } + my ($pack,$file,$line) = caller; + croak "Your vendor has not defined Socket macro $constname, used"; } eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; @@ -271,8 +278,4 @@ sub AUTOLOAD { bootstrap Socket $VERSION; -# Preloaded methods go here. Autoload methods go after __END__, and are -# processed by the autosplit program. - 1; -__END__ diff --git a/gnu/usr.bin/perl/ext/Socket/Socket.xs b/gnu/usr.bin/perl/ext/Socket/Socket.xs index 378824f42d4..e3b282b0adb 100644 --- a/gnu/usr.bin/perl/ext/Socket/Socket.xs +++ b/gnu/usr.bin/perl/ext/Socket/Socket.xs @@ -30,10 +30,119 @@ #ifndef INADDR_NONE #define INADDR_NONE 0xffffffff #endif /* INADDR_NONE */ +#ifndef INADDR_BROADCAST +#define INADDR_BROADCAST 0xffffffff +#endif /* INADDR_BROADCAST */ #ifndef INADDR_LOOPBACK #define INADDR_LOOPBACK 0x7F000001 #endif /* INADDR_LOOPBACK */ +#ifndef HAS_INET_ATON + +/* + * Check whether "cp" is a valid ascii representation + * of an Internet address and convert to a binary address. + * Returns 1 if the address is valid, 0 if not. + * This replaces inet_addr, the return value from which + * cannot distinguish between failure and a local broadcast address. + */ +static int +my_inet_aton(cp, addr) +register const char *cp; +struct in_addr *addr; +{ + register U32 val; + register int base; + register char c; + int nparts; + const char *s; + unsigned int parts[4]; + register unsigned int *pp = parts; + + if (!cp) + return 0; + for (;;) { + /* + * Collect number up to ``.''. + * Values are specified as for C: + * 0x=hex, 0=octal, other=decimal. + */ + val = 0; base = 10; + if (*cp == '0') { + if (*++cp == 'x' || *cp == 'X') + base = 16, cp++; + else + base = 8; + } + while ((c = *cp) != '\0') { + if (isDIGIT(c)) { + val = (val * base) + (c - '0'); + cp++; + continue; + } + if (base == 16 && (s=strchr(hexdigit,c))) { + val = (val << 4) + + ((s - hexdigit) & 15); + cp++; + continue; + } + break; + } + if (*cp == '.') { + /* + * Internet format: + * a.b.c.d + * a.b.c (with c treated as 16-bits) + * a.b (with b treated as 24 bits) + */ + if (pp >= parts + 3 || val > 0xff) + return 0; + *pp++ = val, cp++; + } else + break; + } + /* + * Check for trailing characters. + */ + if (*cp && !isSPACE(*cp)) + return 0; + /* + * Concoct the address according to + * the number of parts specified. + */ + nparts = pp - parts + 1; /* force to an int for switch() */ + switch (nparts) { + + case 1: /* a -- 32 bits */ + break; + + case 2: /* a.b -- 8.24 bits */ + if (val > 0xffffff) + return 0; + val |= parts[0] << 24; + break; + + case 3: /* a.b.c -- 8.8.16 bits */ + if (val > 0xffff) + return 0; + val |= (parts[0] << 24) | (parts[1] << 16); + break; + + case 4: /* a.b.c.d -- 8.8.8.8 bits */ + if (val > 0xff) + return 0; + val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8); + break; + } + addr->s_addr = htonl(val); + return 1; +} + +#undef inet_aton +#define inet_aton my_inet_aton + +#endif /* ! HAS_INET_ATON */ + static int not_here(s) @@ -595,15 +704,17 @@ inet_aton(host) { struct in_addr ip_address; struct hostent * phe; + int ok; if (phe = gethostbyname(host)) { Copy( phe->h_addr, &ip_address, phe->h_length, char ); + ok = 1; } else { - ip_address.s_addr = inet_addr(host); + ok = inet_aton(host, &ip_address); } ST(0) = sv_newmortal(); - if(ip_address.s_addr != INADDR_NONE) { + if (ok) { sv_setpvn( ST(0), (char *)&ip_address, sizeof ip_address ); } } @@ -649,7 +760,7 @@ pack_sockaddr_un(pathname) void unpack_sockaddr_un(sun_sv) SV * sun_sv - PPCODE: + CODE: { #ifdef I_SYS_UN STRLEN sockaddrlen; @@ -748,3 +859,12 @@ INADDR_NONE() ip_address.s_addr = htonl(INADDR_NONE); ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); } + +void +INADDR_BROADCAST() + CODE: + { + struct in_addr ip_address; + ip_address.s_addr = htonl(INADDR_BROADCAST); + ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); + } diff --git a/gnu/usr.bin/perl/ext/util/extliblist b/gnu/usr.bin/perl/ext/util/extliblist deleted file mode 100644 index 2351ddfd0ec..00000000000 --- a/gnu/usr.bin/perl/ext/util/extliblist +++ /dev/null @@ -1,155 +0,0 @@ -case $CONFIG in -'') - if test -f config.sh; then TOP=.; - elif test -f ../config.sh; then TOP=..; - elif test -f ../../config.sh; then TOP=../..; - elif test -f ../../../config.sh; then TOP=../../..; - elif test -f ../../../../config.sh; then TOP=../../../..; - else - echo "Can't find config.sh."; exit 1 - fi - . $TOP/config.sh - ;; -esac -: extliblist -: -: Author: Andy Dougherty doughera@lafcol.lafayette.edu -: -: This utility was only used by the old Makefile.SH extension -: mechanism. It is now obsolete and may be removed in a future -: release. -: -: This utility takes a list of libraries in the form -: -llib1 -llib2 -llib3 -: and prints out lines suitable for inclusion in an extension -: Makefile. -: Extra library paths may be included with the form -L/another/path -: this will affect the searches for all subsequent libraries. -: -: It is intended to be "dotted" from within an extension Makefile.SH. -: see ext/POSIX/Makefile.SH for an example. -: Prior to calling this, the variable potential_libs should be set -: to the potential list of libraries -: -: It sets the following -: extralibs = full list of libraries needed for static linking. -: Only those libraries that actually exist are included. -: dynaloadlibs = full path names of those libraries that are needed -: but can be linked in dynamically on this platform. On -: SunOS, for example, this would be .so* libraries, -: but not archive libraries. -: Eventually, this list can be used to write a bootstrap file. -: statloadlibs = list of those libraries which must be statically -: linked into the shared library. On SunOS 4.1.3, -: for example, I have only an archive version of -: -lm, and it must be linked in statically. -: -: This script uses config.sh variables libs, libpth, and so. It is mostly -: taken from the metaconfig libs.U unit. -extralibs='' -dynaloadlibs='' -statloadlibs='' -Llibpth='' -for thislib in `echo "XXX $potential_libs " | $sed 's/ -l/ /g'` ; do - case "$thislib" in - XXX) - : Handle case where potential_libs is empty. - ;; - -L*) - : Handle possible linker path arguments. - newpath=`echo $thislib | $sed 's/^-L//'` - if $test -d $newpath; then - Llibpth="$Llibpth $newpath" - extralibs="$extralibs $thislib" - statloadlibs="$statloadlibs $thislib" - fi - ;; - *) - : Handle possible library arguments. - for thispth in $Llibpth $libpth; do - : Loop over possible wildcards and take the last one. - for fullname in $thispth/lib$thislib.$so.[0-9]* ; do - : - done - if $test -f $fullname; then - break - elif fullname=$thispth/lib$thislib.$so && $test -f $fullname; then - break - elif fullname=$thispth/lib${thislib}_s.a && $test -f $fullname; then - thislib=${thislib}_s - break - elif fullname=$thispth/lib${thislib}.a && $test -f $fullname; then - break - elif fullname=$thispth/Slib${thislib}.a && $test -f $fullname; then - break - else - fullname='' - fi - done - : Now update library lists - case "$fullname" in - '') - : Skip nonexistent files - ;; - *) - : Do not add it into the extralibs if it is already linked in - : with the main perl executable. - case " $libs " in - *" -l$thislib "*|*" -l${thislib}_s "*) ;; - *) extralibs="$extralibs -l$thislib" ;; - esac - : - : For NeXT and DLD, put files into DYNALOADLIBS to be - : converted into a boostrap file. For other systems, - : we will use ld with what I have misnamed STATLOADLIBS - : to assemble the shared object. - case "$dlsrc" in - dl_dld*|dl_next*) - dynaloadlibs="$dynaloadlibs $fullname" ;; - *) - case "$fullname" in - *.a) - statloadlibs="$statloadlibs -l$thislib" - ;; - *) - : For SunOS4, do not add in this shared library - : if it is already linked in the main - : perl executable - case "$osname" in - sunos) - case " $libs " in - *" -l$thislib "*) ;; - *) statloadlibs="$statloadlibs -l$thislib" ;; - esac - ;; - *) - statloadlibs="$statloadlibs -l$thislib" - ;; - esac - ;; - esac - ;; - esac - ;; - esac - ;; - esac -done - -case "$dlsrc" in -dl_next*) - extralibs=`echo " $extralibs "| $sed -e 's/ -lm / /'` ;; -esac - -set X $extralibs -shift -extralibs="$*" - -set X $dynaloadlibs -shift -dynaloadlibs="$*" - -set X $statloadlibs -shift -statloadlibs="$*" - diff --git a/gnu/usr.bin/perl/ext/util/make_ext b/gnu/usr.bin/perl/ext/util/make_ext index 8c1abbbc013..70a5d2eb231 100644 --- a/gnu/usr.bin/perl/ext/util/make_ext +++ b/gnu/usr.bin/perl/ext/util/make_ext @@ -4,16 +4,35 @@ # It primarily used by the perl Makefile: # # d_dummy $(dynamic_ext): miniperl preplibrary FORCE -# ext/util/make_ext dynamic $@ +# @sh ext/util/make_ext dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL) # # It may be deleted in a later release of perl so try to # avoid using it for other purposes. target=$1; shift extspec=$1; shift +makecmd=$1; shift # Should be something like MAKE=make passthru="$*" # allow extra macro=value to be passed through echo "" +# Previously, $make was taken from config.sh. However, the user might +# instead be running a possibly incompatible make. This might happen if +# the user types "gmake" instead of a plain "make", for example. The +# correct current value of MAKE will come through from the main perl +# makefile as MAKE=/whatever/make in $makecmd. We'll be cautious in +# case third party users of this script (are there any?) don't have the +# MAKE=$(MAKE) argument, which was added after 5.004_03. +case "$makecmd" in +MAKE=*) + eval $makecmd + ;; +*) echo 'ext/util/make_ext: WARNING: Please include MAKE=$(MAKE)' + echo ' in your call to make_ext. See ext/util/make_ext for details.' + exit 1 + ;; +esac + + case $CONFIG in '') if test -f config.sh; then TOP=.; @@ -34,9 +53,9 @@ if test "X$extspec" = X; then fi # The Perl Makefile.SH will expand all extensions to -# lib/auto/X/X.a (or lib/auto/X/Y/Y.a is nested) +# lib/auto/X/X.a (or lib/auto/X/Y/Y.a if nested) # A user wishing to run make_ext might use -# X (or X/Y or X::Y is nested) +# X (or X/Y or X::Y if nested) # canonise into X/Y form (pname) case "$extspec" in @@ -50,7 +69,6 @@ esac mname=`echo "$pname" | sed -e 's!/!::!g'` depth=`echo "$pname" | sed -e 's![^/][^/]*!..!g'` -make=${altmake-make} makefile=Makefile makeargs='' makeopts='' @@ -108,10 +126,10 @@ clean) ;; realclean) ;; *) # Give makefile an opportunity to rewrite itself. # reassure users that life goes on... - $make config $passthru || echo "$make config failed, continuing anyway..." + $MAKE config $passthru || echo "$MAKE config failed, continuing anyway..." ;; esac -$make $makeopts $target $makeargs $passthru || exit +$MAKE $makeopts $target $makeargs $passthru || exit exit $? |