diff options
Diffstat (limited to 'gnu/usr.bin/perl/ext')
52 files changed, 3769 insertions, 2093 deletions
diff --git a/gnu/usr.bin/perl/ext/B/byteperl.c b/gnu/usr.bin/perl/ext/B/byteperl.c deleted file mode 100644 index 6b53e3b174a..00000000000 --- a/gnu/usr.bin/perl/ext/B/byteperl.c +++ /dev/null @@ -1,110 +0,0 @@ -#include "EXTERN.h" -#include "perl.h" -#ifndef PATCHLEVEL -#include "patchlevel.h" -#endif - -static void xs_init _((void)); -static PerlInterpreter *my_perl; - -int -#ifndef CAN_PROTOTYPE -main(argc, argv, env) -int argc; -char **argv; -char **env; -#else /* def(CAN_PROTOTYPE) */ -main(int argc, char **argv, char **env) -#endif /* def(CAN_PROTOTYPE) */ -{ - int exitstatus; - int i; - char **fakeargv; - FILE *fp; -#ifdef INDIRECT_BGET_MACROS - struct bytestream bs; -#endif /* INDIRECT_BGET_MACROS */ - - INIT_SPECIALSV_LIST; - PERL_SYS_INIT(&argc,&argv); - -#if PATCHLEVEL > 3 || (PATCHLEVEL == 3 && SUBVERSION >= 1) - perl_init_i18nl10n(1); -#else - perl_init_i18nl14n(1); -#endif - - if (!PL_do_undump) { - my_perl = perl_alloc(); - if (!my_perl) -#ifdef VMS - exit(vaxc$errno); -#else - exit(1); -#endif - perl_construct( my_perl ); - } - -#ifdef CSH - if (!PL_cshlen) - PL_cshlen = strlen(PL_cshname); -#endif - - if (argc < 2) - fp = stdin; - else { -#ifdef WIN32 - fp = fopen(argv[1], "rb"); -#else - fp = fopen(argv[1], "r"); -#endif - if (!fp) { - perror(argv[1]); -#ifdef VMS - exit(vaxc$errno); -#else - exit(1); -#endif - } - argv++; - argc--; - } - New(666, fakeargv, argc + 4, char *); - fakeargv[0] = argv[0]; - fakeargv[1] = "-e"; - fakeargv[2] = ""; - fakeargv[3] = "--"; - for (i = 1; i < argc; i++) - fakeargv[i + 3] = argv[i]; - fakeargv[argc + 3] = 0; - - exitstatus = perl_parse(my_perl, xs_init, argc + 3, fakeargv, NULL); - if (exitstatus) - exit( exitstatus ); - - sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]); - PL_main_cv = PL_compcv; - PL_compcv = 0; - -#ifdef INDIRECT_BGET_MACROS - bs.data = fp; - bs.fgetc = (int(*) _((void*)))fgetc; - bs.fread = (int(*) _((char*,size_t,size_t,void*)))fread; - bs.freadpv = freadpv; - byterun(bs); -#else - byterun(fp); -#endif /* INDIRECT_BGET_MACROS */ - - exitstatus = perl_run( my_perl ); - - perl_destruct( my_perl ); - perl_free( my_perl ); - - exit( exitstatus ); -} - -static void -xs_init() -{ -} diff --git a/gnu/usr.bin/perl/ext/DB_File/DB_File.pm b/gnu/usr.bin/perl/ext/DB_File/DB_File.pm index e5759ff5585..00b24b90e61 100644 --- a/gnu/usr.bin/perl/ext/DB_File/DB_File.pm +++ b/gnu/usr.bin/perl/ext/DB_File/DB_File.pm @@ -1,10 +1,10 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (Paul.Marquess@btinternet.com) -# last modified 6th March 1999 -# version 1.65 +# last modified 16th January 2000 +# version 1.72 # -# Copyright (c) 1995-9 Paul Marquess. All rights reserved. +# Copyright (c) 1995-2000 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. @@ -141,11 +141,13 @@ sub TIEHASH package DB_File ; use strict; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO $db_version) ; +use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO + $db_version $use_XSLoader + ) ; use Carp; -$VERSION = "1.65" ; +$VERSION = "1.72" ; #typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; $DB_BTREE = new DB_File::BTREEINFO ; @@ -155,8 +157,18 @@ $DB_RECNO = new DB_File::RECNOINFO ; require Tie::Hash; require Exporter; use AutoLoader; -require DynaLoader; -@ISA = qw(Tie::Hash Exporter DynaLoader); +BEGIN { + $use_XSLoader = 1 ; + eval { require XSLoader } ; + + if ($@) { + $use_XSLoader = 0 ; + require DynaLoader; + @ISA = qw(DynaLoader); + } +} + +push @ISA, qw(Tie::Hash Exporter); @EXPORT = qw( $DB_BTREE $DB_HASH $DB_RECNO @@ -196,7 +208,7 @@ sub AUTOLOAD { ($constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { - if ($! =~ /Invalid/) { + if ($! =~ /Invalid/ || $!{EINVAL}) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } @@ -219,19 +231,10 @@ eval { push(@EXPORT, @O); }; -## 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; +if ($use_XSLoader) + { XSLoader::load("DB_File", $VERSION)} +else + { bootstrap DB_File $VERSION } # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. @@ -408,6 +411,12 @@ DB_File - Perl5 access to Berkeley DB version 1.x $a = $X->shift; $X->unshift(list); + # DBM Filters + $old_filter = $db->filter_store_key ( sub { ... } ) ; + $old_filter = $db->filter_store_value( sub { ... } ) ; + $old_filter = $db->filter_fetch_key ( sub { ... } ) ; + $old_filter = $db->filter_fetch_value( sub { ... } ) ; + untie %hash ; untie @array ; @@ -415,10 +424,10 @@ DB_File - Perl5 access to Berkeley DB version 1.x B<DB_File> is a module which allows Perl programs to make use of the facilities provided by Berkeley DB version 1.x (if you have a newer -version of DB, see L<Using DB_File with Berkeley DB version 2>). It is -assumed that you have a copy of the Berkeley DB manual pages at hand -when reading this documentation. The interface defined here mirrors the -Berkeley DB interface closely. +version of DB, see L<Using DB_File with Berkeley DB version 2 or 3>). +It is assumed that you have a copy of the Berkeley DB manual pages at +hand when reading this documentation. The interface defined here +mirrors the Berkeley DB interface closely. 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 @@ -459,32 +468,28 @@ number. =back -=head2 Using DB_File with Berkeley DB version 2 +=head2 Using DB_File with Berkeley DB version 2 or 3 Although B<DB_File> is intended to be used with Berkeley DB version 1, -it can also be used with version 2. In this case the interface is +it can also be used with version 2.or 3 In this case the interface is limited to the functionality provided by Berkeley DB 1.x. Anywhere the -version 2 interface differs, B<DB_File> arranges for it to work like -version 1. This feature allows B<DB_File> scripts that were built with -version 1 to be migrated to version 2 without any changes. +version 2 or 3 interface differs, B<DB_File> arranges for it to work +like version 1. This feature allows B<DB_File> scripts that were built +with version 1 to be migrated to version 2 or 3 without any changes. If you want to make use of the new features available in Berkeley DB -2.x, use the Perl module B<BerkeleyDB> instead. - -At the time of writing this document the B<BerkeleyDB> module is still -alpha quality (the version number is < 1.0), and so unsuitable for use -in any serious development work. Once its version number is >= 1.0, it -is considered stable enough for real work. +2.x or greater, use the Perl module B<BerkeleyDB> instead. -B<Note:> The database file format has changed in Berkeley DB version 2. -If you cannot recreate your databases, you must dump any existing -databases with the C<db_dump185> utility that comes with Berkeley DB. -Once you have rebuilt DB_File to use Berkeley DB version 2, your +B<Note:> The database file format has changed in both Berkeley DB +version 2 and 3. If you cannot recreate your databases, you must dump +any existing databases with the C<db_dump185> utility that comes with +Berkeley DB. +Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your databases can be recreated using C<db_load>. Refer to the Berkeley DB documentation for further details. -Please read L<"COPYRIGHT"> before using version 2.x of Berkeley DB with -DB_File. +Please read L<"COPYRIGHT"> before using version 2.x or 3.x of Berkeley +DB with DB_File. =head2 Interface to Berkeley DB @@ -664,6 +669,7 @@ contents of the database. use DB_File ; use vars qw( %h $k $v ) ; + unlink "fruit" ; tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH or die "Cannot open file 'fruit': $!\n"; @@ -723,6 +729,7 @@ insensitive compare function will be used. # specify the Perl sub that will do the comparison $DB_BTREE->{'compare'} = \&Compare ; + unlink "tree" ; tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE or die "Cannot open file 'tree': $!\n" ; @@ -799,7 +806,7 @@ code: # iterate through the associative array # and print each key/value pair. - foreach (keys %h) + foreach (sort keys %h) { print "$_ -> $h{$_}\n" } untie %h ; @@ -901,6 +908,19 @@ particular value occurred in the BTREE. So assuming the database created above, we can use C<get_dup> like this: + use strict ; + use DB_File ; + + use vars qw($filename $x %h ) ; + + $filename = "tree" ; + + # 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"; + my $cnt = $x->get_dup("Wall") ; print "Wall occurred $cnt times\n" ; @@ -908,7 +928,7 @@ this: print "Larry is there\n" if $hash{'Larry'} ; print "There are $hash{'Brick'} Brick Walls\n" ; - my @list = $x->get_dup("Wall") ; + my @list = sort $x->get_dup("Wall") ; print "Wall => [@list]\n" ; @list = $x->get_dup("Smith") ; @@ -931,7 +951,7 @@ and it will print: $status = $X->find_dup($key, $value) ; -This method checks for the existance of a specific key/value pair. If the +This method checks for the existence of a specific key/value pair. If the pair exists, the cursor is left pointing to the pair and the method returns 0. Otherwise the method returns a non-zero value. @@ -961,7 +981,7 @@ Assuming the database from the previous example: prints this - Larry Wall is there + Larry Wall is there Harry Wall is not there @@ -973,7 +993,7 @@ This method deletes a specific key/value pair. It returns 0 if they exist and have been deleted successfully. Otherwise the method returns a non-zero value. -Again assuming the existance of the C<tree> database +Again assuming the existence of the C<tree> database use strict ; use DB_File ; @@ -1053,7 +1073,7 @@ and print the first matching key/value pair given a partial key. $st == 0 ; $st = $x->seq($key, $value, R_NEXT) ) - { print "$key -> $value\n" } + { print "$key -> $value\n" } print "\nPARTIAL MATCH\n" ; @@ -1126,8 +1146,11 @@ L<Extra RECNO Methods> for a workaround). use strict ; use DB_File ; + my $filename = "text" ; + unlink $filename ; + my @h ; - tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO + tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO or die "Cannot open file 'text': $!\n" ; # Add a few key/value pairs to the file @@ -1160,7 +1183,7 @@ Here is the output from the script: The array contains 5 entries popped black - unshifted white + shifted white Element 1 Exists with value blue The last element is green The 2nd last element is yellow @@ -1466,8 +1489,8 @@ R_CURSOR is the only valid flag at present. 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. +See L<Locking: The Trouble with fd> for an explanation for why you should +not use C<fd> to lock your database. =item B<$status = $X-E<gt>seq($key, $value, $flags) ;> @@ -1488,67 +1511,262 @@ R_RECNOSYNC is the only valid flag at present. =back -=head1 HINTS AND TIPS +=head1 DBM FILTERS +A DBM Filter is a piece of code that is be used when you I<always> +want to make the same transformation to all keys and/or values in a +DBM database. -=head2 Locking Databases +There are four methods associated with DBM Filters. All work identically, +and each is used to install (or uninstall) a single DBM Filter. Each +expects a single parameter, namely a reference to a sub. The only +difference between them is the place that the filter is installed. -Concurrent access of a read-write database by several parties requires -them all to use some kind of locking. Here's an example of Tom's that -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. +To summarise: - use DB_File; +=over 5 - use strict; +=item B<filter_store_key> - sub LOCK_SH { 1 } - sub LOCK_EX { 2 } - sub LOCK_NB { 4 } - sub LOCK_UN { 8 } +If a filter has been installed with this method, it will be invoked +every time you write a key to a DBM database. - my($oldval, $fd, $db, %db, $value, $key); +=item B<filter_store_value> - $key = shift || 'default'; - $value = shift || 'magic'; +If a filter has been installed with this method, it will be invoked +every time you write a value to a DBM database. - $value .= " $$"; - $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644) - || die "dbcreat /tmp/foo.db $!"; - $fd = $db->fd; - print "$$: db fd is $fd\n"; - open(DB_FH, "+<&=$fd") || die "dup $!"; +=item B<filter_fetch_key> +If a filter has been installed with this method, it will be invoked +every time you read a key from a DBM database. - unless (flock (DB_FH, LOCK_SH | LOCK_NB)) { - print "$$: CONTENTION; can't read during write update! - Waiting for read lock ($!) ...."; - unless (flock (DB_FH, LOCK_SH)) { die "flock: $!" } - } - print "$$: Read lock granted\n"; +=item B<filter_fetch_value> - $oldval = $db{$key}; - print "$$: Old value was $oldval\n"; - flock(DB_FH, LOCK_UN); +If a filter has been installed with this method, it will be invoked +every time you read a value from a DBM database. - unless (flock (DB_FH, LOCK_EX | LOCK_NB)) { - print "$$: CONTENTION; must have exclusive lock! - Waiting for write lock ($!) ...."; - unless (flock (DB_FH, LOCK_EX)) { die "flock: $!" } - } +=back - print "$$: Write lock granted\n"; - $db{$key} = $value; - $db->sync; # to flush - sleep 10; +You can use any combination of the methods, from none, to all four. +All filter methods return the existing filter, if present, or C<undef> +in not. + +To delete a filter pass C<undef> to it. + +=head2 The Filter + +When each filter is called by Perl, a local copy of C<$_> will contain +the key or value to be filtered. Filtering is achieved by modifying +the contents of C<$_>. The return code from the filter is ignored. + +=head2 An Example -- the NULL termination problem. + +Consider the following scenario. You have a DBM database +that you need to share with a third-party C application. The C application +assumes that I<all> keys and values are NULL terminated. Unfortunately +when Perl writes to DBM databases it doesn't use NULL termination, so +your Perl application will have to manage NULL termination itself. When +you write to the database you will have to use something like this: + + $hash{"$key\0"} = "$value\0" ; + +Similarly the NULL needs to be taken into account when you are considering +the length of existing keys/values. + +It would be much better if you could ignore the NULL terminations issue +in the main application code and have a mechanism that automatically +added the terminating NULL to all keys and values whenever you write to +the database and have them removed when you read from the database. As I'm +sure you have already guessed, this is a problem that DBM Filters can +fix very easily. + + use strict ; + use DB_File ; + + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; + + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + or die "Cannot open $filename: $!\n" ; + + # Install DBM Filters + $db->filter_fetch_key ( sub { s/\0$// } ) ; + $db->filter_store_key ( sub { $_ .= "\0" } ) ; + $db->filter_fetch_value( sub { s/\0$// } ) ; + $db->filter_store_value( sub { $_ .= "\0" } ) ; + + $hash{"abc"} = "def" ; + my $a = $hash{"ABC"} ; + # ... + undef $db ; + untie %hash ; + +Hopefully the contents of each of the filters should be +self-explanatory. Both "fetch" filters remove the terminating NULL, +and both "store" filters add a terminating NULL. + + +=head2 Another Example -- Key is a C int. + +Here is another real-life example. By default, whenever Perl writes to +a DBM database it always writes the key and value as strings. So when +you use this: + + $hash{12345} = "soemthing" ; + +the key 12345 will get stored in the DBM database as the 5 byte string +"12345". If you actually want the key to be stored in the DBM database +as a C int, you will have to use C<pack> when writing, and C<unpack> +when reading. + +Here is a DBM Filter that does it: + + use strict ; + use DB_File ; + my %hash ; + my $filename = "/tmp/filt" ; + unlink $filename ; + + + my $db = tie %hash, 'DB_File', $filename, O_CREAT|O_RDWR, 0666, $DB_HASH + or die "Cannot open $filename: $!\n" ; + + $db->filter_fetch_key ( sub { $_ = unpack("i", $_) } ) ; + $db->filter_store_key ( sub { $_ = pack ("i", $_) } ) ; + $hash{123} = "def" ; + # ... + undef $db ; + untie %hash ; + +This time only two filters have been used -- we only need to manipulate +the contents of the key, so it wasn't necessary to install any value +filters. + +=head1 HINTS AND TIPS + + +=head2 Locking: The Trouble with fd + +Until version 1.72 of this module, the recommended technique for locking +B<DB_File> databases was to flock the filehandle returned from the "fd" +function. Unfortunately this technique has been shown to be fundamentally +flawed (Kudos to David Harris for tracking this down). Use it at your own +peril! + +The locking technique went like this. + + $db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0644) + || die "dbcreat /tmp/foo.db $!"; + $fd = $db->fd; + open(DB_FH, "+<&=$fd") || die "dup $!"; + flock (DB_FH, LOCK_EX) || die "flock: $!"; + ... + $db{"Tom"} = "Jerry" ; + ... flock(DB_FH, LOCK_UN); undef $db; untie %db; close(DB_FH); - print "$$: Updated db to $key=$value\n"; + +In simple terms, this is what happens: + +=over 5 + +=item 1. + +Use "tie" to open the database. + +=item 2. + +Lock the database with fd & flock. + +=item 3. + +Read & Write to the database. + +=item 4. + +Unlock and close the database. + +=back + +Here is the crux of the problem. A side-effect of opening the B<DB_File> +database in step 2 is that an initial block from the database will get +read from disk and cached in memory. + +To see why this is a problem, consider what can happen when two processes, +say "A" and "B", both want to update the same B<DB_File> database +using the locking steps outlined above. Assume process "A" has already +opened the database and has a write lock, but it hasn't actually updated +the database yet (it has finished step 2, but not started step 3 yet). Now +process "B" tries to open the same database - step 1 will succeed, +but it will block on step 2 until process "A" releases the lock. The +important thing to notice here is that at this point in time both +processes will have cached identical initial blocks from the database. + +Now process "A" updates the database and happens to change some of the +data held in the initial buffer. Process "A" terminates, flushing +all cached data to disk and releasing the database lock. At this point +the database on disk will correctly reflect the changes made by process +"A". + +With the lock released, process "B" can now continue. It also updates the +database and unfortunately it too modifies the data that was in its +initial buffer. Once that data gets flushed to disk it will overwrite +some/all of the changes process "A" made to the database. + +The result of this scenario is at best a database that doesn't contain +what you expect. At worst the database will corrupt. + +The above won't happen every time competing process update the same +B<DB_File> database, but it does illustrate why the technique should +not be used. + +=head2 Safe ways to lock a database + +Starting with version 2.x, Berkeley DB has internal support for locking. +The companion module to this one, B<BerkeleyDB>, provides an interface +to this locking functionality. If you are serious about locking +Berkeley DB databases, I strongly recommend using B<BerkeleyDB>. + +If using B<BerkeleyDB> isn't an option, there are a number of modules +available on CPAN that can be used to implement locking. Each one +implements locking differently and has different goals in mind. It is +therefore worth knowing the difference, so that you can pick the right +one for your application. Here are the three locking wrappers: + +=over 5 + +=item B<Tie::DB_Lock> + +A B<DB_File> wrapper which creates copies of the database file for +read access, so that you have a kind of a multiversioning concurrent read +system. However, updates are still serial. Use for databases where reads +may be lengthy and consistency problems may occur. + +=item B<Tie::DB_LockFile> + +A B<DB_File> wrapper that has the ability to lock and unlock the database +while it is being used. Avoids the tie-before-flock problem by simply +re-tie-ing the database when you get or drop a lock. Because of the +flexibility in dropping and re-acquiring the lock in the middle of a +session, this can be massaged into a system that will work with long +updates and/or reads if the application follows the hints in the POD +documentation. + +=item B<DB_File::Lock> + +An extremely lightweight B<DB_File> wrapper that simply flocks a lockfile +before tie-ing the database and drops the lock after the untie. Allows +one to use the same lockfile for multiple databases to avoid deadlock +problems, if desired. Use for databases where updates are reads are +quick and simple flock locking semantics are enough. + +=back =head2 Sharing Databases With C Applications @@ -1557,7 +1775,7 @@ 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. +not. See L<DBM FILTERS> for a generic way to work around this problem. 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. @@ -1654,7 +1872,7 @@ 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 +attempt to open a database that is already open via the catch-all "Invalid argument" doesn't help. If you run the script with the C<-w> flag the error message becomes: @@ -1746,6 +1964,19 @@ double quotes, like this: 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 REFERENCES + +Articles that are either about B<DB_File> or make use of it. + +=over 5 + +=item 1. + +I<Full-Text Searching in Perl>, Tim Kientzle (tkientzle@ddj.com), +Dr. Dobb's Journal, Issue 295, January 1999, pp 34-41 + +=back + =head1 HISTORY Moved to the Changes file. @@ -1768,13 +1999,12 @@ date, so the most recent version can always be found on CPAN (see L<perlmod/CPAN> for details), in the directory F<modules/by-module/DB_File>. -This version of B<DB_File> will work with either version 1.x or 2.x of -Berkeley DB, but is limited to the functionality provided by version 1. +This version of B<DB_File> will work with either version 1.x, 2.x or +3.x of Berkeley DB, but is limited to the functionality provided by +version 1. -The official web site for Berkeley DB is -F<http://www.sleepycat.com/db>. The ftp equivalent is -F<ftp.sleepycat.com:/pub>. Both versions 1 and 2 of Berkeley DB are -available there. +The official web site for Berkeley DB is F<http://www.sleepycat.com>. +All versions of Berkeley DB are available there. Alternatively, Berkeley DB version 1 is available at your nearest CPAN archive in F<src/misc/db.1.85.tar.gz>. @@ -1785,7 +2015,7 @@ compile properly on IRIX 5.3. =head1 COPYRIGHT -Copyright (c) 1995-9 Paul Marquess. All rights reserved. This program +Copyright (c) 1995-1999 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. @@ -1794,7 +2024,7 @@ makes use of, namely Berkeley DB, is not. Berkeley DB has its own copyright and its own license. Please take the time to read it. Here are are few words taken from the Berkeley DB FAQ (at -http://www.sleepycat.com) regarding the license: +F<http://www.sleepycat.com>) regarding the license: Do I have to license DB to use it in Perl scripts? @@ -1811,7 +2041,8 @@ Berkeley DB authors or the author of DB_File. See L<"AUTHOR"> for details. =head1 SEE ALSO -L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)> +L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>, +L<dbmfilter> =head1 AUTHOR diff --git a/gnu/usr.bin/perl/ext/DB_File/DB_File.xs b/gnu/usr.bin/perl/ext/DB_File/DB_File.xs index 94113eb4e28..2b76bab7226 100644 --- a/gnu/usr.bin/perl/ext/DB_File/DB_File.xs +++ b/gnu/usr.bin/perl/ext/DB_File/DB_File.xs @@ -3,12 +3,12 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess <Paul.Marquess@btinternet.com> - last modified 6th March 1999 - version 1.65 + last modified 16th January 2000 + version 1.72 All comments/suggestions/problems are welcome - Copyright (c) 1995-9 Paul Marquess. All rights reserved. + Copyright (c) 1995-2000 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. @@ -65,8 +65,23 @@ to fix a flag mapping problem with O_RDONLY on the Hurd 1.65 - Fixed a bug in the PUSH logic. Added BOOT check that using 2.3.4 or greater - - + 1.66 - Added DBM filter code + 1.67 - Backed off the use of newSVpvn. + Fixed DBM Filter code for Perl 5.004. + Fixed a small memory leak in the filter code. + 1.68 - fixed backward compatability bug with R_IAFTER & R_IBEFORE + merged in the 5.005_58 changes + 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly. + Fixed the R_SETCURSOR bug introduced in 1.68 + Added a new Perl variable $DB_File::db_ver + 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. + 1.71 - Support for Berkeley DB version 3. + Support for Berkeley DB 2/3's backward compatability mode. + Rewrote push + 1.72 - No change to DB_File.xs */ @@ -75,10 +90,10 @@ #include "XSUB.h" #ifndef PERL_VERSION -#include "patchlevel.h" -#define PERL_REVISION 5 -#define PERL_VERSION PATCHLEVEL -#define PERL_SUBVERSION SUBVERSION +# include "patchlevel.h" +# define PERL_REVISION 5 +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION #endif #if PERL_REVISION == 5 && (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION <= 75 )) @@ -88,6 +103,11 @@ #endif +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(defgv) +#endif + /* Being the Berkeley DB we prefer the <sys/cdefs.h> (which will be * shortly #included by the <db.h>) __attribute__ to the possibly * already defined __attribute__, for example by GNUC or by Perl. */ @@ -98,33 +118,65 @@ be defined here. This clashes with a field name in db.h, so get rid of it. */ #ifdef op -#undef op +# undef op +#endif + +#ifdef COMPAT185 +# include <db_185.h> +#else +# include <db.h> +#endif + +#ifndef pTHX +# define pTHX +# define pTHX_ +# define aTHX +# define aTHX_ +#endif + +#ifndef newSVpvn +# define newSVpvn(a,b) newSVpv(a,b) #endif -#include <db.h> #include <fcntl.h> /* #define TRACE */ +#define DBM_FILTERING + +#ifdef TRACE +# define Trace(x) printf x +#else +# define Trace(x) +#endif +#define DBT_clear(x) Zero(&x, 1, DBT) ; #ifdef DB_VERSION_MAJOR +#if DB_VERSION_MAJOR == 2 +# define BERKELEY_DB_1_OR_2 +#endif + /* map version 2 features & constants onto their version 1 equivalent */ #ifdef DB_Prefix_t -#undef DB_Prefix_t +# undef DB_Prefix_t #endif #define DB_Prefix_t size_t #ifdef DB_Hash_t -#undef DB_Hash_t +# undef DB_Hash_t #endif #define DB_Hash_t u_int32_t /* DBTYPE stays the same */ /* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */ -typedef DB_INFO INFO ; +#if DB_VERSION_MAJOR == 2 + typedef DB_INFO INFO ; +#else /* DB_VERSION_MAJOR > 2 */ +# define DB_FIXEDLEN (0x8000) +#endif /* DB_VERSION_MAJOR == 2 */ /* version 2 has db_recno_t in place of recno_t */ typedef db_recno_t recno_t; @@ -138,11 +190,18 @@ typedef db_recno_t recno_t; #define R_NEXT DB_NEXT #define R_NOOVERWRITE DB_NOOVERWRITE #define R_PREV DB_PREV -#define R_SETCURSOR 0 + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 +# define R_SETCURSOR 0x800000 +#else +# define R_SETCURSOR (-100) +#endif + #define R_RECNOSYNC 0 #define R_FIXEDLEN DB_FIXEDLEN #define R_DUP DB_DUP + #define db_HA_hash h_hash #define db_HA_ffactor h_ffactor #define db_HA_nelem h_nelem @@ -177,13 +236,15 @@ typedef db_recno_t recno_t; #define DB_flags(x, v) x |= v #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 -#define flagSet(flags, bitmask) ((flags) & (bitmask)) +# define flagSet(flags, bitmask) ((flags) & (bitmask)) #else -#define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask)) +# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (bitmask)) #endif #else /* db version 1.x */ +#define BERKELEY_DB_1_OR_2 + typedef union INFO { HASHINFO hash ; RECNOINFO recno ; @@ -192,17 +253,17 @@ typedef union INFO { #ifdef mDB_Prefix_t -#ifdef DB_Prefix_t -#undef DB_Prefix_t -#endif -#define DB_Prefix_t 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 +# ifdef DB_Hash_t +# undef DB_Hash_t +# endif +# define DB_Hash_t mDB_Hash_t #endif #define db_HA_hash hash.hash @@ -248,20 +309,21 @@ typedef union INFO { #define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) #ifdef DB_VERSION_MAJOR -#define db_DESTROY(db) ((db->dbp)->close)(db->dbp, 0) +#define db_DESTROY(db) ( db->cursor->c_close(db->cursor),\ + (db->dbp->close)(db->dbp, 0) ) #define db_close(db) ((db->dbp)->close)(db->dbp, 0) #define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \ ? ((db->cursor)->c_del)(db->cursor, 0) \ : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) -#else +#else /* ! DB_VERSION_MAJOR */ #define db_DESTROY(db) ((db->dbp)->close)(db->dbp) #define db_close(db) ((db->dbp)->close)(db->dbp) #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) -#endif +#endif /* ! DB_VERSION_MAJOR */ #define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags) @@ -273,32 +335,70 @@ typedef struct { SV * prefix ; SV * hash ; int in_memory ; +#ifdef BERKELEY_DB_1_OR_2 INFO info ; +#endif #ifdef DB_VERSION_MAJOR DBC * cursor ; #endif +#ifdef DBM_FILTERING + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; +#endif /* DBM_FILTERING */ + } DB_File_type; typedef DB_File_type * DB_File ; typedef DBT DBTKEY ; +#ifdef DBM_FILTERING + +#define ckFilter(arg,type,name) \ + if (db->type) { \ + SV * save_defsv ; \ + /* printf("filtering %s\n", name) ;*/ \ + if (db->filtering) \ + croak("recursion detected in %s", name) ; \ + db->filtering = TRUE ; \ + save_defsv = newSVsv(DEFSV) ; \ + sv_setsv(DEFSV, arg) ; \ + PUSHMARK(sp) ; \ + (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ + sv_setsv(arg, DEFSV) ; \ + sv_setsv(DEFSV, save_defsv) ; \ + SvREFCNT_dec(save_defsv) ; \ + db->filtering = FALSE ; \ + /*printf("end of filtering %s\n", name) ;*/ \ + } + +#else + +#define ckFilter(arg,type, name) + +#endif /* DBM_FILTERING */ + #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s) -#define OutputValue(arg, name) \ - { if (RETVAL == 0) { \ - my_sv_setpvn(arg, name.data, name.size) ; \ - } \ +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + my_sv_setpvn(arg, name.data, name.size) ; \ + ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ + } \ } -#define OutputKey(arg, name) \ - { if (RETVAL == 0) \ - { \ - if (db->type != DB_RECNO) { \ - my_sv_setpvn(arg, name.data, name.size); \ - } \ - else \ - sv_setiv(arg, (I32)*(I32*)name.data - 1); \ - } \ +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + if (db->type != DB_RECNO) { \ + my_sv_setpvn(arg, name.data, name.size); \ + } \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ + } \ } @@ -311,26 +411,57 @@ static DBTKEY empty ; #ifdef DB_VERSION_MAJOR static int +#ifdef CAN_PROTOTYPE +db_put(DB_File db, DBTKEY key, DBT value, u_int flags) +#else db_put(db, key, value, flags) DB_File db ; DBTKEY key ; DBT value ; u_int flags ; - +#endif { int status ; - if (flagSet(flags, R_CURSOR)) { - status = ((db->cursor)->c_del)(db->cursor, 0); - if (status != 0) - return status ; - -#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 - flags &= ~R_CURSOR ; + if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) { + DBC * temp_cursor ; + DBT l_key, l_value; + +#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 + if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0) #else - flags &= ~DB_OPFLAGS_MASK ; + if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0) #endif + return (-1) ; + + memset(&l_key, 0, sizeof(l_key)); + l_key.data = key.data; + l_key.size = key.size; + memset(&l_value, 0, sizeof(l_value)); + l_value.data = value.data; + l_value.size = value.size; + + if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) { + (void)temp_cursor->c_close(temp_cursor); + return (-1); + } + status = temp_cursor->c_put(temp_cursor, &key, &value, flags); + (void)temp_cursor->c_close(temp_cursor); + + return (status) ; + } + + + if (flagSet(flags, R_CURSOR)) { + return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT); + } + + if (flagSet(flags, R_SETCURSOR)) { + if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0) + return -1 ; + return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE); + } return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; @@ -339,42 +470,19 @@ u_int flags ; #endif /* DB_VERSION_MAJOR */ -static void -GetVersionInfo() -{ - SV * ver_sv = perl_get_sv("DB_File::db_version", TRUE) ; -#ifdef DB_VERSION_MAJOR - int Major, Minor, Patch ; - - (void)db_version(&Major, &Minor, &Patch) ; - - /* check that libdb is recent enough -- we need 2.3.4 or greater */ - if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) - croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", - Major, Minor, Patch) ; - -#if PERL_VERSION > 3 - sv_setpvf(ver_sv, "%d.%d", Major, Minor) ; -#else - { - char buffer[40] ; - sprintf(buffer, "%d.%d", Major, Minor) ; - sv_setpv(ver_sv, buffer) ; - } -#endif - -#else - sv_setiv(ver_sv, 1) ; -#endif - -} - static int +#ifdef CAN_PROTOTYPE +btree_compare(const DBT *key1, const DBT *key2) +#else btree_compare(key1, key2) const DBT * key1 ; const DBT * key2 ; +#endif { +#ifdef dTHX + dTHX; +#endif dSP ; void * data1, * data2 ; int retval ; @@ -383,6 +491,7 @@ const DBT * key2 ; data1 = key1->data ; data2 = key2->data ; +#ifndef newSVpvn /* As newSVpv will assume that the data pointer is a null terminated C string if the size parameter is 0, make sure that data points to an empty string if the length is 0 @@ -391,14 +500,15 @@ const DBT * key2 ; data1 = "" ; if (key2->size == 0) data2 = "" ; +#endif ENTER ; SAVETMPS; PUSHMARK(SP) ; EXTEND(SP,2) ; - PUSHs(sv_2mortal(newSVpv(data1,key1->size))); - PUSHs(sv_2mortal(newSVpv(data2,key2->size))); + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); PUTBACK ; count = perl_call_sv(CurrentDB->compare, G_SCALAR); @@ -418,10 +528,17 @@ const DBT * key2 ; } static DB_Prefix_t +#ifdef CAN_PROTOTYPE +btree_prefix(const DBT *key1, const DBT *key2) +#else btree_prefix(key1, key2) const DBT * key1 ; const DBT * key2 ; +#endif { +#ifdef dTHX + dTHX; +#endif dSP ; void * data1, * data2 ; int retval ; @@ -430,6 +547,7 @@ const DBT * key2 ; data1 = key1->data ; data2 = key2->data ; +#ifndef newSVpvn /* As newSVpv will assume that the data pointer is a null terminated C string if the size parameter is 0, make sure that data points to an empty string if the length is 0 @@ -438,14 +556,15 @@ const DBT * key2 ; data1 = "" ; if (key2->size == 0) data2 = "" ; +#endif ENTER ; SAVETMPS; PUSHMARK(SP) ; EXTEND(SP,2) ; - PUSHs(sv_2mortal(newSVpv(data1,key1->size))); - PUSHs(sv_2mortal(newSVpv(data2,key2->size))); + PUSHs(sv_2mortal(newSVpvn(data1,key1->size))); + PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); PUTBACK ; count = perl_call_sv(CurrentDB->prefix, G_SCALAR); @@ -465,16 +584,25 @@ const DBT * key2 ; } static DB_Hash_t +#ifdef CAN_PROTOTYPE +hash_cb(const void *data, size_t size) +#else hash_cb(data, size) const void * data ; size_t size ; +#endif { +#ifdef dTHX + dTHX; +#endif dSP ; int retval ; int count ; +#ifndef newSVpvn if (size == 0) data = "" ; +#endif /* DGH - Next two lines added to fix corrupted stack problem */ ENTER ; @@ -482,7 +610,7 @@ size_t size ; PUSHMARK(SP) ; - XPUSHs(sv_2mortal(newSVpv((char*)data,size))); + XPUSHs(sv_2mortal(newSVpvn((char*)data,size))); PUTBACK ; count = perl_call_sv(CurrentDB->hash, G_SCALAR); @@ -502,11 +630,15 @@ size_t size ; } -#ifdef TRACE +#if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) static void +#ifdef CAN_PROTOTYPE +PrintHash(INFO *hash) +#else PrintHash(hash) INFO * hash ; +#endif { printf ("HASH Info\n") ; printf (" hash = %s\n", @@ -520,8 +652,12 @@ INFO * hash ; } static void +#ifdef CAN_PROTOTYPE +PrintRecno(INFO *recno) +#else PrintRecno(recno) INFO * recno ; +#endif { printf ("RECNO Info\n") ; printf (" flags = %d\n", recno->db_RE_flags) ; @@ -534,8 +670,12 @@ INFO * recno ; } static void +#ifdef CAN_PROTOTYPE +PrintBtree(INFO *btree) +#else PrintBtree(btree) INFO * btree ; +#endif { printf ("BTREE Info\n") ; printf (" compare = %s\n", @@ -562,15 +702,19 @@ INFO * btree ; static I32 +#ifdef CAN_PROTOTYPE +GetArrayLength(pTHX_ DB_File db) +#else GetArrayLength(db) DB_File db ; +#endif { DBT key ; DBT value ; int RETVAL ; - DBT_flags(key) ; - DBT_flags(value) ; + DBT_clear(key) ; + DBT_clear(value) ; RETVAL = do_SEQ(db, key, value, R_LAST) ; if (RETVAL == 0) RETVAL = *(I32 *)key.data ; @@ -581,13 +725,17 @@ DB_File db ; } static recno_t +#ifdef CAN_PROTOTYPE +GetRecnoKey(pTHX_ DB_File db, I32 value) +#else GetRecnoKey(db, value) DB_File db ; I32 value ; +#endif { if (value < 0) { /* Get the length of the array */ - I32 length = GetArrayLength(db) ; + I32 length = GetArrayLength(aTHX_ db) ; /* check for attempt to write before start of array */ if (length + value + 1 <= 0) @@ -601,14 +749,22 @@ I32 value ; return value ; } + static DB_File +#ifdef CAN_PROTOTYPE +ParseOpenInfo(pTHX_ int isHASH, char *name, int flags, int mode, SV *sv) +#else ParseOpenInfo(isHASH, name, flags, mode, sv) int isHASH ; char * name ; int flags ; int mode ; SV * sv ; +#endif { + +#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */ + SV ** svp; HV * action ; DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; @@ -620,6 +776,11 @@ SV * sv ; Zero(RETVAL, 1, DB_File_type) ; /* Default to HASH */ +#ifdef DBM_FILTERING + RETVAL->filtering = 0 ; + RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_value = RETVAL->filter_store_value = +#endif /* DBM_FILTERING */ RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; RETVAL->type = DB_HASH ; @@ -864,25 +1025,275 @@ SV * sv ; } #else + +#if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2 + RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; +#else RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; +#endif /* DB_LIBRARY_COMPATIBILITY_API */ + #endif return (RETVAL) ; -} +#else /* Berkeley DB Version > 2 */ + + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + DB * dbp ; + STRLEN n_a; + int status ; + +/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Zero(RETVAL, 1, DB_File_type) ; + + /* Default to HASH */ +#ifdef DBM_FILTERING + RETVAL->filtering = 0 ; + RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_value = RETVAL->filter_store_value = +#endif /* DBM_FILTERING */ + 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) ; + + status = db_create(&RETVAL->dbp, NULL,0) ; + /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */ + if (status) { + RETVAL->dbp = NULL ; + return (RETVAL) ; + } + dbp = RETVAL->dbp ; + + if (sv) + { + if (! SvROK(sv) ) + croak ("type parameter is not a reference") ; + + 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 ; + + svp = hv_fetch(action, "hash", 4, FALSE); + + if (svp && SvOK(*svp)) + { + (void)dbp->set_h_hash(dbp, hash_cb) ; + RETVAL->hash = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "ffactor", 7, FALSE); + if (svp) + (void)dbp->set_h_ffactor(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "nelem", 5, FALSE); + if (svp) + (void)dbp->set_h_nelem(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "bsize", 5, FALSE); + if (svp) + (void)dbp->set_pagesize(dbp, SvIV(*svp)); + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) + (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) + (void)dbp->set_lorder(dbp, SvIV(*svp)) ; + + 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 ; + + svp = hv_fetch(action, "compare", 7, FALSE); + if (svp && SvOK(*svp)) + { + (void)dbp->set_bt_compare(dbp, btree_compare) ; + RETVAL->compare = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "prefix", 6, FALSE); + if (svp && SvOK(*svp)) + { + (void)dbp->set_bt_prefix(dbp, btree_prefix) ; + RETVAL->prefix = newSVsv(*svp) ; + } + + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) + (void)dbp->set_flags(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) + (void)dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) + (void)dbp->set_pagesize(dbp, SvIV(*svp)) ; + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) + (void)dbp->set_lorder(dbp, SvIV(*svp)) ; + + PrintBtree(info) ; + + } + else if (sv_isa(sv, "DB_File::RECNOINFO")) + { + int fixed = FALSE ; + + if (isHASH) + croak("DB_File can only tie an array to a DB_RECNO database"); + + RETVAL->type = DB_RECNO ; + + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) { + int flags = SvIV(*svp) ; + /* remove FIXDLEN, if present */ + if (flags & DB_FIXEDLEN) { + fixed = TRUE ; + flags &= ~DB_FIXEDLEN ; + } + } + + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) { + status = dbp->set_cachesize(dbp, 0, SvIV(*svp), 0) ; + } + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) { + status = dbp->set_pagesize(dbp, SvIV(*svp)) ; + } + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) { + status = dbp->set_lorder(dbp, SvIV(*svp)) ; + } + + svp = hv_fetch(action, "bval", 4, FALSE); + if (svp && SvOK(*svp)) + { + int value ; + if (SvPOK(*svp)) + value = (int)*SvPV(*svp, n_a) ; + else + value = SvIV(*svp) ; + + if (fixed) { + status = dbp->set_re_pad(dbp, value) ; + } + else { + status = dbp->set_re_delim(dbp, value) ; + } + + } + + if (fixed) { + svp = hv_fetch(action, "reclen", 6, FALSE); + if (svp) { + u_int32_t len = (u_int32_t)SvIV(*svp) ; + status = dbp->set_re_len(dbp, len) ; + } + } + + if (name != NULL) { + status = dbp->set_re_source(dbp, name) ; + name = NULL ; + } + + svp = hv_fetch(action, "bfname", 6, FALSE); + if (svp && SvOK(*svp)) { + char * ptr = SvPV(*svp,n_a) ; + name = (char*) n_a ? ptr : NULL ; + } + else + name = NULL ; + + + status = dbp->set_flags(dbp, DB_RENUMBER) ; + + if (flags){ + (void)dbp->set_flags(dbp, flags) ; + } + PrintRecno(info) ; + } + else + croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + } + + { + int Flags = 0 ; + int status ; + + /* Map 1.x flags to 3.x flags */ + if ((flags & O_CREAT) == O_CREAT) + Flags |= DB_CREATE ; + +#if O_RDONLY == 0 + if (flags == O_RDONLY) +#else + if ((flags & O_RDONLY) == O_RDONLY && (flags & O_RDWR) != O_RDWR) +#endif + Flags |= DB_RDONLY ; + +#ifdef O_TRUNC + if ((flags & O_TRUNC) == O_TRUNC) + Flags |= DB_TRUNCATE ; +#endif + + status = RETVAL->dbp->open(RETVAL->dbp, name, NULL, RETVAL->type, + Flags, mode) ; + /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ + + if (status == 0) + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, + 0) ; + /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ + + if (status) + RETVAL->dbp = NULL ; + + } + + return (RETVAL) ; + +#endif /* Berkeley DB Version > 2 */ + +} /* ParseOpenInfo */ -static int -not_here(s) -char *s; -{ - croak("DB_File::%s not implemented on this architecture", s); - return -1; -} static double +#ifdef CAN_PROTOTYPE +constant(char *name, int arg) +#else constant(name, arg) char *name; int arg; +#endif { errno = 0; switch (*name) { @@ -1115,11 +1526,11 @@ MODULE = DB_File PACKAGE = DB_File PREFIX = db_ BOOT: { - GetVersionInfo() ; + __getBerkeleyDBInfo() ; + DBT_clear(empty) ; empty.data = &zero ; empty.size = sizeof(recno_t) ; - DBT_flags(empty) ; } double @@ -1146,7 +1557,7 @@ db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_H if (items == 6) sv = ST(5) ; - RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ; + RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ; if (RETVAL->dbp == NULL) RETVAL = NULL ; } @@ -1165,7 +1576,17 @@ db_DESTROY(db) SvREFCNT_dec(db->compare) ; if (db->prefix) SvREFCNT_dec(db->prefix) ; - Safefree(db) ; +#ifdef DBM_FILTERING + if (db->filter_fetch_key) + SvREFCNT_dec(db->filter_fetch_key) ; + if (db->filter_store_key) + SvREFCNT_dec(db->filter_store_key) ; + if (db->filter_fetch_value) + SvREFCNT_dec(db->filter_fetch_value) ; + if (db->filter_store_value) + SvREFCNT_dec(db->filter_store_value) ; +#endif /* DBM_FILTERING */ + safefree(db) ; #ifdef DB_VERSION_MAJOR if (RETVAL > 0) RETVAL = -1 ; @@ -1189,7 +1610,7 @@ db_EXISTS(db, key) { DBT value ; - DBT_flags(value) ; + DBT_clear(value) ; CurrentDB = db ; RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; } @@ -1205,7 +1626,7 @@ db_FETCH(db, key, flags=0) { DBT value ; - DBT_flags(value) ; + DBT_clear(value) ; CurrentDB = db ; /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */ RETVAL = db_get(db, key, value, flags) ; @@ -1231,8 +1652,8 @@ db_FIRSTKEY(db) DBTKEY key ; DBT value ; - DBT_flags(key) ; - DBT_flags(value) ; + DBT_clear(key) ; + DBT_clear(value) ; CurrentDB = db ; RETVAL = do_SEQ(db, key, value, R_FIRST) ; ST(0) = sv_newmortal(); @@ -1247,7 +1668,7 @@ db_NEXTKEY(db, key) { DBT value ; - DBT_flags(value) ; + DBT_clear(value) ; CurrentDB = db ; RETVAL = do_SEQ(db, key, value, R_NEXT) ; ST(0) = sv_newmortal(); @@ -1271,8 +1692,8 @@ unshift(db, ...) DB * Db = db->dbp ; STRLEN n_a; - DBT_flags(key) ; - DBT_flags(value) ; + DBT_clear(key) ; + DBT_clear(value) ; CurrentDB = db ; #ifdef DB_VERSION_MAJOR /* get the first value */ @@ -1309,8 +1730,8 @@ pop(db) DBTKEY key ; DBT value ; - DBT_flags(key) ; - DBT_flags(value) ; + DBT_clear(key) ; + DBT_clear(value) ; CurrentDB = db ; /* First get the final value */ @@ -1336,8 +1757,8 @@ shift(db) DBT value ; DBTKEY key ; - DBT_flags(key) ; - DBT_flags(value) ; + DBT_clear(key) ; + DBT_clear(value) ; CurrentDB = db ; /* get the first value */ RETVAL = do_SEQ(db, key, value, R_FIRST) ; @@ -1365,50 +1786,44 @@ push(db, ...) DB * Db = db->dbp ; int i ; STRLEN n_a; + int keyval ; DBT_flags(key) ; DBT_flags(value) ; CurrentDB = db ; -#ifdef DB_VERSION_MAJOR - RETVAL = 0 ; - key = empty ; - for (i = 1 ; i < items ; ++i) - { - value.data = SvPV(ST(i), n_a) ; - value.size = n_a ; - RETVAL = (Db->put)(Db, NULL, &key, &value, DB_APPEND) ; - if (RETVAL != 0) - break; - } -#else /* Set the Cursor to the Last element */ RETVAL = do_SEQ(db, key, value, R_LAST) ; +#ifndef DB_VERSION_MAJOR if (RETVAL >= 0) +#endif { - if (RETVAL == 1) - key = empty ; - for (i = items - 1 ; i > 0 ; --i) + if (RETVAL == 0) + keyval = *(int*)key.data ; + else + keyval = 0 ; + for (i = 1 ; i < items ; ++i) { value.data = SvPV(ST(i), n_a) ; value.size = n_a ; - RETVAL = (Db->put)(Db, &key, &value, R_IAFTER) ; + ++ keyval ; + key.data = &keyval ; + key.size = sizeof(int) ; + RETVAL = (Db->put)(Db, TXN &key, &value, 0) ; if (RETVAL != 0) break; } } -#endif } OUTPUT: RETVAL - I32 length(db) DB_File db ALIAS: FETCHSIZE = 1 CODE: CurrentDB = db ; - RETVAL = GetArrayLength(db) ; + RETVAL = GetArrayLength(aTHX_ db) ; OUTPUT: RETVAL @@ -1443,7 +1858,7 @@ db_get(db, key, value, flags=0) u_int flags CODE: CurrentDB = db ; - DBT_flags(value) ; + DBT_clear(value) ; RETVAL = db_get(db, key, value, flags) ; #ifdef DB_VERSION_MAJOR if (RETVAL > 0) @@ -1518,7 +1933,7 @@ db_seq(db, key, value, flags) u_int flags CODE: CurrentDB = db ; - DBT_flags(value) ; + DBT_clear(value) ; RETVAL = db_seq(db, key, value, flags); #ifdef DB_VERSION_MAJOR if (RETVAL > 0) @@ -1531,3 +1946,56 @@ db_seq(db, key, value, flags) key value +#ifdef DBM_FILTERING + +#define setFilter(type) \ + { \ + if (db->type) \ + RETVAL = sv_mortalcopy(db->type) ; \ + ST(0) = RETVAL ; \ + if (db->type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->type) ; \ + db->type = NULL ; \ + } \ + else if (code) { \ + if (db->type) \ + sv_setsv(db->type, code) ; \ + else \ + db->type = newSVsv(code) ; \ + } \ + } + + +SV * +filter_fetch_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_key) ; + +SV * +filter_store_key(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; + +#endif /* DBM_FILTERING */ diff --git a/gnu/usr.bin/perl/ext/DB_File/Makefile.PL b/gnu/usr.bin/perl/ext/DB_File/Makefile.PL index 1a13e0bbd8e..cac6578bb30 100644 --- a/gnu/usr.bin/perl/ext/DB_File/Makefile.PL +++ b/gnu/usr.bin/perl/ext/DB_File/Makefile.PL @@ -14,7 +14,15 @@ WriteMakefile( MAN3PODS => {}, # Pods will be built by installman. #INC => '-I/usr/local/include', VERSION_FROM => 'DB_File.pm', + OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', XSPROTOARG => '-noprototypes', - DEFINE => "$OS2", + DEFINE => $OS2 || "", ); +sub MY::postamble { + ' +version$(OBJ_EXT): version.c + +' ; +} + diff --git a/gnu/usr.bin/perl/ext/DB_File/typemap b/gnu/usr.bin/perl/ext/DB_File/typemap index 994ba272323..41a24f4a863 100644 --- a/gnu/usr.bin/perl/ext/DB_File/typemap +++ b/gnu/usr.bin/perl/ext/DB_File/typemap @@ -1,8 +1,8 @@ # typemap for Perl 5 interface to Berkeley # # written by Paul Marquess <Paul.Marquess@btinternet.com> -# last modified 21st February 1999 -# version 1.65 +# last modified 7th September 1999 +# version 1.71 # #################################### DB SECTION # @@ -15,21 +15,23 @@ DBTKEY T_dbtkeydatum INPUT T_dbtkeydatum + ckFilter($arg, filter_store_key, \"filter_store_key\"); + DBT_clear($var) ; if (db->type != DB_RECNO) { $var.data = SvPV($arg, PL_na); $var.size = (int)PL_na; - DBT_flags($var); } else { - Value = GetRecnoKey(db, SvIV($arg)) ; + Value = GetRecnoKey(aTHX_ db, SvIV($arg)) ; $var.data = & Value; $var.size = (int)sizeof(recno_t); - DBT_flags($var); } T_dbtdatum + ckFilter($arg, filter_store_value, \"filter_store_value\"); + DBT_clear($var) ; $var.data = SvPV($arg, PL_na); $var.size = (int)PL_na; - DBT_flags($var); + OUTPUT diff --git a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL index 2141fdeb2f6..83cbd770b06 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL +++ b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL @@ -8,14 +8,19 @@ WriteMakefile( SKIP => [qw(dynamic dynamic_lib dynamic_bs)], XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'DynaLoader_pm.PL', - PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm'}, - PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm'}, - clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm'}, + PL_FILES => {'DynaLoader_pm.PL'=>'DynaLoader.pm', + 'XSLoader_pm.PL'=>'XSLoader.pm'}, + PM => {'DynaLoader.pm' => '$(INST_LIBDIR)/DynaLoader.pm', + 'XSLoader.pm' => '$(INST_LIBDIR)/XSLoader.pm'}, + depend => {'DynaLoader.o' => 'dlutils.c'}, + clean => {FILES => 'DynaLoader.c DynaLoader.xs DynaLoader.pm ' . + 'XSLoader.pm'}, ); sub MY::postamble { ' DynaLoader.xs: $(DLSRC) + $(RM_F) $@ $(CP) $? $@ # Perform very simple tests just to check for major gaffs. diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs index ea5040857d0..35242ed652d 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs @@ -20,6 +20,15 @@ #include "perl.h" #include "XSUB.h" +/* When building as a 64-bit binary on AIX, define this to get the + * correct structure definitions. Also determines the field-name + * macros and gates some logic in readEntries(). -- Steven N. Hirsch + * <hirschs@btv.ibm.com> */ +#ifdef USE_64_BIT_ALL +# define __XCOFF64__ +# define __XCOFF32__ +#endif + #include <stdio.h> #include <errno.h> #include <string.h> @@ -29,6 +38,39 @@ #include <a.out.h> #include <ldfcn.h> +#ifdef USE_64_BIT_ALL +# define AIX_SCNHDR SCNHDR_64 +# define AIX_LDHDR LDHDR_64 +# define AIX_LDSYM LDSYM_64 +# define AIX_LDHDRSZ LDHDRSZ_64 +#else +# define AIX_SCNHDR SCNHDR +# define AIX_LDHDR LDHDR +# define AIX_LDSYM LDSYM +# define AIX_LDHDRSZ LDHDRSZ +#endif + +/* When using Perl extensions written in C++ the longer versions + * of load() and unload() from libC and libC_r need to be used, + * otherwise statics in the extensions won't get initialized right. + * -- Stephanie Beals <bealzy@us.ibm.com> */ + +/* Older AIX C compilers cannot deal with C++ double-slash comments in + the ibmcxx and/or xlC includes. Since we only need a single file, + be more fine-grained about what's included <hirschs@btv.ibm.com> */ +#ifdef USE_libC /* The define comes, when it comes, from hints/aix.pl. */ +# define LOAD loadAndInit +# define UNLOAD terminateAndUnload +# if defined(USE_xlC_load_h) +# include "/usr/lpp/xlC/include/load.h" +# elif defined(USE_ibmcxx_load_h) +# include "/usr/ibmcxx/include/load.h" +# endif +#else +# define LOAD load +# define UNLOAD unload +#endif + /* * AIX 4.3 does remove some useful definitions from ldfcn.h. Define * these here to compensate for that lossage. @@ -77,19 +119,18 @@ typedef struct Module { * We keep a list of all loaded modules to be able to call the fini * handlers at atexit() time. */ -static ModulePtr modList; +static ModulePtr modList; /* XXX threaded */ /* * The last error from one of the dl* routines is kept in static * variables here. Each error is returned only once to the caller. */ -static char errbuf[BUFSIZ]; -static int errvalid; +static char errbuf[BUFSIZ]; /* XXX threaded */ +static int errvalid; /* XXX threaded */ static void caterr(char *); static int readExports(ModulePtr); static void terminate(void); -static void *findMain(void); static char *strerror_failed = "(strerror failed)"; static char *strerror_r_failed = "(strerror_r failed)"; @@ -104,7 +145,7 @@ char *strerrorcat(char *str, int err) { if (buf == 0) return 0; - if (strerror_r(err, buf, sizeof(buf)) == 0) + if (strerror_r(err, buf, BUFSIZ) == 0) msg = buf; else msg = strerror_r_failed; @@ -132,7 +173,7 @@ char *strerrorcpy(char *str, int err) { if (buf == 0) return 0; - if (strerror_r(err, buf, sizeof(buf)) == 0) + if (strerror_r(err, buf, BUFSIZ) == 0) msg = buf; else msg = strerror_r_failed; @@ -154,17 +195,16 @@ char *strerrorcpy(char *str, int err) { /* ARGSUSED */ void *dlopen(char *path, int mode) { + dTHX; register ModulePtr mp; - static void *mainModule; + static int inited; /* XXX threaded */ /* * Upon the first call register a terminate handler that will - * close all libraries. Also get a reference to the main module - * for use with loadbind. + * close all libraries. */ - if (!mainModule) { - if ((mainModule = findMain()) == NULL) - return NULL; + if (!inited) { + inited++; atexit(terminate); } /* @@ -190,11 +230,19 @@ void *dlopen(char *path, int mode) safefree(mp); return NULL; } + /* * load should be declared load(const char *...). Thus we * cast the path to a normal char *. Ugly. */ - if ((mp->entry = (void *)load((char *)path, L_NOAUTODEFER, NULL)) == NULL) { + if ((mp->entry = (void *)LOAD((char *)path, +#ifdef L_LIBPATH_EXEC + L_LIBPATH_EXEC | +#endif + L_NOAUTODEFER, + NULL)) == NULL) { + int saverrno = errno; + safefree(mp->name); safefree(mp); errvalid++; @@ -206,27 +254,34 @@ void *dlopen(char *path, int mode) * can be further described by querying the loader about * the last error. */ - if (errno == ENOEXEC) { - char *tmp[BUFSIZ/sizeof(char *)]; - if (loadquery(L_GETMESSAGES, tmp, sizeof(tmp)) == -1) - strerrorcpy(errbuf, errno); + if (saverrno == ENOEXEC) { + char *moreinfo[BUFSIZ/sizeof(char *)]; + if (loadquery(L_GETMESSAGES, moreinfo, sizeof(moreinfo)) == -1) + strerrorcpy(errbuf, saverrno); else { char **p; - for (p = tmp; *p; p++) + for (p = moreinfo; *p; p++) caterr(*p); } } else - strerrorcat(errbuf, errno); + strerrorcat(errbuf, saverrno); return NULL; } mp->refCnt = 1; mp->next = modList; modList = mp; - if (loadbind(0, mainModule, mp->entry) == -1) { + /* + * Assume anonymous exports come from the module this dlopen + * is linked into, that holds true as long as dlopen and all + * of the perl core are in the same shared object. + */ + if (loadbind(0, (void *)dlopen, mp->entry) == -1) { + int saverrno = errno; + dlclose(mp); errvalid++; strcpy(errbuf, "loadbind: "); - strerrorcat(errbuf, errno); + strerrorcat(errbuf, saverrno); return NULL; } if (readExports(mp) == -1) { @@ -311,7 +366,7 @@ int dlclose(void *handle) if (--mp->refCnt > 0) return 0; - result = unload(mp->entry); + result = UNLOAD(mp->entry); if (result == -1) { errvalid++; strerrorcpy(errbuf, errno); @@ -364,11 +419,12 @@ void *calloc(size_t ne, size_t sz) */ static int readExports(ModulePtr mp) { + dTHX; LDFILE *ldp = NULL; - SCNHDR sh; - LDHDR *lhp; + AIX_SCNHDR sh; + AIX_LDHDR *lhp; char *ldbuf; - LDSYM *ls; + AIX_LDSYM *ls; int i; ExportPtr ep; @@ -412,7 +468,7 @@ static int readExports(ModulePtr mp) } /* * Traverse the list of loaded modules. The entry point - * returned by load() does actually point to the data + * returned by LOAD() does actually point to the data * segment origin. */ lp = (struct ld_info *)buf; @@ -434,7 +490,11 @@ static int readExports(ModulePtr mp) return -1; } } +#ifdef USE_64_BIT_ALL + if (TYPE(ldp) != U803XTOCMAGIC) { +#else if (TYPE(ldp) != U802TOCMAGIC) { +#endif errvalid++; strcpy(errbuf, "readExports: bad magic"); while(ldclose(ldp) == FAILURE) @@ -482,8 +542,8 @@ static int readExports(ModulePtr mp) ; return -1; } - lhp = (LDHDR *)ldbuf; - ls = (LDSYM *)(ldbuf+LDHDRSZ); + lhp = (AIX_LDHDR *)ldbuf; + ls = (AIX_LDSYM *)(ldbuf+AIX_LDHDRSZ); /* * Count the number of exports to include in our export table. */ @@ -507,15 +567,19 @@ static int readExports(ModulePtr mp) * the entry point we got from load. */ ep = mp->exports; - ls = (LDSYM *)(ldbuf+LDHDRSZ); + ls = (AIX_LDSYM *)(ldbuf+AIX_LDHDRSZ); for (i = lhp->l_nsyms; i; i--, ls++) { char *symname; if (!LDR_EXPORT(*ls)) continue; +#ifndef USE_64_BIT_ALL if (ls->l_zeroes == 0) +#endif symname = ls->l_offset+lhp->l_stoff+ldbuf; +#ifndef USE_64_BIT_ALL else symname = ls->l_name; +#endif ep->name = savepv(symname); ep->addr = (void *)((unsigned long)mp->entry + ls->l_value); ep++; @@ -526,56 +590,10 @@ static int readExports(ModulePtr mp) return 0; } -/* - * Find the main modules entry point. This is used as export pointer - * for loadbind() to be able to resolve references to the main part. - */ -static void * findMain(void) -{ - struct ld_info *lp; - char *buf; - int size = 4*1024; - int i; - void *ret; - - if ((buf = safemalloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "findMain: "); - strerrorcat(errbuf, errno); - return NULL; - } - while ((i = loadquery(L_GETINFO, buf, size)) == -1 && errno == ENOMEM) { - safefree(buf); - size += 4*1024; - if ((buf = safemalloc(size)) == NULL) { - errvalid++; - strcpy(errbuf, "findMain: "); - strerrorcat(errbuf, errno); - return NULL; - } - } - if (i == -1) { - errvalid++; - strcpy(errbuf, "findMain: "); - strerrorcat(errbuf, errno); - safefree(buf); - return NULL; - } - /* - * The first entry is the main module. The entry point - * returned by load() does actually point to the data - * segment origin. - */ - lp = (struct ld_info *)buf; - ret = lp->ldinfo_dataorg; - safefree(buf); - return ret; -} - /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. - * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Author: Paul Marquess (Paul.Marquess@btinternet.com) * Created: 10th July 1994 * * Modified: @@ -597,15 +615,15 @@ static void * findMain(void) static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(aTHX); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * @@ -613,16 +631,16 @@ dl_load_file(filename, flags=0) char * filename int flags CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "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); + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); RETVAL = dlopen(filename, 1) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void * @@ -630,15 +648,15 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); void @@ -655,9 +673,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_beos.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_beos.xs index 42a27cb1f17..705c8bc4d07 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_beos.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_beos.xs @@ -18,15 +18,15 @@ #include "dlutils.c" /* SaveError() etc */ static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(aTHX); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * @@ -45,16 +45,16 @@ dl_load_file(filename, flags=0) strcpy(path, filename); } - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", path, flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", path, flags)); bogo = load_add_on(path); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (bogo < 0) { - SaveError("%s", strerror(bogo)); - PerlIO_printf(PerlIO_stderr(), "load_add_on(%s) : %d (%s)\n", path, bogo, strerror(bogo)); + SaveError(aTHX_ "%s", strerror(bogo)); + PerlIO_printf(Perl_debug_log, "load_add_on(%s) : %d (%s)\n", path, bogo, strerror(bogo)); } else { RETVAL = (void *) bogo; - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); } free(path); } @@ -67,23 +67,23 @@ dl_find_symbol(libhandle, symbolname) status_t retcode; void *adr = 0; #ifdef DLSYM_NEEDS_UNDERSCORE - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif RETVAL = NULL; - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); retcode = get_image_symbol((image_id) libhandle, symbolname, B_SYMBOL_TYPE_TEXT, (void **) &adr); RETVAL = adr; - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) { - SaveError("%s", strerror(retcode)) ; - PerlIO_printf(PerlIO_stderr(), "retcode = %p (%s)\n", retcode, strerror(retcode)); + SaveError(aTHX_ "%s", strerror(retcode)) ; + PerlIO_printf(Perl_debug_log, "retcode = %p (%s)\n", retcode, strerror(retcode)); } else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); void @@ -100,9 +100,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", perl_name, (unsigned long) symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((CV *)))symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs deleted file mode 100644 index b64ab3e3456..00000000000 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs +++ /dev/null @@ -1,153 +0,0 @@ -/* 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,PerlIO_printf(PerlIO_stderr(),"dl_load_file(%s):\n", filename)); - - RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ; - - DLDEBUG(2,PerlIO_printf(PerlIO_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,PerlIO_printf(PerlIO_stderr(),"dl_find_symbol(handle=%x, symbol=%s)\n", - libhandle, symbolname)); - RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname); - DLDEBUG(2,PerlIO_printf(PerlIO_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,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))); - - -char * -dl_error() - CODE: - RETVAL = LastError ; - OUTPUT: - RETVAL - -# end. diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs index 2443ab0d694..d8fad2ac5e2 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs @@ -48,12 +48,12 @@ static AV *dl_resolve_using = Nullav; static AV *dl_require_symbols = Nullav; static void -dl_private_init() +dl_private_init(pTHX) { int dlderr; - dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); - dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4); + dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); + dl_require_symbols = get_av("DynaLoader::dl_require_symbols", GV_ADDMULTI); #ifdef __linux__ dlderr = dld_init("/proc/self/exe"); if (dlderr) { @@ -61,8 +61,8 @@ dl_private_init() dlderr = dld_init(dld_find_executable(PL_origargv[0])); if (dlderr) { char *msg = dld_strerror(dlderr); - SaveError("dld_init(%s) failed: %s", PL_origargv[0], msg); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "%s", LastError)); + SaveError(aTHX_ "dld_init(%s) failed: %s", PL_origargv[0], msg); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "%s", LastError)); } #ifdef __linux__ } @@ -85,40 +85,40 @@ dl_load_file(filename, flags=0) GV *gv; CODE: RETVAL = filename; - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "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); + Perl_croak(aTHX_ "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,PerlIO_printf(PerlIO_stderr(), "dld_create_ref(%s)\n", sym)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_create_ref(%s)\n", sym)); if (dlderr = dld_create_reference(sym)) { - SaveError("dld_create_reference(%s): %s", sym, + SaveError(aTHX_ "dld_create_reference(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", filename)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", filename)); if (dlderr = dld_link(filename)) { - SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); + SaveError(aTHX_ "dld_link(%s): %s", filename, dld_strerror(dlderr)); goto haverror; } max = AvFILL(dl_resolve_using); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", sym)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dld_link(%s)\n", sym)); if (dlderr = dld_link(sym)) { - SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); + SaveError(aTHX_ "dld_link(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "libref=%s\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "libref=%s\n", RETVAL)); haverror: ST(0) = sv_newmortal() ; if (dlderr == 0) - sv_setiv(ST(0), (IV)RETVAL); + sv_setiv(ST(0), PTR2IV(RETVAL)); void * @@ -126,16 +126,16 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "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,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ; + SaveError(aTHX_ "dl_find_symbol: Unable to find '%s' symbol", symbolname) ; else - sv_setiv(ST(0), (IV)RETVAL); + sv_setiv(ST(0), PTR2IV(RETVAL)); void @@ -160,9 +160,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs index 24592056531..8e4936d128d 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs @@ -1,15 +1,17 @@ /* dl_dlopen.xs * * Platform: SunOS/Solaris, possibly others which use dlopen. - * Author: Paul Marquess (pmarquess@bfsec.bt.co.uk) + * Author: Paul Marquess (Paul.Marquess@btinternet.com) * Created: 10th July 1994 * * Modified: - * 15th July 1994 - Added code to explicitly save any error messages. - * 3rd August 1994 - Upgraded to v3 spec. - * 9th August 1994 - Changed to use IV - * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, - * basic FreeBSD support, removed ClearError + * 15th July 1994 - Added code to explicitly save any error messages. + * 3rd August 1994 - Upgraded to v3 spec. + * 9th August 1994 - Changed to use IV + * 10th August 1994 - Tim Bunce: Added RTLD_LAZY, switchable debugging, + * basic FreeBSD support, removed ClearError + * 29th Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd + * files when the interpreter exits * */ @@ -37,6 +39,17 @@ RTLD_LAZY (==2) on Solaris 2. + dlclose + ------- + int + dlclose(handle) + void * handle; + + This function takes the handle returned by a previous invocation of + dlopen and closes the associated dynamic object file. It returns zero + on success, and non-zero on failure. + + dlsym ------ void * @@ -57,7 +70,7 @@ Returns a null-terminated string which describes the last error that occurred with either dlopen or dlsym. After each call to dlerror the error message will be reset to a null pointer. The - SaveError function is used to save the error as soo as it happens. + SaveError function is used to save the error as soon as it happens. Return Types @@ -131,24 +144,35 @@ static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); + (void)dl_generic_private_init(aTHX); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * dl_load_file(filename, flags=0) char * filename int flags - PREINIT: + PREINIT: int mode = RTLD_LAZY; - CODE: + CODE: +{ +#if defined(DLOPEN_WONT_DO_RELATIVE_PATHS) + char pathbuf[PATH_MAX + 2]; + if (*filename != '/' && strchr(filename, '/')) { + if (getcwd(pathbuf, PATH_MAX - strlen(filename))) { + strcat(pathbuf, "/"); + strcat(pathbuf, filename); + filename = pathbuf; + } + } +#endif #ifdef RTLD_NOW if (dl_nonlazy) mode = RTLD_NOW; @@ -157,16 +181,30 @@ dl_load_file(filename, flags=0) #ifdef RTLD_GLOBAL mode |= RTLD_GLOBAL; #else - warn("Can't make loaded symbols global on this platform while loading %s",filename); + Perl_warn(aTHX_ "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)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags)); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); +} + + +int +dl_unload_file(libref) + void * libref + CODE: + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_unload_file(%lx):\n", libref)); + RETVAL = (dlclose(libref) == 0 ? 1 : 0); + if (!RETVAL) + SaveError(aTHX_ "%s", dlerror()) ; + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " retval = %d\n", RETVAL)); + OUTPUT: + RETVAL void * @@ -175,19 +213,19 @@ dl_find_symbol(libhandle, symbolname) char * symbolname CODE: #ifdef DLSYM_NEEDS_UNDERSCORE - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL)); void @@ -204,9 +242,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%lx)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n", perl_name, (unsigned long) symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)_((CV *)))symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs index a82e0eac111..582c047be87 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs @@ -33,16 +33,16 @@ static AV *dl_resolve_using = Nullav; static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); + (void)dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void * @@ -53,9 +53,9 @@ dl_load_file(filename, flags=0) shl_t obj = NULL; int i, max, bind_type; CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "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); + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); if (dl_nonlazy) { bind_type = BIND_IMMEDIATE|BIND_VERBOSE; } else { @@ -76,23 +76,23 @@ dl_load_file(filename, flags=0) max = AvFILL(dl_resolve_using); for (i = 0; i <= max; i++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s) (dependent)\n", sym)); obj = shl_load(sym, bind_type, 0L); if (obj == NULL) { goto end; } } - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s): ", filename)); obj = shl_load(filename, bind_type, 0L); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", obj)); end: ST(0) = sv_newmortal() ; if (obj == NULL) - SaveError("%s",Strerror(errno)); + SaveError(aTHX_ "%s",Strerror(errno)); else - sv_setiv( ST(0), (IV)obj); + sv_setiv( ST(0), PTR2IV(obj) ); void * @@ -104,9 +104,9 @@ dl_find_symbol(libhandle, symbolname) void *symaddr = NULL; int status; #ifdef __hp9000s300 - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); @@ -114,17 +114,17 @@ dl_find_symbol(libhandle, symbolname) errno = 0; status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(PROCEDURE) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(PROCEDURE) = %x\n", symaddr)); if (status == -1 && errno == 0) { /* try TYPE_DATA instead */ status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(DATA) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " symbolref(DATA) = %x\n", symaddr)); } if (status == -1) { - SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; + SaveError(aTHX_ "%s",(errno) ? Strerror(errno) : "Symbol not found") ; } else { - sv_setiv( ST(0), (IV)symaddr); + sv_setiv( ST(0), PTR2IV(symaddr) ); } @@ -142,9 +142,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs index dfa8a3eac8c..b8c19f203ec 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs @@ -72,6 +72,7 @@ enum dyldErrorSource static void TranslateError (const char *path, enum dyldErrorSource type, int number) { + dTHX; char *error; unsigned int index; static char *OFIErrorStrings[] = @@ -92,11 +93,11 @@ static void TranslateError index = number; if (index > NUM_OFI_ERRORS - 1) index = NUM_OFI_ERRORS - 1; - error = form(OFIErrorStrings[index], path, number); + error = Perl_form_nocontext(OFIErrorStrings[index], path, number); break; default: - error = form("%s(%d): Totally unknown error type %d\n", + error = Perl_form_nocontext("%s(%d): Totally unknown error type %d\n", path, number, type); break; } @@ -209,7 +210,7 @@ char *symbol; NXStream *nxerr = OpenError(); unsigned long symref = 0; - if (!rld_lookup(nxerr, form("_%s", symbol), &symref)) + if (!rld_lookup(nxerr, Perl_form_nocontext("_%s", symbol), &symref)) TransferError(nxerr); CloseError(nxerr); return (void*) symref; @@ -222,16 +223,16 @@ char *symbol; static void -dl_private_init() +dl_private_init(pTHX) { - (void)dl_generic_private_init(); - dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); + (void)dl_generic_private_init(aTHX); + dl_resolve_using = get_av("DynaLoader::dl_resolve_using", GV_ADDMULTI); } MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); @@ -242,16 +243,16 @@ dl_load_file(filename, flags=0) PREINIT: int mode = 1; CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filename,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "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); + Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void * @@ -260,19 +261,19 @@ dl_find_symbol(libhandle, symbolname) char * symbolname CODE: #if NS_TARGET_MAJOR >= 4 - symbolname = form("_%s", symbolname); + symbolname = Perl_form_nocontext("_%s", symbolname); #endif - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, "dl_find_symbol(handle=%lx, symbol=%s)\n", (unsigned long) libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2, PerlIO_printf(PerlIO_stderr(), + DLDEBUG(2, PerlIO_printf(Perl_debug_log, " symbolref = %lx\n", (unsigned long) RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) - SaveError("%s",dlerror()) ; + SaveError(aTHX_ "%s",dlerror()) ; else - sv_setiv( ST(0), (IV)RETVAL); + sv_setiv( ST(0), PTR2IV(RETVAL) ); void @@ -289,9 +290,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs index 08fd2f3f460..d7a1f863f34 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs +++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs @@ -65,6 +65,12 @@ static AV *dl_require_symbols = Nullav; #include <ssdef.h> #include <starlet.h> +#if defined(VMS_WE_ARE_CASE_SENSITIVE) +#define DL_CASE_SENSITIVE 1<<4 +#else +#define DL_CASE_SENSITIVE 0 +#endif + typedef unsigned long int vmssts; struct libref { @@ -112,6 +118,7 @@ dl_set_error(sts,stv) vmssts stv; { vmssts vec[3]; + dTHX; vec[0] = stv ? 2 : 1; vec[1] = sts; vec[2] = stv; @@ -121,12 +128,13 @@ dl_set_error(sts,stv) static unsigned int findsym_handler(void *sig, void *mech) { + dTHX; unsigned long int myvec[8],args, *usig = (unsigned long int *) sig; /* Be paranoid and assume signal vector passed in might be readonly */ 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,PerlIO_printf(PerlIO_stderr(), "findsym_handler: received\n\t%s\n",LastError)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "findsym_handler: received\n\t%s\n",LastError)); return SS$_CONTINUE; } @@ -140,16 +148,16 @@ my_find_image_symbol(struct dsc$descriptor_s *imgname, { unsigned long int retsts; VAXC$ESTABLISH(findsym_handler); - retsts = lib$find_image_symbol(imgname,symname,entry,defspec); + retsts = lib$find_image_symbol(imgname,symname,entry,defspec,DL_CASE_SENSITIVE); return retsts; } static void -dl_private_init() +dl_private_init(pTHX) { - dl_generic_private_init(); - dl_require_symbols = perl_get_av("DynaLoader::dl_require_symbols", 0x4); + dl_generic_private_init(aTHX); + dl_require_symbols = get_av("DynaLoader::dl_require_symbols", 0x4); /* Set up the static control blocks for dl_expand_filespec() */ dlfab = cc$rms_fab; dlnam = cc$rms_nam; @@ -162,7 +170,7 @@ dl_private_init() MODULE = DynaLoader PACKAGE = DynaLoader BOOT: - (void)dl_private_init(); + (void)dl_private_init(aTHX); void dl_expandspec(filespec) @@ -177,11 +185,11 @@ dl_expandspec(filespec) dlfab.fab$b_fns = strlen(vmsspec); dlfab.fab$l_dna = 0; dlfab.fab$b_dns = 0; - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_expand_filespec(%s):\n",vmsspec)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "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,PerlIO_printf(PerlIO_stderr(), "\tSYNCHK sys$parse = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tSYNCHK sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &PL_sv_undef; @@ -194,7 +202,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,PerlIO_printf(PerlIO_stderr(), "\tsplit filespec: name = %.*s, default = %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\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 +210,7 @@ dl_expandspec(filespec) dlfab.fab$b_dns = deflen; dlfab.fab$b_fns = dlnam.nam$b_name; sts = sys$parse(&dlfab); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tname/default sys$parse = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tname/default sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &PL_sv_undef; @@ -210,14 +218,14 @@ dl_expandspec(filespec) else { /* Now find the actual file */ sts = sys$search(&dlfab); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$search = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$search = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &PL_sv_undef; } else { - ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "\tresult = \\%.*s\\\n", + ST(0) = sv_2mortal(newSVpvn(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "\tresult = \\%.*s\\\n", dlnam.nam$b_rsl,dlnam.nam$l_rsa)); } } @@ -228,6 +236,7 @@ dl_load_file(filespec, flags) char * filespec int flags PREINIT: + dTHX; char vmsspec[NAM$C_MAXRSS]; SV *reqSV, **reqSVhndl; STRLEN deflen; @@ -244,16 +253,16 @@ dl_load_file(filespec, flags) void (*entry)(); CODE: - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s,%x):\n", filespec,flags)); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "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,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tVMS-ified filespec is %s\n", specdsc.dsc$a_pointer)); 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,PerlIO_printf(PerlIO_stderr(), "\tsys$filescan: returns %d, name is %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tsys$filescan: returns %d, name is %.*s\n", sts,namlst[0].len,namlst[0].string)); if (!(sts & 1)) { failed = 1; @@ -269,21 +278,21 @@ dl_load_file(filespec, flags) memcpy(dlptr->defspec.dsc$a_pointer + deflen, namlst[0].string + namlst[0].len, dlptr->defspec.dsc$w_length - deflen); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlibref = name: %s, defspec: %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\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,PerlIO_printf(PerlIO_stderr(), "\t@dl_require_symbols empty, returning untested libref\n")); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\t@dl_require_symbols empty, returning untested libref\n")); } else { symdsc.dsc$w_length = SvCUR(reqSV); symdsc.dsc$a_pointer = SvPVX(reqSV); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t$dl_require_symbols[0] = %.*s\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\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,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts)); if (!(sts&1)) { failed = 1; dl_set_error(sts,0); @@ -298,7 +307,7 @@ dl_load_file(filespec, flags) ST(0) = &PL_sv_undef; } else { - ST(0) = sv_2mortal(newSViv((IV) dlptr)); + ST(0) = sv_2mortal(newSViv(PTR2IV(dlptr))); } @@ -313,19 +322,19 @@ dl_find_symbol(librefptr,symname) void (*entry)(); vmssts sts; - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_find_dymbol(%.*s,%.*s):\n", + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "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,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tentry point is %d\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "\tentry point is %d\n", (unsigned long int) entry)); if (!(sts & 1)) { /* error message already saved by findsym_handler */ ST(0) = &PL_sv_undef; } - else ST(0) = sv_2mortal(newSViv((IV) entry)); + else ST(0) = sv_2mortal(newSViv(PTR2IV(entry))); void @@ -341,9 +350,11 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); - ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); + ST(0) = sv_2mortal(newRV((SV*)newXS(perl_name, + (void(*)(pTHX_ CV *))symref, + filename))); char * diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c b/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c index bfa1f78ac0a..9d88f5fdadf 100644 --- a/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c +++ b/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c @@ -3,6 +3,9 @@ * Currently this file is simply #included into dl_*.xs/.c files. * It should really be split into a dlutils.h and dlutils.c * + * Modified: + * 29th Feburary 2000 - Alan Burlison: Added functionality to close dlopen'd + * files when the interpreter exits */ @@ -18,46 +21,77 @@ static HV *dl_loaded_files = Nullhv; /* only needed on a few systems */ #ifdef DEBUGGING -static int dl_debug = 0; /* value copied from $DynaLoader::dl_error */ +static int dl_debug = 0; /* value copied from $DynaLoader::dl_debug */ #define DLDEBUG(level,code) if (dl_debug>=level) { code; } #else #define DLDEBUG(level,code) #endif +/* Close all dlopen'd files */ static void -dl_generic_private_init(CPERLarg) /* called by dl_*.xs dl_private_init() */ +dl_unload_all_files(pTHXo_ void *unused) +{ + CV *sub; + AV *dl_librefs; + SV *dl_libref; + + if ((sub = get_cv("DynaLoader::dl_unload_file", FALSE)) != NULL) { + dl_librefs = get_av("DynaLoader::dl_librefs", FALSE); + while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(sv_2mortal(dl_libref)); + PUTBACK; + call_sv((SV*)sub, G_DISCARD | G_NODEBUG); + FREETMPS; + LEAVE; + } + } +} + + +static void +dl_generic_private_init(pTHXo) /* called by dl_*.xs dl_private_init() */ { char *perl_dl_nonlazy; #ifdef DEBUGGING - dl_debug = SvIV( perl_get_sv("DynaLoader::dl_debug", 0x04) ); + SV *sv = get_sv("DynaLoader::dl_debug", 0); + dl_debug = sv ? SvIV(sv) : 0; #endif if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) dl_nonlazy = atoi(perl_dl_nonlazy); if (dl_nonlazy) - DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "DynaLoader bind mode is 'non-lazy'\n")); + DLDEBUG(1,PerlIO_printf(Perl_debug_log, "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 */ #endif +#ifdef DL_UNLOAD_ALL_AT_EXIT + call_atexit(&dl_unload_all_files, (void*)0); +#endif } /* SaveError() takes printf style args and saves the result in LastError */ static void -SaveError(CPERLarg_ char* pat, ...) +SaveError(pTHXo_ char* pat, ...) { va_list args; + SV *msv; char *message; - int len; + STRLEN len; /* This code is based on croak/warn, see mess() in util.c */ va_start(args, pat); - message = mess(pat, &args); + msv = vmess(pat, &args); va_end(args); - len = strlen(message) + 1 ; /* include terminating null char */ + message = SvPV(msv,len); + len++; /* include terminating null char */ /* Allocate some memory for the error message */ if (LastError) @@ -67,6 +101,6 @@ SaveError(CPERLarg_ char* pat, ...) /* Copy message into LastError (including terminating null char) */ strncpy(LastError, message, len) ; - DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError)); + DLDEBUG(2,PerlIO_printf(Perl_debug_log, "DynaLoader: stored error msg '%s'\n",LastError)); } diff --git a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm index f1edb8ed79d..92103a1eaf5 100644 --- a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm +++ b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm @@ -37,55 +37,99 @@ applications the newer versions of these constants are suggested (O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK, O_SYNC, O_TRUNC). -Please refer to your native fcntl() and open() documentation to see -what constants are implemented in your system. +For ease of use also the SEEK_* constants (for seek() and sysseek(), +e.g. SEEK_END) and the S_I* constants (for chmod() and stat()) are +available for import. They can be imported either separately or using +the tags C<:seek> and C<:mode>. + +Please refer to your native fcntl(2), open(2), fseek(3), lseek(2) +(equal to Perl's seek() and sysseek(), respectively), and chmod(2) +documentation to see what constants are implemented in your system. + +See L<perlopentut> to learn about the uses of the O_* constants +with sysopen(). + +See L<perlfunc/seek> and L<perlfunc/sysseek> about the SEEK_* constants. + +See L<perlfunc/stat> about the S_I* constants. =cut -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD); +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD); require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Exporter); $VERSION = "1.03"; # Items to export into callers namespace by default # (move infrequently used names to @EXPORT_OK below) @EXPORT = qw( FD_CLOEXEC + F_ALLOCSP + F_ALLOCSP64 + F_COMPAT + F_DUP2FD F_DUPFD F_EXLCK + F_FREESP + F_FREESP64 + F_FSYNC + F_FSYNC64 F_GETFD F_GETFL F_GETLK + F_GETLK64 F_GETOWN + F_NODNY F_POSIX + F_RDACC + F_RDDNY F_RDLCK + F_RWACC + F_RWDNY F_SETFD F_SETFL F_SETLK + F_SETLK64 F_SETLKW + F_SETLKW64 F_SETOWN + F_SHARE F_SHLCK F_UNLCK + F_UNSHARE + F_WRACC + F_WRDNY F_WRLCK O_ACCMODE + O_ALIAS O_APPEND O_ASYNC O_BINARY O_CREAT O_DEFER + O_DIRECT + O_DIRECTORY O_DSYNC O_EXCL O_EXLOCK + O_LARGEFILE O_NDELAY O_NOCTTY + O_NOFOLLOW + O_NOINHERIT O_NONBLOCK + O_RANDOM + O_RAW O_RDONLY O_RDWR + O_RSRC O_RSYNC + O_SEQUENTIAL O_SHLOCK O_SYNC + O_TEMPORARY O_TEXT O_TRUNC O_WRONLY @@ -97,28 +141,69 @@ $VERSION = "1.03"; FASYNC FCREAT FDEFER + FDSYNC FEXCL + FLARGEFILE FNDELAY FNONBLOCK + FRSYNC FSYNC FTRUNC LOCK_EX LOCK_NB LOCK_SH LOCK_UN + S_ISUID S_ISGID S_ISVTX S_ISTXT + _S_IFMT S_IFREG S_IFDIR S_IFLNK + S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT + S_IRUSR S_IWUSR S_IXUSR S_IRWXU + S_IRGRP S_IWGRP S_IXGRP S_IRWXG + S_IROTH S_IWOTH S_IXOTH S_IRWXO + S_IREAD S_IWRITE S_IEXEC + &S_ISREG &S_ISDIR &S_ISLNK &S_ISSOCK &S_ISBLK &S_ISCHR &S_ISFIFO + &S_ISWHT &S_ISENFMT &S_IFMT &S_IMODE + SEEK_SET + SEEK_CUR + SEEK_END ); # Named groups of exports %EXPORT_TAGS = ( 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)], - 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FEXCL - FNDELAY FNONBLOCK FSYNC FTRUNC)], + 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FDSYNC FEXCL FLARGEFILE + FNDELAY FNONBLOCK FRSYNC FSYNC FTRUNC)], + 'seek' => [qw(SEEK_SET SEEK_CUR SEEK_END)], + 'mode' => [qw(S_ISUID S_ISGID S_ISVTX S_ISTXT + _S_IFMT S_IFREG S_IFDIR S_IFLNK + S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT + S_IRUSR S_IWUSR S_IXUSR S_IRWXU + S_IRGRP S_IWGRP S_IXGRP S_IRWXG + S_IROTH S_IWOTH S_IXOTH S_IRWXO + S_IREAD S_IWRITE S_IEXEC + S_ISREG S_ISDIR S_ISLNK S_ISSOCK + S_ISBLK S_ISCHR S_ISFIFO + S_ISWHT S_ISENFMT + S_IFMT S_IMODE + )], ); +sub S_IFMT { @_ ? ( $_[0] & _S_IFMT() ) : _S_IFMT() } +sub S_IMODE { $_[0] & 07777 } + +sub S_ISREG { ( $_[0] & _S_IFMT() ) == S_IFREG() } +sub S_ISDIR { ( $_[0] & _S_IFMT() ) == S_IFDIR() } +sub S_ISLNK { ( $_[0] & _S_IFMT() ) == S_IFLNK() } +sub S_ISSOCK { ( $_[0] & _S_IFMT() ) == S_IFSOCK() } +sub S_ISBLK { ( $_[0] & _S_IFMT() ) == S_IFBLK() } +sub S_ISCHR { ( $_[0] & _S_IFMT() ) == S_IFCHR() } +sub S_ISFIFO { ( $_[0] & _S_IFMT() ) == S_IFIFO() } +sub S_ISWHT { ( $_[0] & _S_IFMT() ) == S_IFWHT() } +sub S_ISENFMT { ( $_[0] & _S_IFMT() ) == S_IFENFMT() } + sub AUTOLOAD { (my $constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname, 0); if ($! != 0) { - if ($! =~ /Invalid/) { + if ($! =~ /Invalid/ || $!{EINVAL}) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } @@ -132,6 +217,6 @@ sub AUTOLOAD { goto &$AUTOLOAD; } -bootstrap Fcntl $VERSION; +XSLoader::load 'Fcntl', $VERSION; 1; diff --git a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs index 5149444b685..b597e03c1a1 100644 --- a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs +++ b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs @@ -1,3 +1,4 @@ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -14,6 +15,10 @@ #endif #endif +#ifdef I_UNISTD +#include <unistd.h> +#endif + /* This comment is a kludge to get metaconfig to see the symbols VAL_O_NONBLOCK VAL_EAGAIN @@ -40,8 +45,40 @@ constant(char *name, int arg) { errno = 0; switch (*name) { + case '_': + if (strEQ(name, "_S_IFMT")) /* Yes, on name _S_IFMT return S_IFMT. */ +#ifdef S_IFMT + return S_IFMT; +#else + goto not_there; +#endif + break; case 'F': if (strnEQ(name, "F_", 2)) { + if (strEQ(name, "F_ALLOCSP")) +#ifdef F_ALLOCSP + return F_ALLOCSP; +#else + goto not_there; +#endif + if (strEQ(name, "F_ALLOCSP64")) +#ifdef F_ALLOCSP64 + return F_ALLOCSP64; +#else + goto not_there; +#endif + if (strEQ(name, "F_COMPAT")) +#ifdef F_COMPAT + return F_COMPAT; +#else + goto not_there; +#endif + if (strEQ(name, "F_DUP2FD")) +#ifdef F_DUP2FD + return F_DUP2FD; +#else + goto not_there; +#endif if (strEQ(name, "F_DUPFD")) #ifdef F_DUPFD return F_DUPFD; @@ -54,6 +91,30 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "F_FREESP")) +#ifdef F_FREESP + return F_FREESP; +#else + goto not_there; +#endif + if (strEQ(name, "F_FREESP64")) +#ifdef F_FREESP64 + return F_FREESP64; +#else + goto not_there; +#endif + if (strEQ(name, "F_FSYNC")) +#ifdef F_FSYNC + return F_FSYNC; +#else + goto not_there; +#endif + if (strEQ(name, "F_FSYNC64")) +#ifdef F_FSYNC64 + return F_FSYNC64; +#else + goto not_there; +#endif if (strEQ(name, "F_GETFD")) #ifdef F_GETFD return F_GETFD; @@ -72,24 +133,60 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "F_GETLK64")) +#ifdef F_GETLK64 + return F_GETLK64; +#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_NODNY")) +#ifdef F_NODNY + return F_NODNY; +#else + goto not_there; +#endif if (strEQ(name, "F_POSIX")) #ifdef F_POSIX return F_POSIX; #else goto not_there; #endif + if (strEQ(name, "F_RDACC")) +#ifdef F_RDACC + return F_RDACC; +#else + goto not_there; +#endif + if (strEQ(name, "F_RDDNY")) +#ifdef F_RDDNY + return F_RDDNY; +#else + goto not_there; +#endif if (strEQ(name, "F_RDLCK")) #ifdef F_RDLCK return F_RDLCK; #else goto not_there; #endif + if (strEQ(name, "F_RWACC")) +#ifdef F_RWACC + return F_RWACC; +#else + goto not_there; +#endif + if (strEQ(name, "F_RWDNY")) +#ifdef F_RWDNY + return F_RWDNY; +#else + goto not_there; +#endif if (strEQ(name, "F_SETFD")) #ifdef F_SETFD return F_SETFD; @@ -108,18 +205,36 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "F_SETLK64")) +#ifdef F_SETLK64 + return F_SETLK64; +#else + goto not_there; +#endif if (strEQ(name, "F_SETLKW")) #ifdef F_SETLKW return F_SETLKW; #else goto not_there; #endif + if (strEQ(name, "F_SETLKW64")) +#ifdef F_SETLKW64 + return F_SETLKW64; +#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_SHARE")) +#ifdef F_SHARE + return F_SHARE; +#else + goto not_there; +#endif if (strEQ(name, "F_SHLCK")) #ifdef F_SHLCK return F_SHLCK; @@ -132,6 +247,24 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "F_UNSHARE")) +#ifdef F_UNSHARE + return F_UNSHARE; +#else + goto not_there; +#endif + if (strEQ(name, "F_WRACC")) +#ifdef F_WRACC + return F_WRACC; +#else + goto not_there; +#endif + if (strEQ(name, "F_WRDNY")) +#ifdef F_WRDNY + return F_WRDNY; +#else + goto not_there; +#endif if (strEQ(name, "F_WRLCK")) #ifdef F_WRLCK return F_WRLCK; @@ -171,12 +304,24 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "FDSYNC")) +#ifdef FDSYNC + return FDSYNC; +#else + goto not_there; +#endif if (strEQ(name, "FEXCL")) #ifdef FEXCL return FEXCL; #else goto not_there; #endif + if (strEQ(name, "FLARGEFILE")) +#ifdef FLARGEFILE + return FLARGEFILE; +#else + goto not_there; +#endif if (strEQ(name, "FNDELAY")) #ifdef FNDELAY return FNDELAY; @@ -189,6 +334,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "FRSYNC")) +#ifdef FRSYNC + return FRSYNC; +#else + goto not_there; +#endif if (strEQ(name, "FSYNC")) #ifdef FSYNC return FSYNC; @@ -271,6 +422,18 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_DIRECT")) +#ifdef O_DIRECT + return O_DIRECT; +#else + goto not_there; +#endif + if (strEQ(name, "O_DIRECTORY")) +#ifdef O_DIRECTORY + return O_DIRECTORY; +#else + goto not_there; +#endif if (strEQ(name, "O_DSYNC")) #ifdef O_DSYNC return O_DSYNC; @@ -289,6 +452,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_LARGEFILE")) +#ifdef O_LARGEFILE + return O_LARGEFILE; +#else + goto not_there; +#endif if (strEQ(name, "O_NDELAY")) #ifdef O_NDELAY return O_NDELAY; @@ -301,12 +470,36 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_NOFOLLOW")) +#ifdef O_NOFOLLOW + return O_NOFOLLOW; +#else + goto not_there; +#endif + if (strEQ(name, "O_NOINHERIT")) +#ifdef O_NOINHERIT + return O_NOINHERIT; +#else + goto not_there; +#endif if (strEQ(name, "O_NONBLOCK")) #ifdef O_NONBLOCK return O_NONBLOCK; #else goto not_there; #endif + if (strEQ(name, "O_RANDOM")) +#ifdef O_RANDOM + return O_RANDOM; +#else + goto not_there; +#endif + if (strEQ(name, "O_RAW")) +#ifdef O_RAW + return O_RAW; +#else + goto not_there; +#endif if (strEQ(name, "O_RDONLY")) #ifdef O_RDONLY return O_RDONLY; @@ -325,6 +518,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_SEQUENTIAL")) +#ifdef O_SEQUENTIAL + return O_SEQUENTIAL; +#else + goto not_there; +#endif if (strEQ(name, "O_SHLOCK")) #ifdef O_SHLOCK return O_SHLOCK; @@ -337,6 +536,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_TEMPORARY")) +#ifdef O_TEMPORARY + return O_TEMPORARY; +#else + goto not_there; +#endif if (strEQ(name, "O_TEXT")) #ifdef O_TEXT return O_TEXT; @@ -355,9 +560,214 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "O_ALIAS")) +#ifdef O_ALIAS + return O_ALIAS; +#else + goto not_there; +#endif + if (strEQ(name, "O_RSRC")) +#ifdef O_RSRC + return O_RSRC; +#else + goto not_there; +#endif } else goto not_there; break; + case 'S': + switch (name[1]) { + case '_': + if (strEQ(name, "S_ISUID")) +#ifdef S_ISUID + return S_ISUID; +#else + goto not_there; +#endif + if (strEQ(name, "S_ISGID")) +#ifdef S_ISGID + return S_ISGID; +#else + goto not_there; +#endif + if (strEQ(name, "S_ISVTX")) +#ifdef S_ISVTX + return S_ISVTX; +#else + goto not_there; +#endif + if (strEQ(name, "S_ISTXT")) +#ifdef S_ISTXT + return S_ISTXT; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFREG")) +#ifdef S_IFREG + return S_IFREG; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFDIR")) +#ifdef S_IFDIR + return S_IFDIR; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFLNK")) +#ifdef S_IFLNK + return S_IFLNK; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFSOCK")) +#ifdef S_IFSOCK + return S_IFSOCK; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFBLK")) +#ifdef S_IFBLK + return S_IFBLK; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFCHR")) +#ifdef S_IFCHR + return S_IFCHR; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFIFO")) +#ifdef S_IFIFO + return S_IFIFO; +#else + goto not_there; +#endif + if (strEQ(name, "S_IFWHT")) +#ifdef S_IFWHT + return S_IFWHT; +#else + goto not_there; +#endif + if (strEQ(name, "S_ENFMT")) +#ifdef S_ENFMT + return S_ENFMT; +#else + goto not_there; +#endif + if (strEQ(name, "S_IRUSR")) +#ifdef S_IRUSR + return S_IRUSR; +#else + goto not_there; +#endif + if (strEQ(name, "S_IWUSR")) +#ifdef S_IWUSR + return S_IWUSR; +#else + goto not_there; +#endif + if (strEQ(name, "S_IXUSR")) +#ifdef S_IXUSR + return S_IXUSR; +#else + goto not_there; +#endif + if (strEQ(name, "S_IRWXU")) +#ifdef S_IRWXU + return S_IRWXU; +#else + goto not_there; +#endif + if (strEQ(name, "S_IRGRP")) +#ifdef S_IRGRP + return S_IRGRP; +#else + goto not_there; +#endif + if (strEQ(name, "S_IWGRP")) +#ifdef S_IWGRP + return S_IWGRP; +#else + goto not_there; +#endif + if (strEQ(name, "S_IXGRP")) +#ifdef S_IXGRP + return S_IXGRP; +#else + goto not_there; +#endif + if (strEQ(name, "S_IRWXG")) +#ifdef S_IRWXG + return S_IRWXG; +#else + goto not_there; +#endif + if (strEQ(name, "S_IROTH")) +#ifdef S_IROTH + return S_IROTH; +#else + goto not_there; +#endif + if (strEQ(name, "S_IWOTH")) +#ifdef S_IWOTH + return S_IWOTH; +#else + goto not_there; +#endif + if (strEQ(name, "S_IXOTH")) +#ifdef S_IXOTH + return S_IXOTH; +#else + goto not_there; +#endif + if (strEQ(name, "S_IRWXO")) +#ifdef S_IRWXO + return S_IRWXO; +#else + goto not_there; +#endif + if (strEQ(name, "S_IREAD")) +#ifdef S_IREAD + return S_IREAD; +#else + goto not_there; +#endif + if (strEQ(name, "S_IWRITE")) +#ifdef S_IWRITE + return S_IWRITE; +#else + goto not_there; +#endif + if (strEQ(name, "S_IEXEC")) +#ifdef S_IEXEC + return S_IEXEC; +#else + goto not_there; +#endif + break; + case 'E': + if (strEQ(name, "SEEK_CUR")) +#ifdef SEEK_CUR + return SEEK_CUR; +#else + return 1; +#endif + if (strEQ(name, "SEEK_END")) +#ifdef SEEK_END + return SEEK_END; +#else + return 2; +#endif + if (strEQ(name, "SEEK_SET")) +#ifdef SEEK_SET + return SEEK_SET; +#else + return 0; +#endif + break; + } } errno = EINVAL; return 0; diff --git a/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm b/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm index 09df4373fb6..ab866eecabe 100644 --- a/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm +++ b/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm @@ -33,21 +33,21 @@ The available functions and the gdbm/perl interface need to be documented. =head1 SEE ALSO -L<perl(1)>, L<DB_File(3)>. +L<perl(1)>, L<DB_File(3)>, L<perldbmfilter>. =cut package GDBM_File; use strict; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD); +our($VERSION, @ISA, @EXPORT, $AUTOLOAD); require Carp; require Tie::Hash; require Exporter; use AutoLoader; -require DynaLoader; -@ISA = qw(Tie::Hash Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Tie::Hash Exporter); @EXPORT = qw( GDBM_CACHESIZE GDBM_FAST @@ -59,14 +59,14 @@ require DynaLoader; GDBM_WRITER ); -$VERSION = "1.00"; +$VERSION = "1.03"; sub AUTOLOAD { my($constname); ($constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname, @_ ? $_[0] : 0); if ($! != 0) { - if ($! =~ /Invalid/) { + if ($! =~ /Invalid/ || $!{EINVAL}) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } @@ -78,7 +78,7 @@ sub AUTOLOAD { goto &$AUTOLOAD; } -bootstrap GDBM_File $VERSION; +XSLoader::load 'GDBM_File', $VERSION; # Preloaded methods go here. Autoload methods go after __END__, and are # processed by the autosplit program. diff --git a/gnu/usr.bin/perl/ext/GDBM_File/typemap b/gnu/usr.bin/perl/ext/GDBM_File/typemap index 317a8f3886c..4f79ae3e32a 100644 --- a/gnu/usr.bin/perl/ext/GDBM_File/typemap +++ b/gnu/usr.bin/perl/ext/GDBM_File/typemap @@ -2,8 +2,8 @@ #################################### DBM SECTION # -datum T_DATUM -gdatum T_GDATUM +datum_key T_DATUM_K +datum_value T_DATUM_V NDBM_File T_PTROBJ GDBM_File T_PTROBJ SDBM_File T_PTROBJ @@ -13,15 +13,20 @@ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT -T_DATUM +T_DATUM_K + ckFilter($arg, filter_store_key, \"filter_store_key\"); + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; +T_DATUM_V + ckFilter($arg, filter_store_value, \"filter_store_value\"); $var.dptr = SvPV($arg, PL_na); $var.dsize = (int)PL_na; -T_GDATUM - UNIMPLEMENTED OUTPUT -T_DATUM - sv_setpvn($arg, $var.dptr, $var.dsize); -T_GDATUM - sv_usepvn($arg, $var.dptr, $var.dsize); +T_DATUM_K + output_datum(aTHX_ $arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); +T_DATUM_V + output_datum(aTHX_ $arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); T_PTROBJ sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/gnu/usr.bin/perl/ext/IO/IO.pm b/gnu/usr.bin/perl/ext/IO/IO.pm index 4d4c81ce405..0087530c7e6 100644 --- a/gnu/usr.bin/perl/ext/IO/IO.pm +++ b/gnu/usr.bin/perl/ext/IO/IO.pm @@ -2,6 +2,24 @@ package IO; +use XSLoader (); +use Carp; + +$VERSION = "1.20"; +XSLoader::load 'IO', $VERSION; + +sub import { + shift; + my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir); + + eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l) + or croak $@; +} + +1; + +__END__ + =head1 NAME IO - load various IO modules @@ -20,17 +38,10 @@ Currently this includes: IO::File IO::Pipe IO::Socket + IO::Dir 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/gnu/usr.bin/perl/ext/IO/IO.xs b/gnu/usr.bin/perl/ext/IO/IO.xs index 300581ed4e2..1b79cfd4c09 100644 --- a/gnu/usr.bin/perl/ext/IO/IO.xs +++ b/gnu/usr.bin/perl/ext/IO/IO.xs @@ -1,20 +1,20 @@ +/* + * Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. + * This program is free software; you can redistribute it and/or + * modify it under the same terms as Perl itself. + */ + +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" - +#include "poll.h" #ifdef I_UNISTD # include <unistd.h> #endif -#ifdef I_FCNTL -#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) -#define _NO_OLDNAMES -#endif +#if defined(I_FCNTL) || defined(HAS_FCNTL) # include <fcntl.h> -#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) -#undef _NO_OLDNAMES -#endif - #endif #ifdef PerlIO @@ -28,6 +28,12 @@ typedef FILE * InputStream; typedef FILE * OutputStream; #endif +#define MY_start_subparse(fmt,flags) start_subparse(fmt,flags) + +#ifndef gv_stashpvn +#define gv_stashpvn(str,len,flags) gv_stashpv(str,flags) +#endif + static int not_here(char *s) { @@ -35,56 +41,99 @@ not_here(char *s) return -1; } -static bool -constant(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; + +#ifndef PerlIO +#define PerlIO_fileno(f) fileno(f) #endif - break; - case 'S': - if (strEQ(name, "SEEK_SET")) -#ifdef SEEK_SET - { *pval = SEEK_SET; return TRUE; } + +static int +io_blocking(InputStream f, int block) +{ + int RETVAL; + if(!f) { + errno = EBADF; + return -1; + } +#if defined(HAS_FCNTL) + RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0); + if (RETVAL >= 0) { + int mode = RETVAL; +#ifdef O_NONBLOCK + /* POSIX style */ +#if defined(O_NDELAY) && O_NDELAY != O_NONBLOCK + /* Ooops has O_NDELAY too - make sure we don't + * get SysV behaviour by mistake. */ + + /* E.g. In UNICOS and UNICOS/mk a F_GETFL returns an O_NDELAY + * after a successful F_SETFL of an O_NONBLOCK. */ + RETVAL = RETVAL & (O_NONBLOCK | O_NDELAY) ? 0 : 1; + + if (block >= 0) { + if ((mode & O_NDELAY) || ((block == 0) && !(mode & O_NONBLOCK))) { + int ret; + mode = (mode & ~O_NDELAY) | O_NONBLOCK; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + else + if ((mode & O_NDELAY) || ((block > 0) && (mode & O_NONBLOCK))) { + int ret; + mode &= ~(O_NONBLOCK | O_NDELAY); + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + } #else - return FALSE; -#endif - if (strEQ(name, "SEEK_CUR")) -#ifdef SEEK_CUR - { *pval = SEEK_CUR; return TRUE; } + /* Standard POSIX */ + RETVAL = RETVAL & O_NONBLOCK ? 0 : 1; + + if ((block == 0) && !(mode & O_NONBLOCK)) { + int ret; + mode |= O_NONBLOCK; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + else if ((block > 0) && (mode & O_NONBLOCK)) { + int ret; + mode &= ~O_NONBLOCK; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } +#endif #else - return FALSE; + /* Not POSIX - better have O_NDELAY or we can't cope. + * for BSD-ish machines this is an acceptable alternative + * for SysV we can't tell "would block" from EOF but that is + * the way SysV is... + */ + RETVAL = RETVAL & O_NDELAY ? 0 : 1; + + if ((block == 0) && !(mode & O_NDELAY)) { + int ret; + mode |= O_NDELAY; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } + else if ((block > 0) && (mode & O_NDELAY)) { + int ret; + mode &= ~O_NDELAY; + ret = fcntl(PerlIO_fileno(f),F_SETFL,mode); + if(ret < 0) + RETVAL = ret; + } #endif - if (strEQ(name, "SEEK_END")) -#ifdef SEEK_END - { *pval = SEEK_END; return TRUE; } + } + return RETVAL; #else - return FALSE; + return -1; #endif - break; - } - - return FALSE; } - MODULE = IO PACKAGE = IO::Seekable PREFIX = f SV * @@ -110,9 +159,9 @@ fsetpos(handle, pos) InputStream handle SV * pos CODE: - char *p; - STRLEN n_a; - if (handle && (p = SvPVx(pos, n_a)) && n_a == sizeof(Fpos_t)) + char *p; + STRLEN len; + if (handle && (p = SvPV(pos,len)) && len == sizeof(Fpos_t)) #ifdef PerlIO RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); #else @@ -144,24 +193,63 @@ new_tmpfile(packname = "IO::File") 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() */ + SvREFCNT_dec(gv); /* undo increment in newRV() */ } else { ST(0) = &PL_sv_undef; SvREFCNT_dec(gv); } +MODULE = IO PACKAGE = IO::Poll + +void +_poll(timeout,...) + int timeout; +PPCODE: +{ +#ifdef HAS_POLL + int nfd = (items - 1) / 2; + SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd)); + struct pollfd *fds = (struct pollfd *)SvPVX(tmpsv); + int i,j,ret; + for(i=1, j=0 ; j < nfd ; j++) { + fds[j].fd = SvIV(ST(i)); + i++; + fds[j].events = SvIV(ST(i)); + i++; + fds[j].revents = 0; + } + if((ret = poll(fds,nfd,timeout)) >= 0) { + for(i=1, j=0 ; j < nfd ; j++) { + sv_setiv(ST(i), fds[j].fd); i++; + sv_setiv(ST(i), fds[j].revents); i++; + } + } + SvREFCNT_dec(tmpsv); + XSRETURN_IV(ret); +#else + not_here("IO::Poll::poll"); +#endif +} + +MODULE = IO PACKAGE = IO::Handle PREFIX = io_ + +void +io_blocking(handle,blk=-1) + InputStream handle + int blk +PROTOTYPE: $;$ +CODE: +{ + int ret = io_blocking(handle, items == 1 ? -1 : blk ? 1 : 0); + if(ret >= 0) + XSRETURN_IV(ret); + else + XSRETURN_UNDEF; +} + 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) = &PL_sv_undef; int ungetc(handle, c) @@ -274,8 +362,7 @@ setvbuf(handle, buf, type, size) int type int size CODE: -/* Should check HAS_SETVBUF once Configure tests for that */ -#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) +#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) && defined(HAS_SETVBUF) if (!handle) /* Try input stream. */ handle = IoIFP(sv_2io(ST(0))); if (handle) @@ -291,3 +378,84 @@ setvbuf(handle, buf, type, size) RETVAL +SysRet +fsync(handle) + OutputStream handle + CODE: +#ifdef HAS_FSYNC + if(handle) + RETVAL = fsync(PerlIO_fileno(handle)); + else { + RETVAL = -1; + errno = EINVAL; + } +#else + RETVAL = (SysRet) not_here("IO::Handle::sync"); +#endif + OUTPUT: + RETVAL + + +BOOT: +{ + HV *stash; + /* + * constant subs for IO::Poll + */ + stash = gv_stashpvn("IO::Poll", 8, TRUE); +#ifdef POLLIN + newCONSTSUB(stash,"POLLIN",newSViv(POLLIN)); +#endif +#ifdef POLLPRI + newCONSTSUB(stash,"POLLPRI", newSViv(POLLPRI)); +#endif +#ifdef POLLOUT + newCONSTSUB(stash,"POLLOUT", newSViv(POLLOUT)); +#endif +#ifdef POLLRDNORM + newCONSTSUB(stash,"POLLRDNORM", newSViv(POLLRDNORM)); +#endif +#ifdef POLLWRNORM + newCONSTSUB(stash,"POLLWRNORM", newSViv(POLLWRNORM)); +#endif +#ifdef POLLRDBAND + newCONSTSUB(stash,"POLLRDBAND", newSViv(POLLRDBAND)); +#endif +#ifdef POLLWRBAND + newCONSTSUB(stash,"POLLWRBAND", newSViv(POLLWRBAND)); +#endif +#ifdef POLLNORM + newCONSTSUB(stash,"POLLNORM", newSViv(POLLNORM)); +#endif +#ifdef POLLERR + newCONSTSUB(stash,"POLLERR", newSViv(POLLERR)); +#endif +#ifdef POLLHUP + newCONSTSUB(stash,"POLLHUP", newSViv(POLLHUP)); +#endif +#ifdef POLLNVAL + newCONSTSUB(stash,"POLLNVAL", newSViv(POLLNVAL)); +#endif + /* + * constant subs for IO::Handle + */ + stash = gv_stashpvn("IO::Handle", 10, TRUE); +#ifdef _IOFBF + newCONSTSUB(stash,"_IOFBF", newSViv(_IOFBF)); +#endif +#ifdef _IOLBF + newCONSTSUB(stash,"_IOLBF", newSViv(_IOLBF)); +#endif +#ifdef _IONBF + newCONSTSUB(stash,"_IONBF", newSViv(_IONBF)); +#endif +#ifdef SEEK_SET + newCONSTSUB(stash,"SEEK_SET", newSViv(SEEK_SET)); +#endif +#ifdef SEEK_CUR + newCONSTSUB(stash,"SEEK_CUR", newSViv(SEEK_CUR)); +#endif +#ifdef SEEK_END + newCONSTSUB(stash,"SEEK_END", newSViv(SEEK_END)); +#endif +} diff --git a/gnu/usr.bin/perl/ext/IO/Makefile.PL b/gnu/usr.bin/perl/ext/IO/Makefile.PL index 6a2d50dc83c..095d7c2b511 100644 --- a/gnu/usr.bin/perl/ext/IO/Makefile.PL +++ b/gnu/usr.bin/perl/ext/IO/Makefile.PL @@ -1,8 +1,9 @@ use ExtUtils::MakeMaker; +use Config qw(%Config); + WriteMakefile( - NAME => 'IO', - MAN3PODS => {}, # Pods will be built by installman. - XSPROTOARG => '-noprototypes', # XXX remove later? - VERSION_FROM => 'lib/IO/Handle.pm', - XS_VERSION => 1.15 + VERSION_FROM => "IO.pm", + NAME => "IO", + OBJECT => '$(O_FILES)', + MAN3PODS => {}, # Pods will be built by installman. ); diff --git a/gnu/usr.bin/perl/ext/IO/README b/gnu/usr.bin/perl/ext/IO/README index e855afade40..191d5504bc1 100644 --- a/gnu/usr.bin/perl/ext/IO/README +++ b/gnu/usr.bin/perl/ext/IO/README @@ -1,4 +1,5 @@ -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. +This directory contains files from the IO distribution created by +Graham Barr. It is currently maintained by the Perl Porters as part +of the Perl source distribution. If you find that you have to modify +any files in this directory then please forward them a patch at +<perl5-porters@perl.org>. diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm index de7fabc6f25..569c2800f80 100644 --- a/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm @@ -49,7 +49,7 @@ these classes with methods that are specific to file handles. =over 4 -=item new ([ ARGS ] ) +=item new ( FILENAME [,MODE [,PERMS]] ) 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, @@ -72,20 +72,21 @@ Otherwise, it is returned to the caller. =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 +it is just a front end for the built-in C<open> function. With two or three 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. +or a ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator (but protects any special characters). 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. +The permissions default to 0666. + +For convenience, C<IO::File> exports the O_XXX constants from the +Fcntl module, if this module is available. =back @@ -98,24 +99,24 @@ L<IO::Seekable> =head1 HISTORY -Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>. +Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. =cut -require 5.000; +require 5.005_64; use strict; -use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA); +our($VERSION, @EXPORT, @EXPORT_OK, @ISA); use Carp; use Symbol; use SelectSaver; use IO::Seekable; +use File::Spec; require Exporter; -require DynaLoader; -@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); +@ISA = qw(IO::Handle IO::Seekable Exporter); -$VERSION = "1.06021"; +$VERSION = "1.08"; @EXPORT = @IO::Seekable::EXPORT; @@ -127,7 +128,6 @@ eval { push(@EXPORT, @O); }; - ################################################ ## Constructor ## @@ -158,7 +158,9 @@ sub open { defined $perms or $perms = 0666; return sysopen($fh, $file, $mode, $perms); } - $file = './' . $file if $file =~ m{\A[^\\/\w]}; + if (! File::Spec->file_name_is_absolute($file)) { + $file = File::Spec->catfile(File::Spec->curdir(),$file); + } $file = IO::Handle::_open_mode_string($mode) . " $file\0"; } open($fh, $file); diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm index 7927641f7f1..930df55fec8 100644 --- a/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm @@ -9,21 +9,21 @@ IO::Handle - supply object methods for I/O handles use IO::Handle; - $fh = new IO::Handle; - if ($fh->fdopen(fileno(STDIN),"r")) { - print $fh->getline; - $fh->close; + $io = new IO::Handle; + if ($io->fdopen(fileno(STDIN),"r")) { + print $io->getline; + $io->close; } - $fh = new IO::Handle; - if ($fh->fdopen(fileno(STDOUT),"w")) { - $fh->print("Some text\n"); + $io = new IO::Handle; + if ($io->fdopen(fileno(STDOUT),"w")) { + $io->print("Some text\n"); } use IO::Handle '_IOLBF'; - $fh->setvbuf($buffer_var, _IOLBF, 1024); + $io->setvbuf($buffer_var, _IOLBF, 1024); - undef $fh; # automatically closes the file if it's open + undef $io; # automatically closes the file if it's open autoflush STDOUT 1; @@ -36,9 +36,7 @@ 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) +for C<IO::File> too. =head1 CONSTRUCTOR @@ -63,87 +61,123 @@ 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 + $io->close + $io->eof + $io->fileno + $io->format_write( [FORMAT_NAME] ) + $io->getc + $io->read ( BUF, LEN, [OFFSET] ) + $io->print ( ARGS ) + $io->printf ( FMT, [ARGS] ) + $io->stat + $io->sysread ( BUF, LEN, [OFFSET] ) + $io->syswrite ( BUF, LEN, [OFFSET] ) + $io->truncate ( LEN ) See L<perlvar> for complete descriptions of each of the following -supported C<IO::Handle> methods: +supported C<IO::Handle> methods. All of them return the previous +value of the attribute and takes an optional single argument that when +given will set the value. If no argument is given the previous value +is unchanged (except for $io->autoflush will actually turn ON +autoflush by default). - 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 + $io->autoflush ( [BOOL] ) $| + $io->format_page_number( [NUM] ) $% + $io->format_lines_per_page( [NUM] ) $= + $io->format_lines_left( [NUM] ) $- + $io->format_name( [STR] ) $~ + $io->format_top_name( [STR] ) $^ + $io->input_line_number( [NUM]) $. + +The following methods are not supported on a per-filehandle basis. + + IO::Handle->format_line_break_characters( [STR] ) $: + IO::Handle->format_formfeed( [STR]) $^L + IO::Handle->output_field_separator( [STR] ) $, + IO::Handle->output_record_separator( [STR] ) $\ + + IO::Handle->input_record_separator( [STR] ) $/ Furthermore, for doing normal I/O you might need these: =over -=item $fh->fdopen ( FD, MODE ) +=item $io->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 +=item $io->opened Returns true if the object is currently a valid file descriptor. -=item $fh->getline +=item $io->getline -This works like <$fh> described in L<perlop/"I/O Operators"> +This works like <$io> 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 +=item $io->getlines -This works like <$fh> when called in an array context to +This works like <$io> 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 ) +=item $io->ungetc ( ORD ) Pushes a character with the given ordinal value back onto the given -handle's input stream. +handle's input stream. Only one character of pushback per handle is +guaranteed. -=item $fh->write ( BUF, LEN [, OFFSET }\] ) +=item $io->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 +=item $io->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 +=item $io->clearerr Clear the given handle's error indicator. +=item $io->sync + +C<sync> synchronizes a file's in-memory state with that on the +physical medium. C<sync> does not operate at the perlio api level, but +operates on the file descriptor, this means that any data held at the +perlio api level will not be synchronized. To synchronize data that is +buffered at the perlio api level you must use the flush method. C<sync> +is not implemented on all platforms. See L<fsync(3c)>. + +=item $io->flush + +C<flush> causes perl to flush any buffered data at the perlio api level. +Any unread data in the buffer will be discarded, and any unwritten data +will be written to the underlying file descriptor. + +=item $io->printflush ( ARGS ) + +Turns on autoflush, print ARGS and then restores the autoflush status of the +C<IO::Handle> object. + +=item $io->blocking ( [ BOOL ] ) + +If called with an argument C<blocking> will turn on non-blocking IO if +C<BOOL> is false, and turn it off if C<BOOL> is true. + +C<blocking> will return the value of the previous setting, or the +current setting if C<BOOL> is not given. + +If an error occurs C<blocking> will return undef and C<$!> will be set. + =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 @@ -152,7 +186,7 @@ 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! Note that you need to import +again, or memory corruption may result! Note that you need to import the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Lastly, there is a special method for working under B<-T> and setuid/gid @@ -160,7 +194,7 @@ scripts: =over -=item $fh->untaint +=item $io->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 @@ -171,7 +205,8 @@ vulnerability should be kept in mind. =head1 NOTE -A C<IO::Handle> object is a GLOB reference. Some modules that +A C<IO::Handle> object is a reference to a symbol/GLOB reference (see +the C<Symbol> package). 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 @@ -193,22 +228,22 @@ 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> +Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> =cut -require 5.000; +require 5.005_64; use strict; -use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA); +our($VERSION, @EXPORT_OK, @ISA); use Carp; use Symbol; use SelectSaver; +use IO (); # Load the XS module require Exporter; @ISA = qw(Exporter); -$VERSION = "1.1505"; -$XS_VERSION = "1.15"; +$VERSION = "1.21"; @EXPORT_OK = qw( autoflush @@ -230,6 +265,9 @@ $XS_VERSION = "1.15"; getline getlines + printflush + flush + SEEK_SET SEEK_CUR SEEK_END @@ -238,30 +276,6 @@ $XS_VERSION = "1.15"; _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. ## @@ -269,18 +283,18 @@ sub AUTOLOAD { sub new { my $class = ref($_[0]) || $_[0] || "IO::Handle"; @_ == 1 or croak "usage: new $class"; - my $fh = gensym; - bless $fh, $class; + my $io = gensym; + bless $io, $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; + my $io = gensym; shift; - IO::Handle::fdopen($fh, @_) + IO::Handle::fdopen($io, @_) or return undef; - bless $fh, $class; + bless $io, $class; } # @@ -307,8 +321,8 @@ sub _open_mode_string { } sub fdopen { - @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)'; - my ($fh, $fd, $mode) = @_; + @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)'; + my ($io, $fd, $mode) = @_; local(*GLOB); if (ref($fd) && "".$fd =~ /GLOB\(/o) { @@ -321,15 +335,15 @@ sub fdopen { $fd = "=$fd"; } - open($fh, _open_mode_string($mode) . '&' . $fd) - ? $fh : undef; + open($io, _open_mode_string($mode) . '&' . $fd) + ? $io : undef; } sub close { - @_ == 1 or croak 'usage: $fh->close()'; - my($fh) = @_; + @_ == 1 or croak 'usage: $io->close()'; + my($io) = @_; - close($fh); + close($io); } ################################################ @@ -340,39 +354,39 @@ sub close { # select sub opened { - @_ == 1 or croak 'usage: $fh->opened()'; + @_ == 1 or croak 'usage: $io->opened()'; defined fileno($_[0]); } sub fileno { - @_ == 1 or croak 'usage: $fh->fileno()'; + @_ == 1 or croak 'usage: $io->fileno()'; fileno($_[0]); } sub getc { - @_ == 1 or croak 'usage: $fh->getc()'; + @_ == 1 or croak 'usage: $io->getc()'; getc($_[0]); } sub eof { - @_ == 1 or croak 'usage: $fh->eof()'; + @_ == 1 or croak 'usage: $io->eof()'; eof($_[0]); } sub print { - @_ or croak 'usage: $fh->print([ARGS])'; + @_ or croak 'usage: $io->print(ARGS)'; my $this = shift; print $this @_; } sub printf { - @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])'; + @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])'; my $this = shift; printf $this @_; } sub getline { - @_ == 1 or croak 'usage: $fh->getline'; + @_ == 1 or croak 'usage: $io->getline()'; my $this = shift; return scalar <$this>; } @@ -380,41 +394,43 @@ sub getline { *gets = \&getline; # deprecated sub getlines { - @_ == 1 or croak 'usage: $fh->getline()'; + @_ == 1 or croak 'usage: $io->getlines()'; wantarray or - croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline'; + croak 'Can\'t call $io->getlines in a scalar context, use $io->getline'; my $this = shift; return <$this>; } sub truncate { - @_ == 2 or croak 'usage: $fh->truncate(LEN)'; + @_ == 2 or croak 'usage: $io->truncate(LEN)'; truncate($_[0], $_[1]); } sub read { - @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])'; + @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])'; read($_[0], $_[1], $_[2], $_[3] || 0); } sub sysread { - @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])'; + @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])'; sysread($_[0], $_[1], $_[2], $_[3] || 0); } sub write { - @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])'; + @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])'; local($\) = ""; + $_[2] = length($_[1]) unless defined $_[2]; print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); } sub syswrite { - @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])'; + @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; + $_[2] = length($_[1]) unless defined $_[2]; syswrite($_[0], $_[1], $_[2], $_[3] || 0); } sub stat { - @_ == 1 or croak 'usage: $fh->stat()'; + @_ == 1 or croak 'usage: $io->stat()'; stat($_[0]); } @@ -423,32 +439,39 @@ sub stat { ## sub autoflush { - my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $old = new SelectSaver qualify($_[0], caller); my $prev = $|; $| = @_ > 1 ? $_[1] : 1; $prev; } sub output_field_separator { + carp "output_field_separator is not supported on a per-handle basis" + if ref($_[0]); my $prev = $,; $, = $_[1] if @_ > 1; $prev; } sub output_record_separator { + carp "output_record_separator is not supported on a per-handle basis" + if ref($_[0]); my $prev = $\; $\ = $_[1] if @_ > 1; $prev; } sub input_record_separator { + carp "input_record_separator is not supported on a per-handle basis" + if ref($_[0]); my $prev = $/; $/ = $_[1] if @_ > 1; $prev; } sub input_line_number { - # localizing $. doesn't work as advertised. grrrrrr. + local $.; + my $tell = tell qualify($_[0], caller) if ref($_[0]); my $prev = $.; $. = $_[1] if @_ > 1; $prev; @@ -490,50 +513,82 @@ sub format_top_name { } sub format_line_break_characters { + carp "format_line_break_characters is not supported on a per-handle basis" + if ref($_[0]); my $prev = $:; $: = $_[1] if @_ > 1; $prev; } sub format_formfeed { + carp "format_formfeed is not supported on a per-handle basis" + if ref($_[0]); my $prev = $^L; $^L = $_[1] if @_ > 1; $prev; } sub formline { - my $fh = shift; + my $io = shift; my $picture = shift; local($^A) = $^A; local($\) = ""; formline($picture, @_); - print $fh $^A; + print $io $^A; } sub format_write { - @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )'; + @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )'; if (@_ == 2) { - my ($fh, $fmt) = @_; - my $oldfmt = $fh->format_name($fmt); - CORE::write($fh); - $fh->format_name($oldfmt); + my ($io, $fmt) = @_; + my $oldfmt = $io->format_name($fmt); + CORE::write($io); + $io->format_name($oldfmt); } else { CORE::write($_[0]); } } +# XXX undocumented 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; + @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );'; + my ($io, $op) = @_; + return fcntl($io, $op, $_[2]); } +# XXX undocumented 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; + @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );'; + my ($io, $op) = @_; + return ioctl($io, $op, $_[2]); +} + +# this sub is for compatability with older releases of IO that used +# a sub called constant to detemine if a constant existed -- GMB +# +# The SEEK_* and _IO?BF constants were the only constants at that time +# any new code should just chech defined(&CONSTANT_NAME) + +sub constant { + no strict 'refs'; + my $name = shift; + (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name}) + ? &{$name}() : undef; +} + + +# so that flush.pl can be depriciated + +sub printflush { + my $io = shift; + my $old = new SelectSaver qualify($io, caller) if ref($io); + local $| = 1; + if(ref($io)) { + print $io @_; + } + else { + print @_; + } } 1; diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm index 23c51b08319..27b5ad03e1a 100644 --- a/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm @@ -1,20 +1,20 @@ # 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 +# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.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; +require 5.005_64; use IO::Handle; use strict; -use vars qw($VERSION); +our($VERSION); use Carp; use Symbol; -$VERSION = "1.0902"; +$VERSION = "1.121"; sub new { my $type = shift; @@ -65,7 +65,7 @@ sub _doit { } bless $io, "IO::Handle"; $io->fdopen($fh, $mode); - $fh->close; + $fh->close; if ($do_spawn) { $pid = eval { system 1, @_ }; # 1 == P_NOWAIT @@ -88,8 +88,12 @@ sub _doit { } sub reader { - @_ >= 1 or croak 'usage: $pipe->reader()'; + @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )'; my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + my $fh = ${*$me}[0]; my $pid = $me->_doit(0, $fh, @_) if(@_); @@ -97,6 +101,8 @@ sub reader { close ${*$me}[1]; bless $me, ref($fh); *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"r") + unless defined($me->fileno); bless $fh; # Really wan't un-bless here ${*$me}{'io_pipe_pid'} = $pid if defined $pid; @@ -105,8 +111,12 @@ sub reader { } sub writer { - @_ >= 1 or croak 'usage: $pipe->writer()'; + @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )'; my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + my $fh = ${*$me}[1]; my $pid = $me->_doit(1, $fh, @_) if(@_); @@ -114,6 +124,8 @@ sub writer { close ${*$me}[0]; bless $me, ref($fh); *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"w") + unless defined($me->fileno); bless $fh; # Really wan't un-bless here ${*$me}{'io_pipe_pid'} = $pid if defined $pid; @@ -123,7 +135,7 @@ sub writer { package IO::Pipe::End; -use vars qw(@ISA); +our(@ISA); @ISA = qw(IO::Handle); @@ -143,7 +155,7 @@ __END__ =head1 NAME -IO::pipe - supply object methods for pipes +IO::Pipe - supply object methods for pipes =head1 SYNOPSIS @@ -228,12 +240,13 @@ L<IO::Handle> =head1 AUTHOR -Graham Barr <bodg@tiuk.ti.com> +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. =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. +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. 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/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm index 86154c5722d..e09d48b9bff 100644 --- a/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm @@ -19,16 +19,17 @@ 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 +C<$io-E<lt>getpos> returns an opaque value that represents the +current position of the IO::File, and C<$io-E<gt>setpos(POS)> 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 + $io->seek( POS, WHENCE ) + $io->sysseek( POS, WHENCE ) + $io->tell =head1 SEE ALSO @@ -39,29 +40,37 @@ L<IO::File> =head1 HISTORY -Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt> +Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt> =cut -require 5.000; +require 5.005_64; use Carp; use strict; -use vars qw($VERSION @EXPORT @ISA); -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); +our($VERSION, @EXPORT, @ISA); +use IO::Handle (); +# XXX we can't get these from IO::Handle or we'll get prototype +# mismatch warnings on C<use POSIX; use IO::File;> :-( +use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); require Exporter; @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); @ISA = qw(Exporter); -$VERSION = "1.06"; +$VERSION = "1.08"; sub seek { - @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)'; + @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)'; seek($_[0], $_[1], $_[2]); } +sub sysseek { + @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)'; + sysseek($_[0], $_[1], $_[2]); +} + sub tell { - @_ == 1 or croak 'usage: $fh->tell()'; + @_ == 1 or croak 'usage: $io->tell()'; tell($_[0]); } diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm index dea684a62ed..df92b04b74f 100644 --- a/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm @@ -1,163 +1,17 @@ # 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. +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.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::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 warnings::register; use vars qw($VERSION @ISA); require Exporter; -$VERSION = "1.10"; +$VERSION = "1.14"; @ISA = qw(Exporter); # This is only so we can do version checking @@ -193,7 +47,9 @@ sub remove sub exists { my $vec = shift; - $vec->[$vec->_fileno(shift) + FIRST_FD]; + my $fno = $vec->_fileno(shift); + return undef unless defined $fno; + $vec->[$fno + FIRST_FD]; } @@ -261,7 +117,7 @@ sub can_write : (); } -sub has_error +sub has_exception { my $vec = shift; my $timeout = shift; @@ -272,6 +128,13 @@ sub has_error : (); } +sub has_error +{ + warnings::warn("Call to depreciated method 'has_error', use 'has_exception'") + if warnings::enabled(); + goto &has_exception; +} + sub count { my $vec = shift; @@ -369,3 +232,149 @@ sub handles } 1; +__END__ + +=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_exception ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that have an exception +condition, for example pending out-of-band data. + +=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 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. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. 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/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm index 2b4bc49daf7..6884f02cf86 100644 --- a/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm +++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm @@ -1,129 +1,29 @@ # 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 +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.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. - -C<IO::Socket>s will be in autoflush mode after creation. Note that -versions of IO::Socket prior to 1.1603 (as shipped with Perl 5.004_04) -did not do this. So if you need backward compatibility, you should -set autoflush explicitly. - -=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 +require 5.005_64; -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); +our(@ISA, $VERSION); use Exporter; +use Errno; + +# legacy + +require IO::Socket::INET; +require IO::Socket::UNIX if ($^O ne 'epoc'); @ISA = qw(IO::Handle); -$VERSION = "1.1603"; +$VERSION = "1.26"; sub import { my $pkg = shift; @@ -133,16 +33,17 @@ sub import { sub new { my($class,%arg) = @_; - my $fh = $class->SUPER::new(); - $fh->autoflush; + my $sock = $class->SUPER::new(); - ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout}; + $sock->autoflush(1); - return scalar(%arg) ? $fh->configure(\%arg) - : $fh; + ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; + + return scalar(%arg) ? $sock->configure(\%arg) + : $sock; } -my @domain2pkg = (); +my @domain2pkg; sub register_domain { my($p,$d) = @_; @@ -150,7 +51,7 @@ sub register_domain { } sub configure { - my($fh,$arg) = @_; + my($sock,$arg) = @_; my $domain = delete $arg->{Domain}; croak 'IO::Socket: Cannot configure a generic socket' @@ -160,150 +61,167 @@ sub configure { unless defined $domain2pkg[$domain]; croak "IO::Socket: Cannot configure socket in domain '$domain'" - unless ref($fh) eq "IO::Socket"; + unless ref($sock) eq "IO::Socket"; - bless($fh, $domain2pkg[$domain]); - $fh->configure($arg); + bless($sock, $domain2pkg[$domain]); + $sock->configure($arg); } sub socket { - @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)'; - my($fh,$domain,$type,$protocol) = @_; + @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)'; + my($sock,$domain,$type,$protocol) = @_; - socket($fh,$domain,$type,$protocol) or + socket($sock,$domain,$type,$protocol) or return undef; - ${*$fh}{'io_socket_domain'} = $domain; - ${*$fh}{'io_socket_type'} = $type; - ${*$fh}{'io_socket_proto'} = $protocol; + ${*$sock}{'io_socket_domain'} = $domain; + ${*$sock}{'io_socket_type'} = $type; + ${*$sock}{'io_socket_proto'} = $protocol; - $fh; + $sock; } sub socketpair { - @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)'; + @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)'; my($class,$domain,$type,$protocol) = @_; - my $fh1 = $class->new(); - my $fh2 = $class->new(); + my $sock1 = $class->new(); + my $sock2 = $class->new(); - socketpair($fh1,$fh2,$domain,$type,$protocol) or + socketpair($sock1,$sock2,$domain,$type,$protocol) or return (); - ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; - ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol; + ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type; + ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol; - ($fh1,$fh2); + ($sock1,$sock2); } 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); + @_ == 2 or croak 'usage: $sock->connect(NAME)'; + my $sock = shift; + my $addr = shift; + my $timeout = ${*$sock}{'io_socket_timeout'}; + my $err; + my $blocking; + $blocking = $sock->blocking(0) if $timeout; + + if (!connect($sock, $addr)) { + if ($timeout && $!{EINPROGRESS}) { + require IO::Select; + + my $sel = new IO::Select $sock; + + if (!$sel->can_write($timeout)) { + $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + $@ = "connect: timeout"; + } + elsif(!connect($sock,$addr) && not $!{EISCONN}) { + # Some systems refuse to re-connect() to + # an already open socket and set errno to EISCONN. + $err = $!; + $@ = "connect: $!"; + } + } + else { + $err = $!; + $@ = "connect: $!"; + } + } - croak "connect: timeout" - unless defined $fh; + $sock->blocking(1) if $blocking; - undef $fh unless $ok; - }; + $! = $err if $err; - $fh; + $err ? undef : $sock; } sub bind { - @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)'; - my $fh = shift; - my $addr = @_ == 1 ? shift : sockaddr_in(@_); + @_ == 2 or croak 'usage: $sock->bind(NAME)'; + my $sock = shift; + my $addr = shift; - return bind($fh, $addr) ? $fh - : undef; + return bind($sock, $addr) ? $sock + : undef; } sub listen { - @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])'; - my($fh,$queue) = @_; + @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])'; + my($sock,$queue) = @_; $queue = 5 unless $queue && $queue > 0; - return listen($fh, $queue) ? $fh - : undef; + return listen($sock, $queue) ? $sock + : undef; } sub accept { - @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])'; - my $fh = shift; - my $pkg = shift || $fh; - my $timeout = ${*$fh}{'io_socket_timeout'}; + @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])'; + my $sock = shift; + my $pkg = shift || $sock; + my $timeout = ${*$sock}{'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; + if($timeout) { + require IO::Select; + + my $sel = new IO::Select $sock; + + unless ($sel->can_read($timeout)) { + $@ = 'accept: timeout'; + $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + return; + } + } + + $peer = accept($new,$sock) + or return; + + return wantarray ? ($new, $peer) + : $new; } sub sockname { - @_ == 1 or croak 'usage: $fh->sockname()'; + @_ == 1 or croak 'usage: $sock->sockname()'; getsockname($_[0]); } sub peername { - @_ == 1 or croak 'usage: $fh->peername()'; - my($fh) = @_; - getpeername($fh) - || ${*$fh}{'io_socket_peername'} + @_ == 1 or croak 'usage: $sock->peername()'; + my($sock) = @_; + getpeername($sock) + || ${*$sock}{'io_socket_peername'} || undef; } +sub connected { + @_ == 1 or croak 'usage: $sock->connected()'; + my($sock) = @_; + getpeername($sock); +} + sub send { - @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])'; - my $fh = $_[0]; + @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])'; + my $sock = $_[0]; my $flags = $_[2] || 0; - my $peer = $_[3] || $fh->peername; + my $peer = $_[3] || $sock->peername; croak 'send: Cannot determine peer address' unless($peer); - my $r = defined(getpeername($fh)) - ? send($fh, $_[1], $flags) - : send($fh, $_[1], $flags, $peer); + my $r = defined(getpeername($sock)) + ? send($sock, $_[1], $flags) + : send($sock, $_[1], $flags, $peer); # remember who we send to, if it was sucessful - ${*$fh}{'io_socket_peername'} = $peer + ${*$sock}{'io_socket_peername'} = $peer if(@_ == 4 && defined $r); $r; } sub recv { - @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])'; + @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])'; my $sock = $_[0]; my $len = $_[2]; my $flags = $_[3] || 0; @@ -312,16 +230,21 @@ sub recv { ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); } +sub shutdown { + @_ == 2 or croak 'usage: $sock->shutdown(HOW)'; + my($sock, $how) = @_; + shutdown($sock, $how); +} sub setsockopt { - @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)'; + @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)'; setsockopt($_[0],$_[1],$_[2],$_[3]); } my $intsize = length(pack("i",0)); sub getsockopt { - @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)'; + @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)'; my $r = getsockopt($_[0],$_[1],$_[2]); # Just a guess $r = unpack("i", $r) @@ -330,399 +253,176 @@ sub getsockopt { } sub sockopt { - my $fh = shift; - @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_) - : $fh->setsockopt(SOL_SOCKET,@_); + my $sock = shift; + @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_) + : $sock->setsockopt(SOL_SOCKET,@_); } sub timeout { - @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])'; - my($fh,$val) = @_; - my $r = ${*$fh}{'io_socket_timeout'} || undef; + @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])'; + my($sock,$val) = @_; + my $r = ${*$sock}{'io_socket_timeout'} || undef; - ${*$fh}{'io_socket_timeout'} = 0 + $val + ${*$sock}{'io_socket_timeout'} = 0 + $val if(@_ == 2); $r; } sub sockdomain { - @_ == 1 or croak 'usage: $fh->sockdomain()'; - my $fh = shift; - ${*$fh}{'io_socket_domain'}; + @_ == 1 or croak 'usage: $sock->sockdomain()'; + my $sock = shift; + ${*$sock}{'io_socket_domain'}; } sub socktype { - @_ == 1 or croak 'usage: $fh->socktype()'; - my $fh = shift; - ${*$fh}{'io_socket_type'} + @_ == 1 or croak 'usage: $sock->socktype()'; + my $sock = shift; + ${*$sock}{'io_socket_type'} } sub protocol { - @_ == 1 or croak 'usage: $fh->protocol()'; - my($fh) = @_; - ${*$fh}{'io_socket_protocol'}; + @_ == 1 or croak 'usage: $sock->protocol()'; + my($sock) = @_; + ${*$sock}{'io_socket_proto'}; } -=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, - icmp => SOCK_RAW, - ); - -=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 (or number) "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 - +1; -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. +__END__ -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 ":". - -If C<Proto> is not given and you specify a symbolic C<PeerPort> port, -then the constructor will try to derive C<Proto> from the service -name. As a last resort C<Proto> "tcp" is assumed. The C<Type> -parameter will be deduced from C<Proto> if not specified. +=head1 NAME -If the constructor is only passed a single argument, it is assumed to -be a C<PeerAddr> specification. +IO::Socket - Object interface to socket communications -Examples: +=head1 SYNOPSIS - $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', - PeerPort => 'http(80)', - Proto => 'tcp'); + use IO::Socket; - $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); +=head1 DESCRIPTION - $sock = IO::Socket::INET->new(Listen => 5, - LocalAddr => 'localhost', - LocalPort => 9000, - Proto => 'tcp'); +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>. - $sock = IO::Socket::INET->new('127.0.0.1:25'); +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>. -=head2 METHODS +=head1 CONSTRUCTOR =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 new ( [ARGS] ) -=item peerport () +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. -Return the port number for the socket on the peer host. + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE -=item peerhost () +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. -Return the address part of the sockaddr structure for the socket on the -peer host in a text form xx.xx.xx.xx + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE =back -=cut - -sub new -{ - my $class = shift; - unshift(@_, "PeerAddr") if @_ == 1; - return $class->SUPER::new(@_); -} - -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); - } - - $proto ||= (getprotobyname "tcp")[2]; - 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 || $type == SOCK_RAW); - - 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]; -} +=head1 METHODS -sub peerhost { - @_ == 1 or croak 'usage: $fh->peerhost()'; - my($fh) = @_; - inet_ntoa($fh->peeraddr); -} +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: -## -## AF_UNIX -## + socket + socketpair + bind + listen + accept + send + recv + peername (getpeername) + sockname (getsockname) + shutdown -package IO::Socket::UNIX; +Some methods take slightly different arguments to those defined in L<perlfunc> +in attempt to make the interface more flexible. These are -use strict; -use vars qw(@ISA $VERSION); -use Socket; -use Carp; -use Exporter; +=over 4 -@ISA = qw(IO::Socket); +=item accept([PKG]) -IO::Socket::UNIX->register_domain( AF_UNIX ); +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. -=head2 IO::Socket::UNIX +=item socketpair(DOMAIN, TYPE, PROTOCOL) -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 +Call C<socketpair> and return a list of two sockets created, or an +empty list on failure. - 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 +=back -=head2 METHODS +Additional methods that are provided are: =over 4 -=item hostpath() +=item timeout([VAL]) -Returns the pathname to the fifo at the local end +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 peerpath() +=item sockopt(OPT [, VAL]) -Returns the pathname to the fifo at the peer end +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. -=back +=item sockdomain -=cut +Returns the numerical number for the socket domain type. For example, for +a AF_INET socket the value of &AF_INET will be returned. -sub configure { - my($fh,$arg) = @_; - my($bport,$cport); +=item socktype - my $type = $arg->{Type} || SOCK_STREAM; +Returns the numerical number for the socket type. For example, for +a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. - $fh->socket(AF_UNIX, $type, 0) or - return undef; +=item protocol - 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; - } +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. - $fh; -} +=item connected -sub hostpath { - @_ == 1 or croak 'usage: $fh->hostpath()'; - my $n = $_[0]->sockname || return undef; - (sockaddr_un($n))[0]; -} +If the socket is in a connected state the the peer address is returned. +If the socket is not in a connected state then undef will be returned. -sub peerpath { - @_ == 1 or croak 'usage: $fh->peerpath()'; - my $n = $_[0]->peername || return undef; - (sockaddr_un($n))[0]; -} +=back =head1 SEE ALSO -L<Socket>, L<IO::Handle> +L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> =head1 AUTHOR -Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. =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. +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. 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/gnu/usr.bin/perl/ext/IPC/SysV/Makefile.PL b/gnu/usr.bin/perl/ext/IPC/SysV/Makefile.PL index 51715e78279..b7c5133866e 100644 --- a/gnu/usr.bin/perl/ext/IPC/SysV/Makefile.PL +++ b/gnu/usr.bin/perl/ext/IPC/SysV/Makefile.PL @@ -1,5 +1,5 @@ # This -*- perl -*- script makes the Makefile -# $Id: Makefile.PL,v 1.2 1999/04/29 22:51:30 millert Exp $ +# $Id: Makefile.PL,v 1.3 2000/04/06 17:05:23 millert Exp $ require 5.002; use ExtUtils::MakeMaker; diff --git a/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm b/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm index ed4fe2b36f9..f98669f4860 100644 --- a/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm +++ b/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm @@ -5,16 +5,14 @@ BEGIN { use strict; } } -use vars qw($VERSION @ISA); require Tie::Hash; -require DynaLoader; +use XSLoader (); -@ISA = qw(Tie::Hash DynaLoader); +our @ISA = qw(Tie::Hash); +our $VERSION = "1.03"; -$VERSION = "1.01"; - -bootstrap NDBM_File $VERSION; +XSLoader::load 'NDBM_File', $VERSION; 1; @@ -35,6 +33,6 @@ NDBM_File - Tied access to ndbm files =head1 DESCRIPTION -See L<perlfunc/tie> +See L<perlfunc/tie>, L<perldbmfilter> =cut diff --git a/gnu/usr.bin/perl/ext/NDBM_File/typemap b/gnu/usr.bin/perl/ext/NDBM_File/typemap index 317a8f3886c..eeb5d59027f 100644 --- a/gnu/usr.bin/perl/ext/NDBM_File/typemap +++ b/gnu/usr.bin/perl/ext/NDBM_File/typemap @@ -2,7 +2,8 @@ #################################### DBM SECTION # -datum T_DATUM +datum_key T_DATUM_K +datum_value T_DATUM_V gdatum T_GDATUM NDBM_File T_PTROBJ GDBM_File T_PTROBJ @@ -13,14 +14,23 @@ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT -T_DATUM +T_DATUM_K + ckFilter($arg, filter_store_key, \"filter_store_key\"); + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; +T_DATUM_V + ckFilter($arg, filter_store_value, \"filter_store_value\"); $var.dptr = SvPV($arg, PL_na); $var.dsize = (int)PL_na; T_GDATUM UNIMPLEMENTED OUTPUT -T_DATUM +T_DATUM_K + sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); +T_DATUM_V sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); T_PTROBJ diff --git a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm index 923640ff348..57fe4c352dd 100644 --- a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm +++ b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm @@ -1,16 +1,14 @@ package ODBM_File; use strict; -use vars qw($VERSION @ISA); require Tie::Hash; -require DynaLoader; +use XSLoader (); -@ISA = qw(Tie::Hash DynaLoader); +our @ISA = qw(Tie::Hash); +our $VERSION = "1.02"; -$VERSION = "1.00"; - -bootstrap ODBM_File $VERSION; +XSLoader::load 'ODBM_File', $VERSION; 1; @@ -30,6 +28,6 @@ ODBM_File - Tied access to odbm files =head1 DESCRIPTION -See L<perlfunc/tie> +See L<perlfunc/tie>, L<perldbmfilter> =cut diff --git a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs index 892c038a9ce..150f2ef8947 100644 --- a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs +++ b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs @@ -2,9 +2,6 @@ #include "perl.h" #include "XSUB.h" -#ifdef NULL -#undef NULL /* XXX Why? */ -#endif #ifdef I_DBM # include <dbm.h> #else @@ -30,7 +27,37 @@ #include <fcntl.h> -typedef void* ODBM_File; +typedef struct { + void * dbp ; + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; + } ODBM_File_type; + +typedef ODBM_File_type * ODBM_File ; +typedef datum datum_key ; +typedef datum datum_value ; + +#define ckFilter(arg,type,name) \ + if (db->type) { \ + SV * save_defsv ; \ + /* printf("filtering %s\n", name) ;*/ \ + if (db->filtering) \ + croak("recursion detected in %s", name) ; \ + db->filtering = TRUE ; \ + save_defsv = newSVsv(DEFSV) ; \ + sv_setsv(DEFSV, arg) ; \ + PUSHMARK(sp) ; \ + (void) perl_call_sv(db->type, G_DISCARD|G_NOARGS); \ + sv_setsv(arg, DEFSV) ; \ + sv_setsv(DEFSV, save_defsv) ; \ + SvREFCNT_dec(save_defsv) ; \ + db->filtering = FALSE ; \ + /*printf("end of filtering %s\n", name) ;*/ \ + } + #define odbm_FETCH(db,key) fetch(key) #define odbm_STORE(db,key,value,flags) store(key,value) @@ -46,10 +73,6 @@ static int dbmrefcnt; MODULE = ODBM_File PACKAGE = ODBM_File PREFIX = odbm_ -#ifndef NULL -# define NULL 0 -#endif - ODBM_File odbm_TIEHASH(dbtype, filename, flags, mode) char * dbtype @@ -59,6 +82,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode) CODE: { char *tmpbuf; + void * dbp ; if (dbmrefcnt++) croak("Old dbm can only open one database"); New(0, tmpbuf, strlen(filename) + 5, char); @@ -75,7 +99,10 @@ odbm_TIEHASH(dbtype, filename, flags, mode) else croak("ODBM_FILE: Can't open %s", filename); } - RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); + dbp = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0); + RETVAL = (ODBM_File)safemalloc(sizeof(ODBM_File_type)) ; + Zero(RETVAL, 1, ODBM_File_type) ; + RETVAL->dbp = dbp ; ST(0) = sv_mortalcopy(&PL_sv_undef); sv_setptrobj(ST(0), RETVAL, dbtype); } @@ -86,17 +113,18 @@ DESTROY(db) CODE: dbmrefcnt--; dbmclose(); + safefree(db); -datum +datum_value odbm_FETCH(db, key) ODBM_File db - datum key + datum_key key int odbm_STORE(db, key, value, flags = DBM_REPLACE) ODBM_File db - datum key - datum value + datum_key key + datum_value value int flags CLEANUP: if (RETVAL) { @@ -109,14 +137,66 @@ odbm_STORE(db, key, value, flags = DBM_REPLACE) int odbm_DELETE(db, key) ODBM_File db - datum key + datum_key key -datum +datum_key odbm_FIRSTKEY(db) ODBM_File db -datum +datum_key odbm_NEXTKEY(db, key) ODBM_File db - datum key + datum_key key + + +#define setFilter(type) \ + { \ + if (db->type) \ + RETVAL = sv_mortalcopy(db->type) ; \ + ST(0) = RETVAL ; \ + if (db->type && (code == &PL_sv_undef)) { \ + SvREFCNT_dec(db->type) ; \ + db->type = Nullsv ; \ + } \ + else if (code) { \ + if (db->type) \ + sv_setsv(db->type, code) ; \ + else \ + db->type = newSVsv(code) ; \ + } \ + } + + + +SV * +filter_fetch_key(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_key) ; + +SV * +filter_store_key(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_key) ; + +SV * +filter_fetch_value(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_fetch_value) ; + +SV * +filter_store_value(db, code) + ODBM_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + setFilter(filter_store_value) ; diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.pm b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm index 0ee6be69559..9338d392fae 100644 --- a/gnu/usr.bin/perl/ext/Opcode/Opcode.pm +++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm @@ -1,8 +1,8 @@ package Opcode; -require 5.002; +require 5.005_64; -use vars qw($VERSION $XS_VERSION @ISA @EXPORT_OK); +our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK); $VERSION = "1.04"; $XS_VERSION = "1.03"; @@ -10,8 +10,8 @@ $XS_VERSION = "1.03"; use strict; use Carp; use Exporter (); -use DynaLoader (); -@ISA = qw(Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Exporter); BEGIN { @EXPORT_OK = qw( @@ -28,7 +28,7 @@ sub opset_to_hex ($); sub opdump (;$); use subs @EXPORT_OK; -bootstrap Opcode $XS_VERSION; +XSLoader::load 'Opcode', $XS_VERSION; _init_optags(); @@ -130,7 +130,7 @@ 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 +PL_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 @@ -332,11 +332,11 @@ invert_opset function. cond_expr flip flop andassign orassign and or xor - warn die lineseq nextstate unstack scope enter leave + warn die lineseq nextstate scope enter leave setstate rv2cv anoncode prototype - entersub leavesub return method -- XXX loops via recursion? + entersub leavesub leavesublv return method method_named -- XXX loops via recursion? leaveeval -- needed for Safe to operate, is safe without entereval @@ -365,7 +365,7 @@ used to implement a resource attack (e.g., consume all available CPU time). grepstart grepwhile mapstart mapwhile enteriter iter - enterloop leaveloop + enterloop leaveloop unstack last next redo goto diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.xs b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs index e93b90046a3..581cbc94d93 100644 --- a/gnu/usr.bin/perl/ext/Opcode/Opcode.xs +++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs @@ -1,3 +1,4 @@ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -11,11 +12,11 @@ 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)); +static SV *new_opset (pTHX_ SV *old_opset); +static int verify_opset (pTHX_ SV *opset, int fatal); +static void set_opset_bits (pTHX_ char *bitmap, SV *bitspec, int on, char *opname); +static void put_op_bitspec (pTHX_ char *optag, STRLEN len, SV *opset); +static SV *get_op_bitspec (pTHX_ char *opname, STRLEN len, int fatal); /* Initialise our private op_named_bits HV. @@ -27,7 +28,7 @@ static SV *get_op_bitspec _((char *opname, STRLEN len, int fatal)); */ static void -op_names_init(void) +op_names_init(pTHX) { int i; STRLEN len; @@ -43,16 +44,16 @@ op_names_init(void) hv_store(op_named_bits, op_names[i], strlen(op_names[i]), sv, 0); } - put_op_bitspec(":none",0, sv_2mortal(new_opset(Nullsv))); + put_op_bitspec(aTHX_ ":none",0, sv_2mortal(new_opset(aTHX_ Nullsv))); - opset_all = new_opset(Nullsv); + opset_all = new_opset(aTHX_ 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] = (PL_maxo & 0x07) ? ~(0xFF << (PL_maxo & 0x07)) : 0xFF; - put_op_bitspec(":all",0, opset_all); /* don't mortalise */ + put_op_bitspec(aTHX_ ":all",0, opset_all); /* don't mortalise */ } @@ -62,10 +63,10 @@ op_names_init(void) */ static void -put_op_bitspec(char *optag, STRLEN len, SV *mask) +put_op_bitspec(pTHX_ char *optag, STRLEN len, SV *mask) { SV **svp; - verify_opset(mask,1); + verify_opset(aTHX_ mask,1); if (!len) len = strlen(optag); svp = hv_fetch(op_named_bits, optag, len, 1); @@ -83,7 +84,7 @@ put_op_bitspec(char *optag, STRLEN len, SV *mask) */ static SV * -get_op_bitspec(char *opname, STRLEN len, int fatal) +get_op_bitspec(pTHX_ char *opname, STRLEN len, int fatal) { SV **svp; if (!len) @@ -106,11 +107,11 @@ get_op_bitspec(char *opname, STRLEN len, int fatal) static SV * -new_opset(SV *old_opset) +new_opset(pTHX_ SV *old_opset) { SV *opset; if (old_opset) { - verify_opset(old_opset,1); + verify_opset(aTHX_ old_opset,1); opset = newSVsv(old_opset); } else { @@ -125,7 +126,7 @@ new_opset(SV *old_opset) static int -verify_opset(SV *opset, int fatal) +verify_opset(pTHX_ SV *opset, int fatal) { char *err = Nullch; if (!SvOK(opset)) err = "undefined"; @@ -139,7 +140,7 @@ verify_opset(SV *opset, int fatal) static void -set_opset_bits(char *bitmap, SV *bitspec, int on, char *opname) +set_opset_bits(pTHX_ char *bitmap, SV *bitspec, int on, char *opname) { if (SvIOK(bitspec)) { int myopcode = SvIV(bitspec); @@ -173,14 +174,14 @@ set_opset_bits(char *bitmap, SV *bitspec, int on, char *opname) static void -opmask_add(SV *opset) /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */ +opmask_add(pTHX_ SV *opset) /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */ { int i,j; char *bitmask; STRLEN len; int myopcode = 0; - verify_opset(opset,1); /* croaks on bad opset */ + verify_opset(aTHX_ opset,1); /* croaks on bad opset */ if (!PL_op_mask) /* caller must ensure PL_op_mask exists */ croak("Can't add to uninitialised PL_op_mask"); @@ -200,23 +201,23 @@ opmask_add(SV *opset) /* THE ONLY FUNCTION TO EDIT PL_op_mask ITSELF */ } static void -opmask_addlocal(SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */ +opmask_addlocal(pTHX_ SV *opset, char *op_mask_buf) /* Localise PL_op_mask then opmask_add() */ { char *orig_op_mask = PL_op_mask; - SAVEPPTR(PL_op_mask); + SAVEVPTR(PL_op_mask); #if !defined(PERL_OBJECT) /* XXX casting to an ordinary function ptr from a member function ptr * is disallowed by Borland */ if (opcode_debug >= 2) - SAVEDESTRUCTOR((void(CPERLscope(*))_((void*)))warn,"PL_op_mask restored"); + SAVEDESTRUCTOR((void(*)(void*))Perl_warn,"PL_op_mask restored"); #endif PL_op_mask = &op_mask_buf[0]; if (orig_op_mask) Copy(orig_op_mask, PL_op_mask, PL_maxo, char); else Zero(PL_op_mask, PL_maxo, char); - opmask_add(opset); + opmask_add(aTHX_ opset); } @@ -230,7 +231,7 @@ BOOT: opset_len = (PL_maxo + 7) / 8; if (opcode_debug >= 1) warn("opset_len %ld\n", (long)opset_len); - op_names_init(); + op_names_init(aTHX); void @@ -244,7 +245,7 @@ PPCODE: ENTER; - opmask_addlocal(mask, op_mask_buf); + opmask_addlocal(aTHX_ mask, op_mask_buf); save_aptr(&PL_endav); PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */ @@ -252,6 +253,8 @@ PPCODE: save_hptr(&PL_defstash); /* save current default stack */ /* the assignment to global defstash changes our sense of 'main' */ PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ + save_hptr(&PL_curstash); + PL_curstash = PL_defstash; /* defstash must itself contain a main:: so we'll add that now */ /* take care with the ref counts (was cause of long standing bug) */ @@ -270,7 +273,10 @@ int verify_opset(opset, fatal = 0) SV *opset int fatal - +CODE: + RETVAL = verify_opset(aTHX_ opset,fatal); +OUTPUT: + RETVAL void invert_opset(opset) @@ -279,7 +285,7 @@ CODE: { char *bitmap; STRLEN len = opset_len; - opset = sv_2mortal(new_opset(opset)); /* verify and clone opset */ + opset = sv_2mortal(new_opset(aTHX_ opset)); /* verify and clone opset */ bitmap = SvPVX(opset); while(len-- > 0) bitmap[len] = ~bitmap[len]; @@ -300,7 +306,7 @@ PPCODE: int i, j, myopcode; char *bitmap = SvPV(opset, len); char **names = (desc) ? get_op_descs() : get_op_names(); - verify_opset(opset,1); + verify_opset(aTHX_ opset,1); for (myopcode=0, i=0; i < opset_len; i++) { U16 bits = bitmap[i]; for (j=0; j < 8 && myopcode < PL_maxo; j++, myopcode++) { @@ -318,21 +324,21 @@ CODE: SV *bitspec, *opset; char *bitmap; STRLEN len, on; - opset = sv_2mortal(new_opset(Nullsv)); + opset = sv_2mortal(new_opset(aTHX_ Nullsv)); bitmap = SvPVX(opset); for (i = 0; i < items; i++) { char *opname; on = 1; - if (verify_opset(ST(i),0)) { + if (verify_opset(aTHX_ 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); + bitspec = get_op_bitspec(aTHX_ opname, len, 1); } - set_opset_bits(bitmap, bitspec, on, opname); + set_opset_bits(aTHX_ bitmap, bitspec, on, opname); } ST(0) = opset; @@ -357,13 +363,13 @@ CODE: 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, sv_2mortal(new_opset(PERMITING ? opset_all : Nullsv))); + sv_setsv(mask, sv_2mortal(new_opset(aTHX_ PERMITING ? opset_all : Nullsv))); else - verify_opset(mask,1); /* croaks */ + verify_opset(aTHX_ 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 */ + if (verify_opset(aTHX_ ST(i),0)) { /* it's a valid mask */ opname = "(opset)"; bitspec = ST(i); } @@ -371,9 +377,9 @@ CODE: 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 */ + bitspec = get_op_bitspec(aTHX_ opname, len, 1); /* croaks */ } - set_opset_bits(bitmap, bitspec, on, opname); + set_opset_bits(aTHX_ bitmap, bitspec, on, opname); } ST(0) = &PL_sv_yes; @@ -388,10 +394,10 @@ PPCODE: char **op_desc = get_op_descs(); /* 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*)))); + args = (SV**)SvPVX(sv_2mortal(newSVpvn((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); + SV *bitspec = get_op_bitspec(aTHX_ opname, len, 1); if (SvIOK(bitspec)) { myopcode = SvIV(bitspec); if (myopcode < 0 || myopcode >= PL_maxo) @@ -423,19 +429,19 @@ define_optag(optagsv, mask) CODE: STRLEN len; char *optag = SvPV(optagsv, len); - put_op_bitspec(optag, len, mask); /* croaks */ + put_op_bitspec(aTHX_ optag, len, mask); /* croaks */ ST(0) = &PL_sv_yes; void empty_opset() CODE: - ST(0) = sv_2mortal(new_opset(Nullsv)); + ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv)); void full_opset() CODE: - ST(0) = sv_2mortal(new_opset(opset_all)); + ST(0) = sv_2mortal(new_opset(aTHX_ opset_all)); void opmask_add(opset) @@ -443,6 +449,8 @@ opmask_add(opset) PREINIT: if (!PL_op_mask) Newz(0, PL_op_mask, PL_maxo, char); +CODE: + opmask_add(aTHX_ opset); void opcodes() @@ -457,7 +465,7 @@ PPCODE: void opmask() CODE: - ST(0) = sv_2mortal(new_opset(Nullsv)); + ST(0) = sv_2mortal(new_opset(aTHX_ Nullsv)); if (PL_op_mask) { char *bitmap = SvPVX(ST(0)); int myopcode; diff --git a/gnu/usr.bin/perl/ext/Opcode/Safe.pm b/gnu/usr.bin/perl/ext/Opcode/Safe.pm index 2d09c2e5c74..7e1d6a34a7d 100644 --- a/gnu/usr.bin/perl/ext/Opcode/Safe.pm +++ b/gnu/usr.bin/perl/ext/Opcode/Safe.pm @@ -2,9 +2,8 @@ package Safe; use 5.003_11; use strict; -use vars qw($VERSION); -$VERSION = "2.06"; +our $VERSION = "2.06"; use Carp; @@ -235,7 +234,7 @@ sub rdo { 1; -__DATA__ +__END__ =head1 NAME diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.pm b/gnu/usr.bin/perl/ext/POSIX/POSIX.pm index 84298cb69aa..9416f70809a 100644 --- a/gnu/usr.bin/perl/ext/POSIX/POSIX.pm +++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.pm @@ -1,203 +1,34 @@ package POSIX; -use vars qw($VERSION @ISA %EXPORT_TAGS @EXPORT_OK $AUTOLOAD); +our(@ISA, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD) = (); -use Carp; use AutoLoader; -require Config; -use Symbol; -require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); - -$VERSION = "1.02" ; - -%EXPORT_TAGS = ( - - assert_h => [qw(assert NDEBUG)], - - ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower - isprint ispunct isspace isupper isxdigit tolower toupper)], - - dirent_h => [qw()], - - 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 - O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK - O_RDONLY O_RDWR O_TRUNC O_WRONLY - creat - SEEK_CUR SEEK_END SEEK_SET - S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU - S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID - S_IWGRP S_IWOTH S_IWUSR)], - - float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG - DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP - DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP - FLT_DIG FLT_EPSILON FLT_MANT_DIG - FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP - FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP - FLT_RADIX FLT_ROUNDS - LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG - LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP - LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)], - - grp_h => [qw()], - - limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX - INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON - MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX - PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN - SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX - ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX - _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT - _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX - _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX - _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], +use XSLoader (); - locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC - LC_TIME NULL localeconv setlocale)], - - math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod - frexp ldexp log10 modf pow sinh tan tanh)], - - pwd_h => [qw()], - - setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], - - 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()], - - stddef_h => [qw(NULL offsetof)], - - stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid - L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET - STREAM_MAX TMP_MAX stderr stdin stdout - clearerr fclose fdopen feof ferror fflush fgetc fgetpos - fgets fopen fprintf fputc fputs fread freopen - fscanf fseek fsetpos ftell fwrite getchar gets - perror putc putchar puts remove rewind - scanf setbuf setvbuf sscanf tmpfile tmpnam - ungetc vfprintf vprintf vsprintf)], - - 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 strtoul wcstombs wctomb)], - - string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat - strchr strcmp strcoll strcpy strcspn strerror strlen - strncat strncmp strncpy strpbrk strrchr strspn strstr - strtok strxfrm)], - - sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU - S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG - S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR - fstat mkfifo)], - - sys_times_h => [qw()], - - sys_types_h => [qw()], - - sys_utsname_h => [qw(uname)], - - sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED - WNOHANG WSTOPSIG WTERMSIG WUNTRACED)], - - termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 - B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL - CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK - ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR - INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST - PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION - TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW - TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART - VSTOP VSUSP VTIME - cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain - tcflow tcflush tcgetattr tcsendbreak tcsetattr )], - - time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime - difftime mktime strftime tzset tzname)], - - unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET - STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK - _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON - _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX - _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED - _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS - _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX - _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL - _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS - _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION - _exit access ctermid cuserid - dup2 dup execl execle execlp execv execve execvp - fpathconf getcwd getegid geteuid getgid getgroups - getpid getuid isatty lseek pathconf pause setgid setpgid - setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)], - - utime_h => [qw()], - -); - -Exporter::export_tags(); - -@EXPORT_OK = qw( - closedir opendir readdir rewinddir - fcntl open - getgrgid getgrnam - atan2 cos exp log sin sqrt - getpwnam getpwuid - kill - fileno getc printf rename sprintf - abs exit rand srand system - chmod mkdir stat umask - times - wait waitpid - gmtime localtime time - alarm chdir chown close fork getlogin getppid getpgrp link - pipe read rmdir sleep unlink write - utime - nice -); +our $VERSION = "1.03" ; # Grandfather old foo_h form to new :foo_h form +my $loaded; + sub import { + load_imports() unless $loaded++; my $this = shift; my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_; local $Exporter::ExportLevel = 1; Exporter::import($this,@list); } +sub croak { require Carp; goto &Carp::croak } -bootstrap POSIX $VERSION; +XSLoader::load 'POSIX', $VERSION; my $EINVAL = constant("EINVAL", 0); my $EAGAIN = constant("EAGAIN", 0); sub AUTOLOAD { if ($AUTOLOAD =~ /::(_?[a-z])/) { + # require AutoLoader; $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD } @@ -273,7 +104,7 @@ sub closedir { sub opendir { usage "opendir(directory)" if @_ != 1; - my $dirhandle = gensym; + my $dirhandle; CORE::opendir($dirhandle, $_[0]) ? $dirhandle : undef; @@ -932,3 +763,178 @@ sub utime { CORE::utime($_[1], $_[2], $_[0]); } +sub load_imports { +%EXPORT_TAGS = ( + + assert_h => [qw(assert NDEBUG)], + + ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower + isprint ispunct isspace isupper isxdigit tolower toupper)], + + dirent_h => [qw()], + + 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 + O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK + O_RDONLY O_RDWR O_TRUNC O_WRONLY + creat + SEEK_CUR SEEK_END SEEK_SET + S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID + S_IWGRP S_IWOTH S_IWUSR)], + + float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG + DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP + DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP + FLT_DIG FLT_EPSILON FLT_MANT_DIG + FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP + FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP + FLT_RADIX FLT_ROUNDS + LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG + LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP + LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)], + + grp_h => [qw()], + + limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX + INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON + MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX + PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN + SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX + ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX + _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT + _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX + _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX + _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], + + locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC + LC_TIME NULL localeconv setlocale)], + + math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod + frexp ldexp log10 modf pow sinh tan tanh)], + + pwd_h => [qw()], + + setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], + + 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()], + + stddef_h => [qw(NULL offsetof)], + + stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid + L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET + STREAM_MAX TMP_MAX stderr stdin stdout + clearerr fclose fdopen feof ferror fflush fgetc fgetpos + fgets fopen fprintf fputc fputs fread freopen + fscanf fseek fsetpos ftell fwrite getchar gets + perror putc putchar puts remove rewind + scanf setbuf setvbuf sscanf tmpfile tmpnam + ungetc vfprintf vprintf vsprintf)], + + 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 strtoul wcstombs wctomb)], + + string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat + strchr strcmp strcoll strcpy strcspn strerror strlen + strncat strncmp strncpy strpbrk strrchr strspn strstr + strtok strxfrm)], + + sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG + S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR + fstat mkfifo)], + + sys_times_h => [qw()], + + sys_types_h => [qw()], + + sys_utsname_h => [qw(uname)], + + sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED + WNOHANG WSTOPSIG WTERMSIG WUNTRACED)], + + termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 + B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL + CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK + ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR + INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST + PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION + TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW + TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART + VSTOP VSUSP VTIME + cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain + tcflow tcflush tcgetattr tcsendbreak tcsetattr )], + + time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime + difftime mktime strftime tzset tzname)], + + unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET + STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK + _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON + _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX + _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED + _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS + _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX + _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL + _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_SAVED_IDS + _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION + _exit access ctermid cuserid + dup2 dup execl execle execlp execv execve execvp + fpathconf getcwd getegid geteuid getgid getgroups + getpid getuid isatty lseek pathconf pause setgid setpgid + setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)], + + utime_h => [qw()], + +); + +# Exporter::export_tags(); +for (values %EXPORT_TAGS) { + push @EXPORT, @$_; +} + +@EXPORT_OK = qw( + closedir opendir readdir rewinddir + fcntl open + getgrgid getgrnam + atan2 cos exp log sin sqrt + getpwnam getpwuid + kill + fileno getc printf rename sprintf + abs exit rand srand system + chmod mkdir stat umask + times + wait waitpid + gmtime localtime time + alarm chdir chown close fork getlogin getppid getpgrp link + pipe read rmdir sleep unlink write + utime + nice +); + +require Exporter; +} diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.pod b/gnu/usr.bin/perl/ext/POSIX/POSIX.pod index 6a4a61aca62..08300e4337b 100644 --- a/gnu/usr.bin/perl/ext/POSIX/POSIX.pod +++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.pod @@ -847,31 +847,35 @@ setjmp() is C-specific: use eval {} instead. =item setlocale -Modifies and queries program's locale. +Modifies and queries program's locale. The following examples assume + + use POSIX qw(setlocale LC_ALL LC_CTYPE); + +has been issued. The following will set the traditional UNIX system locale behavior (the second argument C<"C">). - $loc = POSIX::setlocale( &POSIX::LC_ALL, "C" ); + $loc = setlocale( LC_ALL, "C" ); -The following will query (the missing second argument) the current -LC_CTYPE category. +The following will query the current LC_CTYPE category. (No second +argument means 'query'.) - $loc = POSIX::setlocale( &POSIX::LC_CTYPE); + $loc = setlocale( 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, ""); + $loc = setlocale( 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" ); + $loc = setlocale( LC_ALL, "es_AR.ISO8859-1" ); =item setpgid @@ -1015,8 +1019,13 @@ The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero. I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The year (C<year>) is given in years since 1900. I.e., the year 1995 is 95; the year 2001 is 101. Consult your system's C<strftime()> manpage for details -about these and the other arguments. The given arguments are made consistent -by calling C<mktime()> before calling your system's C<strftime()> function. +about these and the other arguments. +If you want your code to be portable, your format (C<fmt>) argument +should use only the conversion specifiers defined by the ANSI C +standard. These are C<aAbBcdHIjmMpSUwWxXyYZ%>. +The given arguments are made consistent +as though by calling C<mktime()> before calling your system's +C<strftime()> function, except that the C<isdst> value is not affected. The string for Tuesday, December 12, 1995. diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs index 15e026e212b..3a523d1d07a 100644 --- a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs +++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs @@ -1,11 +1,14 @@ #ifdef WIN32 #define _POSIX_ #endif + +#define PERL_NO_GET_CONTEXT + #include "EXTERN.h" #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" -#ifdef PERL_OBJECT /* XXX _very_ temporary hacks */ +#if defined(PERL_OBJECT) || defined(PERL_CAPI) || defined(PERL_IMPLICIT_SYS) # undef signal # undef open # undef setmode @@ -78,6 +81,7 @@ /* The non-POSIX CRTL times() has void return type, so we just get the current time directly */ clock_t vms_times(struct tms *PL_bufptr) { + dTHX; clock_t retval; /* Get wall time and convert to 10 ms intervals to * produce the return value that the POSIX standard expects */ @@ -102,6 +106,9 @@ } # define times(t) vms_times(t) #else +#if defined (__CYGWIN__) +# define tzname _tzname +#endif #if defined (WIN32) # undef mkfifo # define mkfifo(a,b) not_here("mkfifo") @@ -135,8 +142,12 @@ #else # ifndef HAS_MKFIFO -# ifndef mkfifo -# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0)) +# ifdef OS2 +# define mkfifo(a,b) not_here("mkfifo") +# else /* !( defined OS2 ) */ +# ifndef mkfifo +# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0)) +# endif # endif # endif /* !HAS_MKFIFO */ @@ -177,10 +188,10 @@ typedef struct termios* POSIX__Termios; #endif /* Possibly needed prototypes */ -char *cuserid _((char *)); -double strtod _((const char *, char **)); -long strtol _((const char *, char **, int)); -unsigned long strtoul _((const char *, char **, int)); +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") @@ -278,7 +289,7 @@ unsigned long strtoul _((const char *, char **, int)); #endif #ifdef HAS_TZNAME -# ifndef WIN32 +# if !defined(WIN32) && !defined(__CYGWIN__) extern char *tzname[]; # endif #else @@ -303,14 +314,13 @@ char *tzname[] = { "" , "" }; */ #ifdef HAS_GNULIBC # ifndef STRUCT_TM_HASZONE -# define STRUCT_TM_HAS_ZONE +# define STRUCT_TM_HASZONE # endif #endif #ifdef STRUCT_TM_HASZONE static void -init_tm(ptm) /* see mktime, strftime and asctime */ - struct tm *ptm; +init_tm(struct tm *ptm) /* see mktime, strftime and asctime */ { Time_t now; (void)time(&now); @@ -321,6 +331,202 @@ init_tm(ptm) /* see mktime, strftime and asctime */ # define init_tm(ptm) #endif +/* + * mini_mktime - normalise struct tm values without the localtime() + * semantics (and overhead) of mktime(). + */ +static void +mini_mktime(struct tm *ptm) +{ + int yearday; + int secs; + int month, mday, year, jday; + int odd_cent, odd_year; + +#define DAYS_PER_YEAR 365 +#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) +#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) +#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1) +#define SECS_PER_HOUR (60*60) +#define SECS_PER_DAY (24*SECS_PER_HOUR) +/* parentheses deliberately absent on these two, otherwise they don't work */ +#define MONTH_TO_DAYS 153/5 +#define DAYS_TO_MONTH 5/153 +/* offset to bias by March (month 4) 1st between month/mday & year finding */ +#define YEAR_ADJUST (4*MONTH_TO_DAYS+1) +/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */ +#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */ + +/* + * Year/day algorithm notes: + * + * With a suitable offset for numeric value of the month, one can find + * an offset into the year by considering months to have 30.6 (153/5) days, + * using integer arithmetic (i.e., with truncation). To avoid too much + * messing about with leap days, we consider January and February to be + * the 13th and 14th month of the previous year. After that transformation, + * we need the month index we use to be high by 1 from 'normal human' usage, + * so the month index values we use run from 4 through 15. + * + * Given that, and the rules for the Gregorian calendar (leap years are those + * divisible by 4 unless also divisible by 100, when they must be divisible + * by 400 instead), we can simply calculate the number of days since some + * arbitrary 'beginning of time' by futzing with the (adjusted) year number, + * the days we derive from our month index, and adding in the day of the + * month. The value used here is not adjusted for the actual origin which + * it normally would use (1 January A.D. 1), since we're not exposing it. + * We're only building the value so we can turn around and get the + * normalised values for the year, month, day-of-month, and day-of-year. + * + * For going backward, we need to bias the value we're using so that we find + * the right year value. (Basically, we don't want the contribution of + * March 1st to the number to apply while deriving the year). Having done + * that, we 'count up' the contribution to the year number by accounting for + * full quadracenturies (400-year periods) with their extra leap days, plus + * the contribution from full centuries (to avoid counting in the lost leap + * days), plus the contribution from full quad-years (to count in the normal + * leap days), plus the leftover contribution from any non-leap years. + * At this point, if we were working with an actual leap day, we'll have 0 + * days left over. This is also true for March 1st, however. So, we have + * to special-case that result, and (earlier) keep track of the 'odd' + * century and year contributions. If we got 4 extra centuries in a qcent, + * or 4 extra years in a qyear, then it's a leap day and we call it 29 Feb. + * Otherwise, we add back in the earlier bias we removed (the 123 from + * figuring in March 1st), find the month index (integer division by 30.6), + * and the remainder is the day-of-month. We then have to convert back to + * 'real' months (including fixing January and February from being 14/15 in + * the previous year to being in the proper year). After that, to get + * tm_yday, we work with the normalised year and get a new yearday value for + * January 1st, which we subtract from the yearday value we had earlier, + * representing the date we've re-built. This is done from January 1 + * because tm_yday is 0-origin. + * + * Since POSIX time routines are only guaranteed to work for times since the + * UNIX epoch (00:00:00 1 Jan 1970 UTC), the fact that this algorithm + * applies Gregorian calendar rules even to dates before the 16th century + * doesn't bother me. Besides, you'd need cultural context for a given + * date to know whether it was Julian or Gregorian calendar, and that's + * outside the scope for this routine. Since we convert back based on the + * same rules we used to build the yearday, you'll only get strange results + * for input which needed normalising, or for the 'odd' century years which + * were leap years in the Julian calander but not in the Gregorian one. + * I can live with that. + * + * This algorithm also fails to handle years before A.D. 1 gracefully, but + * that's still outside the scope for POSIX time manipulation, so I don't + * care. + */ + + year = 1900 + ptm->tm_year; + month = ptm->tm_mon; + mday = ptm->tm_mday; + /* allow given yday with no month & mday to dominate the result */ + if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { + month = 0; + mday = 0; + jday = 1 + ptm->tm_yday; + } + else { + jday = 0; + } + if (month >= 2) + month+=2; + else + month+=14, year--; + yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400; + yearday += month*MONTH_TO_DAYS + mday + jday; + /* + * Note that we don't know when leap-seconds were or will be, + * so we have to trust the user if we get something which looks + * like a sensible leap-second. Wild values for seconds will + * be rationalised, however. + */ + if ((unsigned) ptm->tm_sec <= 60) { + secs = 0; + } + else { + secs = ptm->tm_sec; + ptm->tm_sec = 0; + } + secs += 60 * ptm->tm_min; + secs += SECS_PER_HOUR * ptm->tm_hour; + if (secs < 0) { + if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) { + /* got negative remainder, but need positive time */ + /* back off an extra day to compensate */ + yearday += (secs/SECS_PER_DAY)-1; + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1); + } + else { + yearday += (secs/SECS_PER_DAY); + secs -= SECS_PER_DAY * (secs/SECS_PER_DAY); + } + } + else if (secs >= SECS_PER_DAY) { + yearday += (secs/SECS_PER_DAY); + secs %= SECS_PER_DAY; + } + ptm->tm_hour = secs/SECS_PER_HOUR; + secs %= SECS_PER_HOUR; + ptm->tm_min = secs/60; + secs %= 60; + ptm->tm_sec += secs; + /* done with time of day effects */ + /* + * The algorithm for yearday has (so far) left it high by 428. + * To avoid mistaking a legitimate Feb 29 as Mar 1, we need to + * bias it by 123 while trying to figure out what year it + * really represents. Even with this tweak, the reverse + * translation fails for years before A.D. 0001. + * It would still fail for Feb 29, but we catch that one below. + */ + jday = yearday; /* save for later fixup vis-a-vis Jan 1 */ + yearday -= YEAR_ADJUST; + year = (yearday / DAYS_PER_QCENT) * 400; + yearday %= DAYS_PER_QCENT; + odd_cent = yearday / DAYS_PER_CENT; + year += odd_cent * 100; + yearday %= DAYS_PER_CENT; + year += (yearday / DAYS_PER_QYEAR) * 4; + yearday %= DAYS_PER_QYEAR; + odd_year = yearday / DAYS_PER_YEAR; + year += odd_year; + yearday %= DAYS_PER_YEAR; + if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */ + month = 1; + yearday = 29; + } + else { + yearday += YEAR_ADJUST; /* recover March 1st crock */ + month = yearday*DAYS_TO_MONTH; + yearday -= month*MONTH_TO_DAYS; + /* recover other leap-year adjustment */ + if (month > 13) { + month-=14; + year++; + } + else { + month-=2; + } + } + ptm->tm_year = year - 1900; + if (yearday) { + ptm->tm_mday = yearday; + ptm->tm_mon = month; + } + else { + ptm->tm_mday = 31; + ptm->tm_mon = month - 1; + } + /* re-build yearday based on Jan 1 to get tm_yday */ + year--; + yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; + yearday += 14*MONTH_TO_DAYS + 1; + ptm->tm_yday = jday - yearday; + /* fix tm_wday if not overridden by caller */ + if ((unsigned)ptm->tm_wday > 6) + ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; +} #ifdef HAS_LONG_DOUBLE # if LONG_DOUBLESIZE > DOUBLESIZE @@ -348,7 +554,7 @@ not_here(char *s) } static -#ifdef HAS_LONG_DOUBLE +#if defined(HAS_LONG_DOUBLE) && (LONG_DOUBLESIZE > DOUBLESIZE) long double #else double @@ -1519,9 +1725,10 @@ constant(char *name, int arg) #else goto not_there; #endif - if (strEQ(name, "L_tmpname")) -#ifdef L_tmpname - return L_tmpname; + /* L_tmpnam[e] was a typo--retained for compatibility */ + if (strEQ(name, "L_tmpname") || strEQ(name, "L_tmpnam")) +#ifdef L_tmpnam + return L_tmpnam; #else goto not_there; #endif @@ -3045,7 +3252,7 @@ setlocale(category, locale = 0) else #endif newctype = RETVAL; - perl_new_ctype(newctype); + new_ctype(newctype); } #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE @@ -3062,7 +3269,7 @@ setlocale(category, locale = 0) else #endif newcoll = RETVAL; - perl_new_collate(newcoll); + new_collate(newcoll); } #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC @@ -3079,7 +3286,7 @@ setlocale(category, locale = 0) else #endif newnum = RETVAL; - perl_new_numeric(newnum); + new_numeric(newnum); } #endif /* USE_LOCALE_NUMERIC */ } @@ -3167,17 +3374,15 @@ sigaction(sig, action, oldaction = 0) # This code is really grody because we're trying to make the signal # interface look beautiful, which is hard. - if (!PL_siggv) - gv_fetchpv("SIG", TRUE, SVt_PVHV); - { + GV *siggv = gv_fetchpv("SIG", TRUE, SVt_PVHV); struct sigaction act; struct sigaction oact; POSIX__SigSet sigset; SV** svp; - SV** sigsvp = hv_fetch(GvHVn(PL_siggv), - sig_name[sig], - strlen(sig_name[sig]), + SV** sigsvp = hv_fetch(GvHVn(siggv), + PL_sig_name[sig], + strlen(PL_sig_name[sig]), TRUE); STRLEN n_a; @@ -3196,7 +3401,7 @@ sigaction(sig, action, oldaction = 0) croak("Can't supply an action without a HANDLER"); sv_setpv(*sigsvp, SvPV(*svp, n_a)); mg_set(*sigsvp); /* handles DEFAULT and IGNORE */ - act.sa_handler = sighandler; + act.sa_handler = PL_sighandlerp; /* Set up any desired mask. */ svp = hv_fetch(action, "MASK", 4, FALSE); @@ -3262,7 +3467,7 @@ INIT: } else if (sv_derived_from(ST(2), "POSIX::SigSet")) { IV tmp = SvIV((SV*)SvRV(ST(2))); - oldsigset = (POSIX__SigSet) tmp; + oldsigset = INT2PTR(POSIX__SigSet,tmp); } else { New(0, oldsigset, 1, sigset_t); @@ -3367,9 +3572,18 @@ write(fd, buffer, nbytes) char * buffer size_t nbytes -char * -tmpnam(s = 0) - char * s = 0; +SV * +tmpnam() + PREINIT: + STRLEN i; + int len; + CODE: + RETVAL = newSVpvn("", 0); + SvGROW(RETVAL, L_tmpnam); + len = strlen(tmpnam(SvPV(RETVAL, i))); + SvCUR_set(RETVAL, len); + OUTPUT: + RETVAL void abort() @@ -3434,10 +3648,12 @@ strtol(str, base = 0) char *unparsed; PPCODE: num = strtol(str, &unparsed, base); - if (num >= IV_MIN && num <= IV_MAX) - PUSHs(sv_2mortal(newSViv((IV)num))); - else +#if IVSIZE <= LONGSIZE + if (num < IV_MIN || num > IV_MAX) PUSHs(sv_2mortal(newSVnv((double)num))); + else +#endif + PUSHs(sv_2mortal(newSViv((IV)num))); if (GIMME == G_ARRAY) { EXTEND(SP, 1); if (unparsed) @@ -3629,7 +3845,7 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) mytm.tm_wday = wday; mytm.tm_yday = yday; mytm.tm_isdst = isdst; - (void) mktime(&mytm); + mini_mktime(&mytm); len = strftime(tmpbuf, sizeof tmpbuf, fmt, &mytm); /* ** The following is needed to handle to the situation where @@ -3645,28 +3861,35 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) ** If there is a better way to make it portable, go ahead by ** all means. */ - if ( ( len > 0 && len < sizeof(tmpbuf) ) - || ( len == 0 && strlen(fmt) == 0 ) ) { + if ((len > 0 && len < sizeof(tmpbuf)) || (len == 0 && *fmt == '\0')) ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); - } else { + else { /* Possibly buf overflowed - try again with a bigger buf */ - int bufsize = strlen(fmt) + sizeof(tmpbuf); + int fmtlen = strlen(fmt); + int bufsize = fmtlen + sizeof(tmpbuf); char* buf; int buflen; New(0, buf, bufsize, char); - while( buf ) { + while (buf) { buflen = strftime(buf, bufsize, fmt, &mytm); - if ( buflen > 0 && buflen < bufsize ) break; + if (buflen > 0 && buflen < bufsize) + break; + /* heuristic to prevent out-of-memory errors */ + if (bufsize > 100*fmtlen) { + Safefree(buf); + buf = NULL; + break; + } bufsize *= 2; Renew(buf, bufsize, char); } - if ( buf ) { - ST(0) = sv_2mortal(newSVpv(buf, buflen)); + if (buf) { + ST(0) = sv_2mortal(newSVpvn(buf, buflen)); Safefree(buf); - } else { - ST(0) = sv_2mortal(newSVpv(tmpbuf, len)); } + else + ST(0) = sv_2mortal(newSVpvn(tmpbuf, len)); } } @@ -3677,8 +3900,8 @@ void tzname() PPCODE: EXTEND(SP,2); - PUSHs(sv_2mortal(newSVpv(tzname[0],strlen(tzname[0])))); - PUSHs(sv_2mortal(newSVpv(tzname[1],strlen(tzname[1])))); + PUSHs(sv_2mortal(newSVpvn(tzname[0],strlen(tzname[0])))); + PUSHs(sv_2mortal(newSVpvn(tzname[1],strlen(tzname[1])))); SysRet access(filename, mode) diff --git a/gnu/usr.bin/perl/ext/POSIX/hints/openbsd.pl b/gnu/usr.bin/perl/ext/POSIX/hints/openbsd.pl index b0303ba7f31..62732ac7b9d 100644 --- a/gnu/usr.bin/perl/ext/POSIX/hints/openbsd.pl +++ b/gnu/usr.bin/perl/ext/POSIX/hints/openbsd.pl @@ -1,4 +1,3 @@ # BSD platforms have extra fields in struct tm that need to be initialized. # XXX A Configure test is needed. - $self->{CCFLAGS} = $Config{ccflags} . ' -DSTRUCT_TM_HASZONE' ; diff --git a/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL b/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL index 749478551fe..a1debb92a33 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL +++ b/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL @@ -16,16 +16,30 @@ WriteMakefile( XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'SDBM_File.pm', DEFINE => $define, + PERL_MALLOC_OK => 1, ); sub MY::postamble { - if ($^O ne 'VMS') { + if ($^O =~ /MSWin32/ && Win32::IsWin95()) { + # XXX: dmake-specific, like rest of Win95 port + return + ' +$(MYEXTLIB): sdbm/Makefile +@[ + cd sdbm + $(MAKE) all + cd .. +] +'; + } + elsif ($^O ne 'VMS') { ' $(MYEXTLIB): sdbm/Makefile cd sdbm && $(MAKE) all '; - } else { - ' + } + else { + ' $(MYEXTLIB) : [.sdbm]descrip.mms set def [.sdbm] $(MMS) all diff --git a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm index a2d4df85587..c5e26c8e04d 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm +++ b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm @@ -1,16 +1,14 @@ package SDBM_File; use strict; -use vars qw($VERSION @ISA); require Tie::Hash; -require DynaLoader; +use XSLoader (); -@ISA = qw(Tie::Hash DynaLoader); +our @ISA = qw(Tie::Hash); +our $VERSION = "1.02" ; -$VERSION = "1.00" ; - -bootstrap SDBM_File $VERSION; +XSLoader::load 'SDBM_File', $VERSION; 1; @@ -30,6 +28,6 @@ SDBM_File - Tied access to sdbm files =head1 DESCRIPTION -See L<perlfunc/tie> +See L<perlfunc/tie>, L<perldbmfilter> =cut diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL index e6fdcf93069..4453dea1fda 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL @@ -42,12 +42,14 @@ INST_STATIC = libsdbm$(LIB_EXT) } sub MY::top_targets { + my $noecho = shift->{NOECHO}; + my $r = ' all :: static - $(NOECHO) $(NOOP) + ' . $noecho . '$(NOOP) config :: - $(NOECHO) $(NOOP) + ' . $noecho . '$(NOOP) lint: lint -abchx $(LIBSRCS) @@ -58,7 +60,7 @@ lint: # variables into the environment so $(MYEXTLIB) is set in here to this # value which can not be built. sdbm/libsdbm.a: - $(NOECHO) $(NOOP) + ' . $noecho . '$(NOOP) ' unless $^O eq 'VMS'; return $r; diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c index a9a805a4aa3..4f0fde23027 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c @@ -8,7 +8,11 @@ */ #include "config.h" -#include "EXTERN.h" +#ifdef __CYGWIN__ +# define EXTCONST extern const +#else +# include "EXTERN.h" +#endif #include "sdbm.h" #include "tune.h" #include "pair.h" @@ -102,6 +106,17 @@ getpair(char *pag, datum key) return val; } +int +exipair(char *pag, datum key) +{ + register short *ino = (short *) pag; + + if (ino[0] == 0) + return 0; + + return (seepair(pag, ino[0], key.dptr, key.dsize) != 0); +} + #ifdef SEEDUPS int duppair(char *pag, datum key) diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h index 8a675b90659..b6944edd071 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h @@ -2,6 +2,7 @@ #define chkpage sdbm__chkpage #define delpair sdbm__delpair #define duppair sdbm__duppair +#define exipair sdbm__exipair #define fitpair sdbm__fitpair #define getnkey sdbm__getnkey #define getpair sdbm__getpair @@ -11,6 +12,7 @@ extern int fitpair proto((char *, int)); extern void putpair proto((char *, datum, datum)); extern datum getpair proto((char *, datum)); +extern int exipair proto((char *, datum)); extern int delpair proto((char *, datum)); extern int chkpage proto((char *)); extern datum getnkey proto((char *, int)); diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 index 7e5c1764042..fe6fe76e255 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 @@ -1,7 +1,7 @@ .\" $Id: sdbm.3,v 1.2 90/12/13 13:00:57 oz Exp $ .TH SDBM 3 "1 March 1990" .SH NAME -sdbm, 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 +sdbm, sdbm_open, sdbm_prep, sdbm_close, sdbm_fetch, sdbm_store, sdbm_delete, sdbm_exists, sdbm_firstkey, sdbm_nextkey, sdbm_hash, sdbm_rdonly, sdbm_error, sdbm_clearerr, sdbm_dirfno, sdbm_pagfno \- data base subroutines .SH SYNOPSIS .nf .ft B @@ -26,6 +26,8 @@ int sdbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags) .sp int sdbm_delete(\s-1DBM\s0 *db, datum key) .sp +int sdbm_exists(\s-1DBM\s0 *db, datum key) +.sp datum sdbm_firstkey(\s-1DBM\s0 *db) .sp datum sdbm_nextkey(\s-1DBM\s0 *db) @@ -47,6 +49,7 @@ int sdbm_pagfno(\s-1DBM\s0 *db) .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_exists "" "\fLsdbm_exists\fR \(em test \fLsdbm\fR key existence" .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" @@ -149,6 +152,8 @@ Given a handle, one can retrieve data associated with a key by using the routine, and associate data with a key by using the .BR sdbm_store (\|) routine. +.BR sdbm_exists (\|) +will say whether a given key exists in the database. .LP The values of the .I flags diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c index c147e45b43a..64c75cbb208 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c @@ -9,6 +9,9 @@ #include "INTERN.h" #include "config.h" +#ifdef WIN32 +#include "io.h" +#endif #include "sdbm.h" #include "tune.h" #include "pair.h" @@ -36,7 +39,7 @@ extern int errno; extern Malloc_t malloc proto((MEM_SIZE)); extern Free_t free proto((Malloc_t)); -extern Off_t lseek(int, Off_t, int); + #endif /* @@ -125,7 +128,7 @@ sdbm_prep(char *dirname, char *pagname, int flags, int mode) * open the files in sequence, and stat the dirfile. * If we fail anywhere, undo everything, return NULL. */ -#if defined(OS2) || defined(MSDOS) || defined(WIN32) +#if defined(OS2) || defined(MSDOS) || defined(WIN32) || defined(__CYGWIN__) flags |= O_BINARY; # endif if ((db->pagf = open(pagname, flags, mode)) > -1) { @@ -182,6 +185,18 @@ sdbm_fetch(register DBM *db, datum key) } int +sdbm_exists(register DBM *db, datum key) +{ + if (db == NULL || bad(key)) + return errno = EINVAL, -1; + + if (getpage(db, exhash(key))) + return exipair(db->pagbuf, key); + + return ioerr(db), -1; +} + +int sdbm_delete(register DBM *db, datum key) { if (db == NULL || bad(key)) @@ -416,9 +431,12 @@ getdbit(register DBM *db, register long int dbit) dirb = c / DBLKSIZ; if (dirb != db->dirbno) { + int got; if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) + || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) return 0; + if (got==0) + memset(db->dirbuf,0,DBLKSIZ); db->dirbno = dirb; debug(("dir read: %d\n", dirb)); @@ -437,10 +455,12 @@ setdbit(register DBM *db, register long int dbit) dirb = c / DBLKSIZ; if (dirb != db->dirbno) { - (void) memset(db->dirbuf, 0, DBLKSIZ); + int got; if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 - || read(db->dirf, db->dirbuf, DBLKSIZ) < 0) + || (got=read(db->dirf, db->dirbuf, DBLKSIZ)) < 0) return 0; + if (got==0) + memset(db->dirbuf,0,DBLKSIZ); db->dirbno = dirb; debug(("dir read: %d\n", dirb)); @@ -448,8 +468,13 @@ setdbit(register DBM *db, register long int dbit) db->dirbuf[c % DBLKSIZ] |= (1 << dbit % BYTESIZ); +#if 0 if (dbit >= db->maxbno) db->maxbno += DBLKSIZ * BYTESIZ; +#else + if (OFF_DIR((dirb+1))*BYTESIZ > db->maxbno) + db->maxbno=OFF_DIR((dirb+1))*BYTESIZ; +#endif if (lseek(db->dirf, OFF_DIR(dirb), SEEK_SET) < 0 || write(db->dirf, db->dirbuf, DBLKSIZ) < 0) diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h index 84d5f75468c..86ba82d82fb 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h +++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h @@ -79,6 +79,7 @@ extern int sdbm_delete proto((DBM *, datum)); extern int sdbm_store proto((DBM *, datum, datum, int)); extern datum sdbm_firstkey proto((DBM *)); extern datum sdbm_nextkey proto((DBM *)); +extern int sdbm_exists proto((DBM *, datum)); /* * other @@ -98,8 +99,12 @@ extern long sdbm_hash proto((char *, int)); #define dbm_clearerr sdbm_clearerr #endif -/* Most of the following is stolen from perl.h. */ +/* Most of the following is stolen from perl.h. We don't include + perl.h here because we just want the portability parts of perl.h, + not everything else. +*/ #ifndef H_PERL /* Include guard */ +#include "embed.h" /* Follow all the global renamings. */ /* * The following contortions are brought to you on behalf of all the @@ -168,27 +173,17 @@ extern long sdbm_hash proto((char *, int)); /* 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) */ +#if defined(MYMALLOC) && !defined(PERL_POLLUTE_MALLOC) +# define malloc Perl_malloc +# define calloc Perl_calloc +# define realloc Perl_realloc +# define free Perl_mfree + +Malloc_t Perl_malloc proto((MEM_SIZE nbytes)); +Malloc_t Perl_calloc proto((MEM_SIZE elements, MEM_SIZE size)); +Malloc_t Perl_realloc proto((Malloc_t where, MEM_SIZE nbytes)); +Free_t Perl_mfree proto((Malloc_t where)); +#endif /* MYMALLOC */ #ifdef I_STRING #include <string.h> diff --git a/gnu/usr.bin/perl/ext/SDBM_File/typemap b/gnu/usr.bin/perl/ext/SDBM_File/typemap index 317a8f3886c..eeb5d59027f 100644 --- a/gnu/usr.bin/perl/ext/SDBM_File/typemap +++ b/gnu/usr.bin/perl/ext/SDBM_File/typemap @@ -2,7 +2,8 @@ #################################### DBM SECTION # -datum T_DATUM +datum_key T_DATUM_K +datum_value T_DATUM_V gdatum T_GDATUM NDBM_File T_PTROBJ GDBM_File T_PTROBJ @@ -13,14 +14,23 @@ DBZ_File T_PTROBJ FATALFUNC T_OPAQUEPTR INPUT -T_DATUM +T_DATUM_K + ckFilter($arg, filter_store_key, \"filter_store_key\"); + $var.dptr = SvPV($arg, PL_na); + $var.dsize = (int)PL_na; +T_DATUM_V + ckFilter($arg, filter_store_value, \"filter_store_value\"); $var.dptr = SvPV($arg, PL_na); $var.dsize = (int)PL_na; T_GDATUM UNIMPLEMENTED OUTPUT -T_DATUM +T_DATUM_K + sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_key,\"filter_fetch_key\"); +T_DATUM_V sv_setpvn($arg, $var.dptr, $var.dsize); + ckFilter($arg, filter_fetch_value,\"filter_fetch_value\"); T_GDATUM sv_usepvn($arg, $var.dptr, $var.dsize); T_PTROBJ diff --git a/gnu/usr.bin/perl/ext/Socket/Socket.pm b/gnu/usr.bin/perl/ext/Socket/Socket.pm index 1ed19f713d2..02f098df77c 100644 --- a/gnu/usr.bin/perl/ext/Socket/Socket.pm +++ b/gnu/usr.bin/perl/ext/Socket/Socket.pm @@ -1,7 +1,7 @@ package Socket; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); -$VERSION = "1.7"; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); +$VERSION = "1.72"; =head1 NAME @@ -160,10 +160,11 @@ have AF_UNIX in the right place. =cut use Carp; +use warnings::register; require Exporter; -require DynaLoader; -@ISA = qw(Exporter DynaLoader); +use XSLoader (); +@ISA = qw(Exporter); @EXPORT = qw( inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in pack_sockaddr_un unpack_sockaddr_un @@ -193,6 +194,8 @@ require DynaLoader; AF_UNIX AF_UNSPEC AF_X25 + IOV_MAX + MSG_BCAST MSG_CTLFLAGS MSG_CTLIGNORE MSG_CTRUNC @@ -203,6 +206,7 @@ require DynaLoader; MSG_ERRQUEUE MSG_FIN MSG_MAXIOVLEN + MSG_MCAST MSG_NOSIGNAL MSG_OOB MSG_PEEK @@ -241,6 +245,9 @@ require DynaLoader; SCM_CREDS SCM_RIGHTS SCM_TIMESTAMP + SHUT_RD + SHUT_RDWR + SHUT_WR SOCK_DGRAM SOCK_RAW SOCK_RDM @@ -266,9 +273,17 @@ require DynaLoader; SO_SNDTIMEO SO_TYPE SO_USELOOPBACK + UIO_MAXIOV ); -@EXPORT_OK = qw(CR LF CRLF $CR $LF $CRLF); +@EXPORT_OK = qw(CR LF CRLF $CR $LF $CRLF + + IPPROTO_TCP + TCP_KEEPALIVE + TCP_MAXRT + TCP_MAXSEG + TCP_NODELAY + TCP_STDURG); %EXPORT_TAGS = ( crlf => [qw(CR LF CRLF $CR $LF $CRLF)], @@ -288,7 +303,8 @@ BEGIN { sub sockaddr_in { if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die my($af, $port, @quad) = @_; - carp "6-ARG sockaddr_in call is deprecated" if $^W; + warnings::warn "6-ARG sockaddr_in call is deprecated" + if warnings::enabled(); pack_sockaddr_in($port, inet_aton(join('.', @quad))); } elsif (wantarray) { croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1; @@ -309,6 +325,115 @@ sub sockaddr_un { } } +sub INADDR_ANY (); +sub INADDR_BROADCAST (); +sub INADDR_LOOPBACK (); +sub INADDR_LOOPBACK (); + +sub AF_802 (); +sub AF_APPLETALK (); +sub AF_CCITT (); +sub AF_CHAOS (); +sub AF_DATAKIT (); +sub AF_DECnet (); +sub AF_DLI (); +sub AF_ECMA (); +sub AF_GOSIP (); +sub AF_HYLINK (); +sub AF_IMPLINK (); +sub AF_INET (); +sub AF_LAT (); +sub AF_MAX (); +sub AF_NBS (); +sub AF_NIT (); +sub AF_NS (); +sub AF_OSI (); +sub AF_OSINET (); +sub AF_PUP (); +sub AF_SNA (); +sub AF_UNIX (); +sub AF_UNSPEC (); +sub AF_X25 (); +sub IOV_MAX (); +sub MSG_BCAST (); +sub MSG_CTLFLAGS (); +sub MSG_CTLIGNORE (); +sub MSG_CTRUNC (); +sub MSG_DONTROUTE (); +sub MSG_DONTWAIT (); +sub MSG_EOF (); +sub MSG_EOR (); +sub MSG_ERRQUEUE (); +sub MSG_FIN (); +sub MSG_MAXIOVLEN (); +sub MSG_MCAST (); +sub MSG_NOSIGNAL (); +sub MSG_OOB (); +sub MSG_PEEK (); +sub MSG_PROXY (); +sub MSG_RST (); +sub MSG_SYN (); +sub MSG_TRUNC (); +sub MSG_URG (); +sub MSG_WAITALL (); +sub PF_802 (); +sub PF_APPLETALK (); +sub PF_CCITT (); +sub PF_CHAOS (); +sub PF_DATAKIT (); +sub PF_DECnet (); +sub PF_DLI (); +sub PF_ECMA (); +sub PF_GOSIP (); +sub PF_HYLINK (); +sub PF_IMPLINK (); +sub PF_INET (); +sub PF_LAT (); +sub PF_MAX (); +sub PF_NBS (); +sub PF_NIT (); +sub PF_NS (); +sub PF_OSI (); +sub PF_OSINET (); +sub PF_PUP (); +sub PF_SNA (); +sub PF_UNIX (); +sub PF_UNSPEC (); +sub PF_X25 (); +sub SCM_CONNECT (); +sub SCM_CREDENTIALS (); +sub SCM_CREDS (); +sub SCM_RIGHTS (); +sub SCM_TIMESTAMP (); +sub SHUT_RD (); +sub SHUT_RDWR (); +sub SHUT_WR (); +sub SOCK_DGRAM (); +sub SOCK_RAW (); +sub SOCK_RDM (); +sub SOCK_SEQPACKET (); +sub SOCK_STREAM (); +sub SOL_SOCKET (); +sub SOMAXCONN (); +sub SO_ACCEPTCONN (); +sub SO_BROADCAST (); +sub SO_DEBUG (); +sub SO_DONTLINGER (); +sub SO_DONTROUTE (); +sub SO_ERROR (); +sub SO_KEEPALIVE (); +sub SO_LINGER (); +sub SO_OOBINLINE (); +sub SO_RCVBUF (); +sub SO_RCVLOWAT (); +sub SO_RCVTIMEO (); +sub SO_REUSEADDR (); +sub SO_SNDBUF (); +sub SO_SNDLOWAT (); +sub SO_SNDTIMEO (); +sub SO_TYPE (); +sub SO_USELOOPBACK (); +sub UIO_MAXIOV (); sub AUTOLOAD { my($constname); @@ -318,10 +443,10 @@ sub AUTOLOAD { my ($pack,$file,$line) = caller; croak "Your vendor has not defined Socket macro $constname, used"; } - eval "sub $AUTOLOAD { $val }"; + eval "sub $AUTOLOAD () { $val }"; goto &$AUTOLOAD; } -bootstrap Socket $VERSION; +XSLoader::load 'Socket', $VERSION; 1; diff --git a/gnu/usr.bin/perl/ext/Socket/Socket.xs b/gnu/usr.bin/perl/ext/Socket/Socket.xs index 0bd6e590570..0584e785b52 100644 --- a/gnu/usr.bin/perl/ext/Socket/Socket.xs +++ b/gnu/usr.bin/perl/ext/Socket/Socket.xs @@ -1,3 +1,4 @@ +#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -6,42 +7,58 @@ # ifdef I_SYS_TYPES # include <sys/types.h> # endif -#include <sys/socket.h> -#ifdef MPE -# define PF_INET AF_INET -# define PF_UNIX AF_UNIX -# define SOCK_RAW 3 -#endif -#ifdef I_SYS_UN -#include <sys/un.h> -#endif +# include <sys/socket.h> +# if defined(USE_SOCKS) && defined(I_SOCKS) +# include <socks.h> +# endif +# ifdef MPE +# define PF_INET AF_INET +# define PF_UNIX AF_UNIX +# define SOCK_RAW 3 +# endif +# ifdef I_SYS_UN +# include <sys/un.h> +# endif +/* XXX Configure test for <netinet/in_systm.h needed XXX */ +# if defined(NeXT) || defined(__NeXT__) +# include <netinet/in_systm.h> +# endif # ifdef I_NETINET_IN # include <netinet/in.h> # endif -#include <netdb.h> -#ifdef I_ARPA_INET -# include <arpa/inet.h> -#endif +# ifdef I_NETDB +# include <netdb.h> +# endif +# ifdef I_ARPA_INET +# include <arpa/inet.h> +# endif +# ifdef I_NETINET_TCP +# include <netinet/tcp.h> +# endif #else -#include "sockadapt.h" +# include "sockadapt.h" +#endif + +#ifdef I_SYSUIO +# include <sys/uio.h> #endif #ifndef AF_NBS -#undef PF_NBS +# undef PF_NBS #endif #ifndef AF_X25 -#undef PF_X25 +# undef PF_X25 #endif #ifndef INADDR_NONE -#define INADDR_NONE 0xffffffff +# define INADDR_NONE 0xffffffff #endif /* INADDR_NONE */ #ifndef INADDR_BROADCAST -#define INADDR_BROADCAST 0xffffffff +# define INADDR_BROADCAST 0xffffffff #endif /* INADDR_BROADCAST */ #ifndef INADDR_LOOPBACK -#define INADDR_LOOPBACK 0x7F000001 +# define INADDR_LOOPBACK 0x7F000001 #endif /* INADDR_LOOPBACK */ #ifndef HAS_INET_ATON @@ -56,6 +73,7 @@ static int my_inet_aton(register const char *cp, struct in_addr *addr) { + dTHX; register U32 val; register int base; register char c; @@ -322,6 +340,18 @@ constant(char *name, int arg) case 'H': break; case 'I': + if (strEQ(name, "IOV_MAX")) +#ifdef IOV_MAX + return IOV_MAX; +#else + goto not_there; +#endif + if (strEQ(name, "IPPROTO_TCP")) +#ifdef IPPROTO_TCP + return IPPROTO_TCP; +#else + goto not_there; +#endif break; case 'J': break; @@ -330,6 +360,12 @@ constant(char *name, int arg) case 'L': break; case 'M': + if (strEQ(name, "MSG_BCAST")) +#ifdef MSG_BCAST + return MSG_BCAST; +#else + goto not_there; +#endif if (strEQ(name, "MSG_CTLFLAGS")) #ifdef MSG_CTLFLAGS return MSG_CTLFLAGS; @@ -390,6 +426,12 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "MSG_MCAST")) +#ifdef MSG_MCAST + return MSG_MCAST; +#else + goto not_there; +#endif if (strEQ(name, "MSG_NOSIGNAL")) #ifdef MSG_NOSIGNAL return MSG_NOSIGNAL; @@ -624,6 +666,24 @@ constant(char *name, int arg) #else goto not_there; #endif + if (strEQ(name, "SHUT_RD")) +#ifdef SHUT_RD + return SHUT_RD; +#else + return 0; +#endif + if (strEQ(name, "SHUT_RDWR")) +#ifdef SHUT_RDWR + return SHUT_RDWR; +#else + return 2; +#endif + if (strEQ(name, "SHUT_WR")) +#ifdef SHUT_WR + return SHUT_WR; +#else + return 1; +#endif if (strEQ(name, "SOCK_DGRAM")) #ifdef SOCK_DGRAM return SOCK_DGRAM; @@ -782,8 +842,44 @@ constant(char *name, int arg) #endif break; case 'T': + if (strEQ(name, "TCP_KEEPALIVE")) +#ifdef TCP_KEEPALIVE + return TCP_KEEPALIVE; +#else + goto not_there; +#endif + if (strEQ(name, "TCP_MAXRT")) +#ifdef TCP_MAXRT + return TCP_MAXRT; +#else + goto not_there; +#endif + if (strEQ(name, "TCP_MAXSEG")) +#ifdef TCP_MAXSEG + return TCP_MAXSEG; +#else + goto not_there; +#endif + if (strEQ(name, "TCP_NODELAY")) +#ifdef TCP_NODELAY + return TCP_NODELAY; +#else + goto not_there; +#endif + if (strEQ(name, "TCP_STDURG")) +#ifdef TCP_STDURG + return TCP_STDURG; +#else + goto not_there; +#endif break; case 'U': + if (strEQ(name, "UIO_MAXIOV")) +#ifdef UIO_MAXIOV + return UIO_MAXIOV; +#else + goto not_there; +#endif break; case 'V': break; @@ -851,7 +947,7 @@ inet_ntoa(ip_address_sv) Copy( ip_address, &addr, sizeof addr, char ); addr_str = inet_ntoa(addr); - ST(0) = sv_2mortal(newSVpv(addr_str, strlen(addr_str))); + ST(0) = sv_2mortal(newSVpvn(addr_str, strlen(addr_str))); } void @@ -862,13 +958,38 @@ pack_sockaddr_un(pathname) #ifdef I_SYS_UN struct sockaddr_un sun_ad; /* fear using sun */ STRLEN len; + Zero( &sun_ad, sizeof sun_ad, char ); sun_ad.sun_family = AF_UNIX; len = strlen(pathname); if (len > sizeof(sun_ad.sun_path)) len = sizeof(sun_ad.sun_path); +# ifdef OS2 /* Name should start with \socket\ and contain backslashes! */ + { + int off; + char *s, *e; + + if (pathname[0] != '/' && pathname[0] != '\\') + croak("Relative UNIX domain socket name '%s' unsupported", pathname); + else if (len < 8 + || pathname[7] != '/' && pathname[7] != '\\' + || !strnicmp(pathname + 1, "socket", 6)) + off = 7; + else + off = 0; /* Preserve names starting with \socket\ */ + Copy( "\\socket", sun_ad.sun_path, off, char); + Copy( pathname, sun_ad.sun_path + off, len, char ); + + s = sun_ad.sun_path + off - 1; + e = s + len + 1; + while (++s < e) + if (*s = '/') + *s = '\\'; + } +# else /* !( defined OS2 ) */ Copy( pathname, sun_ad.sun_path, len, char ); - ST(0) = sv_2mortal(newSVpv((char *)&sun_ad, sizeof sun_ad)); +# endif + ST(0) = sv_2mortal(newSVpvn((char *)&sun_ad, sizeof sun_ad)); #else ST(0) = (SV *) not_here("pack_sockaddr_un"); #endif @@ -903,7 +1024,7 @@ unpack_sockaddr_un(sun_sv) e = addr.sun_path; while (*e && e < addr.sun_path + sizeof addr.sun_path) ++e; - ST(0) = sv_2mortal(newSVpv(addr.sun_path, e - addr.sun_path)); + ST(0) = sv_2mortal(newSVpvn(addr.sun_path, e - addr.sun_path)); #else ST(0) = (SV *) not_here("unpack_sockaddr_un"); #endif @@ -922,7 +1043,7 @@ pack_sockaddr_in(port,ip_address) sin.sin_port = htons(port); Copy( ip_address, &sin.sin_addr, sizeof sin.sin_addr, char ); - ST(0) = sv_2mortal(newSVpv((char *)&sin, sizeof sin)); + ST(0) = sv_2mortal(newSVpvn((char *)&sin, sizeof sin)); } void @@ -952,7 +1073,7 @@ unpack_sockaddr_in(sin_sv) EXTEND(SP, 2); PUSHs(sv_2mortal(newSViv((IV) port))); - PUSHs(sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address))); + PUSHs(sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address))); } void @@ -961,7 +1082,7 @@ INADDR_ANY() { struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_ANY); - ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address )); + ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address )); } void @@ -970,7 +1091,7 @@ INADDR_LOOPBACK() { struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_LOOPBACK); - ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); + ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)); } void @@ -979,7 +1100,7 @@ INADDR_NONE() { struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_NONE); - ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); + ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)); } void @@ -988,5 +1109,5 @@ INADDR_BROADCAST() { struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_BROADCAST); - ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); + ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)); } |