summaryrefslogtreecommitdiff
path: root/ext
diff options
context:
space:
mode:
Diffstat (limited to 'ext')
-rw-r--r--ext/DB_File/DB_File.pm679
-rw-r--r--ext/DB_File/DB_File.xs170
-rw-r--r--ext/DB_File/Makefile.PL9
-rw-r--r--ext/DB_File/typemap2
-rw-r--r--ext/Devel/DProf/DProf.pm106
-rw-r--r--ext/Devel/DProf/DProf.xs247
-rw-r--r--ext/Devel/DProf/Makefile.PL8
-rw-r--r--ext/Devel/DProf/README3
-rw-r--r--ext/Devel/DProf/dprofpp394
-rw-r--r--ext/Devel/DProf/test.pl20
-rw-r--r--ext/DynaLoader/DynaLoader.pm516
-rw-r--r--ext/DynaLoader/dl_dld.xs47
-rw-r--r--ext/DynaLoader/dl_dlopen.xs13
-rw-r--r--ext/DynaLoader/dl_hpux.xs61
-rw-r--r--ext/DynaLoader/dl_next.xs27
-rw-r--r--ext/DynaLoader/dl_vms.xs9
-rw-r--r--ext/DynaLoader/dlutils.c27
-rw-r--r--ext/Fcntl/Fcntl.xs14
-rw-r--r--ext/ODBM_File/ODBM_File.xs8
-rw-r--r--ext/POSIX/POSIX.xs4
-rw-r--r--ext/Socket/Socket.pm79
-rw-r--r--ext/Socket/Socket.xs134
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));
+ }
View Lorry Controller Status