diff options
author | Malcolm Beattie <mbeattie@sable.ox.ac.uk> | 1997-05-25 10:31:21 +0000 |
---|---|---|
committer | Malcolm Beattie <mbeattie@sable.ox.ac.uk> | 1997-05-25 10:31:21 +0000 |
commit | ae77835f9b08444f73b593d4cdc0758132dbbf00 (patch) | |
tree | 5f626cfecad7636b4da1329b5602c41f2cf53d23 /ext | |
parent | c750a3ec3b866067ab46dbcc9083205d823047c3 (diff) | |
parent | ec4e49dc1523dcdb6bec56a66be410eab95cfa61 (diff) | |
download | perl-ae77835f9b08444f73b593d4cdc0758132dbbf00.tar.gz |
First stab at 5.003 -> 5.004 integration.
p4raw-id: //depot/perl@18
Diffstat (limited to 'ext')
62 files changed, 7266 insertions, 4728 deletions
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 61ac26aafe..2d5e744671 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,181 +1,144 @@ # 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 30th Apr 1997 +# version 1.14 +# +# 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 {} ; -} - -%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]} ; + my $self = shift ; + my $key = shift ; - 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 DESTROY { undef %{$_[0]} } +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 {} ; -} - -%elements = ( 'bval' => 0, - 'cachesize' => 0, - 'psize' => 0, - 'flags' => 0, - 'lorder' => 0, - 'reclen' => 0, - 'bfname' => 0 - ) ; -sub FETCH -{ - return $_[0]{$_[1]} if defined $elements{$_[1]} ; + my $pkg = shift ; - 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 +146,12 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO) ; use Carp; -$VERSION = "1.01" ; +$VERSION = "1.14" ; #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 +160,7 @@ require DynaLoader; @ISA = qw(Tie::Hash Exporter DynaLoader); @EXPORT = qw( $DB_BTREE $DB_HASH $DB_RECNO + BTREEMAGIC BTREEVERSION DB_LOCK @@ -225,6 +189,7 @@ require DynaLoader; R_SETCURSOR R_SNAPSHOT __R_UNUSED + ); sub AUTOLOAD { @@ -246,16 +211,86 @@ sub AUTOLOAD { goto &$AUTOLOAD; } + +# import borrowed from IO::File +# exports Fcntl constants if available. +sub import { + my $pkg = shift; + my $callpkg = caller; + Exporter::export $pkg, $callpkg, @_; + eval { + require Fcntl; + Exporter::export 'Fcntl', $callpkg, '/^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 +298,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 +329,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 +345,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 +358,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 +376,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 +384,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 +404,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. -To change one of these elements, just assign to it like this +If you are using the DB_RECNO interface and you intend making use of +C<bval>, you should check out L<The 'bval' Option>. - $DB_HASH->{cachesize} = 10000 ; +=head2 Default Parameters +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: -=head2 RECNO + tie %A, "DB_File", "filename" ; +is equivalent to: -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", "filename", O_CREAT|O_RDWR, 0666, $DB_HASH ; +It is also possible to omit the filename parameter as well, so the +call: + + 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 +538,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. -=head2 Using the Berkeley DB Interface Directly +=item B<$X-E<gt>shift> + +Removes and returns the first element of the array. + +=item B<$X-E<gt>unshift(list) ;> + +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. + + use DB_File ; + $db = tie %hash, "DB_File", "filename" + or die "Cannot tie filename: $!" ; + ... + undef $db ; + untie %hash ; -All the constants defined in L<dbopen> are also available. +See L<The untie() Gotcha> for more details. -Below is a list of the functions available. +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 del +=item * -The flags parameter is optional. +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: -=item fd + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; -As in I<recno>. + # Get the first key/value pair and set the cursor + $X->seq($key, $value, R_FIRST) ; -=item seq + # this line will modify the cursor + $count = scalar keys %x ; -The flags parameter is optional. + # Get the second key/value pair. + # oops, it didn't, it got the last key/value pair! + $X->seq($key, $value, R_NEXT) ; -Both the key and value parameters will be set. +The code above can be rearranged to get around the problem, like this: -=item sync + $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE + or die "Cannot tie $filename: $!" ; -The flags parameter is optional. + # this line will modify the cursor + $count = scalar keys %x ; + + # 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 +1293,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 +1335,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 +1576,97 @@ 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 -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. +Removed some redundant code in DB_File.xs. -If you cannot find any, then either you didn't look very hard or the -moment has passed and I have dropped them. +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. + +Added get_dup method. + +=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. + +=back =head1 BUGS @@ -651,23 +1679,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/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index fe967e6279..b76c53e8a5 100644 --- a/ext/DB_File/DB_File.xs +++ b/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 30th Apr 1997 + version 1.14 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,28 @@ 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. + */ #include "EXTERN.h" @@ -27,25 +53,41 @@ #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 +96,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 +165,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 +212,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 +235,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 +249,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 +265,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 +329,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 +525,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 +793,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 +803,29 @@ 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 +>>>> ORIGINAL VERSION +BOOT: + newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file); + +==== THEIR VERSION +==== YOUR VERSION BOOT: newXS("DB_File::TIEARRAY", XS_DB_File_TIEHASH, file); +<<<< int db_DESTROY(db) DB_File db @@ -743,6 +849,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 +904,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 +925,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 +980,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 +993,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) ; } } @@ -990,3 +1115,4 @@ db_seq(db, key, value, flags) OUTPUT: key value + diff --git a/ext/DB_File/Makefile.PL b/ext/DB_File/Makefile.PL index 4cda63507d..39b8bc7030 100644 --- a/ext/DB_File/Makefile.PL +++ b/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/ext/DB_File/typemap b/ext/DB_File/typemap index 4acc65e078..5ca9c54f72 100644 --- a/ext/DB_File/typemap +++ b/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); } diff --git a/ext/DynaLoader/DynaLoader.pm b/ext/DynaLoader/DynaLoader.pm index 282d364372..67043102a5 100644 --- a/ext/DynaLoader/DynaLoader.pm +++ b/ext/DynaLoader/DynaLoader.pm @@ -12,20 +12,33 @@ package DynaLoader; # # Tim.Bunce@ig.co.uk, August 1994 -use vars qw($VERSION @ISA) ; +use vars qw($VERSION); + +$VERSION = "1.02"; require Carp; require Config; + require AutoLoader; +*AUTOLOAD = \&AutoLoader::AUTOLOAD; -@ISA=qw(AutoLoader); +# enable debug/trace messages from DynaLoader perl code +$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; -$VERSION = "1.00" ; +# +# 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 import { } # override import inherited from AutoLoader +sub dl_load_flags { 0x00 } -# enable debug/trace messages from DynaLoader perl code -$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; +# ($dl_dlext, $dlsrc) = @Config::Config{'dlext', 'dlsrc'}; @@ -39,6 +52,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"; @@ -137,9 +152,11 @@ sub bootstrap { # in this perl code simply because this was the last perl code # it executed. - my $libref = dl_load_file($file) or + my $libref = dl_load_file($file, $module->dl_load_flags) or Carp::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; @@ -149,6 +166,8 @@ sub bootstrap { my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + push(@dl_modules, $module); # record loaded module + # See comment block above &$xs(@args); } @@ -268,12 +287,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 +311,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 @@ -313,11 +345,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 +393,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 +410,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 +500,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 +527,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 +564,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 +601,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 +633,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 +672,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/ext/DynaLoader/Makefile.PL b/ext/DynaLoader/Makefile.PL index 64ee4d0259..9323935880 100644 --- a/ext/DynaLoader/Makefile.PL +++ b/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/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs index f8bace1314..bdf33b2410 100644 --- a/ext/DynaLoader/dl_aix.xs +++ b/ext/DynaLoader/dl_aix.xs @@ -524,12 +524,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 +545,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 +570,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/ext/DynaLoader/dl_cygwin32.xs b/ext/DynaLoader/dl_cygwin32.xs new file mode 100644 index 0000000000..2b7563764e --- /dev/null +++ b/ext/DynaLoader/dl_cygwin32.xs @@ -0,0 +1,153 @@ +/* dl_cygwin32.xs + * + * Platform: Win32 (Windows NT/Windows 95) + * Author: Wei-Yuen Tan (wyt@hip.com) + * Created: A warm day in June, 1995 + * + * Modified: + * August 23rd 1995 - rewritten after losing everything when I + * wiped off my NT partition (eek!) + */ +/* Modified from the original dl_win32.xs to work with cygwin32 + -John Cerney 3/26/97 +*/ +/* Porting notes: + +I merely took Paul's dl_dlopen.xs, took out extraneous stuff and +replaced the appropriate SunOS calls with the corresponding Win32 +calls. + +*/ + +#define WIN32_LEAN_AND_MEAN +// Defines from windows needed for this function only. Can't include full +// Cygwin32 windows headers because of problems with CONTEXT redefinition +// Removed logic to tell not dynamically load static modules. It is assumed that all +// modules are dynamically built. This should be similar to the behavoir on sunOS. +// Leaving in the logic would have required changes to the standard perlmain.c code +// +// // Includes call a dll function to initialize it's impure_ptr. +#include <stdio.h> +void (*impure_setupptr)(struct _reent *); // pointer to the impure_setup routine + +//#include <windows.h> +#define LOAD_WITH_ALTERED_SEARCH_PATH (8) +typedef void *HANDLE; +typedef HANDLE HINSTANCE; +#define STDCALL __attribute__ ((stdcall)) +typedef int STDCALL (*FARPROC)(); + +HINSTANCE +STDCALL +LoadLibraryExA( + char* lpLibFileName, + HANDLE hFile, + unsigned int dwFlags + ); +unsigned int +STDCALL +GetLastError( + void + ); +FARPROC +STDCALL +GetProcAddress( + HINSTANCE hModule, + char* lpProcName + ); + +#include <string.h> + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "dlutils.c" /* SaveError() etc */ + +static void +dl_private_init() +{ + (void)dl_generic_private_init(); +} + + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(); + +void * +dl_load_file(filename,flags=0) + char * filename + int flags + PREINIT: + CODE: + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + + RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ; + + DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL){ + SaveError("%d",GetLastError()) ; + } + else{ + // setup the dll's impure_ptr: + impure_setupptr = GetProcAddress(RETVAL, "impure_setup"); + if( impure_setupptr == NULL){ + printf( + "Cygwin32 dynaloader error: could not load impure_setup symbol\n"); + RETVAL = NULL; + } + else{ + // setup the DLLs impure_ptr: + (*impure_setupptr)(_impure_ptr); + sv_setiv( ST(0), (IV)RETVAL); + } + } + + + +void * +dl_find_symbol(libhandle, symbolname) + void * libhandle + char * symbolname + CODE: + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + libhandle, symbolname)); + RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (RETVAL == NULL) + SaveError("%d",GetLastError()) ; + else + sv_setiv( ST(0), (IV)RETVAL); + + +void +dl_undef_symbols() + PPCODE: + + + +# 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/ext/DynaLoader/dl_dld.xs b/ext/DynaLoader/dl_dld.xs index a0028a1f7a..44933ec92c 100644 --- a/ext/DynaLoader/dl_dld.xs +++ b/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/ext/DynaLoader/dl_dlopen.xs b/ext/DynaLoader/dl_dlopen.xs index a2a68162b2..fef4530cfe 100644 --- a/ext/DynaLoader/dl_dlopen.xs +++ b/ext/DynaLoader/dl_dlopen.xs @@ -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/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs index 0e146830ef..51d464e6de 100644 --- a/ext/DynaLoader/dl_hpux.xs +++ b/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/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs index 33a41003ef..92d14bc81c 100644 --- a/ext/DynaLoader/dl_next.xs +++ b/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/ext/DynaLoader/dl_os2.xs b/ext/DynaLoader/dl_os2.xs deleted file mode 100644 index 2c72be23ed..0000000000 --- a/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/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs index 3f46ffc940..0329ebd9cb 100644 --- a/ext/DynaLoader/dl_vms.xs +++ b/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/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 67dea787cc..58006789ef 100644 --- a/ext/DynaLoader/dlutils.c +++ b/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/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm index 32a3194326..678b7fd897 100644 --- a/ext/Fcntl/Fcntl.pm +++ b/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,15 +22,24 @@ 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) +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>. + +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 = @@ -38,11 +48,19 @@ $VERSION = "1.00"; FD_CLOEXEC F_RDLCK F_UNLCK F_WRLCK 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_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 +); +# Named groups of exports +%EXPORT_TAGS = ( + 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)], ); sub AUTOLOAD { @@ -66,8 +84,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/ext/Fcntl/Fcntl.xs b/ext/Fcntl/Fcntl.xs index 90f3af5028..a94864332e 100644 --- a/ext/Fcntl/Fcntl.xs +++ b/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; @@ -87,6 +93,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; @@ -115,6 +127,37 @@ int arg; 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 +226,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/ext/FileHandle/FileHandle.pm b/ext/FileHandle/FileHandle.pm deleted file mode 100644 index 2770b91c7f..0000000000 --- a/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/ext/FileHandle/FileHandle.xs b/ext/FileHandle/FileHandle.xs deleted file mode 100644 index 3a99cf1dc8..0000000000 --- a/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/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm index 3f1d83e004..9c7ae066b7 100644 --- a/ext/GDBM_File/GDBM_File.pm +++ b/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/ext/IO/IO.pm b/ext/IO/IO.pm new file mode 100644 index 0000000000..1ba05ca916 --- /dev/null +++ b/ext/IO/IO.pm @@ -0,0 +1,36 @@ +# + +package IO; + +=head1 NAME + +IO - load various IO modules + +=head1 SYNOPSIS + + use IO; + +=head1 DESCRIPTION + +C<IO> provides a simple mechanism to load all of the IO modules at one go. +Currently this includes: + + IO::Handle + IO::Seekable + IO::File + IO::Pipe + IO::Socket + +For more information on any of these modules, please see its respective +documentation. + +=cut + +use IO::Handle; +use IO::Seekable; +use IO::File; +use IO::Pipe; +use IO::Socket; + +1; + diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs new file mode 100644 index 0000000000..2eb16f40ec --- /dev/null +++ b/ext/IO/IO.xs @@ -0,0 +1,286 @@ +#include "EXTERN.h" +#define PERLIO_NOT_STDIO 1 +#include "perl.h" +#include "XSUB.h" + +#ifdef I_UNISTD +# include <unistd.h> +#endif +#ifdef I_FCNTL +# include <fcntl.h> +#endif + +#ifdef PerlIO +typedef int SysRet; +typedef PerlIO * InputStream; +typedef PerlIO * OutputStream; +#else +#define PERLIO_IS_STDIO 1 +typedef int SysRet; +typedef FILE * InputStream; +typedef FILE * OutputStream; +#endif + +static int +not_here(s) +char *s; +{ + croak("%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; + case 'S': + if (strEQ(name, "SEEK_SET")) +#ifdef SEEK_SET + { *pval = SEEK_SET; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "SEEK_CUR")) +#ifdef SEEK_CUR + { *pval = SEEK_CUR; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "SEEK_END")) +#ifdef SEEK_END + { *pval = SEEK_END; return TRUE; } +#else + return FALSE; +#endif + break; + } + + return FALSE; +} + + +MODULE = IO PACKAGE = IO::Seekable PREFIX = f + +SV * +fgetpos(handle) + InputStream handle + CODE: + if (handle) { + Fpos_t pos; +#ifdef PerlIO + PerlIO_getpos(handle, &pos); +#else + fgetpos(handle, &pos); +#endif + ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + } + else { + ST(0) = &sv_undef; + errno = EINVAL; + } + +SysRet +fsetpos(handle, pos) + InputStream handle + SV * pos + CODE: + char *p; + if (handle && (p = SvPVx(pos, na)) && na == sizeof(Fpos_t)) +#ifdef PerlIO + RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); +#else + RETVAL = fsetpos(handle, (Fpos_t*)p); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +MODULE = IO PACKAGE = IO::File PREFIX = f + +SV * +new_tmpfile(packname = "IO::File") + char * packname + PREINIT: + OutputStream fp; + GV *gv; + CODE: +#ifdef PerlIO + fp = PerlIO_tmpfile(); +#else + fp = tmpfile(); +#endif + gv = (GV*)SvREFCNT_inc(newGVgen(packname)); + hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); + if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) { + ST(0) = sv_2mortal(newRV((SV*)gv)); + sv_bless(ST(0), gv_stashpv(packname, TRUE)); + SvREFCNT_dec(gv); /* undo increment in newRV() */ + } + else { + ST(0) = &sv_undef; + SvREFCNT_dec(gv); + } + +MODULE = IO PACKAGE = IO::Handle PREFIX = f + +SV * +constant(name) + char * name + CODE: + IV i; + if (constant(name, &i)) + ST(0) = sv_2mortal(newSViv(i)); + else + ST(0) = &sv_undef; + +int +ungetc(handle, c) + InputStream handle + int c + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_ungetc(handle, c); +#else + RETVAL = ungetc(c, handle); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +ferror(handle) + InputStream handle + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_error(handle); +#else + RETVAL = ferror(handle); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +clearerr(handle) + InputStream handle + CODE: + if (handle) { +#ifdef PerlIO + PerlIO_clearerr(handle); +#else + clearerr(handle); +#endif + RETVAL = 0; + } + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +untaint(handle) + SV * handle + CODE: +#ifdef IOf_UNTAINT + IO * io; + io = sv_2io(handle); + if (io) { + IoFLAGS(io) |= IOf_UNTAINT; + RETVAL = 0; + } + else { +#endif + RETVAL = -1; + errno = EINVAL; +#ifdef IOf_UNTAINT + } +#endif + OUTPUT: + RETVAL + +SysRet +fflush(handle) + OutputStream handle + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_flush(handle); +#else + RETVAL = Fflush(handle); +#endif + 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) +#ifdef PERLIO_IS_STDIO + setbuf(handle, buf); +#else + not_here("IO::Handle::setbuf"); +#endif + +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: +/* Should check HAS_SETVBUF once Configure tests for that */ +#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) + if (handle) + RETVAL = setvbuf(handle, buf, type, size); + else { + RETVAL = -1; + errno = EINVAL; + } +#else + RETVAL = (SysRet) not_here("IO::Handle::setvbuf"); +#endif + OUTPUT: + RETVAL + + diff --git a/ext/FileHandle/Makefile.PL b/ext/IO/Makefile.PL index 7efd382043..4a34be61fb 100644 --- a/ext/FileHandle/Makefile.PL +++ b/ext/IO/Makefile.PL @@ -1,7 +1,8 @@ use ExtUtils::MakeMaker; WriteMakefile( - NAME => 'FileHandle', + NAME => 'IO', MAN3PODS => ' ', # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'FileHandle.pm', + VERSION_FROM => 'lib/IO/Handle.pm', + XS_VERSION => 1.15 ); diff --git a/ext/IO/README b/ext/IO/README new file mode 100644 index 0000000000..e855afade4 --- /dev/null +++ b/ext/IO/README @@ -0,0 +1,4 @@ +This directory contains files from the IO distribution maintained by +Graham Barr <bodg@tiuk.ti.com>. If you find that you have to modify +any files in this directory then please forward him a patch for only +the files in this directory. diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm new file mode 100644 index 0000000000..b1aecffb5d --- /dev/null +++ b/ext/IO/lib/IO/File.pm @@ -0,0 +1,174 @@ +# + +package IO::File; + +=head1 NAME + +IO::File - supply object methods for filehandles + +=head1 SYNOPSIS + + use IO::File; + + $fh = new IO::File; + if ($fh->open("< file")) { + print <$fh>; + $fh->close; + } + + $fh = new IO::File "> file"; + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = new IO::File "file", "r"; + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + + $fh = new IO::File "file", O_WRONLY|O_APPEND; + if (defined $fh) { + print $fh "corge\n"; + + $pos = $fh->getpos; + $fh->setpos($pos); + + undef $fh; # automatically closes the file + } + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends +these classes with methods that are specific to file handles. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ([ ARGS ] ) + +Creates a C<IO::File>. If it receives any parameters, they are passed to +the method C<open>; if the open fails, the object is destroyed. Otherwise, +it is returned to the caller. + +=item new_tmpfile + +Creates an C<IO::File> opened for read/write on a newly created temporary +file. On systems where this is possible, the temporary file is anonymous +(i.e. it is unlinked after creation, but held open). If the temporary +file cannot be created or opened, the C<IO::File> object is destroyed. +Otherwise, it is returned to the caller. + +=back + +=head1 METHODS + +=over 4 + +=item open( FILENAME [,MODE [,PERMS]] ) + +C<open> accepts one, two or three parameters. 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, optionally followed by a file permission value. + +If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.) +or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator. + +If C<IO::File::open> is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C<sysopen> operator. +For convenience, C<IO::File::import> tries to import the O_XXX +constants from the Fcntl module. If dynamic loading is not available, +this may fail, but the rest of IO::File will still work. + +=back + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle> +L<IO::Seekable> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>. + +=cut + +require 5.000; +use strict; +use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA); +use Carp; +use Symbol; +use SelectSaver; +use IO::Seekable; + +require Exporter; +require DynaLoader; + +@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); + +$VERSION = "1.0602"; + +@EXPORT = @IO::Seekable::EXPORT; + +sub import { + my $pkg = shift; + my $callpkg = caller; + Exporter::export $pkg, $callpkg, @_; + + # + # If the Fcntl extension is available, + # export its constants for sysopen(). + # + eval { + require Fcntl; + Exporter::export 'Fcntl', $callpkg, '/^O_/'; + }; +} + + +################################################ +## Constructor +## + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::File"; + @_ >= 0 && @_ <= 3 + or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]"; + my $fh = $class->SUPER::new(); + if (@_) { + $fh->open(@_) + or return undef; + } + $fh; +} + +################################################ +## Open +## + +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 if $file =~ m{\A[^\\/\w]}; + $file = IO::Handle::_open_mode_string($mode) . " $file\0"; + } + open($fh, $file); +} + +1; diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm new file mode 100644 index 0000000000..f270f3ff98 --- /dev/null +++ b/ext/IO/lib/IO/Handle.pm @@ -0,0 +1,542 @@ + +package IO::Handle; + +=head1 NAME + +IO::Handle - supply object methods for I/O handles + +=head1 SYNOPSIS + + use IO::Handle; + + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDIN),"r")) { + print $fh->getline; + $fh->close; + } + + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDOUT),"w")) { + $fh->print("Some text\n"); + } + + $fh->setvbuf($buffer_var, _IOLBF, 1024); + + undef $fh; # automatically closes the file if it's open + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C<IO::Handle> is the base class for all other IO handle classes. It is +not intended that objects of C<IO::Handle> would be created directly, +but instead C<IO::Handle> is inherited from by several other classes +in the IO hierarchy. + +If you are reading this documentation, looking for a replacement for +the C<FileHandle> package, then I suggest you read the documentation +for C<IO::File> + +A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package) + +=head1 CONSTRUCTOR + +=over 4 + +=item new () + +Creates a new C<IO::Handle> object. + +=item new_from_fd ( FD, MODE ) + +Creates a C<IO::Handle> like C<new> does. +It requires two parameters, which are passed to the method C<fdopen>; +if the fdopen fails, the object is destroyed. Otherwise, it is returned +to the caller. + +=back + +=head1 METHODS + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Handle> methods, which are just front ends for the +corresponding built-in functions: + + close + fileno + getc + eof + read + truncate + stat + print + printf + sysread + syswrite + +See L<perlvar> for complete descriptions of each of the following +supported C<IO::Handle> 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 + format_write + +Furthermore, for doing normal I/O you might need these: + +=over + +=item $fh->fdopen ( FD, MODE ) + +C<fdopen> is like an ordinary C<open> except that its first parameter +is not a filename but rather a file handle name, a IO::Handle object, +or a file descriptor number. + +=item $fh->opened + +Returns true if the object is currently a valid file descriptor. + +=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. + +=item $fh->ungetc ( ORD ) + +Pushes a character with the given ordinal value back onto the given +handle's input stream. + +=item $fh->write ( BUF, LEN [, OFFSET }\] ) + +This C<write> is like C<write> found in C, that is it is the +opposite of read. The wrapper for the perl C<write> function is +called C<format_write>. + +=item $fh->flush + +Flush the given handle's buffer. + +=item $fh->error + +Returns a true value if the given handle has experienced any errors +since it was opened or since the last call to C<clearerr>. + +=item $fh->clearerr + +Clear the given handle's error indicator. + +=back + +If the C functions setbuf() and/or setvbuf() are available, then +C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering +policy for an IO::Handle. The calling sequences for the Perl functions +are the same as their C counterparts--including the constants C<_IOFBF>, +C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter +specifies a scalar variable to use as a buffer. WARNING: A variable +used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any +way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called +again, or memory corruption may result! + +Lastly, there is a special method for working under B<-T> and setuid/gid +scripts: + +=over + +=item $fh->untaint + +Marks the object as taint-clean, and as such data read from it will also +be considered taint-clean. Note that this is a very trusting action to +take, and appropriate consideration for the data source and potential +vulnerability should be kept in mind. + +=back + +=head1 NOTE + +A C<IO::Handle> object is a GLOB reference. Some modules that +inherit from C<IO::Handle> may want to keep object related variables +in the hash table part of the GLOB. In an attempt to prevent modules +trampling on each other I propose the that any such module should prefix +its variables with its own name separated by _'s. For example the IO::Socket +module keeps a C<timeout> variable in 'io_socket_timeout'. + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::File> + +=head1 BUGS + +Due to backwards compatibility, all filehandles resemble objects +of class C<IO::Handle>, or actually classes derived from that class. +They actually aren't. Which means you can't derive your own +class from C<IO::Handle> and inherit those methods. + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> + +=cut + +require 5.000; +use strict; +use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA); +use Carp; +use Symbol; +use SelectSaver; + +require Exporter; +@ISA = qw(Exporter); + +$VERSION = "1.1504"; +$XS_VERSION = "1.15"; + +@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 + format_write + + print + printf + getline + getlines + + SEEK_SET + SEEK_CUR + SEEK_END + _IOFBF + _IOLBF + _IONBF +); + + +################################################ +## Interaction with the XS. +## + +require DynaLoader; +@IO::ISA = qw(DynaLoader); +bootstrap IO $XS_VERSION; + +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 IO::Handle macro"; + no strict 'refs'; + *$AUTOLOAD = sub { $val }; + goto &$AUTOLOAD; +} + + +################################################ +## Constructors, destructors. +## + +sub new { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 1 or croak "usage: new $class"; + my $fh = gensym; + bless $fh, $class; +} + +sub new_from_fd { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; + my $fh = gensym; + shift; + IO::Handle::fdopen($fh, @_) + or return undef; + bless $fh, $class; +} + +# +# There is no need for DESTROY to do anything, because when the +# last reference to an IO object is gone, Perl automatically +# closes its associated files (if any). However, to avoid any +# attempts to autoload DESTROY, we here define it to do nothing. +# +sub DESTROY {} + + +################################################ +## Open and close. +## + +sub _open_mode_string { + my ($mode) = @_; + $mode =~ /^\+?(<|>>?)$/ + or $mode =~ s/^r(\+?)$/$1</ + or $mode =~ s/^w(\+?)$/$1>/ + or $mode =~ s/^a(\+?)$/$1>>/ + or croak "IO::Handle: bad open mode: $mode"; + $mode; +} + +sub fdopen { + @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)'; + my ($fh, $fd, $mode) = @_; + local(*GLOB); + + if (ref($fd) && "".$fd =~ /GLOB\(/o) { + # It's a glob reference; Alias it as we cannot get name of anon GLOBs + my $n = qualify(*GLOB); + *GLOB = *{*$fd}; + $fd = $n; + } elsif ($fd =~ m#^\d+$#) { + # It's an FD number; prefix with "=". + $fd = "=$fd"; + } + + open($fh, _open_mode_string($mode) . '&' . $fd) + ? $fh : undef; +} + +sub close { + @_ == 1 or croak 'usage: $fh->close()'; + my($fh) = @_; + + close($fh); +} + +################################################ +## Normal I/O functions. +## + +# flock +# select + +sub opened { + @_ == 1 or croak 'usage: $fh->opened()'; + defined fileno($_[0]); +} + +sub fileno { + @_ == 1 or croak 'usage: $fh->fileno()'; + fileno($_[0]); +} + +sub getc { + @_ == 1 or croak 'usage: $fh->getc()'; + getc($_[0]); +} + +sub eof { + @_ == 1 or croak 'usage: $fh->eof()'; + eof($_[0]); +} + +sub print { + @_ or croak 'usage: $fh->print([ARGS])'; + my $this = shift; + print $this @_; +} + +sub printf { + @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])'; + my $this = shift; + printf $this @_; +} + +sub getline { + @_ == 1 or croak 'usage: $fh->getline'; + my $this = shift; + return scalar <$this>; +} + +*gets = \&getline; # deprecated + +sub getlines { + @_ == 1 or croak 'usage: $fh->getline()'; + wantarray or + croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline'; + my $this = shift; + return <$this>; +} + +sub truncate { + @_ == 2 or croak 'usage: $fh->truncate(LEN)'; + truncate($_[0], $_[1]); +} + +sub read { + @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])'; + read($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub sysread { + @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])'; + sysread($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub write { + @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])'; + local($\) = ""; + print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); +} + +sub syswrite { + @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])'; + syswrite($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub stat { + @_ == 1 or croak 'usage: $fh->stat()'; + stat($_[0]); +} + +################################################ +## 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; +} + +sub formline { + my $fh = shift; + my $picture = shift; + local($^A) = $^A; + local($\) = ""; + formline($picture, @_); + print $fh $^A; +} + +sub format_write { + @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )'; + if (@_ == 2) { + my ($fh, $fmt) = @_; + my $oldfmt = $fh->format_name($fmt); + write($fh); + $fh->format_name($oldfmt); + } else { + write($_[0]); + } +} + +sub fcntl { + @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );'; + my ($fh, $op, $val) = @_; + my $r = fcntl($fh, $op, $val); + defined $r && $r eq "0 but true" ? 0 : $r; +} + +sub ioctl { + @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );'; + my ($fh, $op, $val) = @_; + my $r = ioctl($fh, $op, $val); + defined $r && $r eq "0 but true" ? 0 : $r; +} + +1; diff --git a/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm new file mode 100644 index 0000000000..ae6d9a547e --- /dev/null +++ b/ext/IO/lib/IO/Pipe.pm @@ -0,0 +1,239 @@ +# IO::Pipe.pm +# +# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Pipe; + +require 5.000; + +use IO::Handle; +use strict; +use vars qw($VERSION); +use Carp; +use Symbol; + +$VERSION = "1.0901"; + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::Pipe"; + @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; + + my $me = bless gensym(), $class; + + my($readfh,$writefh) = @_ ? @_ : $me->handles; + + pipe($readfh, $writefh) + or return undef; + + @{*$me} = ($readfh, $writefh); + + $me; +} + +sub handles { + @_ == 1 or croak 'usage: $pipe->handles()'; + (IO::Pipe::End->new(), IO::Pipe::End->new()); +} + +my $do_spawn = $^O eq 'os2'; + +sub _doit { + my $me = shift; + my $rw = shift; + + my $pid = $do_spawn ? 0 : fork(); + + if($pid) { # Parent + return $pid; + } + elsif(defined $pid) { # Child or spawn + my $fh; + my $io = $rw ? \*STDIN : \*STDOUT; + my ($mode, $save) = $rw ? "r" : "w"; + if ($do_spawn) { + require Fcntl; + $save = IO::Handle->new_from_fd($io, $mode); + # Close in child: + fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!"; + $fh = $rw ? ${*$me}[0] : ${*$me}[1]; + } else { + shift; + $fh = $rw ? $me->reader() : $me->writer(); # close the other end + } + bless $io, "IO::Handle"; + $io->fdopen($fh, $mode); + $fh->close; + + if ($do_spawn) { + $pid = eval { system 1, @_ }; # 1 == P_NOWAIT + my $err = $!; + + $io->fdopen($save, $mode); + $save->close or croak "Cannot close $!"; + croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0; + return $pid; + } else { + exec @_ or + croak "IO::Pipe: Cannot exec: $!"; + } + } + else { + croak "IO::Pipe: Cannot fork: $!"; + } + + # NOT Reached +} + +sub reader { + @_ >= 1 or croak 'usage: $pipe->reader()'; + my $me = shift; + my $fh = ${*$me}[0]; + my $pid = $me->_doit(0, $fh, @_) + if(@_); + + close ${*$me}[1]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +sub writer { + @_ >= 1 or croak 'usage: $pipe->writer()'; + my $me = shift; + my $fh = ${*$me}[1]; + my $pid = $me->_doit(1, $fh, @_) + if(@_); + + close ${*$me}[0]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +package IO::Pipe::End; + +use vars qw(@ISA); + +@ISA = qw(IO::Handle); + +sub close { + my $fh = shift; + my $r = $fh->SUPER::close(@_); + + waitpid(${*$fh}{'io_pipe_pid'},0) + if(defined ${*$fh}{'io_pipe_pid'}); + + $r; +} + +1; + +__END__ + +=head1 NAME + +IO::pipe - supply object methods for pipes + +=head1 SYNOPSIS + + use IO::Pipe; + + $pipe = new IO::Pipe; + + if($pid = fork()) { # Parent + $pipe->reader(); + + while(<$pipe> { + .... + } + + } + elsif(defined $pid) { # Child + $pipe->writer(); + + print $pipe .... + } + + or + + $pipe = new IO::Pipe; + + $pipe->reader(qw(ls -l)); + + while(<$pipe>) { + .... + } + +=head1 DESCRIPTION + +C<IO::Pipe> provides an interface to createing pipes between +processes. + +=head1 CONSTRCUTOR + +=over 4 + +=item new ( [READER, WRITER] ) + +Creates a C<IO::Pipe>, which is a reference to a newly created symbol +(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two +arguments, which should be objects blessed into C<IO::Handle>, or a +subclass thereof. These two objects will be used for the system call +to C<pipe>. If no arguments are given then method C<handles> is called +on the new C<IO::Pipe> object. + +These two handles are held in the array part of the GLOB until either +C<reader> or C<writer> is called. + +=back + +=head1 METHODS + +=over 4 + +=item reader ([ARGS]) + +The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a +handle at the reading end of the pipe. If C<ARGS> are given then C<fork> +is called and C<ARGS> are passed to exec. + +=item writer ([ARGS]) + +The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a +handle at the writing end of the pipe. If C<ARGS> are given then C<fork> +is called and C<ARGS> are passed to exec. + +=item handles () + +This method is called during construction by C<IO::Pipe::new> +on the newly created C<IO::Pipe> object. It returns an array of two objects +blessed into C<IO::Pipe::End>, or a subclass thereof. + +=back + +=head1 SEE ALSO + +L<IO::Handle> + +=head1 AUTHOR + +Graham Barr <bodg@tiuk.ti.com> + +=head1 COPYRIGHT + +Copyright (c) 1996 Graham Barr. All rights reserved. This program is free +software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=cut diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm new file mode 100644 index 0000000000..91c381a61e --- /dev/null +++ b/ext/IO/lib/IO/Seekable.pm @@ -0,0 +1,68 @@ +# + +package IO::Seekable; + +=head1 NAME + +IO::Seekable - supply seek based methods for I/O objects + +=head1 SYNOPSIS + + use IO::Seekable; + package IO::Something; + @ISA = qw(IO::Seekable); + +=head1 DESCRIPTION + +C<IO::Seekable> does not have a constuctor of its own as is intended to +be inherited by other C<IO::Handle> based objects. It provides methods +which allow seeking of the file descriptors. + +If the C functions fgetpos() and fsetpos() are available, then +C<IO::File::getpos> returns an opaque value that represents the +current position of the IO::File, and C<IO::File::setpos> uses +that value to return to a previously visited position. + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Seekable> methods, which are just front ends for the +corresponding built-in functions: + + seek + tell + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle> +L<IO::File> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt> + +=cut + +require 5.000; +use Carp; +use strict; +use vars qw($VERSION @EXPORT @ISA); +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); +require Exporter; + +@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); +@ISA = qw(Exporter); + +$VERSION = "1.06"; + +sub seek { + @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)'; + seek($_[0], $_[1], $_[2]); +} + +sub tell { + @_ == 1 or croak 'usage: $fh->tell()'; + tell($_[0]); +} + +1; diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm new file mode 100644 index 0000000000..dea684a62e --- /dev/null +++ b/ext/IO/lib/IO/Select.pm @@ -0,0 +1,371 @@ +# IO::Select.pm +# +# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +# software; you can redistribute it and/or modify it under the same terms +# as Perl itself. + +package IO::Select; + +=head1 NAME + +IO::Select - OO interface to the select system call + +=head1 SYNOPSIS + + use IO::Select; + + $s = IO::Select->new(); + + $s->add(\*STDIN); + $s->add($some_handle); + + @ready = $s->can_read($timeout); + + @ready = IO::Select->new(@handles)->read(0); + +=head1 DESCRIPTION + +The C<IO::Select> package implements an object approach to the system C<select> +function call. It allows the user to see what IO handles, see L<IO::Handle>, +are ready for reading, writing or have an error condition pending. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ HANDLES ] ) + +The constructor creates a new object and optionally initialises it with a set +of handles. + +=back + +=head1 METHODS + +=over 4 + +=item add ( HANDLES ) + +Add the list of handles to the C<IO::Select> object. It is these values that +will be returned when an event occurs. C<IO::Select> keeps these values in a +cache which is indexed by the C<fileno> of the handle, so if more than one +handle with the same C<fileno> is specified then only the last one is cached. + +Each handle can be an C<IO::Handle> object, an integer or an array +reference where the first element is a C<IO::Handle> or an integer. + +=item remove ( HANDLES ) + +Remove all the given handles from the object. This method also works +by the C<fileno> of the handles. So the exact handles that were added +need not be passed, just handles that have an equivalent C<fileno> + +=item exists ( HANDLE ) + +Returns a true value (actually the handle itself) if it is present. +Returns undef otherwise. + +=item handles + +Return an array of all registered handles. + +=item can_read ( [ TIMEOUT ] ) + +Return an array of handles that are ready for reading. C<TIMEOUT> is +the maximum amount of time to wait before returning an empty list. If +C<TIMEOUT> is not given and any handles are registered then the call +will block. + +=item can_write ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that can be written to. + +=item has_error ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that have an error +condition, for example EOF. + +=item count () + +Returns the number of handles that the object will check for when +one of the C<can_> methods is called or the object is passed to +the C<select> static method. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item select ( READ, WRITE, ERROR [, TIMEOUT ] ) + +C<select> is a static method, that is you call it with the package +name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef> +or C<IO::Select> objects. C<TIMEOUT> is optional and has the same +effect as for the core select call. + +The result will be an array of 3 elements, each a reference to an array +which will hold the handles that are ready for reading, writing and have +error conditions respectively. Upon error an empty array is returned. + +=back + +=head1 EXAMPLE + +Here is a short example which shows how C<IO::Select> could be used +to write a server which communicates with several sockets while also +listening for more connections on a listen socket + + use IO::Select; + use IO::Socket; + + $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080); + $sel = new IO::Select( $lsn ); + + while(@ready = $sel->can_read) { + foreach $fh (@ready) { + if($fh == $lsn) { + # Create a new socket + $new = $lsn->accept; + $sel->add($new); + } + else { + # Process socket + + # Maybe we have finished with the socket + $sel->remove($fh); + $fh->close; + } + } + } + +=head1 AUTHOR + +Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> + +=head1 COPYRIGHT + +Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=cut + +use strict; +use vars qw($VERSION @ISA); +require Exporter; + +$VERSION = "1.10"; + +@ISA = qw(Exporter); # This is only so we can do version checking + +sub VEC_BITS () {0} +sub FD_COUNT () {1} +sub FIRST_FD () {2} + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + + my $vec = bless [undef,0], $type; + + $vec->add(@_) + if @_; + + $vec; +} + +sub add +{ + shift->_update('add', @_); +} + + +sub remove +{ + shift->_update('remove', @_); +} + + +sub exists +{ + my $vec = shift; + $vec->[$vec->_fileno(shift) + FIRST_FD]; +} + + +sub _fileno +{ + my($self, $f) = @_; + $f = $f->[0] if ref($f) eq 'ARRAY'; + ($f =~ /^\d+$/) ? $f : fileno($f); +} + +sub _update +{ + my $vec = shift; + my $add = shift eq 'add'; + + my $bits = $vec->[VEC_BITS]; + $bits = '' unless defined $bits; + + my $count = 0; + my $f; + foreach $f (@_) + { + my $fn = $vec->_fileno($f); + next unless defined $fn; + my $i = $fn + FIRST_FD; + if ($add) { + if (defined $vec->[$i]) { + $vec->[$i] = $f; # if array rest might be different, so we update + next; + } + $vec->[FD_COUNT]++; + vec($bits, $fn, 1) = 1; + $vec->[$i] = $f; + } else { # remove + next unless defined $vec->[$i]; + $vec->[FD_COUNT]--; + vec($bits, $fn, 1) = 0; + $vec->[$i] = undef; + } + $count++; + } + $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef; + $count; +} + +sub can_read +{ + my $vec = shift; + my $timeout = shift; + my $r = $vec->[VEC_BITS]; + + defined($r) && (select($r,undef,undef,$timeout) > 0) + ? handles($vec, $r) + : (); +} + +sub can_write +{ + my $vec = shift; + my $timeout = shift; + my $w = $vec->[VEC_BITS]; + + defined($w) && (select(undef,$w,undef,$timeout) > 0) + ? handles($vec, $w) + : (); +} + +sub has_error +{ + my $vec = shift; + my $timeout = shift; + my $e = $vec->[VEC_BITS]; + + defined($e) && (select(undef,undef,$e,$timeout) > 0) + ? handles($vec, $e) + : (); +} + +sub count +{ + my $vec = shift; + $vec->[FD_COUNT]; +} + +sub bits +{ + my $vec = shift; + $vec->[VEC_BITS]; +} + +sub as_string # for debugging +{ + my $vec = shift; + my $str = ref($vec) . ": "; + my $bits = $vec->bits; + my $count = $vec->count; + $str .= defined($bits) ? unpack("b*", $bits) : "undef"; + $str .= " $count"; + my @handles = @$vec; + splice(@handles, 0, FIRST_FD); + for (@handles) { + $str .= " " . (defined($_) ? "$_" : "-"); + } + $str; +} + +sub _max +{ + my($a,$b,$c) = @_; + $a > $b + ? $a > $c + ? $a + : $c + : $b > $c + ? $b + : $c; +} + +sub select +{ + shift + if defined $_[0] && !ref($_[0]); + + my($r,$w,$e,$t) = @_; + my @result = (); + + my $rb = defined $r ? $r->[VEC_BITS] : undef; + my $wb = defined $w ? $w->[VEC_BITS] : undef; + my $eb = defined $e ? $e->[VEC_BITS] : undef; + + if(select($rb,$wb,$eb,$t) > 0) + { + my @r = (); + my @w = (); + my @e = (); + my $i = _max(defined $r ? scalar(@$r)-1 : 0, + defined $w ? scalar(@$w)-1 : 0, + defined $e ? scalar(@$e)-1 : 0); + + for( ; $i >= FIRST_FD ; $i--) + { + my $j = $i - FIRST_FD; + push(@r, $r->[$i]) + if defined $rb && defined $r->[$i] && vec($rb, $j, 1); + push(@w, $w->[$i]) + if defined $wb && defined $w->[$i] && vec($wb, $j, 1); + push(@e, $e->[$i]) + if defined $eb && defined $e->[$i] && vec($eb, $j, 1); + } + + @result = (\@r, \@w, \@e); + } + @result; +} + + +sub handles +{ + my $vec = shift; + my $bits = shift; + my @h = (); + my $i; + my $max = scalar(@$vec) - 1; + + for ($i = FIRST_FD; $i <= $max; $i++) + { + next unless defined $vec->[$i]; + push(@h, $vec->[$i]) + if !defined($bits) || vec($bits, $i - FIRST_FD, 1); + } + + @h; +} + +1; diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm new file mode 100644 index 0000000000..171042cccc --- /dev/null +++ b/ext/IO/lib/IO/Socket.pm @@ -0,0 +1,707 @@ +# IO::Socket.pm +# +# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Socket; + +=head1 NAME + +IO::Socket - Object interface to socket communications + +=head1 SYNOPSIS + + use IO::Socket; + +=head1 DESCRIPTION + +C<IO::Socket> provides an object interface to creating and using sockets. It +is built upon the L<IO::Handle> interface and inherits all the methods defined +by L<IO::Handle>. + +C<IO::Socket> only defines methods for those operations which are common to all +types of socket. Operations which are specified to a socket in a particular +domain have methods defined in sub classes of C<IO::Socket> + +C<IO::Socket> will export all functions (and constants) defined by L<Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket>, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. +C<new> only looks for one key C<Domain> which tells new which domain +the socket will be in. All other arguments will be passed to the +configuration method of the package for that domain, See below. + +=back + +=head1 METHODS + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Socket> methods, which are just front ends for the +corresponding built-in functions: + + socket + socketpair + bind + listen + accept + send + recv + peername (getpeername) + sockname (getsockname) + +Some methods take slightly different arguments to those defined in L<perlfunc> +in attempt to make the interface more flexible. These are + +=over 4 + +=item accept([PKG]) + +perform the system call C<accept> on the socket and return a new object. The +new object will be created in the same class as the listen socket, unless +C<PKG> is specified. This object can be used to communicate with the client +that was trying to connect. In a scalar context the new socket is returned, +or undef upon failure. In an array context a two-element array is returned +containing the new socket and the peer address, the list will +be empty upon failure. + +Additional methods that are provided are + +=item timeout([VAL]) + +Set or get the timeout value associated with this socket. If called without +any arguments then the current setting is returned. If called with an argument +the current setting is changed and the previous value returned. + +=item sockopt(OPT [, VAL]) + +Unified method to both set and get options in the SOL_SOCKET level. If called +with one argument then getsockopt is called, otherwise setsockopt is called. + +=item sockdomain + +Returns the numerical number for the socket domain type. For example, for +a AF_INET socket the value of &AF_INET will be returned. + +=item socktype + +Returns the numerical number for the socket type. For example, for +a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. + +=item protocol + +Returns the numerical number for the protocol being used on the socket, if +known. If the protocol is unknown, as with an AF_UNIX socket, zero +is returned. + +=back + +=cut + + +require 5.000; + +use Config; +use IO::Handle; +use Socket 1.3; +use Carp; +use strict; +use vars qw(@ISA $VERSION); +use Exporter; + +@ISA = qw(IO::Handle); + +$VERSION = "1.1602"; + +sub import { + my $pkg = shift; + my $callpkg = caller; + Exporter::export 'Socket', $callpkg, @_; +} + +sub new { + my($class,%arg) = @_; + my $fh = $class->SUPER::new(); + + ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout}; + + return scalar(%arg) ? $fh->configure(\%arg) + : $fh; +} + +my @domain2pkg = (); + +sub register_domain { + my($p,$d) = @_; + $domain2pkg[$d] = $p; +} + +sub configure { + my($fh,$arg) = @_; + my $domain = delete $arg->{Domain}; + + croak 'IO::Socket: Cannot configure a generic socket' + unless defined $domain; + + croak "IO::Socket: Unsupported socket domain" + unless defined $domain2pkg[$domain]; + + croak "IO::Socket: Cannot configure socket in domain '$domain'" + unless ref($fh) eq "IO::Socket"; + + bless($fh, $domain2pkg[$domain]); + $fh->configure($arg); +} + +sub socket { + @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)'; + my($fh,$domain,$type,$protocol) = @_; + + socket($fh,$domain,$type,$protocol) or + return undef; + + ${*$fh}{'io_socket_domain'} = $domain; + ${*$fh}{'io_socket_type'} = $type; + ${*$fh}{'io_socket_proto'} = $protocol; + + $fh; +} + +sub socketpair { + @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)'; + my($class,$domain,$type,$protocol) = @_; + my $fh1 = $class->new(); + my $fh2 = $class->new(); + + socketpair($fh1,$fh1,$domain,$type,$protocol) or + return (); + + ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; + ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol; + + ($fh1,$fh2); +} + +sub connect { + @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)'; + my $fh = shift; + my $addr = @_ == 1 ? shift : sockaddr_in(@_); + my $timeout = ${*$fh}{'io_socket_timeout'}; + local($SIG{ALRM}) = $timeout ? sub { undef $fh; } + : $SIG{ALRM} || 'DEFAULT'; + + eval { + croak 'connect: Bad address' + if(@_ == 2 && !defined $_[1]); + + if($timeout) { + defined $Config{d_alarm} && defined alarm($timeout) or + $timeout = 0; + } + + my $ok = connect($fh, $addr); + + alarm(0) + if($timeout); + + croak "connect: timeout" + unless defined $fh; + + undef $fh unless $ok; + }; + + $fh; +} + +sub bind { + @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)'; + my $fh = shift; + my $addr = @_ == 1 ? shift : sockaddr_in(@_); + + return bind($fh, $addr) ? $fh + : undef; +} + +sub listen { + @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])'; + my($fh,$queue) = @_; + $queue = 5 + unless $queue && $queue > 0; + + return listen($fh, $queue) ? $fh + : undef; +} + +sub accept { + @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])'; + my $fh = shift; + my $pkg = shift || $fh; + my $timeout = ${*$fh}{'io_socket_timeout'}; + my $new = $pkg->new(Timeout => $timeout); + my $peer = undef; + + eval { + if($timeout) { + my $fdset = ""; + vec($fdset, $fh->fileno,1) = 1; + croak "accept: timeout" + unless select($fdset,undef,undef,$timeout); + } + $peer = accept($new,$fh); + }; + + return wantarray ? defined $peer ? ($new, $peer) + : () + : defined $peer ? $new + : undef; +} + +sub sockname { + @_ == 1 or croak 'usage: $fh->sockname()'; + getsockname($_[0]); +} + +sub peername { + @_ == 1 or croak 'usage: $fh->peername()'; + my($fh) = @_; + getpeername($fh) + || ${*$fh}{'io_socket_peername'} + || undef; +} + +sub send { + @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])'; + my $fh = $_[0]; + my $flags = $_[2] || 0; + my $peer = $_[3] || $fh->peername; + + croak 'send: Cannot determine peer address' + unless($peer); + + my $r = defined(getpeername($fh)) + ? send($fh, $_[1], $flags) + : send($fh, $_[1], $flags, $peer); + + # remember who we send to, if it was sucessful + ${*$fh}{'io_socket_peername'} = $peer + if(@_ == 4 && defined $r); + + $r; +} + +sub recv { + @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])'; + my $sock = $_[0]; + my $len = $_[2]; + my $flags = $_[3] || 0; + + # remember who we recv'd from + ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); +} + + +sub setsockopt { + @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)'; + setsockopt($_[0],$_[1],$_[2],$_[3]); +} + +my $intsize = length(pack("i",0)); + +sub getsockopt { + @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)'; + my $r = getsockopt($_[0],$_[1],$_[2]); + # Just a guess + $r = unpack("i", $r) + if(defined $r && length($r) == $intsize); + $r; +} + +sub sockopt { + my $fh = shift; + @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_) + : $fh->setsockopt(SOL_SOCKET,@_); +} + +sub timeout { + @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])'; + my($fh,$val) = @_; + my $r = ${*$fh}{'io_socket_timeout'} || undef; + + ${*$fh}{'io_socket_timeout'} = 0 + $val + if(@_ == 2); + + $r; +} + +sub sockdomain { + @_ == 1 or croak 'usage: $fh->sockdomain()'; + my $fh = shift; + ${*$fh}{'io_socket_domain'}; +} + +sub socktype { + @_ == 1 or croak 'usage: $fh->socktype()'; + my $fh = shift; + ${*$fh}{'io_socket_type'} +} + +sub protocol { + @_ == 1 or croak 'usage: $fh->protocol()'; + my($fh) = @_; + ${*$fh}{'io_socket_protocol'}; +} + +=head1 SUB-CLASSES + +=cut + +## +## AF_INET +## + +package IO::Socket::INET; + +use strict; +use vars qw(@ISA); +use Socket; +use Carp; +use Exporter; + +@ISA = qw(IO::Socket); + +IO::Socket::INET->register_domain( AF_INET ); + +my %socket_type = ( tcp => SOCK_STREAM, + udp => SOCK_DGRAM, + ); + +=head2 IO::Socket::INET + +C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket +and some related methods. The constructor can take the following options + + PeerAddr Remote host address <hostname>[:<port>] + PeerPort Remote port or service <service>[(<no>)] | <no> + LocalAddr Local host bind address hostname[:port] + LocalPort Local host bind port <service>[(<no>)] | <no> + Proto Protocol name "tcp" | "udp" | ... + Type Socket type SOCK_STREAM | SOCK_DGRAM | ... + Listen Queue size for listen + Reuse Set SO_REUSEADDR before binding + Timeout Timeout value for various operations + + +If C<Listen> is defined then a listen socket is created, else if the +socket type, which is derived from the protocol, is SOCK_STREAM then +connect() is called. + +The C<PeerAddr> can be a hostname or the IP-address on the +"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic +service name. The service name might be followed by a number in +parenthesis which is used if the service is not known by the system. +The C<PeerPort> specification can also be embedded in the C<PeerAddr> +by preceding it with a ":". + +Only one of C<Type> or C<Proto> needs to be specified, one will be +assumed from the other. If you specify a symbolic C<PeerPort> port, +then the constructor will try to derive C<Type> and C<Proto> from +the service name. + +Examples: + + $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', + PeerPort => 'http(80)', + Proto => 'tcp'); + + $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); + + $sock = IO::Socket::INET->new(Listen => 5, + LocalAddr => 'localhost', + LocalPort => 9000, + Proto => 'tcp'); + +=head2 METHODS + +=over 4 + +=item sockaddr () + +Return the address part of the sockaddr structure for the socket + +=item sockport () + +Return the port number that the socket is using on the local host + +=item sockhost () + +Return the address part of the sockaddr structure for the socket in a +text form xx.xx.xx.xx + +=item peeraddr () + +Return the address part of the sockaddr structure for the socket on +the peer host + +=item peerport () + +Return the port number for the socket on the peer host. + +=item peerhost () + +Return the address part of the sockaddr structure for the socket on the +peer host in a text form xx.xx.xx.xx + +=back + +=cut + +sub _sock_info { + my($addr,$port,$proto) = @_; + my @proto = (); + my @serv = (); + + $port = $1 + if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,); + + if(defined $proto) { + @proto = $proto =~ m,\D, ? getprotobyname($proto) + : getprotobynumber($proto); + + $proto = $proto[2] || undef; + } + + if(defined $port) { + $port =~ s,\((\d+)\)$,,; + + my $defport = $1 || undef; + my $pnum = ($port =~ m,^(\d+)$,)[0]; + + @serv= getservbyname($port, $proto[0] || "") + if($port =~ m,\D,); + + $port = $pnum || $serv[2] || $defport || undef; + + $proto = (getprotobyname($serv[3]))[2] || undef + if @serv && !$proto; + } + + return ($addr || undef, + $port || undef, + $proto || undef + ); +} + +sub _error { + my $fh = shift; + $@ = join("",ref($fh),": ",@_); + carp $@ if $^W; + close($fh) + if(defined fileno($fh)); + return undef; +} + +sub configure { + my($fh,$arg) = @_; + my($lport,$rport,$laddr,$raddr,$proto,$type); + + + ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, + $arg->{LocalPort}, + $arg->{Proto}); + + $laddr = defined $laddr ? inet_aton($laddr) + : INADDR_ANY; + + return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'") + unless(defined $laddr); + + unless(exists $arg->{Listen}) { + ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, + $arg->{PeerPort}, + $proto); + } + + if(defined $raddr) { + $raddr = inet_aton($raddr); + return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'") + unless(defined $raddr); + } + + return _error($fh,'Cannot determine protocol') + unless($proto); + + my $pname = (getprotobynumber($proto))[0]; + $type = $arg->{Type} || $socket_type{$pname}; + + $fh->socket(AF_INET, $type, $proto) or + return _error($fh,"$!"); + + if ($arg->{Reuse}) { + $fh->sockopt(SO_REUSEADDR,1) or + return _error($fh); + } + + $fh->bind($lport || 0, $laddr) or + return _error($fh,"$!"); + + if(exists $arg->{Listen}) { + $fh->listen($arg->{Listen} || 5) or + return _error($fh,"$!"); + } + else { + return _error($fh,'Cannot determine remote port') + unless($rport || $type == SOCK_DGRAM); + + if($type == SOCK_STREAM || defined $raddr) { + return _error($fh,'Bad peer address') + unless(defined $raddr); + + $fh->connect($rport,$raddr) or + return _error($fh,"$!"); + } + } + + $fh; +} + +sub sockaddr { + @_ == 1 or croak 'usage: $fh->sockaddr()'; + my($fh) = @_; + (sockaddr_in($fh->sockname))[1]; +} + +sub sockport { + @_ == 1 or croak 'usage: $fh->sockport()'; + my($fh) = @_; + (sockaddr_in($fh->sockname))[0]; +} + +sub sockhost { + @_ == 1 or croak 'usage: $fh->sockhost()'; + my($fh) = @_; + inet_ntoa($fh->sockaddr); +} + +sub peeraddr { + @_ == 1 or croak 'usage: $fh->peeraddr()'; + my($fh) = @_; + (sockaddr_in($fh->peername))[1]; +} + +sub peerport { + @_ == 1 or croak 'usage: $fh->peerport()'; + my($fh) = @_; + (sockaddr_in($fh->peername))[0]; +} + +sub peerhost { + @_ == 1 or croak 'usage: $fh->peerhost()'; + my($fh) = @_; + inet_ntoa($fh->peeraddr); +} + +## +## AF_UNIX +## + +package IO::Socket::UNIX; + +use strict; +use vars qw(@ISA $VERSION); +use Socket; +use Carp; +use Exporter; + +@ISA = qw(IO::Socket); + +IO::Socket::UNIX->register_domain( AF_UNIX ); + +=head2 IO::Socket::UNIX + +C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket +and some related methods. The constructor can take the following options + + Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM) + Local Path to local fifo + Peer Path to peer fifo + Listen Create a listen socket + +=head2 METHODS + +=over 4 + +=item hostpath() + +Returns the pathname to the fifo at the local end + +=item peerpath() + +Returns the pathanme to the fifo at the peer end + +=back + +=cut + +sub configure { + my($fh,$arg) = @_; + my($bport,$cport); + + my $type = $arg->{Type} || SOCK_STREAM; + + $fh->socket(AF_UNIX, $type, 0) or + return undef; + + if(exists $arg->{Local}) { + my $addr = sockaddr_un($arg->{Local}); + $fh->bind($addr) or + return undef; + } + if(exists $arg->{Listen}) { + $fh->listen($arg->{Listen} || 5) or + return undef; + } + elsif(exists $arg->{Peer}) { + my $addr = sockaddr_un($arg->{Peer}); + $fh->connect($addr) or + return undef; + } + + $fh; +} + +sub hostpath { + @_ == 1 or croak 'usage: $fh->hostpath()'; + my $n = $_[0]->sockname || return undef; + (sockaddr_un($n))[0]; +} + +sub peerpath { + @_ == 1 or croak 'usage: $fh->peerpath()'; + my $n = $_[0]->peername || return undef; + (sockaddr_un($n))[0]; +} + +=head1 SEE ALSO + +L<Socket>, L<IO::Handle> + +=head1 AUTHOR + +Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> + +=head1 COPYRIGHT + +Copyright (c) 1996 Graham Barr. All rights reserved. This program is free +software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=cut + +1; # Keep require happy diff --git a/ext/NDBM_File/NDBM_File.pm b/ext/NDBM_File/NDBM_File.pm index 6072e651fc..47b1f5aa3c 100644 --- a/ext/NDBM_File/NDBM_File.pm +++ b/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/ext/NDBM_File/hints/dec_osf.pl b/ext/NDBM_File/hints/dec_osf.pl new file mode 100644 index 0000000000..e96d907e10 --- /dev/null +++ b/ext/NDBM_File/hints/dec_osf.pl @@ -0,0 +1,2 @@ +# Spider Boardman <spider@Orb.Nashua.NH.US> +$self->{LIBS} = ['']; diff --git a/ext/NDBM_File/hints/dynixptx.pl b/ext/NDBM_File/hints/dynixptx.pl new file mode 100644 index 0000000000..d402c17901 --- /dev/null +++ b/ext/NDBM_File/hints/dynixptx.pl @@ -0,0 +1,3 @@ +# On DYNIX/ptx 4.0 (v4.1.3), ndbm is actually contained in the +# libc library, and must be explicitly linked against -lc when compiling. +$self->{LIBS} = ['-lc']; diff --git a/ext/ODBM_File/ODBM_File.pm b/ext/ODBM_File/ODBM_File.pm index e5386e853b..923640ff34 100644 --- a/ext/ODBM_File/ODBM_File.pm +++ b/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/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs index c1b405ff89..d23b318e0d 100644 --- a/ext/ODBM_File/ODBM_File.xs +++ b/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) { diff --git a/ext/ODBM_File/hints/dec_osf.pl b/ext/ODBM_File/hints/dec_osf.pl index f041bf96c0..febb7cdb21 100644 --- a/ext/ODBM_File/hints/dec_osf.pl +++ b/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/ext/ODBM_File/hints/hpux.pl b/ext/ODBM_File/hints/hpux.pl new file mode 100644 index 0000000000..31f9d24bca --- /dev/null +++ b/ext/ODBM_File/hints/hpux.pl @@ -0,0 +1,4 @@ +# Try to work around "bad free" messages. See note in ODBM_File.xs. +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# Sun Sep 8 12:57:52 EDT 1996 +$self->{CCFLAGS} = $Config{ccflags} . ' -DDBM_BUG_DUPLICATE_FREE' ; diff --git a/ext/ODBM_File/hints/ultrix.pl b/ext/ODBM_File/hints/ultrix.pl new file mode 100644 index 0000000000..31f9d24bca --- /dev/null +++ b/ext/ODBM_File/hints/ultrix.pl @@ -0,0 +1,4 @@ +# Try to work around "bad free" messages. See note in ODBM_File.xs. +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# Sun Sep 8 12:57:52 EDT 1996 +$self->{CCFLAGS} = $Config{ccflags} . ' -DDBM_BUG_DUPLICATE_FREE' ; diff --git a/ext/Opcode/Makefile.PL b/ext/Opcode/Makefile.PL new file mode 100644 index 0000000000..7fdcdf6ac1 --- /dev/null +++ b/ext/Opcode/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'Opcode', + MAN3PODS => ' ', + VERSION_FROM => 'Opcode.pm', + XS_VERSION => '1.02' +); diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm new file mode 100644 index 0000000000..a35ad1b47b --- /dev/null +++ b/ext/Opcode/Opcode.pm @@ -0,0 +1,569 @@ +package Opcode; + +require 5.002; + +use vars qw($VERSION $XS_VERSION @ISA @EXPORT_OK); + +$VERSION = "1.04"; +$XS_VERSION = "1.02"; + +use strict; +use Carp; +use Exporter (); +use DynaLoader (); +@ISA = qw(Exporter DynaLoader); + +BEGIN { + @EXPORT_OK = qw( + opset ops_to_opset + opset_to_ops opset_to_hex invert_opset + empty_opset full_opset + opdesc opcodes opmask define_optag + opmask_add verify_opset opdump + ); +} + +sub opset (;@); +sub opset_to_hex ($); +sub opdump (;$); +use subs @EXPORT_OK; + +bootstrap Opcode $XS_VERSION; + +_init_optags(); + +sub ops_to_opset { opset @_ } # alias for old name + +sub opset_to_hex ($) { + return "(invalid opset)" unless verify_opset($_[0]); + unpack("h*",$_[0]); +} + +sub opdump (;$) { + my $pat = shift; + # handy utility: perl -MOpcode=opdump -e 'opdump File' + foreach(opset_to_ops(full_opset)) { + my $op = sprintf " %12s %s\n", $_, opdesc($_); + next if defined $pat and $op !~ m/$pat/i; + print $op; + } +} + + + +sub _init_optags { + my(%all, %seen); + @all{opset_to_ops(full_opset)} = (); # keys only + + local($_); + local($/) = "\n=cut"; # skip to optags definition section + <DATA>; + $/ = "\n="; # now read in 'pod section' chunks + while(<DATA>) { + next unless m/^item\s+(:\w+)/; + my $tag = $1; + + # Split into lines, keep only indented lines + my @lines = grep { m/^\s/ } split(/\n/); + foreach (@lines) { s/--.*// } # delete comments + my @ops = map { split ' ' } @lines; # get op words + + foreach(@ops) { + warn "$tag - $_ already tagged in $seen{$_}\n" if $seen{$_}; + $seen{$_} = $tag; + delete $all{$_}; + } + # opset will croak on invalid names + define_optag($tag, opset(@ops)); + } + close(DATA); + warn "Untagged opnames: ".join(' ',keys %all)."\n" if %all; +} + + +1; + +__DATA__ + +=head1 NAME + +Opcode - Disable named opcodes when compiling perl code + +=head1 SYNOPSIS + + use Opcode; + + +=head1 DESCRIPTION + +Perl code is always 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. +The internal format is based on many distinct I<opcodes>. + +By default no opmask is in effect and any code can be compiled. + +The Opcode module allow you to define an I<operator mask> to be in +effect when perl I<next> compiles any code. Attempting to compile code +which contains a masked opcode will cause the compilation to fail +with an error. The code will not be executed. + +=head1 NOTE + +The Opcode module is not usually used directly. See the ops pragma and +Safe modules for more typical uses. + +=head1 WARNING + +The authors make B<no warranty>, implied or otherwise, about the +suitability of this software for safety or security purposes. + +The authors shall not in any case be liable for special, incidental, +consequential, indirect or other similar damages arising from the use +of this software. + +Your mileage will vary. If in any doubt B<do not use it>. + + +=head1 Operator Names and Operator Lists + +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 (and installed into the perl library). + +Each operator has both a terse name (its opname) and a more verbose or +recognisable descriptive name. The opdesc function can be used to +return a list of descriptions for a list of operators. + +Many of the functions and methods listed below take a list of +operators as parameters. Most operator lists can be made up of several +types of element. Each element can be one of + +=over 8 + +=item an operator name (opname) + +Operator names are typically small lowercase words like enterloop, +leaveloop, last, next, redo etc. Sometimes they are rather cryptic +like gv2cv, i_ncmp and ftsvtx. + +=item an operator tag name (optag) + +Operator tags can be used to refer to groups (or sets) of operators. +Tag names always being with a colon. The Opcode module defines several +optags and the user can define others using the define_optag function. + +=item a negated opname or optag + +An opname or optag can be prefixed with an exclamation mark, e.g., !mkdir. +Negating an opname or optag means remove the corresponding ops from the +accumulated set of ops at that point. + +=item an operator set (opset) + +An I<opset> as a binary string of approximately 43 bytes which holds a +set or zero or more operators. + +The opset and opset_to_ops functions can be used to convert from +a list of operators to an opset and I<vice versa>. + +Wherever a list of operators can be given you can use one or more opsets. +See also Manipulating Opsets below. + +=back + + +=head1 Opcode Functions + +The Opcode package contains functions for manipulating operator names +tags and sets. All are available for export by the package. + +=over 8 + +=item opcodes + +In a scalar context opcodes returns the number of opcodes in this +version of perl (around 340 for perl5.002). + +In a list context it returns a list of all the operator names. +(Not yet implemented, use @names = opset_to_ops(full_opset).) + +=item opset (OP, ...) + +Returns an opset containing the listed operators. + +=item opset_to_ops (OPSET) + +Returns a list of operator names corresponding to those operators in +the set. + +=item opset_to_hex (OPSET) + +Returns a string representation of an opset. Can be handy for debugging. + +=item full_opset + +Returns an opset which includes all operators. + +=item empty_opset + +Returns an opset which contains no operators. + +=item invert_opset (OPSET) + +Returns an opset which is the inverse set of the one supplied. + +=item verify_opset (OPSET, ...) + +Returns true if the supplied opset looks like a valid opset (is the +right length etc) otherwise it returns false. If an optional second +parameter is true then verify_opset will croak on an invalid opset +instead of returning false. + +Most of the other Opcode functions call verify_opset automatically +and will croak if given an invalid opset. + +=item define_optag (OPTAG, OPSET) + +Define OPTAG as a symbolic name for OPSET. Optag names always start +with a colon C<:>. + +The optag name used must not be defined already (define_optag will +croak if it is already defined). Optag names are global to the perl +process and optag definitions cannot be altered or deleted once +defined. + +It is strongly recommended that applications using Opcode should use a +leading capital letter on their tag names since lowercase names are +reserved for use by the Opcode module. If using Opcode within a module +you should prefix your tags names with the name of your module to +ensure uniqueness and thus avoid clashes with other modules. + +=item opmask_add (OPSET) + +Adds the supplied opset to the current opmask. Note that there is +currently I<no> mechanism for unmasking ops once they have been masked. +This is intentional. + +=item opmask + +Returns an opset corresponding to the current opmask. + +=item opdesc (OP, ...) + +This takes a list of operator names and returns the corresponding list +of operator descriptions. + +=item opdump (PAT) + +Dumps to STDOUT a two column list of op names and op descriptions. +If an optional pattern is given then only lines which match the +(case insensitive) pattern will be output. + +It's designed to be used as a handy command line utility: + + perl -MOpcode=opdump -e opdump + perl -MOpcode=opdump -e 'opdump Eval' + +=back + +=head1 Manipulating Opsets + +Opsets may be manipulated using the perl bit vector operators & (and), | (or), +^ (xor) and ~ (negate/invert). + +However you should never rely on the numerical position of any opcode +within the opset. In other words both sides of a bit vector operator +should be opsets returned from Opcode functions. + +Also, since the number of opcodes in your current version of perl might +not be an exact multiple of eight, there may be unused bits in the last +byte of an upset. This should not cause any problems (Opcode functions +ignore those extra bits) but it does mean that using the ~ operator +will typically not produce the same 'physical' opset 'string' as the +invert_opset function. + + +=head1 TO DO (maybe) + + $bool = opset_eq($opset1, $opset2) true if opsets are logically eqiv + + $yes = opset_can($opset, @ops) true if $opset has all @ops set + + @diff = opset_diff($opset1, $opset2) => ('foo', '!bar', ...) + +=cut + +# the =cut above is used by _init_optags() to get here quickly + +=head1 Predefined Opcode Tags + +=over 5 + +=item :base_core + + null stub scalar pushmark wantarray const defined undef + + rv2sv sassign + + rv2av aassign aelem aelemfast aslice av2arylen + + rv2hv helem hslice each values keys exists delete + + preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec + int hex oct abs pow multiply i_multiply divide i_divide + modulo i_modulo add i_add subtract i_subtract + + left_shift right_shift bit_and bit_xor bit_or negate i_negate + not complement + + 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 + + substr vec stringify study pos length index rindex ord chr + + ucfirst lcfirst uc lc quotemeta trans chop schop chomp schomp + + match split + + list lslice splice push pop shift unshift reverse + + cond_expr flip flop andassign orassign and or xor + + warn die lineseq nextstate unstack scope enter leave + + rv2cv anoncode prototype + + entersub leavesub return method -- XXX loops via recursion? + + leaveeval -- needed for Safe to operate, is safe without entereval + +=item :base_mem + +These memory related ops are not included in :base_core because they +can easily be used to implement a resource attack (e.g., consume all +available memory). + + concat repeat join range + + anonlist anonhash + +Note that despite the existance of this optag a memory resource attack +may still be possible using only :base_core ops. + +Disabling these ops is a I<very> heavy handed way to attempt to prevent +a memory resource attack. It's probable that a specific memory limit +mechanism will be added to perl in the near future. + +=item :base_loop + +These loop ops are not included in :base_core because they can easily be +used to implement a resource attack (e.g., consume all available CPU time). + + grepstart grepwhile + mapstart mapwhile + enteriter iter + enterloop leaveloop + last next redo + goto + +=item :base_io + +These ops enable I<filehandle> (rather than filename) based input and +output. These are safe on the assumption that only pre-existing +filehandles are available for use. To create new filehandles other ops +such as open would need to be enabled. + + readline rcatline getc read + + formline enterwrite leavewrite + + print sysread syswrite send recv + + eof tell seek sysseek + + readdir telldir seekdir rewinddir + +=item :base_orig + +These are a hotchpotch of opcodes still waiting to be considered + + gvsv gv gelem + + padsv padav padhv padany + + rv2gv refgen srefgen ref + + bless -- could be used to change ownership of objects (reblessing) + + pushre regcmaybe regcomp subst substcont + + sprintf prtf -- can core dump + + crypt + + tie untie + + dbmopen dbmclose + sselect select + pipe_op sockpair + + getppid getpgrp setpgrp getpriority setpriority localtime gmtime + + entertry leavetry -- can be used to 'hide' fatal errors + +=item :base_math + +These ops are not included in :base_core because of the risk of them being +used to generate floating point exceptions (which would have to be caught +using a $SIG{FPE} handler). + + atan2 sin cos exp log sqrt + +These ops are not included in :base_core because they have an effect +beyond the scope of the compartment. + + rand srand + +=item :default + +A handy tag name for a I<reasonable> default set of ops. (The current ops +allowed are unstable while development continues. It will change.) + + :base_core :base_mem :base_loop :base_io :base_orig + +If safety matters to you (and why else would you be using the Opcode module?) +then you should not rely on the definition of this, or indeed any other, optag! + + +=item :filesys_read + + stat lstat readlink + + ftatime ftblk ftchr ftctime ftdir fteexec fteowned fteread + ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned + ftrread ftsgid ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx + + fttext ftbinary + + fileno + +=item :sys_db + + ghbyname ghbyaddr ghostent shostent ehostent -- hosts + gnbyname gnbyaddr gnetent snetent enetent -- networks + gpbyname gpbynumber gprotoent sprotoent eprotoent -- protocols + gsbyname gsbyport gservent sservent eservent -- services + + gpwnam gpwuid gpwent spwent epwent getlogin -- users + ggrnam ggrgid ggrent sgrent egrent -- groups + +=item :browse + +A handy tag name for a I<reasonable> default set of ops beyond the +:default optag. Like :default (and indeed all the other optags) its +current definition is unstable while development continues. It will change. + +The :browse tag represents the next step beyond :default. It it a +superset of the :default ops and adds :filesys_read the :sys_db. +The intent being that scripts can access more (possibly sensitive) +information about your system but not be able to change it. + + :default :filesys_read :sys_db + +=item :filesys_open + + sysopen open close + umask binmode + + open_dir closedir -- other dir ops are in :base_io + +=item :filesys_write + + link unlink rename symlink truncate + + mkdir rmdir + + utime chmod chown + + fcntl -- not strictly filesys related, but possibly as dangerous? + +=item :subprocess + + backtick system + + fork + + wait waitpid + + glob -- access to Cshell via <`rm *`> + +=item :ownprocess + + exec exit kill + + time tms -- could be used for timing attacks (paranoid?) + +=item :others + +This tag holds groups of assorted specialist opcodes that don't warrant +having optags defined for them. + +SystemV Interprocess Communications: + + msgctl msgget msgrcv msgsnd + + semctl semget semop + + shmctl shmget shmread shmwrite + +=item :still_to_be_decided + + chdir + flock ioctl + + socket getpeername ssockopt + bind connect listen accept shutdown gsockopt getsockname + + sleep alarm -- changes global timer state and signal handling + sort -- assorted problems including core dumps + tied -- can be used to access object implementing a tie + pack unpack -- can be used to create/use memory pointers + + entereval -- can be used to hide code from initial compile + require dofile + + caller -- get info about calling environment and args + + reset + + dbstate -- perl -d version of nextstate(ment) opcode + +=item :dangerous + +This tag is simply a bucket for opcodes that are unlikely to be used via +a tag name but need to be tagged for completness and documentation. + + syscall dump chroot + + +=back + +=head1 SEE ALSO + +ops(3) -- perl pragma interface to Opcode module. + +Safe(3) -- Opcode and namespace limited execution compartments + +=head1 AUTHORS + +Originally designed and implemented by Malcolm Beattie, +mbeattie@sable.ox.ac.uk as part of Safe version 1. + +Split out from Safe module version 1, named opcode tags and other +changes added by Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>. + +=cut + diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs new file mode 100644 index 0000000000..9d4b726536 --- /dev/null +++ b/ext/Opcode/Opcode.xs @@ -0,0 +1,472 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* maxo shouldn't differ from MAXO but leave room anyway (see BOOT:) */ +#define OP_MASK_BUF_SIZE (MAXO + 100) + +static HV *op_named_bits; /* cache shared for whole process */ +static SV *opset_all; /* mask with all bits set */ +static IV opset_len; /* length of opmasks in bytes */ +static int opcode_debug = 0; + +static SV *new_opset _((SV *old_opset)); +static int verify_opset _((SV *opset, int fatal)); +static void set_opset_bits _((char *bitmap, SV *bitspec, int on, char *opname)); +static void put_op_bitspec _((char *optag, STRLEN len, SV *opset)); +static SV *get_op_bitspec _((char *opname, STRLEN len, int fatal)); + + +/* Initialise our private op_named_bits HV. + * It is first loaded with the name and number of each perl operator. + * Then the builtin tags :none and :all are added. + * Opcode.pm loads the standard optags from __DATA__ + */ + +static void +op_names_init() +{ + int i; + STRLEN len; + char *opname; + char *bitmap; + + op_named_bits = newHV(); + for(i=0; i < maxo; ++i) { + hv_store(op_named_bits, op_name[i],strlen(op_name[i]), + Sv=newSViv(i), 0); + SvREADONLY_on(Sv); + } + + put_op_bitspec(":none",0, sv_2mortal(new_opset(Nullsv))); + + opset_all = new_opset(Nullsv); + bitmap = SvPV(opset_all, len); + i = len-1; /* deal with last byte specially, see below */ + while(i-- > 0) + bitmap[i] = 0xFF; + /* Take care to set the right number of bits in the last byte */ + bitmap[len-1] = (maxo & 0x07) ? ~(0xFF << (maxo & 0x07)) : 0xFF; + put_op_bitspec(":all",0, opset_all); /* don't mortalise */ +} + + +/* Store a new tag definition. Always a mask. + * The tag must not already be defined. + * SV *mask is copied not referenced. + */ + +static void +put_op_bitspec(optag, len, mask) + char *optag; + STRLEN len; + SV *mask; +{ + SV **svp; + verify_opset(mask,1); + if (!len) + len = strlen(optag); + svp = hv_fetch(op_named_bits, optag, len, 1); + if (SvOK(*svp)) + croak("Opcode tag \"%s\" already defined", optag); + sv_setsv(*svp, mask); + SvREADONLY_on(*svp); +} + + + +/* Fetch a 'bits' entry for an opname or optag (IV/PV). + * Note that we return the actual entry for speed. + * Always sv_mortalcopy() if returing it to user code. + */ + +static SV * +get_op_bitspec(opname, len, fatal) + char *opname; + STRLEN len; + int fatal; +{ + SV **svp; + if (!len) + len = strlen(opname); + svp = hv_fetch(op_named_bits, opname, len, 0); + if (!svp || !SvOK(*svp)) { + if (!fatal) + return Nullsv; + if (*opname == ':') + croak("Unknown operator tag \"%s\"", opname); + if (*opname == '!') /* XXX here later, or elsewhere? */ + croak("Can't negate operators here (\"%s\")", opname); + if (isALPHA(*opname)) + croak("Unknown operator name \"%s\"", opname); + croak("Unknown operator prefix \"%s\"", opname); + } + return *svp; +} + + + +static SV * +new_opset(old_opset) + SV *old_opset; +{ + SV *opset; + if (old_opset) { + verify_opset(old_opset,1); + opset = newSVsv(old_opset); + } + else { + opset = newSV(opset_len); + Zero(SvPVX(opset), opset_len + 1, char); + SvCUR_set(opset, opset_len); + (void)SvPOK_only(opset); + } + /* not mortalised here */ + return opset; +} + + +static int +verify_opset(opset, fatal) + SV *opset; + int fatal; +{ + char *err = Nullch; + if (!SvOK(opset)) err = "undefined"; + else if (!SvPOK(opset)) err = "wrong type"; + else if (SvCUR(opset) != opset_len) err = "wrong size"; + if (err && fatal) { + croak("Invalid opset: %s", err); + } + return !err; +} + + +static void +set_opset_bits(bitmap, bitspec, on, opname) + char *bitmap; + SV *bitspec; + int on; + char *opname; +{ + if (SvIOK(bitspec)) { + int myopcode = SvIV(bitspec); + int offset = myopcode >> 3; + int bit = myopcode & 0x07; + if (myopcode >= maxo || myopcode < 0) + croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode); + if (opcode_debug >= 2) + warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n", + myopcode, offset, bit, opname, (on)?"on":"off"); + if (on) + bitmap[offset] |= 1 << bit; + else + bitmap[offset] &= ~(1 << bit); + } + else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { + + STRLEN len; + char *specbits = SvPV(bitspec, len); + if (opcode_debug >= 2) + warn("set_opset_bits opset %s %s\n", opname, (on)?"on":"off"); + if (on) + while(len-- > 0) bitmap[len] |= specbits[len]; + else + while(len-- > 0) bitmap[len] &= ~specbits[len]; + } + else + croak("panic: invalid bitspec for \"%s\" (type %u)", + opname, (unsigned)SvTYPE(bitspec)); +} + + +static void +opmask_add(opset) /* THE ONLY FUNCTION TO EDIT op_mask ITSELF */ + SV *opset; +{ + int i,j; + char *bitmask; + STRLEN len; + int myopcode = 0; + + verify_opset(opset,1); /* croaks on bad opset */ + + if (!op_mask) /* caller must ensure op_mask exists */ + croak("Can't add to uninitialised op_mask"); + + /* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal() */ + + bitmask = SvPV(opset, len); + for (i=0; i < opset_len; i++) { + U16 bits = bitmask[i]; + if (!bits) { /* optimise for sparse masks */ + myopcode += 8; + continue; + } + for (j=0; j < 8 && myopcode < maxo; ) + op_mask[myopcode++] |= bits & (1 << j++); + } +} + +static void +opmask_addlocal(opset, op_mask_buf) /* Localise op_mask then opmask_add() */ + SV *opset; + char *op_mask_buf; +{ + char *orig_op_mask = op_mask; + SAVEPPTR(op_mask); + if (opcode_debug >= 2) + SAVEDESTRUCTOR((void(*)_((void*)))warn,"op_mask restored"); + op_mask = &op_mask_buf[0]; + if (orig_op_mask) + Copy(orig_op_mask, op_mask, maxo, char); + else + Zero(op_mask, maxo, char); + opmask_add(opset); +} + + + +MODULE = Opcode PACKAGE = Opcode + +PROTOTYPES: ENABLE + +BOOT: + assert(maxo < OP_MASK_BUF_SIZE); + opset_len = (maxo + 7) / 8; + if (opcode_debug >= 1) + warn("opset_len %ld\n", (long)opset_len); + op_names_init(); + + +void +_safe_call_sv(package, mask, codesv) + char * package + SV * mask + SV * codesv + PPCODE: + char op_mask_buf[OP_MASK_BUF_SIZE]; + GV *gv; + + ENTER; + + opmask_addlocal(mask, op_mask_buf); + + save_aptr(&endav); + endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */ + + save_hptr(&defstash); /* save current default stack */ + /* the assignment to global defstash changes our sense of 'main' */ + defstash = gv_stashpv(package, GV_ADDWARN); /* should exist already */ + + /* defstash must itself contain a main:: so we'll add that now */ + /* take care with the ref counts (was cause of long standing bug) */ + /* XXX I'm still not sure if this is right, GV_ADDWARN should warn! */ + gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV); + sv_free((SV*)GvHV(gv)); + GvHV(gv) = (HV*)SvREFCNT_inc(defstash); + + PUSHMARK(sp); + perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */ + SPAGAIN; /* for the PUTBACK added by xsubpp */ + LEAVE; + + +int +verify_opset(opset, fatal = 0) + SV *opset + int fatal + + +void +invert_opset(opset) + SV *opset + CODE: + { + char *bitmap; + STRLEN len = opset_len; + opset = new_opset(opset); /* verify and clone opset */ + bitmap = SvPVX(opset); + while(len-- > 0) + bitmap[len] = ~bitmap[len]; + /* take care of extra bits beyond maxo in last byte */ + if (maxo & 07) + bitmap[opset_len-1] &= ~(0xFF << (maxo & 0x07)); + } + ST(0) = opset; + + +void +opset_to_ops(opset, desc = 0) + SV *opset + int desc + PPCODE: + { + STRLEN len; + int i, j, myopcode; + char *bitmap = SvPV(opset, len); + char **names = (desc) ? op_desc : op_name; + verify_opset(opset,1); + for (myopcode=0, i=0; i < opset_len; i++) { + U16 bits = bitmap[i]; + for (j=0; j < 8 && myopcode < maxo; j++, myopcode++) { + if ( bits & (1 << j) ) + XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0))); + } + } + } + + +void +opset(...) + CODE: + int i, j; + SV *bitspec, *opset; + char *bitmap; + STRLEN len, on; + opset = new_opset(Nullsv); + bitmap = SvPVX(opset); + for (i = 0; i < items; i++) { + char *opname; + on = 1; + if (verify_opset(ST(i),0)) { + opname = "(opset)"; + bitspec = ST(i); + } + else { + opname = SvPV(ST(i), len); + if (*opname == '!') { on=0; ++opname;--len; } + bitspec = get_op_bitspec(opname, len, 1); + } + set_opset_bits(bitmap, bitspec, on, opname); + } + ST(0) = opset; + + +#define PERMITING (ix == 0 || ix == 1) +#define ONLY_THESE (ix == 0 || ix == 2) + +void +permit_only(safe, ...) + SV *safe + ALIAS: + permit = 1 + deny_only = 2 + deny = 3 + CODE: + int i, on; + SV *bitspec, *mask; + char *bitmap, *opname; + STRLEN len; + + if (!SvROK(safe) || !SvOBJECT(SvRV(safe)) || SvTYPE(SvRV(safe))!=SVt_PVHV) + croak("Not a Safe object"); + mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1); + if (ONLY_THESE) /* *_only = new mask, else edit current */ + sv_setsv(mask, new_opset(PERMITING ? opset_all : Nullsv)); + else verify_opset(mask,1); /* croaks */ + bitmap = SvPVX(mask); + for (i = 1; i < items; i++) { + on = PERMITING ? 0 : 1; /* deny = mask bit on */ + if (verify_opset(ST(i),0)) { /* it's a valid mask */ + opname = "(opset)"; + bitspec = ST(i); + } + else { /* it's an opname/optag */ + opname = SvPV(ST(i), len); + /* invert if op has ! prefix (only one allowed) */ + if (*opname == '!') { on = !on; ++opname; --len; } + bitspec = get_op_bitspec(opname, len, 1); /* croaks */ + } + set_opset_bits(bitmap, bitspec, on, opname); + } + ST(0) = &sv_yes; + + + +void +opdesc(...) + PPCODE: + int i, myopcode; + STRLEN len; + SV **args; + /* copy args to a scratch area since we may push output values onto */ + /* the stack faster than we read values off it if masks are used. */ + args = (SV**)SvPVX(sv_2mortal(newSVpv((char*)&ST(0), items*sizeof(SV*)))); + for (i = 0; i < items; i++) { + char *opname = SvPV(args[i], len); + SV *bitspec = get_op_bitspec(opname, len, 1); + if (SvIOK(bitspec)) { + myopcode = SvIV(bitspec); + if (myopcode < 0 || myopcode >= maxo) + croak("panic: opcode %d (%s) out of range",myopcode,opname); + XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); + } + else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) { + int b, j; + char *bitmap = SvPV(bitspec,na); + myopcode = 0; + for (b=0; b < opset_len; b++) { + U16 bits = bitmap[b]; + for (j=0; j < 8 && myopcode < maxo; j++, myopcode++) + if (bits & (1 << j)) + XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0))); + } + } + else + croak("panic: invalid bitspec for \"%s\" (type %u)", + opname, (unsigned)SvTYPE(bitspec)); + } + + +void +define_optag(optagsv, mask) + SV *optagsv + SV *mask + CODE: + STRLEN len; + char *optag = SvPV(optagsv, len); + put_op_bitspec(optag, len, mask); /* croaks */ + ST(0) = &sv_yes; + + +void +empty_opset() + CODE: + ST(0) = sv_2mortal(new_opset(Nullsv)); + +void +full_opset() + CODE: + ST(0) = sv_2mortal(new_opset(opset_all)); + +void +opmask_add(opset) + SV *opset + PREINIT: + if (!op_mask) + Newz(0, op_mask, maxo, char); + +void +opcodes() + PPCODE: + if (GIMME == G_ARRAY) { + croak("opcodes in list context not yet implemented"); /* XXX */ + } + else { + XPUSHs(sv_2mortal(newSViv(maxo))); + } + +void +opmask() + CODE: + ST(0) = sv_2mortal(new_opset(Nullsv)); + if (op_mask) { + char *bitmap = SvPVX(ST(0)); + int myopcode; + for(myopcode=0; myopcode < maxo; ++myopcode) { + if (op_mask[myopcode]) + bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07); + } + } + diff --git a/ext/Opcode/Safe.pm b/ext/Opcode/Safe.pm new file mode 100644 index 0000000000..c9d741647e --- /dev/null +++ b/ext/Opcode/Safe.pm @@ -0,0 +1,555 @@ +package Safe; + +use 5.003_11; +use strict; +use vars qw($VERSION); + +$VERSION = "2.06"; + +use Carp; + +use Opcode 1.01, qw( + opset opset_to_ops opmask_add + empty_opset full_opset invert_opset verify_opset + opdesc opcodes opmask define_optag opset_to_hex +); + +*ops_to_opset = \&opset; # Temporary alias for old Penguins + + +my $default_root = 0; +my $default_share = ['*_']; #, '*main::']; + +sub new { + my($class, $root, $mask) = @_; + my $obj = {}; + bless $obj, $class; + + if (defined($root)) { + croak "Can't use \"$root\" as root name" + if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/; + $obj->{Root} = $root; + $obj->{Erase} = 0; + } + else { + $obj->{Root} = "Safe::Root".$default_root++; + $obj->{Erase} = 1; + } + + # use permit/deny methods instead till interface issues resolved + # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...; + croak "Mask parameter to new no longer supported" if defined $mask; + $obj->permit_only(':default'); + + # 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->share_from('main', $default_share); + return $obj; +} + +sub DESTROY { + my $obj = shift; + $obj->erase if $obj->{Erase}; +} + +sub erase { + my $obj= shift; + my $pkg = $obj->root(); + my ($stem, $leaf); + + no strict 'refs'; + $pkg = "main::$pkg\::"; # expand to full symbol table name + ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + + # The 'my $foo' is needed! Without it you get an + # 'Attempt to free unreferenced scalar' warning! + my $stem_symtab = *{$stem}{HASH}; + + #warn "erase($pkg) stem=$stem, leaf=$leaf"; + #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n"; + # ", join(', ', %$stem_symtab),"\n"; + + delete $stem_symtab->{$leaf}; + +# my $leaf_glob = $stem_symtab->{$leaf}; +# my $leaf_symtab = *{$leaf_glob}{HASH}; +# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n"; +# %$leaf_symtab = (); + #delete $leaf_symtab->{'__ANON__'}; + #delete $leaf_symtab->{'foo'}; + #delete $leaf_symtab->{'main::'}; +# my $foo = undef ${"$stem\::"}{"$leaf\::"}; + + $obj->share_from('main', $default_share); + 1; +} + + +sub reinit { + my $obj= shift; + $obj->erase; + $obj->share_redo; +} + +sub root { + my $obj = shift; + croak("Safe root method now read-only") if @_; + return $obj->{Root}; +} + + +sub mask { + my $obj = shift; + return $obj->{Mask} unless @_; + $obj->deny_only(@_); +} + +# v1 compatibility methods +sub trap { shift->deny(@_) } +sub untrap { shift->permit(@_) } + +sub deny { + my $obj = shift; + $obj->{Mask} |= opset(@_); +} +sub deny_only { + my $obj = shift; + $obj->{Mask} = opset(@_); +} + +sub permit { + my $obj = shift; + # XXX needs testing + $obj->{Mask} &= invert_opset opset(@_); +} +sub permit_only { + my $obj = shift; + $obj->{Mask} = invert_opset opset(@_); +} + + +sub dump_mask { + my $obj = shift; + print opset_to_hex($obj->{Mask}),"\n"; +} + + + +sub share { + my($obj, @vars) = @_; + $obj->share_from(scalar(caller), \@vars); +} + +sub share_from { + my $obj = shift; + my $pkg = shift; + my $vars = shift; + my $no_record = shift || 0; + my $root = $obj->root(); + croak("vars not an array ref") unless ref $vars eq 'ARRAY'; + no strict 'refs'; + # Check that 'from' package actually exists + croak("Package \"$pkg\" does not exist") + unless keys %{"$pkg\::"}; + my $arg; + foreach $arg (@$vars) { + # catch some $safe->share($var) errors: + croak("'$arg' not a valid symbol table name") + unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/ + or $arg =~ /^\$\W$/; + my ($var, $type); + $type = $1 if ($var = $arg) =~ s/^(\W)//; + # warn "share_from $pkg $type $var"; + *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"} + : ($type eq '&') ? \&{$pkg."::$var"} + : ($type eq '$') ? \${$pkg."::$var"} + : ($type eq '@') ? \@{$pkg."::$var"} + : ($type eq '%') ? \%{$pkg."::$var"} + : ($type eq '*') ? *{$pkg."::$var"} + : croak(qq(Can't share "$type$var" of unknown type)); + } + $obj->share_record($pkg, $vars) unless $no_record or !$vars; +} + +sub share_record { + my $obj = shift; + my $pkg = shift; + my $vars = shift; + my $shares = \%{$obj->{Shares} ||= {}}; + # Record shares using keys of $obj->{Shares}. See reinit. + @{$shares}{@$vars} = ($pkg) x @$vars if @$vars; +} +sub share_redo { + my $obj = shift; + my $shares = \%{$obj->{Shares} ||= {}}; + my($var, $pkg); + while(($var, $pkg) = each %$shares) { + # warn "share_redo $pkg\:: $var"; + $obj->share_from($pkg, [ $var ], 1); + } +} +sub share_forget { + delete shift->{Shares}; +} + +sub varglob { + my ($obj, $var) = @_; + no strict 'refs'; + return *{$obj->root()."::$var"}; +} + + +sub reval { + my ($obj, $expr, $strict) = @_; + my $root = $obj->{Root}; + + # Create anon sub ref in root of compartment. + # Uses a closure (on $expr) to pass in the code to be executed. + # (eval on one line to keep line numbers as expected by caller) + my $evalcode = sprintf('package %s; sub { eval $expr; }', $root); + my $evalsub; + + if ($strict) { use strict; $evalsub = eval $evalcode; } + else { no strict; $evalsub = eval $evalcode; } + + return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); +} + +sub rdo { + my ($obj, $file) = @_; + my $root = $obj->{Root}; + + my $evalsub = eval + sprintf('package %s; sub { do $file }', $root); + return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); +} + + +1; + +__DATA__ + +=head1 NAME + +Safe - Compile and execute code in restricted compartments + +=head1 SYNOPSIS + + use Safe; + + $compartment = new Safe; + + $compartment->permit(qw(time sort :browse)); + + $result = $compartment->reval($unsafe_code); + +=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 I<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 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. + +The default operator mask for a newly created compartment is +the ':default' optag. + +It is important that you read the Opcode(3) module documentation +for more information, especially for detailed definitions of opnames, +optags and opsets. + +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 + + +=head1 WARNING + +The authors make B<no warranty>, implied or otherwise, about the +suitability of this software for safety or security purposes. + +The authors shall not in any case be liable for special, incidental, +consequential, indirect or other similar damages arising from the use +of this software. + +Your mileage will vary. If in any doubt B<do not use it>. + + +=head2 RECENT CHANGES + +The interface to the Safe module has changed quite dramatically since +version 1 (as supplied with Perl5.002). Study these pages carefully if +you have code written to use Safe version 1 because you will need to +makes changes. + + +=head2 Methods in class Safe + +To create a new compartment, use + + $cpt = new Safe; + +Optional argument is (NAMESPACE), where NAMESPACE is the root namespace +to use for the compartment (defaults to "Safe::Root0", incremented for +each new compartment). + +Note that version 1.00 of the Safe module supported a second optional +parameter, MASK. That functionality has been withdrawn pending deeper +consideration. Use the permit and deny methods described below. + +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 permit (OP, ...) + +Permit the listed operators to be used when compiling code in the +compartment (in I<addition> to any operators already permitted). + +=item permit_only (OP, ...) + +Permit I<only> the listed operators to be used when compiling code in +the compartment (I<no> other operators are permitted). + +=item deny (OP, ...) + +Deny the listed operators from being used when compiling code in the +compartment (other operators may still be permitted). + +=item deny_only (OP, ...) + +Deny I<only> the listed operators from being used when compiling code +in the compartment (I<all> other operators will be permitted). + +=item trap (OP, ...) + +=item untrap (OP, ...) + +The trap and untrap methods are synonyms for deny and permit +respectfully. + +=item share (NAME, ...) + +This shares the variable(s) in the argument list with the compartment. +This is almost identical to exporting variables using the L<Exporter(3)> +module. + +Each NAME must be the B<name> of a variable, typically with the leading +type identifier included. A bareword is treated as a function name. + +Examples of legal names are '$foo' for a scalar, '@foo' for an +array, '%foo' for a hash, '&foo' or '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). + +Each NAME is assumed to be in the calling package. See share_from +for an alternative method (which share uses). + +=item share_from (PACKAGE, ARRAYREF) + +This method is similar to share() but allows you to explicitly name the +package that symbols should be shared from. The symbol names (including +type characters) are supplied as an array reference. + + $safe->share_from('main', [ '$foo', '%bar', 'func' ]); + + +=item varglob (VARNAME) + +This returns a glob reference 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). The compartment's root package appears to be the +C<main::> package to the code inside the compartment. + +Any attempt by the code in STRING to use an operator which is not permitted +by the compartment 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()>. The context (list or scalar) is determined +by the caller as usual. + +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 and the context was always scalar. + +Some points to note: + +If the entereval op is permitted then the code can use eval "..." to +'hide' code which might use denied ops. This is not a major problem +since when the code tries to execute the eval it will fail because the +opmask is still in effect. However this technique would allow clever, +and possibly harmful, code to 'probe' the boundaries of what is +possible. + +Any string eval which is executed by code executing in a compartment, +or by code called from code executing in a compartment, will be eval'd +in the namespace of the compartment. This is potentially a serious +problem. + +Consider a function foo() in package pkg compiled outside a compartment +but shared with it. Assume the compartment has a root package called +'Root'. If foo() contains an eval statement like eval '$foo = 1' then, +normally, $pkg::foo will be set to 1. If foo() is called from the +compartment (by whatever means) then instead of setting $pkg::foo, the +eval will actually set $Root::pkg::foo. + +This can easily be demonstrated by using a module, such as the Socket +module, which uses eval "..." as part of an AUTOLOAD function. You can +'use' the module outside the compartment and share an (autoloaded) +function with the compartment. If an autoload is triggered by code in +the compartment, or by any code anywhere that is called by any means +from the compartment, then the eval in the Socket module's AUTOLOAD +function happens in the namespace of the compartment. Any variables +created or used by the eval'd code are now under the control of +the code in the compartment. + +A similar effect applies to I<all> runtime symbol lookups in code +called from a compartment but not compiled within it. + + + +=item rdo (FILENAME) + +This evaluates the contents of file FILENAME inside the compartment. +See above documentation on the B<reval> method for further details. + +=item root (NAMESPACE) + +This method returns the name of the package that is the root of the +compartment's namespace. + +Note that this behaviour differs from version 1.00 of the Safe module +where the root module could be used to change the namespace. That +functionality has been withdrawn pending deeper consideration. + +=item mask (MASK) + +This is a get-or-set method for the compartment's operator mask. + +With no MASK argument present, it returns the current operator mask of +the compartment. + +With the MASK argument present, it sets the operator mask for the +compartment (equivalent to calling the deny_only method). + +=back + + +=head2 Some Safety Issues + +This section is currently just an outline of some of the things code in +a compartment might do (intentionally or unintentionally) which can +have an effect outside the compartment. + +=over 8 + +=item Memory + +Consuming all (or nearly all) available memory. + +=item CPU + +Causing infinite loops etc. + +=item Snooping + +Copying private information out of your system. Even something as +simple as your user name is of value to others. Much useful information +could be gleaned from your environment variables for example. + +=item Signals + +Causing signals (especially SIGFPE and SIGALARM) to affect your process. + +Setting up a signal handler will need to be carefully considered +and controlled. What mask is in effect when a signal handler +gets called? If a user can get an imported function to get an +exception and call the user's signal handler, does that user's +restricted mask get re-instated before the handler is called? +Does an imported handler get called with its original mask or +the user's one? + +=item State Changes + +Ops such as chdir obviously effect the process as a whole and not just +the code in the compartment. Ops such as rand and srand have a similar +but more subtle effect. + +=back + +=head2 AUTHOR + +Originally designed and implemented by Malcolm Beattie, +mbeattie@sable.ox.ac.uk. + +Reworked to use the Opcode module and other changes added by Tim Bunce +E<lt>F<Tim.Bunce@ig.co.uk>E<gt>. + +=cut + diff --git a/ext/Opcode/ops.pm b/ext/Opcode/ops.pm new file mode 100644 index 0000000000..b9ea36cef3 --- /dev/null +++ b/ext/Opcode/ops.pm @@ -0,0 +1,45 @@ +package ops; + +use Opcode qw(opmask_add opset invert_opset); + +sub import { + shift; + # Not that unimport is the prefered form since import's don't + # accumulate well owing to the 'only ever add opmask' rule. + # E.g., perl -Mops=:set1 -Mops=:setb is unlikely to do as expected. + opmask_add(invert_opset opset(@_)) if @_; +} + +sub unimport { + shift; + opmask_add(opset(@_)) if @_; +} + +1; + +__END__ + +=head1 NAME + +ops - Perl pragma to restrict unsafe operations when compiling + +=head1 SYNOPSIS + + perl -Mops=:default ... # only allow reasonably safe operations + + perl -M-ops=system ... # disable the 'system' opcode + +=head1 DESCRIPTION + +Since the ops pragma currently has an irreversable global effect, it is +only of significant practical use with the C<-M> option on the command line. + +See the L<Opcode> module for information about opcodes, optags, opmasks +and important information about safety. + +=head1 SEE ALSO + +Opcode(3), Safe(3), perlrun(3) + +=cut + diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index 66b55c1565..2885c0d84c 100644 --- a/ext/POSIX/POSIX.pm +++ b/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/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index 4b7585117c..c781765a14 100644 --- a/ext/POSIX/POSIX.pod +++ b/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/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 3ba3c5b426..f723db796a 100644 --- a/ext/POSIX/POSIX.xs +++ b/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 @@ -41,59 +41,64 @@ #include <sys/types.h> #include <time.h> #include <unistd.h> +#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 + /* 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 +119,15 @@ 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) +# else +# define HAS_TZNAME /* shows up in VMS 7.0 */ +# endif /* __VMS_VER < 70000000 */ /* The POSIX notion of ttyname() is better served by getname() under VMS */ static char ttnambuf[64]; @@ -152,7 +160,6 @@ } # define times(t) vms_times(t) #else -# include <fcntl.h> # include <grp.h> # include <sys/times.h> # ifdef HAS_UNAME @@ -190,6 +197,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 +236,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 +264,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 +627,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 +703,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 +729,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 +770,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 +809,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 +841,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 +921,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 +983,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 +997,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 +1035,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 +1055,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 +1079,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 +1731,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 +2008,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 +2798,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 +2810,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 +2822,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 +2834,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 +2846,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 +2858,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 +2870,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 +2882,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 +2894,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 +2906,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 +2918,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 +2947,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 +3013,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 +3295,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 +3378,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 +3533,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/ext/POSIX/hints/next_3.pl b/ext/POSIX/hints/next_3.pl new file mode 100644 index 0000000000..d90778398b --- /dev/null +++ b/ext/POSIX/hints/next_3.pl @@ -0,0 +1,5 @@ +# NeXT *does* have setpgid when we use the -posix flag, but +# doesn't when we don't. The main perl sources are compiled +# without -posix, so the hints/next_3.sh hint file tells Configure +# that d_setpgid=undef. +$self->{CCFLAGS} = $Config{ccflags} . ' -posix -DHAS_SETPGID' ; diff --git a/ext/SDBM_File/Makefile.PL b/ext/SDBM_File/Makefile.PL index 8fc9411768..210879f90b 100644 --- a/ext/SDBM_File/Makefile.PL +++ b/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') ? '/D "MSDOS"' : ''; + WriteMakefile( NAME => 'SDBM_File', MYEXTLIB => 'sdbm/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/ext/SDBM_File/SDBM_File.pm b/ext/SDBM_File/SDBM_File.pm index 9b7acc1e09..a2d4df8558 100644 --- a/ext/SDBM_File/SDBM_File.pm +++ b/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/ext/SDBM_File/sdbm/Makefile.PL b/ext/SDBM_File/sdbm/Makefile.PL index b4bd6f9549..21ad7576c3 100644 --- a/ext/SDBM_File/sdbm/Makefile.PL +++ b/ext/SDBM_File/sdbm/Makefile.PL @@ -1,28 +1,31 @@ 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, + 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/ext/SDBM_File/sdbm/pair.c b/ext/SDBM_File/sdbm/pair.c index a02c73f28f..23bbfe9a67 100644 --- a/ext/SDBM_File/sdbm/pair.c +++ b/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/ext/SDBM_File/sdbm/pair.h b/ext/SDBM_File/sdbm/pair.h index bd66d02fd2..8a675b9065 100644 --- a/ext/SDBM_File/sdbm/pair.h +++ b/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/ext/SDBM_File/sdbm/readme.ps b/ext/SDBM_File/sdbm/readme.ps deleted file mode 100644 index 2b0c675595..0000000000 --- a/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: psdit.pro,v 2.1 85/11/24 12:19:43 shore Rel $ - -/$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/ext/SDBM_File/sdbm/sdbm.3 b/ext/SDBM_File/sdbm/sdbm.3 index f0f2d07c84..7e5c176404 100644 --- a/ext/SDBM_File/sdbm/sdbm.3 +++ b/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/ext/SDBM_File/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c index d4836be671..c2d9cbd47d 100644 --- a/ext/SDBM_File/sdbm/sdbm.c +++ b/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/ext/SDBM_File/sdbm/sdbm.h b/ext/SDBM_File/sdbm/sdbm.h index 4d6c844890..fdd9165145 100644 --- a/ext/SDBM_File/sdbm/sdbm.h +++ b/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/ext/Safe/Makefile.PL b/ext/Safe/Makefile.PL deleted file mode 100644 index 108109f61d..0000000000 --- a/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/ext/Safe/Safe.pm b/ext/Safe/Safe.pm deleted file mode 100644 index 0fafcbe741..0000000000 --- a/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/ext/Safe/Safe.xs b/ext/Safe/Safe.xs deleted file mode 100644 index 6b25924a33..0000000000 --- a/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/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index 43c3c404bc..51dce5939e 100644 --- a/ext/Socket/Socket.pm +++ b/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/ext/Socket/Socket.xs b/ext/Socket/Socket.xs index 378824f42d..e3b282b0ad 100644 --- a/ext/Socket/Socket.xs +++ b/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/ext/util/make_ext b/ext/util/make_ext index 8c1abbbc01..bfbcc8340e 100644 --- a/ext/util/make_ext +++ b/ext/util/make_ext @@ -34,9 +34,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 +50,6 @@ esac mname=`echo "$pname" | sed -e 's!/!::!g'` depth=`echo "$pname" | sed -e 's![^/][^/]*!..!g'` -make=${altmake-make} makefile=Makefile makeargs='' makeopts='' |