diff options
author | Andy Dougherty <doughera@lafcol.lafayette.edu> | 1995-10-31 03:33:09 +0000 |
---|---|---|
committer | Andy Dougherty <doughera@lafcol.lafayette.edu> | 1995-10-31 03:33:09 +0000 |
commit | 8e07c86ebc651fe92eb7e3b25f801f57cfb8dd6f (patch) | |
tree | bd67a65038befe4bef8b330a688bf7d915cab92f /ext | |
parent | e50aee73b3d4c555c37e4b4a16694765fb16c887 (diff) | |
download | perl-8e07c86ebc651fe92eb7e3b25f801f57cfb8dd6f.tar.gz |
This is my patch patch.1n for perl5.001.perl-5.001n
To apply, change to your perl directory, run the command above, then
apply with
patch -p1 -N < thispatch.
This is a consolidation patch. It contains many of the most commonly
applied or agreed-to patches that have been circulating since
patch.1m.
It also changes the 'unofficial patchlevel' in perl.c.
There are some problems (see items marked with '***').
I will attempt to address those in a patch.1o in a few days.
This patch contains the following packages:
My Jumbo Configure patch vs. 1m, with subsequent patches 1, 2, and 3.
Mainly, this provides easier use of local libraries, documents
the installation process in a new INSTALL file, moves important
questions towards the beginning, and improves detection of
signal names (mostly for Linux).
xsubpp-1.922.
Patches from Larry:
eval "1" memory leak patch (as modified by GSAR to apply to 5.001m).
NETaa14551 Infinite loop in formats,
NETaa13729 scope.c patch (fixed problems on AIX and others)
NETaa14138 "substr() & s///" (pp_hot.c)
Patches from ftp.perl.com:
ftp://ftp.perl.com/pub/perl/src/patches/closure-bug.patch,
version of 20 Sep 1995
Includes fix for NETaa14347 (32k limit in regex), and other
fixes.
ftp://ftp.perl.com/pub/perl/src/patches/debugger.patch,
version of 27 Aug 1995
ftp://ftp.perl.com/pub/perl/src/patches/glob-undef.patch,
version of 4 Sep 1995
NETaa14421 $_ doesn't undef
ftp://ftp.perl.com/pub/perl/src/patches/op-segfault.patch,
version of 21 Aug 1995
ftp://ftp.perl.com/pub/perl/src/patches/warn-ref-hash-key.patch,
version of 5 Jun 1995
Tim Bunce's Jumbo DynaLoader patch for Perl5.001m, which is
NETaa14636 Jumbo DynaLoader patch for Perl5.001m, and
Additional patch for NETaa14636 Jumbo DynaLoader patch for Perl5.001m
version of 09 Oct 1995.
***This needs some additional parentheses.***
MakeMaker-5.00. Supercedes NETaa13540 (VMS MakeMaker patches).
(Updates minimod.PL as well.)
***This has a couple of minor problems.
pod2man is run even if it isn't available.
LD_RUN_PATH gets set to some mysterious values.***
NETaa14657 Paul Marquess Net::Ping patch. I've included
Net-Ping-1.00.
NETaa14661 Dean Roehrich DProf. Installed as ext/Devel/DProf.
Configure should pick this up automatically. (5 Apr 1995
version.)
NETaa13742 Jack Shirazi Socket in 5.001. I've also included
his socket.t test in t/lib/socket.t.
c2ph-1.7.
Dean's perlapi patches of Oct 12, 1995, which superceded those
of Oct 8, 1995. This is the one that did
mv perlapi.pid perlxs.pod.
NETaa14310 Tim Bunce A trivial patch for configpm (handy for shell scripts)
DB_File-1.0 patch from Paul Marquess (pmarquess@bfsec.bt.co.uk)
last modified 7th October 1995
version 1.0
Added or updated the following hints files:
hints/hpux.sh
hints/ncr_tower.sh
hints/netbsd.sh
hints/ultrix.sh
Patch and enjoy.
Andy Dougherty doughera@lafcol.lafayette.edu
Dept. of Physics
Lafayette College, Easton PA 18042
Diffstat (limited to 'ext')
-rw-r--r-- | ext/DB_File/DB_File.pm | 679 | ||||
-rw-r--r-- | ext/DB_File/DB_File.xs | 170 | ||||
-rw-r--r-- | ext/DB_File/Makefile.PL | 9 | ||||
-rw-r--r-- | ext/DB_File/typemap | 2 | ||||
-rw-r--r-- | ext/Devel/DProf/DProf.pm | 106 | ||||
-rw-r--r-- | ext/Devel/DProf/DProf.xs | 247 | ||||
-rw-r--r-- | ext/Devel/DProf/Makefile.PL | 8 | ||||
-rw-r--r-- | ext/Devel/DProf/README | 3 | ||||
-rw-r--r-- | ext/Devel/DProf/dprofpp | 394 | ||||
-rw-r--r-- | ext/Devel/DProf/test.pl | 20 | ||||
-rw-r--r-- | ext/DynaLoader/DynaLoader.pm | 516 | ||||
-rw-r--r-- | ext/DynaLoader/dl_dld.xs | 47 | ||||
-rw-r--r-- | ext/DynaLoader/dl_dlopen.xs | 13 | ||||
-rw-r--r-- | ext/DynaLoader/dl_hpux.xs | 61 | ||||
-rw-r--r-- | ext/DynaLoader/dl_next.xs | 27 | ||||
-rw-r--r-- | ext/DynaLoader/dl_vms.xs | 9 | ||||
-rw-r--r-- | ext/DynaLoader/dlutils.c | 27 | ||||
-rw-r--r-- | ext/Fcntl/Fcntl.xs | 14 | ||||
-rw-r--r-- | ext/ODBM_File/ODBM_File.xs | 8 | ||||
-rw-r--r-- | ext/POSIX/POSIX.xs | 4 | ||||
-rw-r--r-- | ext/Socket/Socket.pm | 79 | ||||
-rw-r--r-- | ext/Socket/Socket.xs | 134 |
22 files changed, 1829 insertions, 748 deletions
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 5b9fba7765..0491d6bb42 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -1,8 +1,251 @@ # DB_File.pm -- Perl 5 interface to Berkeley DB # # written by Paul Marquess (pmarquess@bfsec.bt.co.uk) -# last modified 19th May 1995 -# version 0.2 +# last modified 7th October 1995 +# version 1.0 + +package DB_File::HASHINFO ; +use Carp; + +sub TIEHASH +{ + bless {} ; +} + +%elements = ( 'bsize' => 0, + 'ffactor' => 0, + 'nelem' => 0, + 'cachesize' => 0, + 'hash' => 0, + 'lorder' => 0 + ) ; + +sub FETCH +{ + return $_[0]{$_[1]} if defined $elements{$_[1]} ; + + croak "DB_File::HASHINFO::FETCH - Unknown element '$_[1]'" ; +} + + +sub STORE +{ + if ( defined $elements{$_[1]} ) + { + $_[0]{$_[1]} = $_[2] ; + return ; + } + + croak "DB_File::HASHINFO::STORE - Unknown element '$_[1]'" ; +} + +sub DELETE +{ + if ( defined $elements{$_[1]} ) + { + delete ${$_[0]}{$_[1]} ; + return ; + } + + croak "DB_File::HASHINFO::DELETE - Unknown element '$_[1]'" ; +} + + +sub DESTROY {undef %{$_[0]} } +sub FIRSTKEY { croak "DB_File::HASHINFO::FIRSTKEY is not implemented" } +sub NEXTKEY { croak "DB_File::HASHINFO::NEXTKEY is not implemented" } +sub EXISTS { croak "DB_File::HASHINFO::EXISTS is not implemented" } +sub CLEAR { croak "DB_File::HASHINFO::CLEAR is not implemented" } + +package DB_File::BTREEINFO ; +use Carp; + +sub TIEHASH +{ + bless {} ; +} + +%elements = ( 'flags' => 0, + 'cachesize' => 0, + 'maxkeypage' => 0, + 'minkeypage' => 0, + 'psize' => 0, + 'compare' => 0, + 'prefix' => 0, + 'lorder' => 0 + ) ; + +sub FETCH +{ + return $_[0]{$_[1]} if defined $elements{$_[1]} ; + + croak "DB_File::BTREEINFO::FETCH - Unknown element '$_[1]'" ; +} + + +sub STORE +{ + if ( defined $elements{$_[1]} ) + { + $_[0]{$_[1]} = $_[2] ; + return ; + } + + croak "DB_File::BTREEINFO::STORE - Unknown element '$_[1]'" ; +} + +sub DELETE +{ + if ( defined $elements{$_[1]} ) + { + delete ${$_[0]}{$_[1]} ; + return ; + } + + croak "DB_File::BTREEINFO::DELETE - Unknown element '$_[1]'" ; +} + + +sub DESTROY {undef %{$_[0]} } +sub FIRSTKEY { croak "DB_File::BTREEINFO::FIRSTKEY is not implemented" } +sub NEXTKEY { croak "DB_File::BTREEINFO::NEXTKEY is not implemented" } +sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" } +sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" } + +package DB_File::RECNOINFO ; +use Carp; + +sub TIEHASH +{ + bless {} ; +} + +%elements = ( 'bval' => 0, + 'cachesize' => 0, + 'psize' => 0, + 'flags' => 0, + 'lorder' => 0, + 'reclen' => 0, + 'bfname' => 0 + ) ; +sub FETCH +{ + return $_[0]{$_[1]} if defined $elements{$_[1]} ; + + croak "DB_File::RECNOINFO::FETCH - Unknown element '$_[1]'" ; +} + + +sub STORE +{ + if ( defined $elements{$_[1]} ) + { + $_[0]{$_[1]} = $_[2] ; + return ; + } + + croak "DB_File::RECNOINFO::STORE - Unknown element '$_[1]'" ; +} + +sub DELETE +{ + if ( defined $elements{$_[1]} ) + { + delete ${$_[0]}{$_[1]} ; + return ; + } + + croak "DB_File::RECNOINFO::DELETE - Unknown element '$_[1]'" ; +} + + +sub DESTROY {undef %{$_[0]} } +sub FIRSTKEY { croak "DB_File::RECNOINFO::FIRSTKEY is not implemented" } +sub NEXTKEY { croak "DB_File::RECNOINFO::NEXTKEY is not implemented" } +sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" } +sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" } + + + +package DB_File ; +use Carp; + +$VERSION = 1.0 ; + +#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; +$DB_BTREE = TIEHASH DB_File::BTREEINFO ; +$DB_HASH = TIEHASH DB_File::HASHINFO ; +$DB_RECNO = TIEHASH DB_File::RECNOINFO ; + +require TieHash; +require Exporter; +use AutoLoader; +require DynaLoader; +@ISA = qw(TieHash Exporter DynaLoader); +@EXPORT = qw( + $DB_BTREE $DB_HASH $DB_RECNO + BTREEMAGIC + BTREEVERSION + DB_LOCK + DB_SHMEM + DB_TXN + HASHMAGIC + HASHVERSION + MAX_PAGE_NUMBER + MAX_PAGE_OFFSET + MAX_REC_NUMBER + RET_ERROR + RET_SPECIAL + RET_SUCCESS + R_CURSOR + R_DUP + R_FIRST + R_FIXEDLEN + R_IAFTER + R_IBEFORE + R_LAST + R_NEXT + R_NOKEY + R_NOOVERWRITE + R_PREV + R_RECNOSYNC + R_SETCURSOR + R_SNAPSHOT + __R_UNUSED +); + +sub AUTOLOAD { + local($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + croak "Your vendor has not defined DB macro $constname, used at $file line $line. +"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +@liblist = (); +@liblist = split ' ', $Config::Config{"DB_File_loadlibs"} + if defined $Config::Config{"DB_File_loadlibs"}; + +bootstrap DB_File @liblist; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +1; +__END__ + +=cut =head1 NAME @@ -28,16 +271,15 @@ DB_File - Perl5 access to Berkeley DB =head1 DESCRIPTION -B<DB_File> is a module which allows Perl programs to make use of -the facilities provided by Berkeley DB. If you intend to use this -module you should really have a copy of the Berkeley DB manual -page at hand. The interface defined here -mirrors the Berkeley DB interface closely. +B<DB_File> is a module which allows Perl programs to make use of the +facilities provided by Berkeley DB. If you intend to use this +module you should really have a copy of the Berkeley DB manualpage at +hand. 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 three of the database types currently -supported by Berkeley DB. +Berkeley DB is a C library which provides a consistent interface to a +number of database formats. B<DB_File> provides an interface to all +three of the database types currently supported by Berkeley DB. The file types are: @@ -45,50 +287,50 @@ The file types are: =item DB_HASH -This database type allows arbitrary key/data pairs to be stored in data files. -This is equivalent to the functionality provided by -other hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. -Remember though, the files created using DB_HASH are -not compatible with any of the other packages mentioned. +This database type allows arbitrary key/data pairs to be stored in data +files. This is equivalent to the functionality provided by other +hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though, +the files created using DB_HASH are not compatible with any of the +other packages mentioned. -A default hashing algorithm, which will be adequate for most applications, -is built into Berkeley DB. -If you do need to use your own hashing algorithm it is possible to write your -own in Perl and have B<DB_File> use it instead. +A default hashing algorithm, which will be adequate for most +applications, is built into Berkeley DB. If you do need to use your own +hashing algorithm it is possible to write your own in Perl and have +B<DB_File> use it instead. =item DB_BTREE -The btree format allows arbitrary key/data pairs to be stored in a sorted, -balanced binary tree. +The btree format allows arbitrary key/data pairs to be stored in a +sorted, balanced binary tree. -As with the DB_HASH format, it is possible to provide a user defined Perl routine -to perform the comparison of keys. By default, though, the keys are stored -in lexical order. +As with the DB_HASH format, it is possible to provide a user defined +Perl routine to perform the comparison of keys. By default, though, the +keys are stored in lexical order. =item DB_RECNO -DB_RECNO allows both fixed-length and variable-length flat text files to be -manipulated using -the same key/value pair interface as in DB_HASH and DB_BTREE. -In this case the key will consist of a record (line) number. +DB_RECNO allows both fixed-length and variable-length flat text files +to be manipulated using the same key/value pair interface as in DB_HASH +and DB_BTREE. In this case the key will consist of a record (line) +number. =back =head2 How does DB_File interface to Berkeley DB? B<DB_File> allows access to Berkeley DB files using the tie() mechanism -in Perl 5 (for full details, see L<perlfunc/tie()>). -This facility allows B<DB_File> to access Berkeley DB files using -either an associative array (for DB_HASH & DB_BTREE file types) or an -ordinary array (for the DB_RECNO file type). +in Perl 5 (for full details, see L<perlfunc/tie()>). This facility +allows B<DB_File> to access Berkeley DB files using either an +associative array (for DB_HASH & DB_BTREE file types) or an ordinary +array (for the DB_RECNO file type). -In addition to the tie() interface, it is also possible to use most of the -functions provided in the Berkeley DB API. +In addition to the tie() interface, it is also possible to use most of +the functions provided in the Berkeley DB API. =head2 Differences with Berkeley DB -Berkeley DB uses the function dbopen() to open or create a -database. Below is the C prototype for dbopen(). +Berkeley DB uses the function dbopen() to open or create a database. +Below is the C prototype for dbopen(). DB* dbopen (const char * file, int flags, int mode, @@ -100,25 +342,24 @@ Depending on which of these is actually chosen, the final parameter, I<openinfo> points to a data structure which allows tailoring of the specific interface method. -This interface is handled -slightly differently in B<DB_File>. Here is an equivalent call using -B<DB_File>. +This interface is handled slightly differently in B<DB_File>. Here is +an equivalent call using B<DB_File>. tie %array, DB_File, $filename, $flags, $mode, $DB_HASH ; -The C<filename>, C<flags> and C<mode> parameters are the direct equivalent -of their dbopen() counterparts. The final parameter $DB_HASH -performs the function of both the C<type> and C<openinfo> -parameters in dbopen(). +The C<filename>, C<flags> and C<mode> parameters are the direct +equivalent of their dbopen() counterparts. The final parameter $DB_HASH +performs the function of both the C<type> and C<openinfo> parameters in +dbopen(). -In the example above $DB_HASH is actually a reference to a hash object. -B<DB_File> has three of these pre-defined references. -Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO. +In the example above $DB_HASH is actually a reference to a hash +object. B<DB_File> has three of these pre-defined references. Apart +from $DB_HASH, there is also $DB_BTREE and $DB_RECNO. -The keys allowed in each of these pre-defined references is limited to the names -used in the equivalent C structure. -So, for example, the $DB_HASH reference will only allow keys called C<bsize>, -C<cachesize>, C<ffactor>, C<hash>, C<lorder> and C<nelem>. +The keys allowed in each of these pre-defined references is limited to +the names used in the equivalent C structure. So, for example, the +$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>, +C<ffactor>, C<hash>, C<lorder> and C<nelem>. To change one of these elements, just assign to it like this @@ -134,33 +375,33 @@ RECNO arrays begins at 0 rather than 1 as in Berkeley DB. =head2 In Memory Databases -Berkeley DB allows the creation of in-memory databases by using NULL (that is, a -C<(char *)0 in C) in -place of the filename. -B<DB_File> uses C<undef> instead of NULL to provide this functionality. +Berkeley DB allows the creation of in-memory databases by using NULL +(that is, a C<(char *)0 in C) in place of the filename. B<DB_File> +uses C<undef> instead of NULL to provide this functionality. =head2 Using the Berkeley DB Interface Directly As well as accessing Berkeley DB using a tied hash or array, it is also -possible to make direct use of most of the functions defined in the Berkeley DB -documentation. +possible to make direct use of most of the functions defined in the +Berkeley DB documentation. To do this you need to remember the return value from the tie. $db = tie %hash, DB_File, "filename" -Once you have done that, you can access the Berkeley DB API functions directly. +Once you have done that, you can access the Berkeley DB API functions +directly. $db->put($key, $value, R_NOOVERWRITE) ; -All the functions defined in L<dbx(3X)> are available except -for close() and dbopen() itself. -The B<DB_File> interface to these functions have been implemented to mirror -the the way Berkeley DB works. In particular note that all the functions return -only a status value. Whenever a Berkeley DB function returns data via one of -its parameters, the B<DB_File> equivalent does exactly the same. +All the functions defined in L<dbx(3X)> are available except for +close() and dbopen() itself. The B<DB_File> interface to these +functions have been implemented to mirror the the way Berkeley DB +works. In particular note that all the functions return only a status +value. Whenever a Berkeley DB function returns data via one of its +parameters, the B<DB_File> equivalent does exactly the same. All the constants defined in L<dbopen> are also available. @@ -170,17 +411,16 @@ Below is a list of the functions available. =item get -Same as in C<recno> except that the flags parameter is optional. -Remember the value -associated with the key you request is returned in the $value parameter. +Same as in C<recno> except that the flags parameter is optional. +Remember the value associated with the key you request is returned in +the $value parameter. =item put As usual the flags parameter is optional. -If you use either the R_IAFTER or -R_IBEFORE flags, the key parameter will have the record number of the inserted -key/value pair set. +If you use either the R_IAFTER or R_IBEFORE flags, the key parameter +will have the record number of the inserted key/value pair set. =item del @@ -204,15 +444,15 @@ The flags parameter is optional. =head1 EXAMPLES -It is always a lot easier to understand something when you see a real example. -So here are a few. +It is always a lot easier to understand something when you see a real +example. So here are a few. =head2 Using HASH use DB_File ; use Fcntl ; - tie %h, DB_File, "hashed", O_RDWR|O_CREAT, 0640, $DB_HASH ; + tie %h, "DB_File", "hashed", O_RDWR|O_CREAT, 0640, $DB_HASH ; # Add a key/value pair to the file $h{"apple"} = "orange" ; @@ -227,9 +467,10 @@ So here are a few. =head2 Using BTREE -Here is sample of code which used BTREE. Just to make life more interesting -the default comparision function will not be used. Instead a Perl sub, C<Compare()>, -will be used to do a case insensitive comparison. +Here is sample of code which used BTREE. Just to make life more +interesting the default comparision function will not be used. Instead +a Perl sub, C<Compare()>, will be used to do a case insensitive +comparison. use DB_File ; use Fcntl ; @@ -243,7 +484,7 @@ will be used to do a case insensitive comparison. $DB_BTREE->{compare} = 'Compare' ; - tie %h, DB_File, "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE ; + tie %h, 'DB_File', "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE ; # Add a key/value pair to the file $h{'Wall'} = 'Larry' ; @@ -301,23 +542,37 @@ process if I<dbopen> returned an error. This allows file protection errors to be caught at run time. Thanks to Judith Grass <grass@cybercash.com> for spotting the bug. +=head2 0.3 + +Added prototype support for multiple btree compare callbacks. + +=head 1.0 + +B<DB_File> has been in use for over a year. To reflect that, the +version number has been incremented to 1.0. + +Added complete support for multiple concurrent callbacks. + +Using the I<push> method on an empty list didn't work properly. This +has been fixed. + =head1 WARNINGS -If you happen find any other functions defined in the source for this module -that have not been mentioned in this document -- beware. -I may drop them at a moments notice. +If you happen find any other functions defined in the source for this +module that have not been mentioned in this document -- beware. I may +drop them at a moments notice. -If you cannot find any, then either you didn't look very hard or the moment has -passed and I have dropped them. +If you cannot find any, then either you didn't look very hard or the +moment has passed and I have dropped them. =head1 BUGS -Some older versions of Berkeley DB had problems with fixed length records -using the RECNO file format. The newest version at the time of writing -was 1.85 - this seems to have fixed the problems with RECNO. +Some older versions of Berkeley DB had problems with fixed length +records using the RECNO file format. The newest version at the time of +writing was 1.85 - this seems to have fixed the problems with RECNO. -I am sure there are bugs in the code. If you do find any, or can suggest any -enhancements, I would welcome your comments. +I am sure there are bugs in the code. If you do find any, or can +suggest any enhancements, I would welcome your comments. =head1 AVAILABILITY @@ -328,252 +583,14 @@ directory C</ucb/4bsd/db.tar.gz>. It is I<not> under the GPL. L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)> -Berkeley DB is available from F<ftp.cs.berkeley.edu> in the directory F</ucb/4bsd>. +Berkeley DB is available from F<ftp.cs.berkeley.edu> in the directory +F</ucb/4bsd>. =head1 AUTHOR -The DB_File interface was written by -Paul Marquess <pmarquess@bfsec.bt.co.uk>. -Questions about the DB system itself may be addressed to -Keith Bostic <bostic@cs.berkeley.edu>. +The DB_File interface was written by Paul Marquess +<pmarquess@bfsec.bt.co.uk>. +Questions about the DB system itself may be addressed to Keith Bostic +<bostic@cs.berkeley.edu>. =cut - -package DB_File::HASHINFO ; -use Carp; - -sub TIEHASH -{ - bless {} ; -} - -%elements = ( 'bsize' => 0, - 'ffactor' => 0, - 'nelem' => 0, - 'cachesize' => 0, - 'hash' => 0, - 'lorder' => 0 - ) ; - -sub FETCH -{ - return $_[0]{$_[1]} if defined $elements{$_[1]} ; - - croak "DB_File::HASHINFO::FETCH - Unknown element '$_[1]'" ; -} - - -sub STORE -{ - if ( defined $elements{$_[1]} ) - { - $_[0]{$_[1]} = $_[2] ; - return ; - } - - croak "DB_File::HASHINFO::STORE - Unknown element '$_[1]'" ; -} - -sub DELETE -{ - if ( defined $elements{$_[1]} ) - { - delete ${$_[0]}{$_[1]} ; - return ; - } - - croak "DB_File::HASHINFO::DELETE - Unknown element '$_[1]'" ; -} - - -sub DESTROY {undef %{$_[0]} } -sub FIRSTKEY { croak "DB_File::HASHINFO::FIRSTKEY is not implemented" } -sub NEXTKEY { croak "DB_File::HASHINFO::NEXTKEY is not implemented" } -sub EXISTS { croak "DB_File::HASHINFO::EXISTS is not implemented" } -sub CLEAR { croak "DB_File::HASHINFO::CLEAR is not implemented" } - -package DB_File::BTREEINFO ; -use Carp; - -sub TIEHASH -{ - bless {} ; -} - -%elements = ( 'flags' => 0, - 'cachesize' => 0, - 'maxkeypage' => 0, - 'minkeypage' => 0, - 'psize' => 0, - 'compare' => 0, - 'prefix' => 0, - 'lorder' => 0 - ) ; - -sub FETCH -{ - return $_[0]{$_[1]} if defined $elements{$_[1]} ; - - croak "DB_File::BTREEINFO::FETCH - Unknown element '$_[1]'" ; -} - - -sub STORE -{ - if ( defined $elements{$_[1]} ) - { - $_[0]{$_[1]} = $_[2] ; - return ; - } - - croak "DB_File::BTREEINFO::STORE - Unknown element '$_[1]'" ; -} - -sub DELETE -{ - if ( defined $elements{$_[1]} ) - { - delete ${$_[0]}{$_[1]} ; - return ; - } - - croak "DB_File::BTREEINFO::DELETE - Unknown element '$_[1]'" ; -} - - -sub DESTROY {undef %{$_[0]} } -sub FIRSTKEY { croak "DB_File::BTREEINFO::FIRSTKEY is not implemented" } -sub NEXTKEY { croak "DB_File::BTREEINFO::NEXTKEY is not implemented" } -sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" } -sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" } - -package DB_File::RECNOINFO ; -use Carp; - -sub TIEHASH -{ - bless {} ; -} - -%elements = ( 'bval' => 0, - 'cachesize' => 0, - 'psize' => 0, - 'flags' => 0, - 'lorder' => 0, - 'reclen' => 0, - 'bfname' => 0 - ) ; -sub FETCH -{ - return $_[0]{$_[1]} if defined $elements{$_[1]} ; - - croak "DB_File::RECNOINFO::FETCH - Unknown element '$_[1]'" ; -} - - -sub STORE -{ - if ( defined $elements{$_[1]} ) - { - $_[0]{$_[1]} = $_[2] ; - return ; - } - - croak "DB_File::RECNOINFO::STORE - Unknown element '$_[1]'" ; -} - -sub DELETE -{ - if ( defined $elements{$_[1]} ) - { - delete ${$_[0]}{$_[1]} ; - return ; - } - - croak "DB_File::RECNOINFO::DELETE - Unknown element '$_[1]'" ; -} - - -sub DESTROY {undef %{$_[0]} } -sub FIRSTKEY { croak "DB_File::RECNOINFO::FIRSTKEY is not implemented" } -sub NEXTKEY { croak "DB_File::RECNOINFO::NEXTKEY is not implemented" } -sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" } -sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" } - - - -package DB_File ; -use Carp; - -#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE; -$DB_BTREE = TIEHASH DB_File::BTREEINFO ; -$DB_HASH = TIEHASH DB_File::HASHINFO ; -$DB_RECNO = TIEHASH DB_File::RECNOINFO ; - -require TieHash; -require Exporter; -use AutoLoader; -require DynaLoader; -@ISA = qw(TieHash Exporter DynaLoader); -@EXPORT = qw( - $DB_BTREE $DB_HASH $DB_RECNO - BTREEMAGIC - BTREEVERSION - DB_LOCK - DB_SHMEM - DB_TXN - HASHMAGIC - HASHVERSION - MAX_PAGE_NUMBER - MAX_PAGE_OFFSET - MAX_REC_NUMBER - RET_ERROR - RET_SPECIAL - RET_SUCCESS - R_CURSOR - R_DUP - R_FIRST - R_FIXEDLEN - R_IAFTER - R_IBEFORE - R_LAST - R_NEXT - R_NOKEY - R_NOOVERWRITE - R_PREV - R_RECNOSYNC - R_SETCURSOR - R_SNAPSHOT - __R_UNUSED -); - -sub AUTOLOAD { - local($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - $val = constant($constname, @_ ? $_[0] : 0); - if ($! != 0) { - if ($! =~ /Invalid/) { - $AutoLoader::AUTOLOAD = $AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - ($pack,$file,$line) = caller; - croak "Your vendor has not defined DB macro $constname, used at $file line $line. -"; - } - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -@liblist = (); -@liblist = split ' ', $Config::Config{"DB_File_loadlibs"} - if defined $Config::Config{"DB_File_loadlibs"}; - -bootstrap DB_File @liblist; - -# Preloaded methods go here. Autoload methods go after __END__, and are -# processed by the autosplit program. - -1; -__END__ diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs index 0541668e24..8abb230da1 100644 --- a/ext/DB_File/DB_File.xs +++ b/ext/DB_File/DB_File.xs @@ -3,14 +3,17 @@ DB_File.xs -- Perl 5 interface to Berkeley DB written by Paul Marquess (pmarquess@bfsec.bt.co.uk) - last modified 19th May 1995 - version 0.2 + last modified 7th October 1995 + version 1.0 All comments/suggestions/problems are welcome Changes: 0.1 - Initial Release 0.2 - No longer bombs out if dbopen returns an error. + 0.3 - Added some support for multiple btree compares + 1.0 - Complete support for multiple callbacks added. + Fixed a problem with pushing a value onto an empty list. */ #include "EXTERN.h" @@ -21,7 +24,15 @@ #include <fcntl.h> -typedef DB * DB_File; +typedef struct { + DBTYPE type ; + DB * dbp ; + SV * compare ; + SV * prefix ; + SV * hash ; + } DB_File_type; + +typedef DB_File_type * DB_File ; typedef DBT DBTKEY ; union INFO { @@ -30,25 +41,21 @@ union INFO { BTREEINFO btree ; } ; -typedef struct { - SV * sub ; - } CallBackInfo ; - /* #define TRACE */ -#define db_DESTROY(db) (db->close)(db) -#define db_DELETE(db, key, flags) (db->del)(db, &key, flags) -#define db_STORE(db, key, value, flags) (db->put)(db, &key, &value, flags) -#define db_FETCH(db, key, flags) (db->get)(db, &key, &value, flags) +#define db_DESTROY(db) (db->dbp->close)(db->dbp) +#define db_DELETE(db, key, flags) (db->dbp->del)(db->dbp, &key, flags) +#define db_STORE(db, key, value, flags) (db->dbp->put)(db->dbp, &key, &value, flags) +#define db_FETCH(db, key, flags) (db->dbp->get)(db->dbp, &key, &value, flags) -#define db_close(db) (db->close)(db) -#define db_del(db, key, flags) (db->del)(db, &key, flags) -#define db_fd(db) (db->fd)(db) -#define db_put(db, key, value, flags) (db->put)(db, &key, &value, flags) -#define db_get(db, key, value, flags) (db->get)(db, &key, &value, flags) -#define db_seq(db, key, value, flags) (db->seq)(db, &key, &value, flags) -#define db_sync(db, flags) (db->sync)(db, flags) +#define db_close(db) (db->dbp->close)(db->dbp) +#define db_del(db, key, flags) (db->dbp->del)(db->dbp, &key, flags) +#define db_fd(db) (db->dbp->fd)(db->dbp) +#define db_put(db, key, value, flags) (db->dbp->put)(db->dbp, &key, &value, flags) +#define db_get(db, key, value, flags) (db->dbp->get)(db->dbp, &key, &value, flags) +#define db_seq(db, key, value, flags) (db->dbp->seq)(db->dbp, &key, &value, flags) +#define db_sync(db, flags) (db->dbp->sync)(db->dbp, flags) #define OutputValue(arg, name) \ @@ -57,7 +64,7 @@ typedef struct { #define OutputKey(arg, name) \ { if (RETVAL == 0) \ { \ - if (db->close != DB_recno_close) \ + if (db->type != DB_RECNO) \ sv_setpvn(arg, name.data, name.size); \ else \ sv_setiv(arg, (I32)*(I32*)name.data - 1); \ @@ -65,13 +72,10 @@ typedef struct { } /* Internal Global Data */ - -static recno_t Value ; -static int (*DB_recno_close)() = NULL ; - -static CallBackInfo hash_callback = { 0 } ; -static CallBackInfo compare_callback = { 0 } ; -static CallBackInfo prefix_callback = { 0 } ; +static recno_t Value ; +static DB_File CurrentDB ; +static recno_t zero = 0 ; +static DBTKEY empty = { &zero, sizeof(recno_t) } ; static int @@ -105,7 +109,7 @@ const DBT * key2 ; PUSHs(sv_2mortal(newSVpv(data2,key2->size))); PUTBACK ; - count = perl_call_sv(compare_callback.sub, G_SCALAR); + count = perl_call_sv(CurrentDB->compare, G_SCALAR); SPAGAIN ; @@ -152,7 +156,7 @@ const DBT * key2 ; PUSHs(sv_2mortal(newSVpv(data2,key2->size))); PUTBACK ; - count = perl_call_sv(prefix_callback.sub, G_SCALAR); + count = perl_call_sv(CurrentDB->prefix, G_SCALAR); SPAGAIN ; @@ -184,7 +188,7 @@ size_t size ; XPUSHs(sv_2mortal(newSVpv((char*)data,size))); PUTBACK ; - count = perl_call_sv(hash_callback.sub, G_SCALAR); + count = perl_call_sv(CurrentDB->hash, G_SCALAR); SPAGAIN ; @@ -256,7 +260,7 @@ BTREEINFO btree ; static I32 GetArrayLength(db) -DB_File db ; +DB * db ; { DBT key ; DBT value ; @@ -282,10 +286,12 @@ char * string ; SV ** svp; HV * action ; union INFO info ; - DB_File RETVAL ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; void * openinfo = NULL ; - DBTYPE type = DB_HASH ; + /* DBTYPE type = DB_HASH ; */ + RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; + RETVAL->type = DB_HASH ; if (sv) { @@ -295,7 +301,7 @@ char * string ; action = (HV*)SvRV(sv); if (sv_isa(sv, "DB_File::HASHINFO")) { - type = DB_HASH ; + RETVAL->type = DB_HASH ; openinfo = (void*)&info ; svp = hv_fetch(action, "hash", 4, FALSE); @@ -303,7 +309,7 @@ char * string ; if (svp && SvOK(*svp)) { info.hash.hash = hash_cb ; - hash_callback.sub = *svp ; + RETVAL->hash = newSVsv(*svp) ; } else info.hash.hash = NULL ; @@ -327,14 +333,14 @@ char * string ; } else if (sv_isa(sv, "DB_File::BTREEINFO")) { - type = DB_BTREE ; + RETVAL->type = DB_BTREE ; openinfo = (void*)&info ; svp = hv_fetch(action, "compare", 7, FALSE); if (svp && SvOK(*svp)) { info.btree.compare = btree_compare ; - compare_callback.sub = *svp ; + RETVAL->compare = newSVsv(*svp) ; } else info.btree.compare = NULL ; @@ -343,7 +349,7 @@ char * string ; if (svp && SvOK(*svp)) { info.btree.prefix = btree_prefix ; - prefix_callback.sub = *svp ; + RETVAL->prefix = newSVsv(*svp) ; } else info.btree.prefix = NULL ; @@ -371,7 +377,7 @@ char * string ; } else if (sv_isa(sv, "DB_File::RECNOINFO")) { - type = DB_RECNO ; + RETVAL->type = DB_RECNO ; openinfo = (void *)&info ; svp = hv_fetch(action, "flags", 5, FALSE); @@ -415,14 +421,16 @@ char * string ; } - RETVAL = dbopen(name, flags, mode, type, openinfo) ; + RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; +#if 0 /* kludge mode on: RETVAL->type for DB_RECNO is set to DB_BTREE so remember a DB_RECNO by saving the address of one of it's internal routines */ - if (RETVAL && type == DB_RECNO) - DB_recno_close = RETVAL->close ; + if (RETVAL->dbp && type == DB_RECNO) + DB_recno_close = RETVAL->dbp->close ; +#endif return (RETVAL) ; @@ -710,6 +718,16 @@ BOOT: int db_DESTROY(db) DB_File db + INIT: + CurrentDB = db ; + CLEANUP: + if (db->hash) + SvREFCNT_dec(db->hash) ; + if (db->compare) + SvREFCNT_dec(db->compare) ; + if (db->prefix) + SvREFCNT_dec(db->prefix) ; + Safefree(db) ; int @@ -717,6 +735,8 @@ db_DELETE(db, key, flags=0) DB_File db DBTKEY key u_int flags + INIT: + CurrentDB = db ; int db_FETCH(db, key, flags=0) @@ -727,7 +747,8 @@ db_FETCH(db, key, flags=0) { DBT value ; - RETVAL = (db->get)(db, &key, &value, flags) ; + CurrentDB = db ; + RETVAL = (db->dbp->get)(db->dbp, &key, &value, flags) ; ST(0) = sv_newmortal(); if (RETVAL == 0) sv_setpvn(ST(0), value.data, value.size); @@ -739,6 +760,8 @@ db_STORE(db, key, value, flags=0) DBTKEY key DBT value u_int flags + INIT: + CurrentDB = db ; int @@ -749,11 +772,12 @@ db_FIRSTKEY(db) DBTKEY key ; DBT value ; - RETVAL = (db->seq)(db, &key, &value, R_FIRST) ; + CurrentDB = db ; + RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_FIRST) ; ST(0) = sv_newmortal(); if (RETVAL == 0) { - if (db->type != DB_RECNO) + if (db->dbp->type != DB_RECNO) sv_setpvn(ST(0), key.data, key.size); else sv_setiv(ST(0), (I32)*(I32*)key.data - 1); @@ -768,11 +792,12 @@ db_NEXTKEY(db, key) { DBT value ; - RETVAL = (db->seq)(db, &key, &value, R_NEXT) ; + CurrentDB = db ; + RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_NEXT) ; ST(0) = sv_newmortal(); if (RETVAL == 0) { - if (db->type != DB_RECNO) + if (db->dbp->type != DB_RECNO) sv_setpvn(ST(0), key.data, key.size); else sv_setiv(ST(0), (I32)*(I32*)key.data - 1); @@ -793,6 +818,7 @@ unshift(db, ...) int i ; int One ; + CurrentDB = db ; RETVAL = -1 ; for (i = items-1 ; i > 0 ; --i) { @@ -801,7 +827,7 @@ unshift(db, ...) One = 1 ; key.data = &One ; key.size = sizeof(int) ; - RETVAL = (db->put)(db, &key, &value, R_IBEFORE) ; + RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ; if (RETVAL != 0) break; } @@ -817,13 +843,14 @@ pop(db) DBTKEY key ; DBT value ; + CurrentDB = db ; /* First get the final value */ - RETVAL = (db->seq)(db, &key, &value, R_LAST) ; + RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_LAST) ; ST(0) = sv_newmortal(); /* Now delete it */ if (RETVAL == 0) { - RETVAL = (db->del)(db, &key, R_CURSOR) ; + RETVAL = (db->dbp->del)(db->dbp, &key, R_CURSOR) ; if (RETVAL == 0) sv_setpvn(ST(0), value.data, value.size); } @@ -837,13 +864,14 @@ shift(db) DBTKEY key ; DBT value ; + CurrentDB = db ; /* get the first value */ - RETVAL = (db->seq)(db, &key, &value, R_FIRST) ; + RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_FIRST) ; ST(0) = sv_newmortal(); /* Now delete it */ if (RETVAL == 0) { - RETVAL = (db->del)(db, &key, R_CURSOR) ; + RETVAL = (db->dbp->del)(db->dbp, &key, R_CURSOR) ; if (RETVAL == 0) sv_setpvn(ST(0), value.data, value.size); } @@ -856,22 +884,25 @@ push(db, ...) CODE: { DBTKEY key ; + DBTKEY * keyptr = &key ; DBT value ; int i ; + CurrentDB = db ; /* Set the Cursor to the Last element */ - RETVAL = (db->seq)(db, &key, &value, R_LAST) ; - if (RETVAL == 0) + RETVAL = (db->dbp->seq)(db->dbp, &key, &value, R_LAST) ; + if (RETVAL >= 0) { - /* for (i = 1 ; i < items ; ++i) */ - for (i = items - 1 ; i > 0 ; --i) - { - value.data = SvPV(ST(i), na) ; - value.size = na ; - RETVAL = (db->put)(db, &key, &value, R_IAFTER) ; - if (RETVAL != 0) - break; - } + if (RETVAL == 1) + keyptr = &empty ; + for (i = items - 1 ; i > 0 ; --i) + { + value.data = SvPV(ST(i), na) ; + value.size = na ; + RETVAL = (db->dbp->put)(db->dbp, keyptr, &value, R_IAFTER) ; + if (RETVAL != 0) + break; + } } } OUTPUT: @@ -882,7 +913,8 @@ I32 length(db) DB_File db CODE: - RETVAL = GetArrayLength(db) ; + CurrentDB = db ; + RETVAL = GetArrayLength(db->dbp) ; OUTPUT: RETVAL @@ -896,6 +928,8 @@ db_del(db, key, flags=0) DB_File db DBTKEY key u_int flags + INIT: + CurrentDB = db ; int @@ -904,6 +938,8 @@ db_get(db, key, value, flags=0) DBTKEY key DBT value u_int flags + INIT: + CurrentDB = db ; OUTPUT: value @@ -913,17 +949,23 @@ db_put(db, key, value, flags=0) DBTKEY key DBT value u_int flags + INIT: + CurrentDB = db ; OUTPUT: key if (flags & (R_IAFTER|R_IBEFORE)) OutputKey(ST(1), key); int db_fd(db) DB_File db + INIT: + CurrentDB = db ; int db_sync(db, flags=0) DB_File db u_int flags + INIT: + CurrentDB = db ; int @@ -932,6 +974,8 @@ db_seq(db, key, value, flags) DBTKEY key DBT value u_int flags + INIT: + CurrentDB = db ; OUTPUT: key value diff --git a/ext/DB_File/Makefile.PL b/ext/DB_File/Makefile.PL index c300d8569f..3ad8015d95 100644 --- a/ext/DB_File/Makefile.PL +++ b/ext/DB_File/Makefile.PL @@ -1,2 +1,9 @@ use ExtUtils::MakeMaker; -WriteMakefile(LIBS => ["-L/usr/local/lib -ldb"]); + +WriteMakefile( + NAME => 'DB_File', + LIBS => ["-L/usr/local/lib -ldb"], + #INC => '-I/usr/local/include', + VERSION => 1.0, + ); + diff --git a/ext/DB_File/typemap b/ext/DB_File/typemap index 242fa041d2..4acc65e078 100644 --- a/ext/DB_File/typemap +++ b/ext/DB_File/typemap @@ -15,7 +15,7 @@ DBTKEY T_dbtkeydatum INPUT T_dbtkeydatum - if (db->close != DB_recno_close) + if (db->type != DB_RECNO) { $var.data = SvPV($arg, na); $var.size = (int)na; diff --git a/ext/Devel/DProf/DProf.pm b/ext/Devel/DProf/DProf.pm new file mode 100644 index 0000000000..8ec82d04f2 --- /dev/null +++ b/ext/Devel/DProf/DProf.pm @@ -0,0 +1,106 @@ +# Devel::DProf - a Perl code profiler +# 5apr95 +# Dean Roehrich +# +# changes/bugs fixed since 01mar95 version: +# - record $pwd and build pathname for tmon.out +# (so the profile doesn't get lost if the process chdir's) +# changes/bugs fixed since 03feb95 version: +# - fixed some doc bugs +# - added require 5.000 +# - added -w note to bugs section of pod +# changes/bugs fixed since 31dec94 version: +# - podified +# + +require 5.000; + +=head1 NAME + +Devel::DProf - a Perl code profiler + +=head1 SYNOPSIS + + PERL5DB="use Devel::DProf;" + export PERL5DB + + perl5 -d test.pl + +=head1 DESCRIPTION + +The Devel::DProf package is a Perl code profiler. This will collect +information on the execution time of a Perl script and of the subs in that +script. This information can be used to determine which subroutines are +using the most time and which subroutines are being called most often. This +information can also be used to create an execution graph of the script, +showing subroutine relationships. + +To use this package the PERL5DB environment variable must be set to the +following value: + + PERL5DB="use Devel::DProf;" + export PERL5DB + +To profile a Perl script run the perl interpreter with the B<-d> debugging +switch. The profiler uses the debugging hooks. So to profile script +"test.pl" the following command should be used: + + perl5 -d test.pl + +When the script terminates the profiler will dump the profile information +to a file called I<tmon.out>. The supplied I<dprofpp> tool can be used to +interpret the information which is in that profile. The following command +will print the top 15 subroutines which used the most time: + + dprofpp + +To print an execution graph of the subroutines in the script use the +following command: + + dprofpp -T + +Consult the "dprofpp" manpage for other options. + +=head1 BUGS + +If perl5 is invoked with the B<-w> (warnings) flag then Devel::DProf will +cause a large quantity of warnings to be printed. + +=head1 SEE ALSO + +L<perl>, L<dprofpp>, times(2) + +=cut + +package DB; + +# So Devel::DProf knows where to drop tmon.out. +chop($pwd = `pwd`); +$tmon = "$pwd/tmon.out"; + +# This sub is replaced by an XS version after the profiler is bootstrapped. +sub sub { +# print "nonXS DBsub($sub)\n"; + $single = 0; # disable DB single-stepping + if( wantarray ){ + @a = &$sub; + @a; + } + else{ + $a = &$sub; + $a; + } +} + +# This sub is needed during startup. +sub DB { +# print "nonXS DBDB\n"; +} + + +require DynaLoader; +@Devel::DProf::ISA = qw(DynaLoader); + +bootstrap Devel::DProf; + +1; diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs new file mode 100644 index 0000000000..8670481a35 --- /dev/null +++ b/ext/Devel/DProf/DProf.xs @@ -0,0 +1,247 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* +# Devel::DProf - a Perl code profiler +# 5apr95 +# Dean Roehrich +# +# changes/bugs fixed since 2apr95 version: +# -now mallocing an extra byte for the \0 :) +# changes/bugs fixed since 01mar95 version: +# -stringified code ref is used for name of anonymous sub. +# -include stash name with stringified code ref. +# -use perl.c's DBsingle and DBsub. +# -now using croak() and warn(). +# -print "timer is on" before turning timer on. +# -use safefree() instead of free(). +# -rely on PM to provide full path name to tmon.out. +# -print errno if unable to write tmon.out. +# changes/bugs fixed since 03feb95 version: +# -comments +# changes/bugs fixed since 31dec94 version: +# -added patches from Andy. +# +*/ + +/*#define DBG_SUB 1 /* */ +/*#define DBG_TIMER 1 /* */ + +#ifdef DBG_SUB +# define DBG_SUB_NOTIFY(A,B) warn( A, B ) +#else +# define DBG_SUB_NOTIFY(A,B) /* nothing */ +#endif + +#ifdef DBG_TIMER +# define DBG_TIMER_NOTIFY(A) warn( A ) +#else +# define DBG_TIMER_NOTIFY(A) /* nothing */ +#endif + +/* HZ == clock ticks per second */ +#ifndef HZ +#define HZ 60 +#endif + +static SV * Sub; /* pointer to $DB::sub */ +static char *Tmon; /* name of tmon.out */ + +/* Everything is built on times(2). See its manpage for a description + * of the timings. + */ + +static +struct tms prof_start, + prof_end; + +static +clock_t rprof_start, /* elapsed real time, in ticks */ + rprof_end; + +union prof_any { + clock_t tms_utime; /* cpu time spent in user space */ + clock_t tms_stime; /* cpu time spent in system */ + clock_t realtime; /* elapsed real time, in ticks */ + char *name; + opcode ptype; +}; + +typedef union prof_any PROFANY; + +static PROFANY *profstack; +static int profstack_max = 128; +static int profstack_ix = 0; + + +static void +prof_mark( ptype ) +opcode ptype; +{ + struct tms t; + clock_t realtime; + char *name, *pv; + char *hvname; + STRLEN len; + SV *sv; + + if( profstack_ix + 5 > profstack_max ){ + profstack_max = profstack_max * 3 / 2; + Renew( profstack, profstack_max, PROFANY ); + } + + realtime = times(&t); + pv = SvPV( Sub, len ); + + if( SvROK(Sub) ){ + /* Attempt to make CODE refs identifiable by + * including their package name. + */ + sv = (SV*)SvRV(Sub); + if( sv && SvTYPE(sv) == SVt_PVCV ){ + hvname = HvNAME(CvSTASH(sv)); + len += strlen( hvname ) + 2; /* +2 for more ::'s */ + + } + else { + croak( "DProf prof_mark() lost on supposed CODE ref %s.\n", pv ); + } + name = (char *)safemalloc( len * sizeof(char) + 1 ); + strcpy( name, hvname ); + strcat( name, "::" ); + strcat( name, pv ); + } + else{ + name = (char *)safemalloc( len * sizeof(char) + 1 ); + strcpy( name, pv ); + } + + profstack[profstack_ix++].ptype = ptype; + profstack[profstack_ix++].tms_utime = t.tms_utime; + profstack[profstack_ix++].tms_stime = t.tms_stime; + profstack[profstack_ix++].realtime = realtime; + profstack[profstack_ix++].name = name; +} + +static void +prof_record(){ + FILE *fp; + char *name; + int base = 0; + opcode ptype; + clock_t tms_utime; + clock_t tms_stime; + clock_t realtime; + + if( (fp = fopen( Tmon, "w" )) == NULL ){ + warn("DProf: unable to write %s, errno = %d\n", Tmon, errno ); + return; + } + + fprintf(fp, "#fOrTyTwO\n" ); + fprintf(fp, "$hz=%d;\n", HZ ); + fprintf(fp, "# All values are given in HZ\n" ); + fprintf(fp, "$rrun_utime=%ld; $rrun_stime=%ld; $rrun_rtime=%ld\n", + prof_end.tms_utime - prof_start.tms_utime, + prof_end.tms_stime - prof_start.tms_stime, + rprof_end - rprof_start ); + fprintf(fp, "PART2\n" ); + + while( base < profstack_ix ){ + ptype = profstack[base++].ptype; + tms_utime = profstack[base++].tms_utime; + tms_stime = profstack[base++].tms_stime; + realtime = profstack[base++].realtime; + name = profstack[base++].name; + + switch( ptype ){ + case OP_LEAVESUB: + fprintf(fp,"- %ld %ld %ld %s\n", + tms_utime, tms_stime, realtime, name ); + break; + case OP_ENTERSUB: + fprintf(fp,"+ %ld %ld %ld %s\n", + tms_utime, tms_stime, realtime, name ); + break; + default: + fprintf(fp,"Profiler unknown prof code %d\n", ptype); + } + } + fclose( fp ); +} + +#define for_real +#ifdef for_real + +XS(XS_DB_sub) +{ + dXSARGS; + dORIGMARK; + SP -= items; + + DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) ); + + sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ + + prof_mark( OP_ENTERSUB ); + PUSHMARK( ORIGMARK ); + + perl_call_sv( Sub, GIMME ); + + prof_mark( OP_LEAVESUB ); + SPAGAIN; + PUTBACK; + return; +} + +#endif /* for_real */ + +#ifdef testing + + MODULE = Devel::DProf PACKAGE = DB + + void + sub(...) + PPCODE: + + dORIGMARK; + /* SP -= items; added by xsubpp */ + DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) ); + + sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ + + prof_mark( OP_ENTERSUB ); + PUSHMARK( ORIGMARK ); + + perl_call_sv( Sub, GIMME ); + + prof_mark( OP_LEAVESUB ); + SPAGAIN; + /* PUTBACK; added by xsubpp */ + +#endif /* testing */ + + +MODULE = Devel::DProf PACKAGE = Devel::DProf + +void +END() + PPCODE: + rprof_end = times(&prof_end); + DBG_TIMER_NOTIFY("Profiler timer is off.\n"); + prof_record(); + +BOOT: + newXS("DB::sub", XS_DB_sub, file); + Sub = GvSV(DBsub); /* name of current sub */ + sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ + { /* obtain name of tmon.out file */ + SV *sv; + sv = perl_get_sv( "DB::tmon", FALSE ); + Tmon = (char *)safemalloc( SvCUR(sv) * sizeof(char) ); + strcpy( Tmon, SvPVX(sv) ); + } + New( 0, profstack, profstack_max, PROFANY ); + DBG_TIMER_NOTIFY("Profiler timer is on.\n"); + rprof_start = times(&prof_start); diff --git a/ext/Devel/DProf/Makefile.PL b/ext/Devel/DProf/Makefile.PL new file mode 100644 index 0000000000..a1d7b0774d --- /dev/null +++ b/ext/Devel/DProf/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + 'NAME' => 'Devel::DProf', + 'VERSION' => 'Apr5,1995', + 'clean' => {'FILES' => "tmon.out"}, + 'EXE_FILES' => ['dprofpp'], + +); diff --git a/ext/Devel/DProf/README b/ext/Devel/DProf/README new file mode 100644 index 0000000000..970e26b46e --- /dev/null +++ b/ext/Devel/DProf/README @@ -0,0 +1,3 @@ +Please consult the pod in DProf.pm. + +Dean Roehrich diff --git a/ext/Devel/DProf/dprofpp b/ext/Devel/DProf/dprofpp new file mode 100644 index 0000000000..6b6c0e70f2 --- /dev/null +++ b/ext/Devel/DProf/dprofpp @@ -0,0 +1,394 @@ +#!/usr/local/bin/perl + +require 5.000; + + +# dprofpp - display perl profile data +# 5apr95 +# Dean Roehrich +# +# changes/bugs fixed since 10feb95 version: +# - summary info is printed by default, opt_c is gone. +# - fixed some doc bugs +# - changed name to dprofpp +# changes/bugs fixed since 03feb95 version: +# - fixed division by zero. +# - replace many local()s with my(). +# - now prints user+system times by default +# now -u prints user time, -U prints unsorted. +# - fixed documentation +# - fixed output, to clarify that times are given in seconds. +# - can now fake exit timestamps if the profile is garbled. +# changes/bugs fixed since 17jun94 version: +# - podified. +# - correct old documentation flaws. +# - added Andy's patches. +# + + +=head1 NAME + +dprofpp - display perl profile data + +=head1 SYNOPSIS + +dprofpp [B<-a|-t|-l|-v|-U|-T>] [B<-s|-r|-u>] [B<-q>] [B<-F>] [B<-O cnt>] [profile] + +=head1 DESCRIPTION + +The I<dprofpp> command interprets a profile file produced by the Devel::DProf +profiler. By default dprofpp will read the file I<tmon.out> and will display +the 15 subroutines which are using the most time. + +=head1 OPTIONS + +=over 5 + +=item B<-a> + +Sort alphabetically by subroutine names. + +=item B<-t> + +(default) Sort by amount of user+system time used. The first few lines +should show you which subroutines are using the most time. + +=item B<-l> + +Sort by number of calls to the subroutines. This may help identify +candidates for inlining. + +=item B<-v> + +Sort by average time spent in subroutines during each call. This may help +identify candidates for inlining. + +=item B<-U> + +Do not sort. Display in the order found in the raw profile. + +=item B<-F> + +Force the generation of fake exit timestamps if dprofpp reports that the +profile is garbled. This is only useful if dprofpp determines that the +profile is garbled due to missing exit timestamps. You're on your own if +you do this. Consult the BUGS section. + +=item B<-T> + +Display subroutine call tree to stdout. Subroutine statistics are +not displayed. + +=item B<-q> + +Do not display column headers. Does nothing if B<-T> is used. + +=item B<-O cnt> + +Show only I<cnt> subroutines. The default is 15. Does nothing if B<-T> +is used. + +=item B<-r> + +Display elapsed real times rather than user+system times. + +=item B<-s> + +Display system times rather than user+system times. + +=item B<-u> + +Display user times rather than user+system times. + +=back + +=head1 BUGS + +Applications which call I<die> from within an eval for exception handling +(catch/throw) or for setjmp/longjmp may not generate a readable profile. + +Applications which call I<exit> from within a subroutine will leave an +incomplete profile. + +=head1 FILES + + dprofpp - profile processor + tmon.out - raw profile + +=head1 SEE ALSO + +L<perl>, L<Devel::DProf>, times(2) + +=cut + +use Getopt::Std 'getopts'; + +Setup: { + getopts('O:ltavuTqrsUF'); + +# -O cnt Specifies maximum number of subroutines to display. +# -a Sort by alphabetic name of subroutines. +# -t Sort by user+system time spent in subroutines. (default) +# -l Sort by number of calls to subroutines. +# -v Sort by average amount of time spent in subroutines. +# -T Show call tree. +# -q Do not print column headers. +# -u Use user time rather than user+system time. +# -s Use system time rather than user+system time. +# -r Use real elapsed time rather than user+system time. +# -U Do not sort subroutines. + + $cnt = $opt_O || 15; + $sort = 'by_time'; + $sort = 'by_calls' if defined $opt_l; + $sort = 'by_alpha' if defined $opt_a; + $sort = 'by_avgcpu' if defined $opt_v; + $whichtime = "User+System"; + $whichtime = "System" if defined $opt_s; + $whichtime = "Real" if defined $opt_r; + $whichtime = "User" if defined $opt_u; +} + +Main: { + my $monout = shift || "tmon.out"; + my $fh = "main::fh"; + local $names = {}; + local $times = {}; # times in hz + local $calls = {}; + local $persecs = {}; # times in seconds + local $idkeys = []; + local $runtime; # runtime in seconds + my @a = (); + my $a; + local $rrun_utime = 0; # user time in hz + local $rrun_stime = 0; # system time in hz + local $rrun_rtime = 0; # elapsed run time in hz + local $rrun_ustime = 0; # user+system time in hz + local $hz = 0; + + open( $fh, "<$monout" ) || die "Unable to open $monout\n"; + + header($fh); + + $rrun_ustime = $rrun_utime + $rrun_stime; + + settime( \$runtime, $hz ); + + $~ = 'STAT'; + if( ! $opt_q ){ + $^ = 'CSTAT_top'; + } + + parsestack( $fh, $names, $calls, $times, $idkeys ); + + exit(0) if $opt_T; + + if( $opt_v ){ + percalc( $calls, $times, $persecs, $idkeys ); + } + if( ! $opt_U ){ + @a = sort $sort @$idkeys; + $a = \@a; + } + else { + $a = $idkeys; + } + display( $runtime, $hz, $names, $calls, $times, $cnt, $a ); +} + + +# Sets $runtime to user, system, real, or user+system time. The +# result is given in seconds. +# +sub settime { + my( $runtime, $hz ) = @_; + + if( $opt_r ){ + $$runtime = $rrun_rtime/$hz; + } + elsif( $opt_s ){ + $$runtime = $rrun_stime/$hz; + } + elsif( $opt_u ){ + $$runtime = $rrun_utime/$hz; + } + else{ + $$runtime = $rrun_ustime/$hz; + } +} + + +# Report the times in seconds. +sub display { + my( $runtime, $hz, $names, $calls , $times, $cnt, $idkeys ) = @_; + my( $x, $key, $s ); + #format: $ncalls, $name, $secs, $percall, $pcnt + + for( $x = 0; $x < @$idkeys; ++$x ){ + $key = $idkeys->[$x]; + $ncalls = $calls->{$key}; + $name = $names->{$key}; + $s = $times->{$key}/$hz; + $secs = sprintf("%.3f", $s ); + $percall = sprintf("%.4f", $s/$ncalls ); + $pcnt = sprintf("%.2f", + $runtime ? + (($secs / $runtime) * 100.0) : + 0 ); + write; + $pcnt = $secs = $ncalls = $percall = ""; + write while( length $name ); + last unless --$cnt; + } +} + + +sub parsestack { + my( $fh, $names, $calls, $times, $idkeys ) = @_; + my( $dir, $name ); + my( $t, $syst, $realt, $usert ); + my( $x, $z, $c ); + my @stack = (); + my @tstack = (); + my $tab = 3; + my $in = 0; + + while(<$fh>){ + next if /^#/o; + last if /^PART/o; + chop; + ($dir, $usert, $syst, $realt, $name) = split; + + if ( $opt_u ) { $t = $usert } + elsif( $opt_s ) { $t = $syst } + elsif( $opt_r ) { $t = $realt } + else { $t = $usert + $syst } + + if( $dir eq '+' ){ + if( $opt_T ){ + print " " x $in, "$name\n"; + $in += $tab; + } + if(! defined $names->{$name} ){ + $names->{$name} = $name; + $times->{$name} = 0; + push( @$idkeys, $name ); + } + $calls->{$name}++; + $x = [ $name, $t ]; + push( @stack, $x ); + + # my children will put their time here + push( @tstack, 0 ); + + next; + } + if( $dir eq '-' ){ + exitstamp( \@stack, \@tstack, $t, $times, + $name, \$in, $tab ); + next; + } + die "Bad profile: $_"; + } + if( @stack ){ + my @astack; + + warn "Garbled profile is missing some exit time stamps:\n"; + foreach (@stack) { + printf "${$_}[0]\n"; + push( @astack, @stack ); + } + if( ! $opt_F ){ + die "Garbled profile"; + } + else{ + warn( "Faking " . scalar( @astack ) . " exit timestamp(s) . . .\n"); + + foreach $x ( @astack ){ + $name = $x->[0]; + exitstamp( \@stack, \@tstack, $t, $times, + $name, \$in, $tab ); + } + } + } +} + +sub exitstamp { + my( $stack, $tstack, $t, $times, $name, $in, $tab ) = @_; + + my( $x, $c, $z ); + + $x = pop( @$stack ); + if( ! defined $x ){ + die "Garbled profile, missing an enter time stamp"; + } + if( $x->[0] ne $name ){ + die "Garbled profile, unexpected exit time stamp"; + } + if( $opt_T ){ + $$in -= $tab; + } + # collect childtime + $c = pop( @$tstack ); + # total time this func has been active + $z = $t - $x->[1]; + # less time spent in child funcs. + # prepare to accept that the children may account + # for all my time. + $times->{$name} += ($z > $c)? $z - $c: $c - $z; + + # pass my time to my parent + if( @$tstack ){ + $c = pop( @$tstack ); + push( @$tstack, $c + $z ); + } +} + + +sub header { + my $fh = shift; + chop($_ = <$fh>); + if( ! /^#fOrTyTwO$/ ){ + die "Not a perl profile"; + } + while(<$fh>){ + next if /^#/o; + last if /^PART/o; + eval; + } +} + + +# Report avg time-per-function in seconds +sub percalc { + my( $calls, $times, $persecs, $idkeys ) = @_; + my( $x, $t, $n, $key ); + + for( $x = 0; $x < @$idkeys; ++$x ){ + $key = $idkeys->[$x]; + $n = $calls->{$key}; + $t = $times->{$key} / $hz; + $persecs->{$key} = $t ? $t / $n : 0; + } +} + + +sub by_time { $times->{$b} <=> $times->{$a} } +sub by_calls { $calls->{$b} <=> $calls->{$a} } +sub by_alpha { $names->{$a} cmp $names->{$b} } +sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} } + + +format CSTAT_top = +Total Elapsed Time = @>>>>>> Seconds +($rrun_rtime / $hz) + @>>>>>>>>>> Time = @>>>>>> Seconds +$whichtime, $runtime +%Time Seconds #Calls sec/call Name +. + +format STAT = + ^>>> ^>>>> ^>>>>>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +$pcnt, $secs, $ncalls, $percall, $name +. + diff --git a/ext/Devel/DProf/test.pl b/ext/Devel/DProf/test.pl new file mode 100644 index 0000000000..8fa0f41043 --- /dev/null +++ b/ext/Devel/DProf/test.pl @@ -0,0 +1,20 @@ +#!./perl + +sub foo { + print "in sub foo\n"; + bar(); +} + +sub bar { + print "in sub bar\n"; +} + +sub baz { + print "in sub baz\n"; + bar(); + foo(); +} + +bar(); +baz(); +foo(); diff --git a/ext/DynaLoader/DynaLoader.pm b/ext/DynaLoader/DynaLoader.pm index 00466c3f2a..05053b849e 100644 --- a/ext/DynaLoader/DynaLoader.pm +++ b/ext/DynaLoader/DynaLoader.pm @@ -1,5 +1,264 @@ package DynaLoader; +# And Gandalf said: 'Many folk like to know beforehand what is to +# be set on the table; but those who have laboured to prepare the +# feast like to keep their secret; for wonder makes the words of +# praise louder.' + +# (Quote from Tolkien sugested by Anno Siegel.) +# +# See pod text at end of file for documentation. +# See also ext/DynaLoader/README in source tree for other information. +# +# Tim.Bunce@ig.co.uk, August 1994 + +require Carp; +require Config; +require AutoLoader; + +@ISA=qw(AutoLoader); + + +sub import { } # override import inherited from AutoLoader + +# enable debug/trace messages from DynaLoader perl code +$dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug; + +($dl_dlext, $dlsrc, $osname) + = @Config::Config{'dlext', 'dlsrc', 'osname'}; + +# Some systems need special handling to expand file specifications +# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>) +# See dl_expandspec() for more details. Should be harmless but +# inefficient to define on systems that don't need it. +$do_expand = ($osname eq 'VMS'); + +@dl_require_symbols = (); # names of symbols we need +@dl_resolve_using = (); # names of files to link with +@dl_library_path = (); # path to look for files + +# This is a fix to support DLD's unfortunate desire to relink -lc +@dl_resolve_using = dl_findfile('-lc') if $dlsrc eq "dl_dld.xs"; + +# Initialise @dl_library_path with the 'standard' library path +# for this platform as determined by Configure +push(@dl_library_path, split(' ',$Config::Config{'libpth'})); + +# Add to @dl_library_path any extra directories we can gather from +# environment variables. So far LD_LIBRARY_PATH is the only known +# variable used for this purpose. Others may be added later. +push(@dl_library_path, split(/:/, $ENV{LD_LIBRARY_PATH})) + if $ENV{LD_LIBRARY_PATH}; + + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +boot_DynaLoader() if defined(&boot_DynaLoader); + + +if ($dl_debug) { + print STDERR "DynaLoader.pm loaded (@INC, @dl_library_path)\n"; + print STDERR "DynaLoader not linked into this perl\n" + unless defined(&boot_DynaLoader); +} + +1; # End of main code + + +# The bootstrap function cannot be autoloaded (without complications) +# so we define it here: + +sub bootstrap { + # use local vars to enable $module.bs script to edit values + local(@args) = @_; + local($module) = $args[0]; + local(@dirs, $file); + + Carp::confess "Usage: DynaLoader::bootstrap(module)" unless $module; + + # A common error on platforms which don't support dynamic loading. + # Since it's fatal and potentially confusing we give a detailed message. + Carp::croak("Can't load module $module, dynamic loading not available in this perl.\n". + " (You may need to build a new perl executable which either supports\n". + " dynamic loading or has the $module module statically linked into it.)\n") + unless defined(&dl_load_file); + + my @modparts = split(/::/,$module); + my $modfname = $modparts[-1]; + + # Some systems have restrictions on files names for DLL's etc. + # mod2fname returns appropriate file base name (typically truncated) + # It may also edit @modparts if required. + $modfname = &mod2fname(\@modparts) if defined &mod2fname; + + my $modpname = join('/',@modparts); + + print STDERR "DynaLoader::bootstrap for $module ", + "(auto/$modpname/$modfname.$dl_dlext)\n" if $dl_debug; + + foreach (@INC) { + my $dir = "$_/auto/$modpname"; + next unless -d $dir; # skip over uninteresting directories + + # check for common cases to avoid autoload of dl_findfile + last if ($file=_check_file("$dir/$modfname.$dl_dlext")); + + # no luck here, save dir for possible later dl_findfile search + push(@dirs, "-L$dir"); + } + # last resort, let dl_findfile have a go in all known locations + $file = dl_findfile(@dirs, map("-L$_",@INC), $modfname) unless $file; + + Carp::croak "Can't find loadable object for module $module in \@INC (@INC)" + unless $file; + + my $bootname = "boot_$module"; + $bootname =~ s/\W/_/g; + @dl_require_symbols = ($bootname); + + # Execute optional '.bootstrap' perl script for this module. + # The .bs file can be used to configure @dl_resolve_using etc to + # match the needs of the individual module on this architecture. + my $bs = $file; + $bs =~ s/(\.\w+)?$/\.bs/; # look for .bs 'beside' the library + if (-s $bs) { # only read file if it's not empty + print STDERR "BS: $bs ($osname, $dlsrc)\n" if $dl_debug; + eval { do $bs; }; + warn "$bs: $@\n" if $@; + } + + # Many dynamic extension loading problems will appear to come from + # this section of code: XYZ failed at line 123 of DynaLoader.pm. + # Often these errors are actually occurring in the initialisation + # C code of the extension XS file. Perl reports the error as being + # in this perl code simply because this was the last perl code + # it executed. + + my $libref = dl_load_file($file) or + Carp::croak "Can't load '$file' for module $module: ".dl_error()."\n"; + + my @unresolved = dl_undef_symbols(); + Carp::carp "Undefined symbols present after loading $file: @unresolved\n" + if @unresolved; + + my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or + Carp::croak "Can't find '$bootname' symbol in $file\n"; + + my $xs = dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); + + # See comment block above + &$xs(@args); +} + + +sub _check_file { # private utility to handle dl_expandspec vs -f tests + my($file) = @_; + return $file if (!$do_expand && -f $file); # the common case + return $file if ( $do_expand && ($file=dl_expandspec($file))); + return undef; +} + + +# Let autosplit and the autoloader deal with these functions: +__END__ + + +sub dl_findfile { + # Read ext/DynaLoader/DynaLoader.doc for detailed information. + # This function does not automatically consider the architecture + # or the perl library auto directories. + my (@args) = @_; + my (@dirs, $dir); # which directories to search + my (@found); # full paths to real files we have found + my $vms = ($osname eq 'VMS'); + my $dl_so = $Config::Config{'so'}; # suffix for shared libraries + + print STDERR "dl_findfile(@args)\n" if $dl_debug; + + # accumulate directories but process files as they appear + arg: foreach(@args) { + # Special fast case: full filepath requires no search + if (m:/: && -f $_ && !$do_expand) { + push(@found,$_); + last arg unless wantarray; + next; + } + + # Deal with directories first: + # Using a -L prefix is the preferred option (faster and more robust) + if (m:^-L:) { s/^-L//; push(@dirs, $_); next; } + + # Otherwise we try to try to spot directories by a heuristic + # (this is a more complicated issue than it first appears) + if (m:/: && -d $_) { push(@dirs, $_); next; } + + # VMS: we may be using native VMS directry syntax instead of + # Unix emulation, so check this as well + if ($vms && /[:>\]]/ && -d $_) { push(@dirs, $_); next; } + + # Only files should get this far... + my(@names, $name); # what filenames to look for + if (m:-l: ) { # convert -lname to appropriate library name + s/-l//; + push(@names,"lib$_.$dl_so"); + push(@names,"lib$_.a"); + } else { # Umm, a bare name. Try various alternatives: + # these should be ordered with the most likely first + push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; + push(@names,"lib$_.$dl_so") unless m:/:; + push(@names,"$_.o") unless m/\.(o|$dl_so)$/o; + push(@names,"$_.a") if !m/\.a$/ and $dlsrc eq "dl_dld.xs"; + push(@names, $_); + } + foreach $dir (@dirs, @dl_library_path) { + next unless -d $dir; + foreach $name (@names) { + my($file) = "$dir/$name"; + print STDERR " checking in $dir for $name\n" if $dl_debug; + $file = _check_file($file); + if ($file) { + push(@found, $file); + next arg; # no need to look any further + } + } + } + } + if ($dl_debug) { + foreach(@dirs) { + print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; + } + print STDERR "dl_findfile found: @found\n"; + } + return $found[0] unless wantarray; + @found; +} + + +sub dl_expandspec { + my($spec) = @_; + # Optional function invoked if DynaLoader.pm sets $do_expand. + # Most systems do not require or use this function. + # Some systems may implement it in the dl_*.xs file in which case + # this autoload version will not be called but is harmless. + + # This function is designed to deal with systems which treat some + # 'filenames' in a special way. For example VMS 'Logical Names' + # (something like unix environment variables - but different). + # This function should recognise such names and expand them into + # full file paths. + # Must return undef if $spec is invalid or file does not exist. + + my $file = $spec; # default output to input + + if ($osname eq 'VMS') { # dl_expandspec should be defined in dl_vms.xs + Carp::croak "dl_expandspec: should be defined in XS file!\n"; + } else { + return undef unless -f $file; + } + print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; + $file; +} + + =head1 NAME DynaLoader - Dynamically load C libraries into Perl code @@ -8,8 +267,10 @@ dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl =head1 SYNOPSIS + package YourPackage; require DynaLoader; @ISA = qw(... DynaLoader ...); + bootstrap YourPackage; =head1 DESCRIPTION @@ -300,7 +561,8 @@ calls dl_install_xsub() to install it as "${module}::bootstrap" =item * -calls &{"${module}::bootstrap"} to bootstrap the module +calls &{"${module}::bootstrap"} to bootstrap the module (actually +it uses the function reference returned by dl_install_xsub for speed) =back @@ -319,255 +581,3 @@ Larry Wall designed the elegant inherited bootstrap mechanism and implemented the first Perl 5 dynamic loader using it. =cut - -# -# And Gandalf said: 'Many folk like to know beforehand what is to -# be set on the table; but those who have laboured to prepare the -# feast like to keep their secret; for wonder makes the words of -# praise louder.' -# - -# Quote from Tolkien sugested by Anno Siegel. -# -# Read ext/DynaLoader/README for detailed information. -# -# Tim.Bunce@ig.co.uk, August 1994 - -use Config; -use Carp; -use AutoLoader; - -@ISA=qw(AutoLoader); - - -# enable messages from DynaLoader perl code -$dl_debug = 0 unless $dl_debug; -$dl_debug = $ENV{'PERL_DL_DEBUG'} if $ENV{'PERL_DL_DEBUG'}; - -$dl_so = $dl_dlext = ""; # avoid typo warnings -$dl_so = $Config{'so'}; # suffix for shared libraries -$dl_dlext = $Config{'dlext'}; # suffix for dynamic modules - -# Some systems need special handling to expand file specifications -# (VMS support by Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>) -# See dl_expandspec() for more details. Should be harmless but -# inefficient to define on systems that don't need it. -$do_expand = ($Config{'osname'} eq 'VMS'); - -@dl_require_symbols = (); # names of symbols we need -@dl_resolve_using = (); # names of files to link with -@dl_library_path = (); # path to look for files - -# This is a fix to support DLD's unfortunate desire to relink -lc -@dl_resolve_using = dl_findfile('-lc') if $Config{'dlsrc'} eq "dl_dld.xs"; - -# Initialise @dl_library_path with the 'standard' library path -# for this platform as determined by Configure -push(@dl_library_path, split(' ',$Config{'libpth'})); - -# Add to @dl_library_path any extra directories we can gather from -# environment variables. So far LD_LIBRARY_PATH is the only known -# variable used for this purpose. Others may be added later. -push(@dl_library_path, split(/:/, $ENV{'LD_LIBRARY_PATH'})) - if $ENV{'LD_LIBRARY_PATH'}; - - -# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. -boot_DynaLoader() if defined(&boot_DynaLoader); - - -if ($dl_debug){ - print STDERR "DynaLoader.pm loaded (@dl_library_path)\n"; - print STDERR "DynaLoader not linked into this perl\n" - unless defined(&boot_DynaLoader); -} - -1; # End of main code - - -# The bootstrap function cannot be autoloaded (without complications) -# so we define it here: - -sub bootstrap { - # use local vars to enable $module.bs script to edit values - local(@args) = @_; - local($module) = $args[0]; - local(@dirs, $file); - - confess "Usage: DynaLoader::bootstrap(module)" unless $module; - - # A common error on platforms which don't support dynamic loading. - # Since it's fatal and potentially confusing we give a detailed message. - croak("Can't load module $module, dynamic loading not available in this perl.\n". - " (You may need to build a new perl executable which either supports\n". - " dynamic loading or has the $module module statically linked into it.)\n") - unless defined(&dl_load_file); - - print STDERR "DynaLoader::bootstrap($module)\n" if $dl_debug; - - my(@modparts) = split(/::/,$module); - my($modfname) = $modparts[-1]; - my($modpname) = join('/',@modparts); - foreach (@INC) { - my $dir = "$_/auto/$modpname"; - next unless -d $dir; # skip over uninteresting directories - - # check for common cases to avoid autoload of dl_findfile - last if ($file=_check_file("$dir/$modfname.$dl_dlext")); - - # no luck here, save dir for possible later dl_findfile search - push(@dirs, "-L$dir"); - } - # last resort, let dl_findfile have a go in all known locations - $file = dl_findfile(@dirs, map("-L$_",@INC), $modfname) unless $file; - - croak "Can't find loadable object for module $module in \@INC" - unless $file; - - my($bootname) = "boot_$module"; - $bootname =~ s/\W/_/g; - @dl_require_symbols = ($bootname); - - # Execute optional '.bootstrap' perl script for this module. - # The .bs file can be used to configure @dl_resolve_using etc to - # match the needs of the individual module on this architecture. - my $bs = $file; - $bs =~ s/(\.\w+)?$/\.bs/; # look for .bs 'beside' the library - if (-s $bs) { # only read file if it's not empty - local($osname, $dlsrc) = @Config{'osname','dlsrc'}; - print STDERR "BS: $bs ($osname, $dlsrc)\n" if $dl_debug; - eval { do $bs; }; - warn "$bs: $@\n" if $@; - } - - # Many dynamic extension loading problems will appear to come from - # this section of code: XYZ failed at line 123 of DynaLoader.pm. - # Often these errors are actually occurring in the initialisation - # C code of the extension XS file. Perl reports the error as being - # in this perl code simply because this was the last perl code - # it executed. - - my $libref = dl_load_file($file) or - croak "Can't load '$file' for module $module: ".dl_error()."\n"; - - my(@unresolved) = dl_undef_symbols(); - carp "Undefined symbols present after loading $file: @unresolved\n" - if (@unresolved); - - my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or - croak "Can't find '$bootname' symbol in $file\n"; - - dl_install_xsub("${module}::bootstrap", $boot_symbol_ref, $file); - - # See comment block above - &{"${module}::bootstrap"}(@args); -} - - -sub _check_file{ # private utility to handle dl_expandspec vs -f tests - my($file) = @_; - return $file if (!$do_expand && -f $file); # the common case - return $file if ( $do_expand && ($file=dl_expandspec($file))); - return undef; -} - - -# Let autosplit and the autoloader deal with these functions: -__END__ - - -sub dl_findfile { - # Read ext/DynaLoader/DynaLoader.doc for detailed information. - # This function does not automatically consider the architecture - # or the perl library auto directories. - my (@args) = @_; - my (@dirs, $dir); # which directories to search - my (@found); # full paths to real files we have found - my ($vms) = ($Config{'osname'} eq 'VMS'); - - print STDERR "dl_findfile(@args)\n" if $dl_debug; - - # accumulate directories but process files as they appear - arg: foreach(@args) { - # Special fast case: full filepath requires no search - if (m:/: && -f $_ && !$do_expand){ - push(@found,$_); - last arg unless wantarray; - next; - } - - # Deal with directories first: - # Using a -L prefix is the preferred option (faster and more robust) - if (m:^-L:){ s/^-L//; push(@dirs, $_); next; } - - # Otherwise we try to try to spot directories by a heuristic - # (this is a more complicated issue than it first appears) - if (m:/: && -d $_){ push(@dirs, $_); next; } - - # VMS: we may be using native VMS directry syntax instead of - # Unix emulation, so check this as well - if ($vms && /[:>\]]/ && -d $_){ push(@dirs, $_); next; } - - # Only files should get this far... - my(@names, $name); # what filenames to look for - if (m:-l: ){ # convert -lname to appropriate library name - s/-l//; - push(@names,"lib$_.$dl_so"); - push(@names,"lib$_.a"); - }else{ # Umm, a bare name. Try various alternatives: - # these should be ordered with the most likely first - push(@names,"$_.$dl_so") unless m/\.$dl_so$/o; - push(@names,"lib$_.$dl_so") unless m:/:; - push(@names,"$_.o") unless m/\.(o|$dl_so)$/o; - push(@names,"$_.a") unless m/\.a$/; - push(@names, $_); - } - foreach $dir (@dirs, @dl_library_path) { - next unless -d $dir; - foreach $name (@names) { - my($file) = "$dir/$name"; - print STDERR " checking in $dir for $name\n" if $dl_debug; - $file = _check_file($file); - if ($file){ - push(@found, $file); - next arg; # no need to look any further - } - } - } - } - if ($dl_debug) { - foreach(@dirs) { - print STDERR " dl_findfile ignored non-existent directory: $_\n" unless -d $_; - } - print STDERR "dl_findfile found: @found\n"; - } - return $found[0] unless wantarray; - @found; -} - - -sub dl_expandspec{ - my($spec) = @_; - # Optional function invoked if DynaLoader.pm sets $do_expand. - # Most systems do not require or use this function. - # Some systems may implement it in the dl_*.xs file in which case - # this autoload version will not be called but is harmless. - - # This function is designed to deal with systems which treat some - # 'filenames' in a special way. For example VMS 'Logical Names' - # (something like unix environment variables - but different). - # This function should recognise such names and expand them into - # full file paths. - # Must return undef if $spec is invalid or file does not exist. - - my($file) = $spec; # default output to input - my($osname) = $Config{'osname'}; - - if ($osname eq 'VMS'){ # dl_expandspec should be defined in dl_vms.xs - croak "dl_expandspec: should be defined in XS file!\n"; - }else{ - return undef unless -f $file; - } - print STDERR "dl_expandspec($spec) => $file\n" if $dl_debug; - $file; -} diff --git a/ext/DynaLoader/dl_dld.xs b/ext/DynaLoader/dl_dld.xs index 31f625a26d..a0028a1f7a 100644 --- a/ext/DynaLoader/dl_dld.xs +++ b/ext/DynaLoader/dl_dld.xs @@ -44,11 +44,16 @@ #include "dlutils.c" /* for SaveError() etc */ +static AV *dl_resolve_using = Nullav; +static AV *dl_require_symbols = Nullav; + static void dl_private_init() { 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); #ifdef __linux__ dlderr = dld_init("/proc/self/exe"); if (dlderr) { @@ -77,39 +82,33 @@ dl_load_file(filename) CODE: int dlderr,x,max; GV *gv; - AV *av; RETVAL = filename; DLDEBUG(1,fprintf(stderr,"dl_load_file(%s)\n", filename)); - gv = gv_fetchpv("DynaLoader::dl_require_symbols", FALSE, SVt_PVAV); - if (gv) { - av = GvAV(gv); - max = AvFILL(av); - for (x = 0; x <= max; x++) { - char *sym = SvPVX(*av_fetch(av, x, 0)); - DLDEBUG(1,fprintf(stderr, "dld_create_ref(%s)\n", sym)); - if (dlderr = dld_create_reference(sym)) { - SaveError("dld_create_reference(%s): %s", sym, - dld_strerror(dlderr)); - goto haverror; - } + + max = AvFILL(dl_require_symbols); + for (x = 0; x <= max; x++) { + char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0)); + DLDEBUG(1,fprintf(stderr, "dld_create_ref(%s)\n", sym)); + if (dlderr = dld_create_reference(sym)) { + SaveError("dld_create_reference(%s): %s", sym, + dld_strerror(dlderr)); + goto haverror; } } + DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", filename)); if (dlderr = dld_link(filename)) { SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); goto haverror; } - gv = gv_fetchpv("DynaLoader::dl_resolve_using", FALSE, SVt_PVAV); - if (gv) { - av = GvAV(gv); - max = AvFILL(av); - for (x = 0; x <= max; x++) { - char *sym = SvPVX(*av_fetch(av, x, 0)); - DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", sym)); - if (dlderr = dld_link(sym)) { - SaveError("dld_link(%s): %s", sym, 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,fprintf(stderr, "dld_link(%s)\n", sym)); + if (dlderr = dld_link(sym)) { + SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); + goto haverror; } } DLDEBUG(2,fprintf(stderr,"libref=%s\n", RETVAL)); diff --git a/ext/DynaLoader/dl_dlopen.xs b/ext/DynaLoader/dl_dlopen.xs index 0cba08729e..9a6f0597ec 100644 --- a/ext/DynaLoader/dl_dlopen.xs +++ b/ext/DynaLoader/dl_dlopen.xs @@ -34,7 +34,7 @@ error. The mode parameter must be set to 1 for Solaris 1 and to - RTLD_LAZY on Solaris 2. + RTLD_LAZY (==2) on Solaris 2. dlsym @@ -114,6 +114,10 @@ #include <link.h> #endif +#ifndef RTLD_LAZY +# define RTLD_LAZY 1 /* Solaris 1 */ +#endif + #ifndef HAS_DLERROR # ifdef __NetBSD__ # define dlerror() strerror(errno) @@ -142,9 +146,10 @@ void * dl_load_file(filename) char * filename CODE: - int mode = 1; /* Solaris 1 */ -#ifdef RTLD_LAZY - mode = RTLD_LAZY; /* Solaris 2 */ + int mode = RTLD_LAZY; +#ifdef RTLD_NOW + if (dl_nonlazy) + mode = RTLD_NOW; #endif DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; diff --git a/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs index d2c405ecdc..0e146830ef 100644 --- a/ext/DynaLoader/dl_hpux.xs +++ b/ext/DynaLoader/dl_hpux.xs @@ -21,11 +21,14 @@ #include "dlutils.c" /* for SaveError() etc */ +static AV *dl_resolve_using = Nullav; + static void dl_private_init() { (void)dl_generic_private_init(); + dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); } MODULE = DynaLoader PACKAGE = DynaLoader @@ -39,29 +42,25 @@ dl_load_file(filename) char * filename CODE: shl_t obj = NULL; - int i, max; - GV *gv; - AV *av; - - gv = gv_fetchpv("DynaLoader::dl_resolve_using", FALSE, SVt_PVAV); - if (gv) { - av = GvAV(gv); - max = AvFILL(av); - for (i = 0; i <= max; i++) { - char *sym = SvPVX(*av_fetch(av, i, 0)); - DLDEBUG(1,fprintf(stderr, "dl_load_file(%s) (dependent)\n", sym)); - obj = shl_load(sym, - BIND_IMMEDIATE | BIND_NONFATAL | BIND_NOSTART | BIND_VERBOSE, - 0L); - if (obj == NULL) { - goto end; - } + int i, max, bind_type; + + if (dl_nonlazy) + bind_type = BIND_IMMEDIATE; + else + bind_type = BIND_DEFERRED; + + max = AvFILL(dl_resolve_using); + for (i = 0; i <= max; i++) { + char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); + DLDEBUG(1,fprintf(stderr, "dl_load_file(%s) (dependent)\n", sym)); + obj = shl_load(sym, bind_type | BIND_NOSTART, 0L); + if (obj == NULL) { + goto end; } } DLDEBUG(1,fprintf(stderr,"dl_load_file(%s): ", filename)); - obj = shl_load(filename, - BIND_IMMEDIATE | BIND_NONFATAL | BIND_NOSTART | BIND_VERBOSE, 0L); + obj = shl_load(filename, bind_type | BIND_NOSTART, 0L); DLDEBUG(2,fprintf(stderr," libref=%x\n", obj)); end: @@ -86,27 +85,25 @@ dl_find_symbol(libhandle, symbolname) #endif DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); + ST(0) = sv_newmortal() ; + errno = 0; + status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); DLDEBUG(2,fprintf(stderr," symbolref(PROCEDURE) = %x\n", symaddr)); - ST(0) = sv_newmortal() ; + + if (status == -1 && errno == 0) { /* try TYPE_DATA instead */ + status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr); + DLDEBUG(2,fprintf(stderr," symbolref(DATA) = %x\n", symaddr)); + } + if (status == -1) { - if (errno == 0) { - status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr); - DLDEBUG(2,fprintf(stderr," symbolref(DATA) = %x\n", symaddr)); - if (status == -1) { - SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; - } else { - sv_setiv( ST(0), (IV)symaddr); - } - } else { - SaveError("%s", Strerror(errno)); - } + SaveError("%s",(errno) ? Strerror(errno) : "Symbol not found") ; } else { sv_setiv( ST(0), (IV)symaddr); } -int +void dl_undef_symbols() PPCODE: diff --git a/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs index 9bc5cd81c2..33a41003ef 100644 --- a/ext/DynaLoader/dl_next.xs +++ b/ext/DynaLoader/dl_next.xs @@ -31,17 +31,21 @@ Anno Siegel */ +/* include these before perl headers */ +#include <mach-o/rld.h> +#include <streams/streams.h> + #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#include "dlutils.c" /* SaveError() etc */ +#define DL_LOADONCEONLY +#include "dlutils.c" /* SaveError() etc */ -#include <mach-o/rld.h> -#include <streams/streams.h> static char * dl_last_error = (char *) 0; +static AV *dl_resolve_using = Nullav; NXStream * OpenError() @@ -84,19 +88,21 @@ char * path; int mode; /* mode is ignored */ { int rld_success; - NXStream *nxerr = OpenError(); - AV * av_resolve; + NXStream *nxerr; I32 i, psize; char *result; char **p; + + /* Do not load what is already loaded into this process */ + if (hv_fetch(dl_loaded_files, path, strlen(path), 0)) + return path; - av_resolve = GvAVn(gv_fetchpv( - "DynaLoader::dl_resolve_using", FALSE, SVt_PVAV)); - psize = AvFILL(av_resolve) + 3; + nxerr = OpenError(); + psize = AvFILL(dl_resolve_using) + 3; p = (char **) safemalloc(psize * sizeof(char*)); p[0] = path; for(i=1; i<psize-1; i++) { - p[i] = SvPVx(*av_fetch(av_resolve, i-1, TRUE), na); + p[i] = SvPVx(*av_fetch(dl_resolve_using, i-1, TRUE), na); } p[psize-1] = 0; rld_success = rld_load(nxerr, (struct mach_header **)0, p, @@ -104,6 +110,8 @@ int mode; /* mode is ignored */ safefree((char*) p); if (rld_success) { result = path; + /* prevent multiple loads of same file into same process */ + hv_store(dl_loaded_files, path, strlen(path), &sv_yes, 0); } else { TransferError(nxerr); result = (char*) 0; @@ -144,6 +152,7 @@ static void dl_private_init() { (void)dl_generic_private_init(); + dl_resolve_using = perl_get_av("DynaLoader::dl_resolve_using", 0x4); } MODULE = DynaLoader PACKAGE = DynaLoader diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs index c6e58fb33c..a49e5eb939 100644 --- a/ext/DynaLoader/dl_vms.xs +++ b/ext/DynaLoader/dl_vms.xs @@ -50,6 +50,9 @@ #include "XSUB.h" #include "dlutils.c" /* dl_debug, LastError; SaveError not used */ + +static AV *dl_require_symbols = Nullav; + /* N.B.: * dl_debug and LastError are static vars; you'll need to deal * with them appropriately if you need context independence @@ -117,6 +120,7 @@ static void dl_private_init() { dl_generic_private_init(); + dl_require_symbols = perl_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; @@ -195,7 +199,6 @@ dl_load_file(filespec) char * filespec CODE: char vmsspec[NAM$C_MAXRSS]; - AV *reqAV; SV *reqSV, **reqSVhndl; STRLEN deflen; struct dsc$descriptor_s @@ -239,9 +242,7 @@ dl_load_file(filespec) dlptr->name.dsc$a_pointer, dlptr->defspec.dsc$w_length, dlptr->defspec.dsc$a_pointer)); - if (!(reqAV = GvAV(gv_fetchpv("DynaLoader::dl_require_symbols", - FALSE,SVt_PVAV))) - || !(reqSVhndl = av_fetch(reqAV,0,FALSE)) || !(reqSV = *reqSVhndl)) { + if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) { DLDEBUG(2,fprintf(stderr,"\t@dl_require_symbols empty, returning untested libref\n")); } else { diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 0ce082182c..67dea787cc 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -9,12 +9,17 @@ /* pointer to allocated memory for last error message */ static char *LastError = (char*)NULL; +/* flag for immediate rather than lazy linking (spots unresolved symbol) */ +static int dl_nonlazy = 0; + +#ifdef DL_LOADONCEONLY +static HV *dl_loaded_files = Nullhv; /* only needed on a few systems */ +#endif #ifdef DEBUGGING -/* currently not connected to $DynaLoader::dl_error but should be */ -static int dl_debug = 0; -#define DLDEBUG(level,code) if(dl_debug>=level){ code; } +static int dl_debug = 0; /* value copied from $DynaLoader::dl_error */ +#define DLDEBUG(level,code) if (dl_debug>=level) { code; } #else #define DLDEBUG(level,code) #endif @@ -23,10 +28,17 @@ static int dl_debug = 0; static void dl_generic_private_init() /* called by dl_*.xs dl_private_init() */ { + char *perl_dl_nonlazy; #ifdef DEBUGGING - char *perl_dl_debug = getenv("PERL_DL_DEBUG"); - if (perl_dl_debug) - dl_debug = atoi(perl_dl_debug); + dl_debug = SvIV( perl_get_sv("DynaLoader::dl_debug", 0x04) ); +#endif + if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) + dl_nonlazy = atoi(perl_dl_nonlazy); + if (dl_nonlazy) + DLDEBUG(1,fprintf(stderr,"DynaLoader bind mode is 'non-lazy'\n")); +#ifdef DL_LOADONCEONLY + if (!dl_loaded_files) + dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ #endif } @@ -47,8 +59,7 @@ SaveError(pat, va_alist) char *message; int len; - /* This code is based on croak/warn but I'm not sure where mess() */ - /* gets its buffer space from! */ + /* This code is based on croak/warn, see mess() in util.c */ #ifdef I_STDARG va_start(args, pat); diff --git a/ext/Fcntl/Fcntl.xs b/ext/Fcntl/Fcntl.xs index 308e9dda2c..b505239629 100644 --- a/ext/Fcntl/Fcntl.xs +++ b/ext/Fcntl/Fcntl.xs @@ -4,6 +4,20 @@ #include <fcntl.h> +/* This comment is a kludge to get metaconfig to see the symbols + VAL_O_NONBLOCK + VAL_EAGAIN + RD_NODATA + EOF_NONBLOCK + and include the appropriate metaconfig unit + so that Configure will test how to turn on non-blocking I/O + for a file descriptor. See config.h for how to use these + in your extension. + + While I'm at it, I'll have metaconfig look for HAS_POLL too. + --AD October 16, 1995 +*/ + static int not_here(s) char *s; diff --git a/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs index 2272474dcc..c1b405ff89 100644 --- a/ext/ODBM_File/ODBM_File.xs +++ b/ext/ODBM_File/ODBM_File.xs @@ -5,7 +5,13 @@ #ifdef NULL #undef NULL #endif -#include <dbm.h> +#ifdef I_DBM +# include <dbm.h> +#else +# ifdef I_RPCSVC_DBM +# include <rpcsvc/dbm.h> +# endif +#endif #include <fcntl.h> diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 3d68d91b03..2a1338200d 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -2753,8 +2753,8 @@ sigaction(sig, action, oldaction = 0) POSIX__SigSet sigset; SV** svp; SV** sigsvp = hv_fetch(GvHVn(siggv), - sig_name[sig], - strlen(sig_name[sig]), + whichsigname(sig), + strlen(whichsigname(sig)), TRUE); /* Remember old handler name if desired. */ diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index 86cc86c6b7..5a4b486a22 100644 --- a/ext/Socket/Socket.pm +++ b/ext/Socket/Socket.pm @@ -2,14 +2,19 @@ package Socket; =head1 NAME -Socket - load the C socket.h defines +Socket - load the C socket.h defines and structure manipulators =head1 SYNOPSIS use Socket; $proto = (getprotobyname('udp'))[2]; - socket(Socket_Handle, PF_INET, SOCK_DGRAM, $proto); + socket(Socket_Handle, PF_INET, SOCK_DGRAM, $proto); + $sockaddr_in = pack_sockaddr_in(AF_INET,7,inet_aton("localhost")); + $sockaddr_in = pack_sockaddr_in(AF_INET,7,INADDR_LOOPBACK); + connect(Socket_Handle,$sockaddr_in); + $peer = inet_ntoa((unpack_sockaddr_in(getpeername(Socket_Handle)))[2]); + =head1 DESCRIPTION @@ -19,10 +24,62 @@ file, this uses the B<h2xs> program (see the Perl source distribution) and your native C compiler. This means that it has a far more likely chance of getting the numbers right. -=head1 NOTE +In addition, some structure manipulation functions are available: + +=item inet_aton HOSTNAME + +Takes a string giving the name of a host, and translates that +to the 4-byte string (structure). Takes arguments of both +the 'rtfm.mit.edu' type and '18.181.0.24'. If the host name +cannot be resolved, returns undef. + +=item inet_ntoa IP_ADDRESS + +Takes a four byte ip address (as returned by inet_aton()) +and translates it into a string of the form 'd.d.d.d' +where the 'd's are numbers less than 256 (the normal +readable four dotted number notation for internet addresses). + +=item INADDR_ANY + +Note - does not return a number. + +Returns the 4-byte wildcard ip address which specifies any +of the hosts ip addresses. (A particular machine can have +more than one ip address, each address corresponding to +a particular network interface. This wildcard address +allows you to bind to all of them simultaneously.) +Normally equivalent to inet_aton('0.0.0.0'). + +=item INADDR_LOOPBACK + +Note - does not return a number. + +Returns the 4-byte loopback address. Normally equivalent +to inet_aton('localhost'). -Only C<#define> symbols get translated; you must still correctly -pack up your own arguments to pass to bind(), etc. +=item INADDR_NONE + +Note - does not return a number. + +Returns the 4-byte invalid ip address. Normally equivalent +to inet_aton('255.255.255.255'). + +=item pack_sockaddr_in FAMILY, PORT, IP_ADDRESS + +Takes three arguments, an address family (normally AF_INET), +a port number, and a 4 byte IP_ADDRESS (as returned by +inet_aton()). Returns the sockaddr_in structure with those +arguments packed in. For internet domain sockets, this structure +is normally what you need for the arguments in bind(), connect(), +and send(), and is also returned by getpeername(), getsockname() +and recv(). + +=item unpack_sockaddr_in SOCKADDR_IN + +Takes a sockaddr_in structure (as returned by pack_sockaddr_in()) +and returns an array of three elements: the address family, +the port, and the 4-byte ip-address. =cut @@ -33,6 +90,8 @@ use AutoLoader; require DynaLoader; @ISA = qw(Exporter DynaLoader); @EXPORT = qw( + inet_aton inet_ntoa pack_sockaddr_in unpack_sockaddr_in + INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT @@ -130,16 +189,6 @@ sub AUTOLOAD { goto &$AUTOLOAD; } - -# pack a sockaddr_in structure for use in bind() calls. -# (here to hide the 'S n C4 x8' magic from applications) -sub sockaddr_in{ - my($af, $port, @quad) = @_; - my $pack = 'S n C4 x8'; # lookup $pack from hash using $af? - pack($pack, $af, $port, @quad); -} - - bootstrap Socket; # Preloaded methods go here. Autoload methods go after __END__, and are diff --git a/ext/Socket/Socket.xs b/ext/Socket/Socket.xs index 7a0bf465b2..1f32dab79c 100644 --- a/ext/Socket/Socket.xs +++ b/ext/Socket/Socket.xs @@ -2,7 +2,19 @@ #include "perl.h" #include "XSUB.h" +#ifndef VMS +# ifdef I_SYS_TYPES +# include <sys/types.h> +# endif #include <sys/socket.h> +# ifdef I_NETINET_IN +# include <netinet/in.h> +# endif +#include <netdb.h> +#include <arpa/inet.h> +#else +#include "sockadapt.h" +#endif #ifndef AF_NBS #undef PF_NBS @@ -12,6 +24,14 @@ #undef PF_X25 #endif +#ifndef INADDR_NONE +#define INADDR_NONE 0xffffffff +#endif /* INADDR_NONE */ +#ifndef INADDR_LOOPBACK +#define INADDR_LOOPBACK 0x7F000001 +#endif /* INADDR_LOOPBACK */ + + static int not_here(s) char *s; @@ -556,6 +576,7 @@ not_there: return 0; } + MODULE = Socket PACKAGE = Socket double @@ -563,3 +584,116 @@ constant(name,arg) char * name int arg + +void +inet_aton(host) + char * host + CODE: + { + struct in_addr ip_address; + struct hostent * phe; + + if (phe = gethostbyname(host)) { + Copy( phe->h_addr, &ip_address, phe->h_length, char ); + } else { + ip_address.s_addr = inet_addr(host); + } + + ST(0) = sv_newmortal(); + if(ip_address.s_addr != INADDR_NONE) { + sv_setpvn( ST(0), (char *)&ip_address, sizeof ip_address ); + } + } + +void +inet_ntoa(ip_address_sv) + SV * ip_address_sv + CODE: + { + STRLEN addrlen; + struct in_addr addr; + char * addr_str; + char * ip_address = SvPV(ip_address_sv,addrlen); + if (addrlen != sizeof(addr)) { + croak("Bad arg length for %s, length is %d, should be %d", + "Socket::inet_ntoa", + addrlen, sizeof(addr)); + } + + Copy( ip_address, &addr, sizeof addr, char ); + addr_str = inet_ntoa(addr); + + ST(0) = sv_2mortal(newSVpv(addr_str, strlen(addr_str))); + } + +void +pack_sockaddr_in(family,port,ip_address) + short family + short port + char * ip_address + CODE: + { + struct sockaddr_in sin; + + Zero( &sin, sizeof sin, char ); + sin.sin_family = family; + 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)); + } + +void +unpack_sockaddr_in(sin_sv) + SV * sin_sv + PPCODE: + { + STRLEN sockaddrlen; + struct sockaddr_in addr; + short family; + short port; + struct in_addr ip_address; + char * sin = SvPV(sin_sv,sockaddrlen); + if (sockaddrlen != sizeof(addr)) { + croak("Bad arg length for %s, length is %d, should be %d", + "Socket::unpack_sockaddr_in", + sockaddrlen, sizeof(addr)); + } + + Copy( sin, &addr,sizeof addr, char ); + family = addr.sin_family; + port = ntohs(addr.sin_port); + ip_address = addr.sin_addr; + + EXTEND(sp, 3); + PUSHs(sv_2mortal(newSViv(family))); + PUSHs(sv_2mortal(newSViv(port))); + PUSHs(sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address))); + } + +void +INADDR_ANY() + CODE: + { + struct in_addr ip_address; + ip_address.s_addr = htonl(INADDR_ANY); + ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address )); + } + +void +INADDR_LOOPBACK() + CODE: + { + struct in_addr ip_address; + ip_address.s_addr = htonl(INADDR_LOOPBACK); + ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); + } + +void +INADDR_NONE() + CODE: + { + struct in_addr ip_address; + ip_address.s_addr = htonl(INADDR_NONE); + ST(0) = sv_2mortal(newSVpv((char *)&ip_address,sizeof ip_address)); + } |