# $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $
#
-# Generated on Wed Sep 22 00:13:58 EET DST 1999 [metaconfig 3.0 PL70]
+# Generated on Thu Sep 30 19:41:54 EET DST 1999 [metaconfig 3.0 PL70]
# (with additional metaconfig patches by perlbug@perl.com)
cat >/tmp/c1$$ <<EOF
if $test -r $rsrc/patchlevel.h;then
patchlevel=`awk '/define[ ]+PERL_VERSION/ {print $3}' $rsrc/patchlevel.h`
subversion=`awk '/define[ ]+PERL_SUBVERSION/ {print $3}' $rsrc/patchlevel.h`
+ apiversion=`awk '/define[ ]+PERL_APIVERSION/ {print $3}' $rsrc/patchlevel.h`
else
patchlevel=0
subversion=0
+ apiversion=0
fi
$echo $n "(You have $package" $c
case "$package" in
echo $baserev $patchlevel $subversion | \
$awk '{ printf "%.5f\n", $1 + $2/1000.0 + $3/100000.0 }'`
fi
-: Figure out perl API version. Perhaps this should be in patchlevel.h
-if test "$subversion" -lt 50; then
- apiversion=`LC_ALL=C; export LC_ALL; \
- LANGUAGE=C; export LANGUAGE; \
- echo $baserev $patchlevel | \
- $awk '{ printf "%.3f\n", $1 + $2/1000.0 }'`
-else
- apiversion="$version"
-fi
: determine installation style
: For now, try to deduce it from prefix unless it is already set.
SYMH = perlvars.h intrpvar.h thrdvar.h
+CHMOD_W = chmod +w
+
# The following files are generated automatically
# keywords.h: keywords.pl
# opcode.h: opcode.pl
# To force them to run, type
# make regen_headers
regen_headers: FORCE
+ $(CHMOD_W) proto.h warning.h lib/warning.pm
perl keywords.pl
perl opcode.pl
perl embed.pl
it safe when used by a process with super-user privileges.
apiversion (patchlevel.U):
- This is a number which identifies the lowest version of perl
- to have an API (for XS extensions) compatible with the present
- version. For example, for 5.005_01, the apiversion should be
- 5.005, since 5.005_01 should be binary compatible with 5.005.
- This should probably be incremented manually somehow, perhaps
- from patchlevel.h. For now, we'll guess maintenance subversions
- will retain binary compatibility.
+ MakeMaker will install add-on modules in a directory with the
+ PERL_APIVERSION version number. The value is set manually in
+ patchlevel.h. Normally, for maintenance releases, this is
+ just something like 5.005 or 5.6 or 5.7. That is, it does not
+ include the subversion number and does not change across
+ maintenance releases. This is so that add-on extensions can
+ be shared across maintenance versions. It is unclear how this
+ ought to work for developer versions. If a release breaks
+ binary compatibility, this number should be increased.
ar (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the ar program. After Configure runs,
the value is reset to a plain "ar" and is not useful.
include os2/os2.obj.
awk (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the awk program. After Configure runs,
the value is reset to a plain "awk" and is not useful.
The value is a plain '' and is not useful.
byacc (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the byacc program. After Configure runs,
the value is reset to a plain "byacc" and is not useful.
4 = couldn't cast in argument expression list
cat (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the cat program. After Configure runs,
the value is reset to a plain "cat" and is not useful.
included).
comm (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the comm program. After Configure runs,
the value is reset to a plain "comm" and is not useful.
is primarily for the use of other Configure units.
cp (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the cp program. After Configure runs,
the value is reset to a plain "cp" and is not useful.
The value is a plain '' and is not useful.
cpp (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the cpp program. After Configure runs,
the value is reset to a plain "cpp" and is not useful.
up to the Makefile to use this.
csh (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the csh program. After Configure runs,
the value is reset to a plain "csh" and is not useful.
the C program that it runs under Xenix.
date (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the date program. After Configure runs,
the value is reset to a plain "date" and is not useful.
See trnl.U
echo (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the echo program. After Configure runs,
the value is reset to a plain "echo" and is not useful.
egrep (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the egrep program. After Configure runs,
the value is reset to a plain "egrep" and is not useful.
This is an old synonym for _exe.
expr (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the expr program. After Configure runs,
the value is reset to a plain "expr" and is not useful.
this platform, libpth is the cleaned-up version.
grep (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the grep program. After Configure runs,
the value is reset to a plain "grep" and is not useful.
gidtype (gid_t), but sometimes it isn't.
gzip (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the gzip program. After Configure runs,
the value is reset to a plain "gzip" and is not useful.
string, the hints file must set this to 'none'.
less (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the less program. After Configure runs,
the value is reset to a plain "less" and is not useful.
the user. It is up to the Makefile to use this.
ln (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the ln program. After Configure runs,
the value is reset to a plain "ln" and is not useful.
The value is a plain '' and is not useful.
ls (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the ls program. After Configure runs,
the value is reset to a plain "ls" and is not useful.
The value is a plain '' and is not useful.
make (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the make program. After Configure runs,
the value is reset to a plain "make" and is not useful.
See man3dir.
Mcc (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the Mcc program. After Configure runs,
the value is reset to a plain "Mcc" and is not useful.
Possible values are "BSD 4.3" and "System V".
mkdir (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the mkdir program. After Configure runs,
the value is reset to a plain "mkdir" and is not useful.
modes for system calls.
more (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the more program. After Configure runs,
the value is reset to a plain "more" and is not useful.
This is only useful if you have getnetbyaddr(), naturally.
nm (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the nm program. After Configure runs,
the value is reset to a plain "nm" and is not useful.
in the package. All of them will be built.
nroff (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the nroff program. After Configure runs,
the value is reset to a plain "nroff" and is not useful.
shell scripts and in the "eval 'exec'" idiom.
pg (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the pg program. After Configure runs,
the value is reset to a plain "pg" and is not useful.
no data and an EOF.. Sigh!
rm (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the rm program. After Configure runs,
the value is reset to a plain "rm" and is not useful.
at configuration time, for programs not wanting to bother with it.
sed (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the sed program. After Configure runs,
the value is reset to a plain "sed" and is not useful.
This variable has the names of any libraries needed for socket support.
sort (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the sort program. After Configure runs,
the value is reset to a plain "sort" and is not useful.
The value is a plain '' and is not useful.
test (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the test program. After Configure runs,
the value is reset to a plain "test" and is not useful.
included). Anyway, the type Time_t should be used.
touch (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the touch program. After Configure runs,
the value is reset to a plain "touch" and is not useful.
tr (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the tr program. After Configure runs,
the value is reset to a plain "tr" and is not useful.
ushort, or whatever type is used to declare user ids in the kernel.
uname (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the uname program. After Configure runs,
the value is reset to a plain "uname" and is not useful.
uniq (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the uniq program. After Configure runs,
the value is reset to a plain "uniq" and is not useful.
This variable indicates if the the system supports dynamic
loading of some sort. See also dlsrc and dlobj.
-uselfs (uselfs.U):
+uselargefiles (uselfs.U):
This variable conditionally defines the USE_LARGE_FILES symbol,
and indicates that large file interfaces should be used when
available. The use64bits symbol will also be turned on if necessary.
The value is a plain '' and is not useful.
zip (Loc.U):
- This variable is be used internally by Configure to determine the
+ This variable is used internally by Configure to determine the
full pathname (if any) of the zip program. After Configure runs,
the value is reset to a plain "zip" and is not useful.
# Package name : perl5
# Source directory : .
-# Configuration time: Mon Sep 20 12:44:36 EET DST 1999
+# Configuration time: Thu Sep 30 19:44:33 EET DST 1999
# Configured by : jhi
# Target system : osf1 alpha.hut.fi v4.0 878 alpha
alignbytes='8'
ansi2knr=''
aphostname=''
-apiversion='5.00561'
+apiversion=''
ar='ar'
archlib='/opt/perl/lib/5.00561/alpha-dec_osf-thread'
archlibexp='/opt/perl/lib/5.00561/alpha-dec_osf-thread'
ccsymbols='__LANGUAGE_C__=1 _LONGLONG=1 LANGUAGE_C=1 SYSTYPE_BSD=1'
cf_by='jhi'
cf_email='yourname@yourhost.yourplace.com'
-cf_time='Mon Sep 20 12:44:36 EET DST 1999'
+cf_time='Thu Sep 30 19:44:33 EET DST 1999'
chgrp=''
chmod=''
chown=''
installprefixexp='/opt/perl'
installprivlib='/opt/perl/lib/5.00561'
installscript='/opt/perl/bin'
-installsitearch='/opt/perl/lib/site_perl/5.00561/alpha-dec_osf-thread'
+installsitearch='/opt/perl/lib/site_perl//alpha-dec_osf-thread'
installsitelib='/opt/perl/lib/site_perl'
installstyle='lib'
installusrbinperl='define'
sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 6 6 16 20 23 23 23 29 48 '
sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 6, 6, 16, 20, 23, 23, 23, 29, 48, 0'
signal_t='void'
-sitearch='/opt/perl/lib/site_perl/5.00561/alpha-dec_osf-thread'
-sitearchexp='/opt/perl/lib/site_perl/5.00561/alpha-dec_osf-thread'
+sitearch='/opt/perl/lib/site_perl//alpha-dec_osf-thread'
+sitearchexp='/opt/perl/lib/site_perl//alpha-dec_osf-thread'
sitelib='/opt/perl/lib/site_perl'
sitelibexp='/opt/perl/lib/site_perl'
siteprefix='/opt/perl'
uniq='uniq'
use64bits='define'
usedl='define'
-uselfs='define'
+uselargefiles='undef'
uselongdouble='undef'
usemorebits='undef'
usemultiplicity='undef'
/*
* Package name : perl5
* Source directory : .
- * Configuration time: Mon Sep 20 12:44:36 EET DST 1999
+ * Configuration time: Thu Sep 30 19:44:33 EET DST 1999
* Configured by : jhi
* Target system : osf1 alpha.hut.fi v4.0 878 alpha
*/
* This symbol contains the ~name expanded version of SITEARCH, to be used
* in programs that are not prepared to deal with ~ expansion at run-time.
*/
-#define SITEARCH "/opt/perl/lib/site_perl/5.00561/alpha-dec_osf-thread" /**/
-#define SITEARCH_EXP "/opt/perl/lib/site_perl/5.00561/alpha-dec_osf-thread" /**/
+#define SITEARCH "/opt/perl/lib/site_perl//alpha-dec_osf-thread" /**/
+#define SITEARCH_EXP "/opt/perl/lib/site_perl//alpha-dec_osf-thread" /**/
/* SITELIB:
* This symbol contains the name of the private library for this package.
* should be used when available. The USE_64_BITS symbol will
* also be turned on if necessary.
*/
-#define USE_LARGE_FILES /**/
+/*#define USE_LARGE_FILES / **/
/* USE_LONG_DOUBLE:
* This symbol, if defined, indicates that long doubles should
pad_reset_pending
padix
padix_floor
-parsehook
patchlevel
patleave
pending_ident
# endif /* NO_XSLOCKS */
#endif /* PERL_CAPI */
-#endif _INC_PERL_XSUB_H /* include guard */
+#endif /* _INC_PERL_XSUB_H */ /* include guard */
#define PL_pad_reset_pending (PERL_GET_INTERP->Ipad_reset_pending)
#define PL_padix (PERL_GET_INTERP->Ipadix)
#define PL_padix_floor (PERL_GET_INTERP->Ipadix_floor)
-#define PL_parsehook (PERL_GET_INTERP->Iparsehook)
#define PL_patchlevel (PERL_GET_INTERP->Ipatchlevel)
#define PL_pending_ident (PERL_GET_INTERP->Ipending_ident)
#define PL_perl_destruct_level (PERL_GET_INTERP->Iperl_destruct_level)
#define PL_pad_reset_pending (vTHX->Ipad_reset_pending)
#define PL_padix (vTHX->Ipadix)
#define PL_padix_floor (vTHX->Ipadix_floor)
-#define PL_parsehook (vTHX->Iparsehook)
#define PL_patchlevel (vTHX->Ipatchlevel)
#define PL_pending_ident (vTHX->Ipending_ident)
#define PL_perl_destruct_level (vTHX->Iperl_destruct_level)
#define PL_Ipad_reset_pending PL_pad_reset_pending
#define PL_Ipadix PL_padix
#define PL_Ipadix_floor PL_padix_floor
-#define PL_Iparsehook PL_parsehook
#define PL_Ipatchlevel PL_patchlevel
#define PL_Ipending_ident PL_pending_ident
#define PL_Iperl_destruct_level PL_perl_destruct_level
if ($^O eq 'VMS') { ($out) = __FILE__ =~ /^(.+)_PL$/i; }
$out =~ s/_h$/.h/;
open(OUT,">$out") || die "Cannot open $file:$!";
-print "Extracting $out . . .\n";
+print "Extracting $out...\n";
foreach my $const (qw(AVf_REAL
HEf_SVKEY
SVf_IOK SVf_IVisUV SVf_NOK SVf_POK
Please send any problems or suggested changes to perlbug@perl.com.
-Hint file naming convention: Each hint file name should have only
+=head1 Hint file naming convention.
+
+Each hint file name should have only
one '.'. (This is for portability to non-unix file systems.) Names
should also fit in <= 14 characters, for portability to older SVR3
systems. File names are of the form $osname_$osvers.sh, with all '.'
A glossary of config.sh variables is in the file Porting/Glossary.
+=head1 Setting variables
+
+=head2 Optimizer
+
+If you want to set a variable, try to allow for Configure command-line
+overrides. For example, suppose you think the default optimizer
+setting to be -O2 for a particular platform. You should allow for
+command line overrides with something like
+
+ case "$optimize" in
+ '') optimize='-O2' ;;
+ esac
+
+or, if your system has a decent test(1) command,
+
+ test -z "$optimize" && optimize='-O2'
+
+This allows the user to select a different optimization level, e.g.
+-O6 or -g.
+
+=head2 Compiler and Linker flags
+
+If you want to set $ccflags or $ldflags, you should append to the existing
+value to allow Configure command-line settings, e.g. use
+
+ ccflags="$ccflags -DANOTHER_OPTION_I_NEED"
+
+so that the user can do something like
+
+ sh Configure -Dccflags='FIX_NEGATIVE_ZERO'
+
+and have the FIX_NEGATIVE_ZERO value preserved by the hints file.
+
+=head2 Libraries
+
+Configure will attempt to use the libraries listed in the variable
+$libswanted. If necessary, you should remove broken libraries from
+that list, or add additional libraries to that list. You should
+*not* simply set $libs -- that ignores the possibilities of local
+variations. For example, a setting of libs='-lgdbm -lm -lc' would
+fail if another user were to try to compile Perl on a system without
+GDBM but with Berkeley DB. See hints/dec_osf.sh and hints/solaris_2.sh
+for examples.
+
+=head2 Other
+
+In general, try to avoid hard-wiring something that Configure will
+figure out anyway. Also try to allow for Configure command-line
+overrides.
+
=head1 Hint file tricks
=head2 Printing critical messages
Have the appropriate amount of fun :-)
- Andy Dougherty doughera@lafcol.lafayette.edu
+ Andy Dougherty doughera@lafayette.edu
glibpth="$libpth"
xlibpth="$libpth"
+# This should remove unwanted libraries instead of limiting the set
+# to just these few. E.g. what about Berkeley DB?
libswanted='gdbm m dld'
so=' '
# compiler & linker flags
+# Respect command-line values.
-ccflags='-DAMIGAOS -mstackextend'
-ldflags=''
-optimize='-O2 -fomit-frame-pointer'
+ccflags="$ccflags -DAMIGAOS -mstackextend"
+case "$optimize" in
+'') optimize='-O2 -fomit-frame-pointer';;
+esac
dlext='o'
+# Are these two different from the defaults?
cccdlflags='none'
ccdlflags='none'
lddlflags='-oformat a.out-amiga -r'
#! /bin/sh
# cygwin.sh - hints for building perl using the Cygwin environment for Win32
#
+# Many of these inflexible settings should be changed to allow command-
+# line overrides and allow for variations in local set-ups.
+# I have made first guesses at some of these, but would welcome
+# corrections from someone actually using Cygwin.
+# Andy Dougherty <doughera@lafayette.edu> Tue Sep 28 12:39:38 EDT 1999
_exe='.exe'
exe_ext='.exe'
startsh='#!/bin/sh'
archname='cygwin'
-cc='gcc'
+test -z "$cc" && cc='gcc'
libpth='/usr/i586-cygwin32/lib /usr/lib /usr/local/lib'
so='dll'
libs='-lcygwin -lm -lkernel32'
#optimize='-g'
-ccflags='-DCYGWIN -I/usr/include -I/usr/local/include'
-ldflags='-L/usr/i586-cygwin32/lib -L/usr/lib -L/usr/local/lib'
-usemymalloc='n'
+# Is -I/usr/include *really* needed?
+# Is -I/usr/local/include *really* needed? I thought gcc always looked there.
+ccflags="$ccflags -DCYGWIN -I/usr/include -I/usr/local/include"
+# Is -L/usr/lib *really* needed?
+ldflags="$ldflags -L/usr/i586-cygwin32/lib -L/usr/lib -L/usr/local/lib"
+test -z "$usemymalloc" && usemymalloc='n'
dlsrc='dl_cygwin.xs'
cccdlflags=' '
ld='ld2'
-lddlflags='-L/usr/local/lib'
+# Is -L/usr/local/lib *really* needed?
+lddlflags="$lddlflags -L/usr/local/lib"
useshrplib='true'
libperl='libperl.a'
dlext='dll'
dynamic_ext=' '
-man1dir=/usr/local/man/man1
-man3dir=/usr/local/man/man3
+# What if they aren't using $prefix=/usr/local ??
+# Why is this needed at all? Doesn't Configure suggest this?
+test -z "$man1dir" && man1dir=/usr/local/man/man1
+test -z "$man3dir" && man3dir=/usr/local/man/man3
case "$ldlibpthname" in
'') ldlibpthname=PATH ;;
# for performance, apparently this makes a huge difference (~krader)
d_vfork='define'
-optimize='-Wc,-O3 -W0,-xstring'
+case "$optimize" in
+'') optimize='-Wc,-O3 -W0,-xstring' ;;
+esac
# We override d_socket because it's very hard for Configure to get it right
# in Dynix/Ptx, for several reasons.
d_sockpair='define'
;;
4.2*) # on ptx/TCP 4.2, we can use BSD sockets, but they're not the default.
- cppflags='-Wc,+bsd-socket'
- ccflags='-Wc,+bsd-socket'
- ldflags='-Wc,+bsd-socket'
+ cppflags="$cppflags -Wc,+bsd-socket"
+ ccflags="$ccflags -Wc,+bsd-socket"
+ ldflags="$ldflags -Wc,+bsd-socket"
d_socket='define'
d_oldsock='undef'
d_sockpair='define'
# of libswanted excludes some libraries found there. You may want to
# prevent "ucb" from being removed from libswanted and see if perl will
# build on your system.
-ldflags='-non_shared -systype svr4 -L/svr4/usr/lib -L/svr4/usr/lib/cmplrs/cc -L/usr/ccs/lib -L/svr4/usr/ucblib'
-ccflags='-systype svr4 -D__STDC__=0 -I/svr4/usr/include -I/svr4/usr/ucbinclude'
-cppflags='-D__STDC__=0 -I/svr4/usr/include -I/svr4/usr/ucbinclude'
+ldflags="$ldflags -non_shared -systype svr4 -L/svr4/usr/lib -L/svr4/usr/lib/cmplrs/cc -L/usr/ccs/lib -L/svr4/usr/ucblib"
+ccflags="$ccflags -systype svr4 -D__STDC__=0 -I/svr4/usr/include -I/svr4/usr/ucbinclude"
+cppflags="$ccflags -D__STDC__=0 -I/svr4/usr/include -I/svr4/usr/ucbinclude"
# Don't use problematic libraries:
# Kevin O'Gorman ( kevin@kosman.UUCP, kevin%kosman.uucp@nrc.com )
#
# Use Configure -Dcc=gcc to use gcc.
+
+# Why can't we just use PATH? It contains /usr/ccs/bin.
case "$cc" in
'') cc='/bin/cc'
test -f $cc || cc='/usr/ccs/bin/cc'
;;
esac
-ldflags='-L/usr/ccs/lib -L/usr/ucblib'
+
+ldflags="$ldflags -L/usr/ccs/lib -L/usr/ucblib"
test -d /usr/local/man || mansrc='none'
-ccflags='-I/usr/include -I/usr/ucbinclude'
+# Do we really need to tell cc to look in /usr/include?
+ccflags="$ccflags -I/usr/include -I/usr/ucbinclude"
libswanted=`echo " $libswanted " | sed -e 's/ malloc / /' `
d_index='undef'
d_suidsafe=define
# The weird include path is really to work around some bugs in
# broken system header files.
-ccflags="-D__MINT__ -Uatarist -DDEBUGGING -I$here/../mint"
+ccflags="$ccflags -D__MINT__ -Uatarist -DDEBUGGING -I$here/../mint"
# libs
#
# Some good answers to the questions in Configure:
+# Does Configure really get all these wrong?
usenm='true'
d_suidsafe='true'
clocktype='long'
# Revised again for 5.004_69 by Mark Bixby, markb@cccd.edu.
#
osname='mpeix'
-osvers='5.5'
+osvers='5.5' # Isn't there a way to determine this dynamically?
#
# Force Configure to use our wrapper mpeix/nm script
#
#
# Various directory locations.
#
-prefix='/PERL/PUB'
+# Which ones of these does Configure get wrong?
+test -z "$prefix" && prefix='/PERL/PUB'
archname='PA-RISC1.1'
bin="$prefix"
installman1dir="$prefix/man/man1"
#
# Compiling.
#
-cc='gcc'
+test -z "$cc" && cc='gcc'
cccdlflags='none'
-ccflags='-DMPE -D_POSIX_SOURCE -D_SOCKET_SOURCE -D_POSIX_JOB_CONTROL -DIS_SOCKET_CLIB_ITSELF'
-locincpth='/usr/local/include /usr/contrib/include /BIND/PUB/include'
-optimize='-O2'
+ccflags="$ccflags -DMPE -D_POSIX_SOURCE -D_SOCKET_SOURCE -D_POSIX_JOB_CONTROL -DIS_SOCKET_CLIB_ITSELF"
+locincpth="$locincpth /usr/local/include /usr/contrib/include /BIND/PUB/include"
+test -z "$optimize" && optimize="-O2"
ranlib='/bin/true'
# Special compiling options for certain source files.
+# But what if you want -g?
regcomp_cflags='optimize=-O'
toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"'
#
# Linking.
#
lddlflags='-b'
-libs='-lbind -lsyslog -lcurses -lsvipc -lsocket -lm -lc'
-loclibpth='/usr/local/lib /usr/contrib/lib /BIND/PUB/lib /SYSLOG/PUB'
+# What if you want additional libs (e.g. gdbm)?
+# This should remove the unwanted libraries from $libswanted and
+# add on whatever ones are needed instead.
+libs="$libs -lbind -lsyslog -lcurses -lsvipc -lsocket -lm -lc"
+loclibpth="$loclibpth /usr/local/lib /usr/contrib/lib /BIND/PUB/lib /SYSLOG/PUB"
#
# External functions and data items.
#
+# Does Configure *really* get *all* of these wrong?
+#
d_crypt='define'
d_difftime='define'
d_dlerror='undef'
# use the following two lines if you have perl5.003_22 or better and
# do not encounter intermittent core dumps.
-ccflags='-DUSE_NEXT_CTYPE'
+ccflags="$ccflags -DUSE_NEXT_CTYPE"
usemymalloc='n'
######################################################################
echo It will not be found there. Try moving it to >&4
echo /NextDeveloper/Headers/bsd/gdbm.h. >&4
-ccflags='-DUSE_NEXT_CTYPE -DNEXT30_NO_ATTRIBUTE'
+ccflags="$ccflags -DUSE_NEXT_CTYPE -DNEXT30_NO_ATTRIBUTE"
POSIX_cflags='ccflags="-posix $ccflags"'
useposix='undef'
-ldflags='-u libsys_s'
-libswanted='dbm gdbm db'
+ldflags="$ldflags -u libsys_s"
+libswanted="$libswanted dbm gdbm db"
#
lddlflags='-r'
# Give cccdlflags an empty value since Configure will detect we are
libswanted=' '
libc='/NextLibrary/Frameworks/System.framework/System'
-ldflags='-dynamic -prebind'
-lddlflags='-dynamic -bundle -undefined suppress'
-ccflags='-dynamic -fno-common -DUSE_NEXT_CTYPE -DUSE_PERL_SBRK'
+ldflags="$ldflags -dynamic -prebind"
+lddlflags="$lddlflags -dynamic -bundle -undefined suppress"
+ccflags="$ccflags -dynamic -fno-common -DUSE_NEXT_CTYPE -DUSE_PERL_SBRK"
cccdlflags='none'
ld='cc'
#optimize='-g -O'
PERLVAR(Iorigfilename, char *)
PERLVAR(Idiehook, SV *)
PERLVAR(Iwarnhook, SV *)
-PERLVAR(Iparsehook, SV *)
PERLVAR(Icddir, char *) /* switches */
PERLVAR(Iminus_c, bool)
PERLVARA(Ipatchlevel,10,char)
timethese - run several chunks of code several times
+cmpthese - print results of timethese as a comparison chart
+
timeit - run a chunk of code and see how long it goes
+countit - see how many times a chunk of code runs in a given time
+
=head1 SYNOPSIS
timethis ($count, "code");
'Name2' => sub { ...code2... },
});
+ # cmpthese can be used both ways as well
+ cmpthese($count, {
+ 'Name1' => '...code1...',
+ 'Name2' => '...code2...',
+ });
+
+ cmpthese($count, {
+ 'Name1' => sub { ...code1... },
+ 'Name2' => sub { ...code2... },
+ });
+
+ # ...or in two stages
+ $results = timethese($count,
+ {
+ 'Name1' => sub { ...code1... },
+ 'Name2' => sub { ...code2... },
+ },
+ 'none'
+ );
+ cmpthese( $results ) ;
+
$t = timeit($count, '...other code...')
print "$count loops of other code took:",timestr($t),"\n";
+ $t = countit($time, '...other code...')
+ $count = $t->iters ;
+ print "$count loops of other code took:",timestr($t),"\n";
+
=head1 DESCRIPTION
The Benchmark module encapsulates a number of routines to help you
$t = timeit(10, ' 5 ** $Global ');
debug Benchmark 0;
+=item iters
+
+Returns the number of iterations.
+
=back
=head2 Standard Exports
=over 10
+=item cmpthese ( COUT, CODEHASHREF, [ STYLE ] )
+
+=item cmpthese ( RESULTSHASHREF )
+
+Optionally calls timethese(), then outputs comparison chart. This
+chart is sorted from slowest to highest, and shows the percent
+speed difference between each pair of tests. Can also be passed
+the data structure that timethese() returns:
+
+ $results = timethese( .... );
+ cmpthese( $results );
+
+Returns the data structure returned by timethese().
+
+=item countit(TIME, CODE)
+
+Arguments: TIME is the minimum length of time to run CODE for, and CODE is
+the code to run. CODE may be either a code reference or a string to
+be eval'd; either way it will be run in the caller's package.
+
+TIME is I<not> negative. countit() will run the loop many times to
+calculate the speed of CODE before running it for TIME. The actual
+time run for will usually be greater than TIME due to system clock
+resolution, so it's best to look at the number of iterations divided
+by the times that you are concerned with, not just the iterations.
+
+Returns: a Benchmark object.
+
=item timeit(COUNT, CODE)
Arguments: COUNT is the number of times to run the loop, and CODE is
The COUNT can be zero or negative, see timethis().
+Returns a hash of Benchmark objects, keyed by name.
+
=item timediff ( T1, T2 )
Returns the difference between two Benchmark times as a Benchmark
the requested STYLE. TIMEDIFF is expected to be a Benchmark object
similar to that returned by timediff().
-STYLE can be any of 'all', 'noc', 'nop' or 'auto'. 'all' shows each
-of the 5 times available ('wallclock' time, user time, system time,
+STYLE can be any of 'all', 'none', 'noc', 'nop' or 'auto'. 'all' shows
+each of the 5 times available ('wallclock' time, user time, system time,
user time of children, and system time of children). 'noc' shows all
except the two children times. 'nop' shows only wallclock and the
two children times. 'auto' (the default) will act as 'all' unless
the children times are both zero, in which case it acts as 'noc'.
+'none' prevents output.
FORMAT is the L<printf(3)>-style format specifier (without the
leading '%') to use to print the times. It defaults to '5.2f'.
The data is stored as a list of values from the time and times
functions:
- ($real, $user, $system, $children_user, $children_system)
+ ($real, $user, $system, $children_user, $children_system, $iters)
in seconds for the whole loop (not divided by the number of rounds).
number of rounds but empty loop body) is subtracted
from the time of the real loop.
-The null loop times are cached, the key being the
+The null loop times can be cached, the key being the
number of rounds. The caching can be controlled using
calls like these:
disablecache();
enablecache();
+Caching is off by default, as it can (usually slightly) decrease
+accuracy and does not usually noticably affect runtimes.
+
=head1 INHERITANCE
Benchmark inherits from no other class, except of course
=head1 CAVEATS
Comparing eval'd strings with code references will give you
-inaccurate results: a code reference will show a slower
+inaccurate results: a code reference will show a slightly slower
execution time than the equivalent eval'd string.
The real time timing is done using time(2) and
April 04-07th, 1997: by Jarkko Hietaniemi, added the run-for-some-time
functionality.
+September, 1999; by Barrie Slaymaker: math fixes and accuracy and
+efficiency tweaks. Added cmpthese(). A result is now returned from
+timethese(). Exposed countit() (was runfor()).
+
=cut
# evaluate something in a clean lexical environment
use Carp;
use Exporter;
@ISA=(Exporter);
-@EXPORT=qw(timeit timethis timethese timediff timesum timestr);
+@EXPORT=qw(cmpthese countit timeit timethis timethese timediff timestr);
@EXPORT_OK=qw(clearcache clearallcache disablecache enablecache);
&init;
sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; }
sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; }
sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; }
+sub iters { $_[0]->[5] ; }
sub timediff {
my($a, $b) = @_;
croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@;
print STDERR "runloop $n '$subcode'\n" if $debug;
- # Wait for the user timer to tick. This makes the error range more like -0.01, +0. If
- # we don't wait, then it's more like -0.01, +0.01. This may not seem important, but it
- # significantly reduces the chances of getting too low initial $n in the initial, 'find
- # the minimum' loop in &runfor. This, in turn, can reduce the number of calls to
+ # Wait for the user timer to tick. This makes the error range more like
+ # -0.01, +0. If we don't wait, then it's more like -0.01, +0.01. This
+ # may not seem important, but it significantly reduces the chances of
+ # getting a too low initial $n in the initial, 'find the minimum' loop
+ # in &countit. This, in turn, can reduce the number of calls to
# &runloop a lot, and thus reduce additive errors.
my $tbase = Benchmark->new(0)->[1];
do {
$t0 = Benchmark->new(0);
- } while ( $t0->[1] == $tbase ) ;
+ } while ( $t0->[1] == $tbase );
&$subref;
$t1 = Benchmark->new($n);
$td = &timediff($t1, $t0);
my($wn, $wc, $wd);
printf STDERR "timeit $n $code\n" if $debug;
- my $cache_key = $n . ( ref( $code ) ? 'c' : 's' ) ;
+ my $cache_key = $n . ( ref( $code ) ? 'c' : 's' );
if ($cache && exists $cache{$cache_key} ) {
$wn = $cache{$cache_key};
} else {
$wn = &runloop($n, ref( $code ) ? sub { undef } : '' );
+ # Can't let our baseline have any iterations, or they get subtracted
+ # out of the result.
+ $wn->[5] = 0;
$cache{$cache_key} = $wn;
}
$wc = &runloop($n, $code);
$wd = timediff($wc, $wn);
-
timedebug("timeit: ",$wc);
timedebug(" - ",$wn);
timedebug(" = ",$wd);
my $default_for = 3;
my $min_for = 0.1;
-sub runfor {
- my ($code, $tmax) = @_;
+
+sub countit {
+ my ( $tmax, $code ) = @_;
if ( not defined $tmax or $tmax == 0 ) {
$tmax = $default_for;
$tmax = -$tmax;
}
- die "runfor(..., $tmax): timelimit cannot be less than $min_for.\n"
+ die "countit($tmax, ...): timelimit cannot be less than $min_for.\n"
if $tmax < $min_for;
- my ($n, $td, $tc, $ntot, $rtot, $utot, $stot, $cutot, $cstot );
+ my ($n, $tc);
# First find the minimum $n that gives a significant timing.
-
- my $nmin;
+ for ($n = 1; ; $n *= 2 ) {
+ my $td = timeit($n, $code);
+ $tc = $td->[1] + $td->[2];
+ last if $tc > 0.1;
+ }
- for ($n = 1, $tc = 0; ; $n *= 2 ) {
- $td = timeit($n, $code);
+ my $nmin = $n;
+
+ # Get $n high enough that we can guess the final $n with some accuracy.
+ my $tpra = 0.1 * $tmax; # Target/time practice.
+ while ( $tc < $tpra ) {
+ # The 5% fudge is to keep us from iterating again all
+ # that often (this speeds overall responsiveness when $tmax is big
+ # and we guess a little low). This does not noticably affect
+ # accuracy since we're not couting these times.
+ $n = int( $tpra * 1.05 * $n / $tc ); # Linear approximation.
+ my $td = timeit($n, $code);
$tc = $td->[1] + $td->[2];
- last if $tc > 0.1 ;
}
- $nmin = $n;
-
- my $ttot = 0;
- my $tpra = 0.05 * $tmax; # Target/time practice.
- # Double $n until we have think we have practiced enough.
- for ( ; $ttot < $tpra; $n *= 2 ) {
- $td = timeit($n, $code);
- $ntot += $n;
- $rtot += $td->[0];
- $utot += $td->[1];
- $stot += $td->[2];
- $ttot = $utot + $stot;
+ # Now, do the 'for real' timing(s), repeating until we exceed
+ # the max.
+ my $ntot = 0;
+ my $rtot = 0;
+ my $utot = 0.0;
+ my $stot = 0.0;
+ my $cutot = 0.0;
+ my $cstot = 0.0;
+ my $ttot = 0.0;
+
+ # The 5% fudge is because $n is often a few % low even for routines
+ # with stable times and avoiding extra timeit()s is nice for
+ # accuracy's sake.
+ $n = int( $n * ( 1.05 * $tmax / $tc ) );
+
+ while () {
+ my $td = timeit($n, $code);
+ $ntot += $n;
+ $rtot += $td->[0];
+ $utot += $td->[1];
+ $stot += $td->[2];
$cutot += $td->[3];
$cstot += $td->[4];
- }
-
- my $r;
+ $ttot = $utot + $stot;
+ last if $ttot >= $tmax;
- # Then iterate towards the $tmax.
- while ( $ttot < $tmax ) {
- $r = $tmax / $ttot - 1; # Linear approximation.
+ my $r = $tmax / $ttot - 1; # Linear approximation.
$n = int( $r * $ntot );
$n = $nmin if $n < $nmin;
- $td = timeit($n, $code);
- $ntot += $n;
- $rtot += $td->[0];
- $utot += $td->[1];
- $stot += $td->[2];
- $ttot = $utot + $stot;
- $cutot += $td->[3];
- $cstot += $td->[4];
}
return bless [ $rtot, $utot, $stot, $cutot, $cstot, $ntot ];
$title = "timethis $n" unless defined $title;
} else {
$fort = n_to_for( $n );
- $t = runfor($code, $fort);
+ $t = countit( $fort, $code );
$title = "timethis for $fort" unless defined $title;
$forn = $t->[-1];
}
local $| = 1;
$style = "" unless defined $style;
- printf("%10s: ", $title);
- print timestr($t, $style, $defaultfmt),"\n";
+ printf("%10s: ", $title) unless $style eq 'none';
+ print timestr($t, $style, $defaultfmt),"\n" unless $style eq 'none';
$n = $forn if defined $forn;
unless ref $alt eq HASH;
my @names = sort keys %$alt;
$style = "" unless defined $style;
- print "Benchmark: ";
+ print "Benchmark: " unless $style eq 'none';
if ( $n > 0 ) {
croak "non-integer loopcount $n, stopped" if int($n)<$n;
- print "timing $n iterations of";
+ print "timing $n iterations of" unless $style eq 'none';
} else {
- print "running";
+ print "running" unless $style eq 'none';
}
- print " ", join(', ',@names);
+ print " ", join(', ',@names) unless $style eq 'none';
unless ( $n > 0 ) {
my $for = n_to_for( $n );
- print ", each for at least $for CPU seconds";
+ print ", each for at least $for CPU seconds" unless $style eq 'none';
}
- print "...\n";
+ print "...\n" unless $style eq 'none';
# we could save the results in an array and produce a summary here
# sum, min, max, avg etc etc
+ my %results;
foreach my $name (@names) {
- timethis ($n, $alt -> {$name}, $name, $style);
+ $results{$name} = timethis ($n, $alt -> {$name}, $name, $style);
+ }
+
+ return \%results;
+}
+
+sub cmpthese{
+ my $results = ref $_[0] ? $_[0] : timethese( @_ );
+
+ return $results
+ if defined $_[2] && $_[2] eq 'none';
+
+ # Flatten in to an array of arrays with the name as the first field
+ my @vals = map{ [ $_, @{$results->{$_}} ] } keys %$results;
+
+ for (@vals) {
+ # The epsilon fudge here is to prevent div by 0. Since clock
+ # resolutions are much larger, it's below the noise floor.
+ my $rate = $_->[6] / ( $_->[2] + $_->[3] + 0.000000000000001 );
+ $_->[7] = $rate;
+ }
+
+ # Sort by rate
+ @vals = sort { $a->[7] <=> $b->[7] } @vals;
+
+ # If more than half of the rates are greater than one...
+ my $display_as_rate = $vals[$#vals>>1]->[7] > 1;
+
+ my @rows;
+ my @col_widths;
+
+ my @top_row = (
+ '',
+ $display_as_rate ? 'Rate' : 's/iter',
+ map { $_->[0] } @vals
+ );
+
+ push @rows, \@top_row;
+ @col_widths = map { length( $_ ) } @top_row;
+
+ # Build the data rows
+ # We leave the last column in even though it never has any data. Perhaps
+ # it should go away. Also, perhaps a style for a single column of
+ # percentages might be nice.
+ for my $row_val ( @vals ) {
+ my @row;
+
+ # Column 0 = test name
+ push @row, $row_val->[0];
+ $col_widths[0] = length( $row_val->[0] )
+ if length( $row_val->[0] ) > $col_widths[0];
+
+ # Column 1 = performance
+ my $row_rate = $row_val->[7];
+
+ # We assume that we'll never get a 0 rate.
+ my $a = $display_as_rate ? $row_rate : 1 / $row_rate;
+
+ # Only give a few decimal places before switching to sci. notation,
+ # since the results aren't usually that accurate anyway.
+ my $format =
+ $a >= 100 ?
+ "%0.0f" :
+ $a >= 10 ?
+ "%0.1f" :
+ $a >= 1 ?
+ "%0.2f" :
+ $a >= 0.1 ?
+ "%0.3f" :
+ "%0.2e";
+
+ $format .= "/s"
+ if $display_as_rate;
+ # Using $b here due to optimizing bug in _58 through _61
+ my $b = sprintf( $format, $a );
+ push @row, $b;
+ $col_widths[1] = length( $b )
+ if length( $b ) > $col_widths[1];
+
+ # Columns 2..N = performance ratios
+ my $skip_rest = 0;
+ for ( my $col_num = 0 ; $col_num < @vals ; ++$col_num ) {
+ my $col_val = $vals[$col_num];
+ my $out;
+ if ( $skip_rest ) {
+ $out = '';
+ }
+ elsif ( $col_val->[0] eq $row_val->[0] ) {
+ $out = "--";
+ # $skip_rest = 1;
+ }
+ else {
+ my $col_rate = $col_val->[7];
+ $out = sprintf( "%.0f%%", 100*$row_rate/$col_rate - 100 );
+ }
+ push @row, $out;
+ $col_widths[$col_num+2] = length( $out )
+ if length( $out ) > $col_widths[$col_num+2];
+
+ # A little wierdness to set the first column width properly
+ $col_widths[$col_num+2] = length( $col_val->[0] )
+ if length( $col_val->[0] ) > $col_widths[$col_num+2];
+ }
+ push @rows, \@row;
+ }
+
+ # Equalize column widths in the chart as much as possible without
+ # exceeding 80 characters. This does not use or affect cols 0 or 1.
+ my @sorted_width_refs =
+ sort { $$a <=> $$b } map { \$_ } @col_widths[2..$#col_widths];
+ my $max_width = ${$sorted_width_refs[-1]};
+
+ my $total = 0;
+ for ( @col_widths ) { $total += $_ }
+
+ STRETCHER:
+ while ( $total < 80 ) {
+ my $min_width = ${$sorted_width_refs[0]};
+ last
+ if $min_width == $max_width;
+ for ( @sorted_width_refs ) {
+ last
+ if $$_ > $min_width;
+ ++$$_;
+ ++$total;
+ last STRETCHER
+ if $total >= 80;
+ }
}
+
+ # Dump the output
+ my $format = join( ' ', map { "%${_}s" } @col_widths ) . "\n";
+ substr( $format, 1, 0 ) = '-';
+ for ( @rows ) {
+ printf $format, @$_;
+ }
+
+ return $results;
}
+
1;
$thisdone |= $var_name eq "THIS";
$retvaldone |= $var_name eq "RETVAL";
$var_types{$var_name} = $var_type;
- print "\t" . &map_type($var_type);
+ # XXXX This check is a safeguard against the unfinished conversion of
+ # generate_init(). When generate_init() is fixed,
+ # one can use 2-args map_type() unconditionally.
+ if ($var_type =~ / \( \s* \* \s* \) /x) {
+ # Function pointers are not yet supported with &output_init!
+ print "\t" . &map_type($var_type, $var_name);
+ $name_printed = 1;
+ } else {
+ print "\t" . &map_type($var_type);
+ $name_printed = 0;
+ }
$var_num = $args_match{$var_name};
$proto_arg[$var_num] = ProtoString($var_type)
$func_args =~ s/\b($var_name)\b/&$1/;
}
if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/) {
+ if ($name_printed) {
+ print ";\n";
+ } else {
print "\t$var_name;\n";
+ }
} elsif ($var_init =~ /\S/) {
- &output_init($var_type, $var_num, $var_name, $var_init);
+ &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
} elsif ($var_num) {
# generate initialization code
- &generate_init($var_type, $var_num, $var_name);
+ &generate_init($var_type, $var_num, $var_name, $name_printed);
} else {
print ";\n";
}
$_ = '' ;
} else {
if ($ret_type ne "void") {
- print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
+ print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
if !$retvaldone;
$args_match{"RETVAL"} = 0;
$var_types{"RETVAL"} = $ret_type;
&Exit;
sub output_init {
- local($type, $num, $var, $init) = @_;
+ local($type, $num, $var, $init, $name_printed) = @_;
local($arg) = "ST(" . ($num - 1) . ")";
if( $init =~ /^=/ ) {
- eval qq/print "\\t$var $init\\n"/;
+ if ($name_printed) {
+ eval qq/print " $init\\n"/;
+ } else {
+ eval qq/print "\\t$var $init\\n"/;
+ }
warn $@ if $@;
} else {
if( $init =~ s/^\+// && $num ) {
- &generate_init($type, $num, $var);
+ &generate_init($type, $num, $var, $name_printed);
+ } elsif ($name_printed) {
+ print ";\n";
+ $init =~ s/^;//;
} else {
eval qq/print "\\t$var;\\n"/;
warn $@ if $@;
if (defined($defaults{$var})) {
$expr =~ s/(\t+)/$1 /g;
$expr =~ s/ /\t/g;
- eval qq/print "\\t$var;\\n"/;
- warn $@ if $@;
+ if ($name_printed) {
+ print ";\n";
+ } else {
+ eval qq/print "\\t$var;\\n"/;
+ warn $@ if $@;
+ }
$deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
warn $@ if $@;
} elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
- eval qq/print "\\t$var;\\n"/;
- warn $@ if $@;
+ if ($name_printed) {
+ print ";\n";
+ } else {
+ eval qq/print "\\t$var;\\n"/;
+ warn $@ if $@;
+ }
$deferred .= eval qq/"\\n$expr;\\n"/;
warn $@ if $@;
} else {
+ die "panic: do not know how to handle this branch for function pointers"
+ if $name_printed;
eval qq/print "$expr;\\n"/;
warn $@ if $@;
}
}
sub map_type {
- my($type) = @_;
+ my($type, $varname) = @_;
$type =~ tr/:/_/;
$type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
+ if ($varname) {
+ if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
+ (substr $type, pos $type, 0) = " $varname ";
+ } else {
+ $type .= "\t$varname";
+ }
+ }
$type;
}
svp = &PL_diehook;
else if (strEQ(s,"__WARN__"))
svp = &PL_warnhook;
- else if (strEQ(s,"__PARSE__"))
- svp = &PL_parsehook;
else
Perl_croak(aTHX_ "No such hook: %s", s);
i = 0;
#define PL_padix (*Perl_Ipadix_ptr(aTHXo))
#undef PL_padix_floor
#define PL_padix_floor (*Perl_Ipadix_floor_ptr(aTHXo))
-#undef PL_parsehook
-#define PL_parsehook (*Perl_Iparsehook_ptr(aTHXo))
#undef PL_patchlevel
#define PL_patchlevel (*Perl_Ipatchlevel_ptr(aTHXo))
#undef PL_pending_ident
# ucfirst etc not OK: TMP arg processed inplace
# each repeat not OK too due to array context
# pack split - unknown whether they are safe
+# sprintf: is calling do_sprintf(TARG,...) which can act on TARG
+# before other args are processed.
# pp_hot.c
# readline - unknown whether it is safe
index index ck_index isT@ S S S?
rindex rindex ck_index isT@ S S S?
-sprintf sprintf ck_fun_locale mfsT@ S L
+sprintf sprintf ck_fun_locale mfst@ S L
formline formline ck_fun ms@ S L
ord ord ck_fun ifsTu% S?
chr chr ck_fun fsTu% S?
PL_warnhook = Nullsv;
SvREFCNT_dec(PL_diehook);
PL_diehook = Nullsv;
- SvREFCNT_dec(PL_parsehook);
- PL_parsehook = Nullsv;
/* call exit list functions */
while (PL_exitlistlen-- > 0)
TODO
+=over 4
+
+=item Possibly changed pseudo-random number generator
+
+In 5.005_0x and earlier, perl's rand() function used the C library
+rand(3) function. As of 5.005_52, Configure tests for drand48(),
+random(), and rand() (in that order) and picks the first one it finds.
+Perl programs that depend on reproducing a specific set of pseudo-random
+numbers will now likely produce different output.
+
+=back
+
=head2 C Source Incompatibilities
=over 4
len);>. It might work with your compiler, but it won't work for everyone.
Break this sort of statement up into separate assignments:
+ SV *s;
STRLEN len;
char * ptr;
- ptr = SvPV(len);
+ ptr = SvPV(s, len);
foo(ptr, len);
If you want to know if the scalar value is TRUE, you can use:
Test two strings to see if they are equal. The C<len> parameter indicates
the number of bytes to compare. Returns true or false.
+(A wrapper for C<strncmp>).
- int strnEQ( char *s1, char *s2 )
+ int strnEQ( const char *s1, const char *s2, size_t len )
=item strnNE
Test two strings to see if they are different. The C<len> parameter
indicates the number of bytes to compare. Returns true or false.
+(A wrapper for C<strncmp>).
- int strnNE( char *s1, char *s2, int len )
+ int strnNE( const char *s1, const char *s2, size_t len )
=item sv_2mortal
print "ok 11\n";
unlink "lib/file-$$" or die "unlink: $!";
+END {
+ 1 while unlink "file-$$";
+ 1 while unlink "lib/file-$$";
+}
{print "not ok 5\n";}
# This could be stricter.
-if (gmtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Nov|Dec) ([ \d]\d) (\d\d):(\d\d):(\d\d) (\d\d\d\d)$/)
+if (gmtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) ([ \d]\d) (\d\d):(\d\d):(\d\d) (\d\d\d\d)$/)
{print "ok 6\n";}
else
{print "not ok 6\n";}
=item B<-F>
Additional flags to specify to C preprocessor when scanning header for
-function declarations. Should not be used without B<-x>.
+function declarations. Should not be used without B<-x>.
+
+=item B<-M> I<regular expression>
+
+selects functions/macros to process.
=item B<-O>
=item B<-f>
Allows an extension to be created for a header even if that header is
-not found in /usr/include.
+not found in standard include directories.
=item B<-h>
Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
+=item B<-o> I<regular expression>
+
+Use "opaque" data type for the C types matched by the regular
+expression, even if these types are C<typedef>-equivalent to types
+from typemaps. Should not be used without B<-x>.
+
+This may be useful since, say, types which are C<typedef>-equivalent
+to integers may represent OS-related handles, and one may want to work
+with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
+Use C<-o .> if you want to handle all the C<typedef>ed types as opaque types.
+
+The type-to-match is whitewashed (except for commas, which have no
+whitespace before them, and multiple C<*> which have no whitespace
+between them).
+
=item B<-p> I<prefix>
Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_>
Note that some types of arguments/return-values for functions may
result in XSUB-declarations/typemap-entries which need
hand-editing. Such may be objects which cannot be converted from/to a
-pointer (like C<long long>), pointers to functions, or arrays.
+pointer (like C<long long>), pointers to functions, or arrays. See
+also the section on L<LIMITATIONS of B<-x>>.
=back
# Same with function declaration in proto.h as visible from perl.h.
h2xs -xAn perl2 perl.h,proto.h
+ # Same but select only functions which match /^av_/
+ h2xs -M '^av_' -xAn perl2 perl.h,proto.h
+
+ # Same but treat SV* etc as "opaque" types
+ h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
+
=head1 ENVIRONMENT
No environment variables are used.
The usual warnings if it cannot read or write the files involved.
+=head1 LIMITATIONS of B<-x>
+
+F<h2xs> would not distinguish whether an argument to a C function
+which is of the form, say, C<int *>, is an input, output, or
+input/output parameter. In particular, argument declarations of the
+form
+
+ int
+ foo(n)
+ int *n
+
+should be better rewritten as
+
+ int
+ foo(n)
+ int &n
+
+if C<n> is an input parameter.
+
+Additionally, F<h2xs> has no facilities to intuit that a function
+
+ int
+ foo(addr,l)
+ char *addr
+ int l
+
+takes a pair of address and length of data at this address, so it is better
+to rewrite this function as
+
+ int
+ foo(sv)
+ SV *addr
+ PREINIT:
+ STRLEN len;
+ char *s;
+ CODE:
+ s = SvPV(sv,len);
+ RETVAL = foo(s, len);
+ OUTPUT:
+ RETVAL
+
+or alternately
+
+ static int
+ my_foo(SV *sv)
+ {
+ STRLEN len;
+ char *s = SvPV(sv,len);
+
+ return foo(s, len);
+ }
+
+ MODULE = foo PACKAGE = foo PREFIX = my_
+
+ int
+ foo(sv)
+ SV *sv
+
+See L<perlxs> and L<perlxstut> for additional details.
+
=cut
-my( $H2XS_VERSION ) = ' $Revision: 1.19 $ ' =~ /\$Revision:\s+([^\s]+)/;
+use strict;
+
+
+my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/;
my $TEMPLATE_VERSION = '0.01';
+my @ARGS = @ARGV;
use Getopt::Std;
-A Omit all autoloading facilities (implies -c).
-C Omit creating the Changes file, add HISTORY heading to stub POD.
-F Additional flags for C preprocessor (used with -x).
+ -M Mask to select C functions/macros (default is select all).
-O Allow overwriting of a pre-existing extension directory.
-P Omit the stub POD section.
-X Omit the XS portion (implies both -c and -f).
-f Force creation of the extension even if the C header does not exist.
-h Display this help message
-n Specify a name to use for the extension (recommended).
+ -o Regular expression for \"opaque\" types.
-p Specify a prefix which should be removed from the Perl function names.
-s Create subroutines for specified macros.
-v Specify a version number for this extension.
}
-getopts("ACF:OPXcdfhn:p:s:v:x") || usage;
+getopts("ACF:M:OPXcdfhn:o:p:s:v:x") || usage;
+use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_c
+ $opt_d $opt_f $opt_h $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x);
usage if $opt_h;
# -X implies -c and -f
$opt_c = $opt_f = 1 if $opt_X;
-%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
+my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
+my $extralibs;
+my @path_h;
while (my $arg = shift) {
if ($arg =~ /^-l/i) {
usage "Must supply header file or module name\n"
unless (@path_h or $opt_n);
+my $fmask;
+my $tmask;
+
+$fmask = qr{$opt_M} if defined $opt_M;
+$tmask = qr{$opt_o} if defined $opt_o;
+my $tmask_all = $tmask && $opt_o eq '.';
+
+if ($opt_x) {
+ eval {require C::Scan; 1}
+ or die <<EOD;
+C::Scan required if you use -x option.
+To install C::Scan, execute
+ perl -MCPAN -e "install C::Scan"
+EOD
+ unless ($tmask_all) {
+ $C::Scan::VERSION >= 0.70
+ or die <<EOD;
+C::Scan v. 0.70 or later required unless you use -o . option.
+You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
+To install C::Scan, execute
+ perl -MCPAN -e "install C::Scan"
+EOD
+ }
+} elsif ($opt_o or $opt_F) {
+ warn <<EOD;
+Options -o and -F do not make sense without -x.
+EOD
+}
+
+my @path_h_ini = @path_h;
+my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
if( @path_h ){
+ use Config;
+ use File::Spec;
+ my @paths;
+ if ($^O eq 'VMS') { # Consider overrides of default location
+ # XXXX This is not equivalent to what the older version did:
+ # it was looking at $hadsys header-file per header-file...
+ my($hadsys) = grep s!^sys/!!i , @path_h;
+ @paths = qw( Sys\$Library VAXC$Include );
+ push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
+ push @paths, qw( DECC$Library_Include DECC$System_Include );
+ } else {
+ @paths = (File::Spec->curdir(), $Config{usrinc},
+ (split ' ', $Config{locincpth}), '/usr/include');
+ }
foreach my $path_h (@path_h) {
$name ||= $path_h;
if( $path_h =~ s#::#/#g && $opt_n ){
warn "Nesting of headerfile ignored with -n\n";
}
$path_h .= ".h" unless $path_h =~ /\.h$/;
- $fullpath = $path_h;
+ my $fullpath = $path_h;
$path_h =~ s/,.*$// if $opt_x;
- if ($^O eq 'VMS') { # Consider overrides of default location
- if ($path_h !~ m![:>\[]!) {
- my($hadsys) = ($path_h =~ s!^sys/!!i);
- if ($ENV{'DECC$System_Include'}) { $path_h = "DECC\$System_Include:$path_h"; }
- elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h"; }
- elsif ($ENV{'GNU_CC_Include'}) { $path_h = 'GNU_CC_Include:' .
- ($hadsys ? '[vms]' : '[000000]') . $path_h; }
- elsif ($ENV{'VAXC$Include'}) { $path_h = "VAXC\$_Include:$path_h"; }
- else { $path_h = "Sys\$Library:$path_h"; }
- }
- }
- elsif ($^O eq 'os2') {
- $path_h = "/usr/include/$path_h"
- if $path_h !~ m#^([a-z]:)?[./]#i and -r "/usr/include/$path_h";
- }
- else {
- $path_h = "/usr/include/$path_h"
- if $path_h !~ m#^[./]# and -r "/usr/include/$path_h";
+ $fullpath{$path_h} = $fullpath;
+
+ if (not -f $path_h) {
+ my $tmp_path_h = $path_h;
+ for my $dir (@paths) {
+ last if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
+ }
}
if (!$opt_c) {
# Record the names of simple #define constants into const_names
# Function prototypes are processed below.
open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
+ defines:
while (<CH>) {
- if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) {
- print "Matched $_ ($1)\n" if $opt_d;
- $_ = $1;
+ if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) {
+ my $def = $1;
+ my $rest = $2;
+ $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
+ $rest =~ s/^\s+//;
+ $rest =~ s/\s+$//;
+ # Cannot do: (-1) and ((LHANDLE)3) are OK:
+ #print("Skip non-wordy $def => $rest\n"),
+ # next defines if $rest =~ /[^\w\$]/;
+ if ($rest =~ /"/) {
+ print("Skip stringy $def => $rest\n") if $opt_d;
+ next defines;
+ }
+ print "Matched $_ ($def)\n" if $opt_d;
+ $seen_define{$def} = $rest;
+ $_ = $def;
next if /^_.*_h_*$/i; # special case, but for what?
if (defined $opt_p) {
if (!/^$opt_p(\d)/) {
warn "can't remove $opt_p prefix from '$_'!\n";
}
}
- $const_names{$_}++;
+ $prefixless{$def} = $_;
+ if (!$fmask or /$fmask/) {
+ print "... Passes mask of -M.\n" if $opt_d and $fmask;
+ $const_names{$_}++;
+ }
}
}
close(CH);
}
}
- @const_names = sort keys %const_names;
}
-$module = $opt_n || do {
+my $module = $opt_n || do {
$name =~ s/\.h$//;
if( $name !~ /::/ ){
$name =~ s#^.*/##;
$name;
};
+my ($ext, $nested, @modparts, $modfname, $modpname);
(chdir 'ext', $ext = 'ext/') if -d 'ext';
if( $module =~ /::/ ){
die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
}
if( $nested ){
- $modpath = "";
+ my $modpath = "";
foreach (@modparts){
mkdir("$modpath$_", 0777);
$modpath .= "$_/";
my %std_types;
my $fdecls = [];
my $fdecls_parsed = [];
+my $typedef_rex;
+my %typedefs_pre;
+my %known_fnames;
+
+my @fnames;
+my @fnames_no_prefix;
if( ! $opt_X ){ # use XS, unless it was disabled
open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
if ($opt_x) {
- require C::Scan; # Run-time directive
require Config; # Run-time directive
warn "Scanning typemaps...\n";
get_typemap();
- my $c;
- my $filter;
+ my @td;
+ my @good_td;
+ my $addflags = $opt_F || '';
+
foreach my $filename (@path_h) {
- my $addflags = $opt_F || '';
- if ($fullpath =~ /,/) {
+ my $c;
+ my $filter;
+
+ if ($fullpath{$filename} =~ /,/) {
$filename = $`;
$filter = $';
}
$c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
'add_cppflags' => $addflags;
$c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]);
-
+
push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
push(@$fdecls, @{$c->get('fdecls')});
+
+ push @td, @{$c->get('typedefs_maybe')};
+
+ unless ($tmask_all) {
+ warn "Scanning $filename for typedefs...\n";
+ my $td = $c->get('typedef_hash');
+ # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
+ my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
+ push @good_td, @f_good_td;
+ @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td};
+ }
+ }
+ { local $" = '|';
+ $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b);
+ }
+ %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
+ if ($fmask) {
+ my @good;
+ for my $i (0..$#$fdecls_parsed) {
+ next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
+ push @good, $i;
+ print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
+ if $opt_d;
+ }
+ $fdecls = [@$fdecls[@good]];
+ $fdecls_parsed = [@$fdecls_parsed[@good]];
+ }
+ @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
+ # Sort declarations:
+ {
+ my %h = map( ($_->[1], $_), @$fdecls_parsed);
+ $fdecls_parsed = [ @h{@fnames} ];
+ }
+ @fnames_no_prefix = @fnames;
+ @fnames_no_prefix
+ = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix;
+ # Remove macros which expand to typedefs
+ print "Typedefs are @td.\n" if $opt_d;
+ my %td = map {($_, $_)} @td;
+ # Add some other possible but meaningless values for macros
+ for my $k (qw(char double float int long short unsigned signed void)) {
+ $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
+ }
+ # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
+ my $n = 0;
+ my %bad_macs;
+ while (keys %td > $n) {
+ $n = keys %td;
+ my ($k, $v);
+ while (($k, $v) = each %seen_define) {
+ # print("found '$k'=>'$v'\n"),
+ $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
+ }
+ }
+ # Now %bad_macs contains names of bad macros
+ for my $k (keys %bad_macs) {
+ delete $const_names{$prefixless{$k}};
+ print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
}
}
}
+my @const_names = sort keys %const_names;
open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
print PM <<"END";
package $module;
+require 5.005_62;
use strict;
END
$myISA .= ');';
print PM "\n$myISA\n\n";
+my @exported_names = (@const_names, @fnames_no_prefix);
+
print PM<<"END";
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
+
+# This allows declaration use $module ':all';
+# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( 'all' => [ qw(
+ @exported_names
+) ] );
+
+our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
+
our \@EXPORT = qw(
@const_names
);
croak "Your vendor has not defined $module macro \$constname";
}
}
- no strict 'refs';
- *\$AUTOLOAD = sub () { \$val };
+ { no strict 'refs';
+ # Next line doesn't help with older Perls; in newers: no such warnings
+ # local \$^W = 0; # Prototype mismatch: sub XXX vs ()
+ if (\$] >= 5.00561) { # Fixed between 5.005_53 and 5.005_61
+ *\$AUTOLOAD = sub () { \$val };
+ } else {
+ *\$AUTOLOAD = sub { \$val };
+ }
+ }
goto &\$AUTOLOAD;
}
END
}
+my $after;
if( $opt_P ){ # if POD is disabled
$after = '__END__';
}
__END__
END
-$author = "A. U. Thor";
-$email = 'a.u.thor@a.galaxy.far.far.away';
+my $author = "A. U. Thor";
+my $email = 'a.u.thor@a.galaxy.far.far.away';
my $revhist = '';
$revhist = <<EOT if $opt_C;
=item $TEMPLATE_VERSION
-Original version; created by h2xs $H2XS_VERSION
+Original version; created by h2xs $H2XS_VERSION with options
+
+ @ARGS
=back
EOT
-my $const_doc = '';
-my $fdecl_doc = '';
+my $exp_doc = <<EOD;
+
+=head2 EXPORT
+
+None by default.
+
+EOD
if (@const_names and not $opt_P) {
- $const_doc = <<EOD;
-\n=head2 Exported constants
+ $exp_doc .= <<EOD;
+=head2 Exportable constants
@{[join "\n ", @const_names]}
EOD
}
if (defined $fdecls and @$fdecls and not $opt_P) {
- $fdecl_doc = <<EOD;
-\n=head2 Exported functions
+ $exp_doc .= <<EOD;
+=head2 Exportable functions
- @{[join "\n ", @$fdecls]}
+EOD
+ $exp_doc .= <<EOD if $opt_p;
+When accessing these functions from Perl, prefix C<$opt_p> should be removed.
+
+EOD
+ $exp_doc .= <<EOD;
+ @{[join "\n ", @known_fnames{@fnames}]}
EOD
}
-$pod = <<"END" unless $opt_P;
+my $pod = <<"END" unless $opt_P;
## Below is the stub of documentation for your module. You better edit it!
#
#=head1 NAME
#unedited.
#
#Blah blah blah.
-#$const_doc$fdecl_doc$revhist
+#$exp_doc$revhist
#=head1 AUTHOR
#
#$author, $email
END
if( @path_h ){
- foreach my $path_h (@path_h) {
+ foreach my $path_h (@path_h_ini) {
my($h) = $path_h;
$h =~ s#^/usr/include/##;
if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
print XS "\n";
}
-if( ! $opt_c ){
-print XS <<"END";
-static int
-not_here(char *s)
+my %pointer_typedefs;
+my %struct_typedefs;
+
+sub td_is_pointer {
+ my $type = shift;
+ my $out = $pointer_typedefs{$type};
+ return $out if defined $out;
+ my $otype = $type;
+ $out = ($type =~ /\*$/);
+ # This converts only the guys which do not have trailing part in the typedef
+ if (not $out
+ and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+ $type = normalize_type($type);
+ print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
+ if $opt_d;
+ $out = td_is_pointer($type);
+ }
+ return ($pointer_typedefs{$otype} = $out);
+}
+
+sub td_is_struct {
+ my $type = shift;
+ my $out = $struct_typedefs{$type};
+ return $out if defined $out;
+ my $otype = $type;
+ $out = ($type =~ /^struct\b/) && !td_is_pointer($type);
+ # This converts only the guys which do not have trailing part in the typedef
+ if (not $out
+ and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+ $type = normalize_type($type);
+ print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
+ if $opt_d;
+ $out = td_is_struct($type);
+ }
+ return ($struct_typedefs{$otype} = $out);
+}
+
+# Some macros will bomb if you try to return them from a double-returning func.
+# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen).
+# Fortunately, we can detect both these cases...
+sub protect_convert_to_double {
+ my $in = shift;
+ my $val;
+ return '' unless defined ($val = $seen_define{$in});
+ return '(IV)' if $known_fnames{$val};
+ # OUT_t of ((OUT_t)-1):
+ return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/;
+ td_is_pointer($2) ? '(IV)' : '';
+}
+
+# For each of the generated functions, length($pref) leading
+# letters are already checked. Moreover, it is recommended that
+# the generated functions uses switch on letter at offset at least
+# $off + length($pref).
+#
+# The given list has length($pref) chars removed at front, it is
+# guarantied that $off leading chars in the rest are the same for all
+# elts of the list.
+#
+# Returns: how at which offset it was decided to make a switch, or -1 if none.
+
+sub write_const;
+
+sub write_const {
+ my ($fh, $pref, $off, $list) = (shift,shift,shift,shift);
+ my %leading;
+ my $offarg = length $pref;
+
+ if (@$list == 0) { # Can happen on the initial iteration only
+ print $fh <<"END";
+static double
+constant(char *name, int len, int arg)
{
- croak("$module::%s not implemented on this architecture", s);
+ errno = EINVAL;
+ return 0;
+}
+END
return -1;
+ }
+
+ if (@$list == 1) { # Can happen on the initial iteration only
+ my $protect = protect_convert_to_double("$pref$list->[0]");
+
+ print $fh <<"END";
+static double
+constant(char *name, int len, int arg)
+{
+ if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */
+#ifdef $pref$list->[0]
+ return $protect$pref$list->[0];
+#else
+ errno = ENOENT;
+ return 0;
+#endif
+ }
+ errno = EINVAL;
+ return 0;
}
+END
+ return -1;
+ }
+ for my $n (@$list) {
+ my $c = substr $n, $off, 1;
+ $leading{$c} = [] unless exists $leading{$c};
+ push @{$leading{$c}}, substr $n, $off + 1;
+ }
+
+ if (keys(%leading) == 1) {
+ return 1 + write_const $fh, $pref, $off + 1, $list;
+ }
+
+ my $leader = substr $list->[0], 0, $off;
+ foreach my $letter (keys %leading) {
+ write_const $fh, "$pref$leader$letter", 0, $leading{$letter}
+ if @{$leading{$letter}} > 1;
+ }
+
+ my $npref = "_$pref";
+ $npref = '' if $pref eq '';
+
+ print $fh <<"END";
static double
-constant(char *name, int arg)
+constant$npref(char *name, int len, int arg)
{
errno = 0;
- switch (*name) {
END
-my(@AZ, @az, @under);
-
-foreach(@const_names){
- @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/;
- @az = 'a' .. 'z' if !@az && /^[a-z]/;
- @under = '_' if !@under && /^_/;
-}
+ print $fh <<"END" if $off;
+ if ($offarg + $off >= len ) {
+ errno = EINVAL;
+ return 0;
+ }
+END
-foreach $letter (@AZ, @az, @under) {
+ print $fh <<"END";
+ switch (name[$offarg + $off]) {
+END
- last if $letter eq 'a' && !@const_names;
+ foreach my $letter (sort keys %leading) {
+ my $let = $letter;
+ $let = '\0' if $letter eq '';
- print XS " case '$letter':\n";
- my($name);
- while (substr($const_names[0],0,1) eq $letter) {
- $name = shift(@const_names);
- $macro = $prefix{$name} ? "$opt_p$name" : $name;
- next if $const_xsub{$macro};
- print XS <<"END";
- if (strEQ(name, "$name"))
-#ifdef $macro
- return $macro;
+ print $fh <<EOP;
+ case '$let':
+EOP
+ if (@{$leading{$letter}} > 1) {
+ # It makes sense to call a function
+ if ($off) {
+ print $fh <<EOP;
+ if (!strnEQ(name + $offarg,"$leader", $off))
+ break;
+EOP
+ }
+ print $fh <<EOP;
+ return constant_$pref$leader$letter(name, len, arg);
+EOP
+ } else {
+ # Do it ourselves
+ my $protect
+ = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]");
+
+ print $fh <<EOP;
+ if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */
+#ifdef $pref$leader$letter$leading{$letter}[0]
+ return $protect$pref$leader$letter$leading{$letter}[0];
#else
goto not_there;
#endif
-END
+ }
+EOP
}
- print XS <<"END";
- break;
-END
-}
-print XS <<"END";
+ }
+ print $fh <<"END";
}
errno = EINVAL;
return 0;
}
END
+
}
+if( ! $opt_c ) {
+ print XS <<"END";
+static int
+not_here(char *s)
+{
+ croak("$module::%s not implemented on this architecture", s);
+ return -1;
+}
+
+END
+
+ write_const(\*XS, '', 0, \@const_names);
+}
+
+my $prefix;
$prefix = "PREFIX = $opt_p" if defined $opt_p;
+
# Now switch from C to XS by issuing the first MODULE declaration:
print XS <<"END";
print XS <<"END" unless $opt_c;
double
-constant(name,arg)
- char * name
+constant(sv,arg)
+PREINIT:
+ STRLEN len;
+INPUT:
+ SV * sv
+ char * s = SvPV(sv, len);
int arg
+CODE:
+ RETVAL = constant(s,len,arg);
+OUTPUT:
+ RETVAL
END
my %seen_decl;
-
+my %typemap;
sub print_decl {
my $fh = shift;
return if $seen_decl{$name}++; # Need to do the same for docs as well?
my @argnames = map {$_->[1]} @$args;
- my @argtypes = map { normalize_type( $_->[0] ) } @$args;
+ my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
my @argarrays = map { $_->[4] || '' } @$args;
my $numargs = @$args;
if ($numargs and $argtypes[-1] eq '...') {
$argnames[-1] = '...';
}
local $" = ', ';
- $type = normalize_type($type);
-
+ $type = normalize_type($type, 1);
+
print $fh <<"EOP";
$type
$name(@argnames)
EOP
- for $arg (0 .. $numargs - 1) {
+ for my $arg (0 .. $numargs - 1) {
print $fh <<"EOP";
$argtypes[$arg] $argnames[$arg]$argarrays[$arg]
EOP
my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
unshift @tm, $stdtypemap;
my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
- my $image;
-
- foreach $typemap (@tm) {
+
+ # Start with useful default values
+ $typemap{float} = 'T_DOUBLE';
+
+ foreach my $typemap (@tm) {
next unless -e $typemap ;
# skip directories, binary files etc.
warn " Scanning $typemap\n";
elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
elsif ($mode eq 'Typemap') {
next if /^\s*($|\#)/ ;
- if ( ($type, $image) =
+ my ($type, $image);
+ if ( ($type, $image) =
/^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
# This may reference undefined functions:
and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
- normalize_type($type);
+ $typemap{normalize_type($type)} = $image;
}
}
}
}
-sub normalize_type {
- my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*';
+sub normalize_type { # Second arg: do not strip const's before \*
my $type = shift;
- $type =~ s/$ignore_mods//go;
- $type =~ s/([\]\[()])/ \1 /g;
- $type =~ s/\s+/ /g;
+ my $do_keep_deep_const = shift;
+ # If $do_keep_deep_const this is heuristical only
+ my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
+ my $ignore_mods
+ = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
+ if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately!
+ $type =~ s/$ignore_mods//go;
+ } else {
+ $type =~ s/$ignore_mods//go;
+ }
+ $type =~ s/([^\s\w])/ \1 /g;
$type =~ s/\s+$//;
$type =~ s/^\s+//;
- $type =~ s/\b\*/ */g;
- $type =~ s/\*\b/* /g;
- $type =~ s/\*\s+(?=\*)/*/g;
+ $type =~ s/\s+/ /g;
+ $type =~ s/\* (?=\*)/*/g;
+ $type =~ s/\. \. \./.../g;
+ $type =~ s/ ,/,/g;
$types_seen{$type}++
unless $type eq '...' or $type eq 'void' or $std_types{$type};
$type;
}
+my $need_opaque;
+
+sub assign_typemap_entry {
+ my $type = shift;
+ my $otype = $type;
+ my $entry;
+ if ($tmask and $type =~ /$tmask/) {
+ print "Type $type matches -o mask\n" if $opt_d;
+ $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+ }
+ elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+ $type = normalize_type $type;
+ print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
+ $entry = assign_typemap_entry($type);
+ }
+ $entry ||= $typemap{$otype}
+ || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+ $typemap{$otype} = $entry;
+ $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
+ return $entry;
+}
+
if ($opt_x) {
- for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
+ for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
}
close XS;
warn "Writing $ext$modpname/typemap\n";
open TM, ">typemap" or die "Cannot open typemap file for write: $!";
- for $type (keys %types_seen) {
- print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n"
+ for $type (sort keys %types_seen) {
+ my $entry = assign_typemap_entry $type;
+ print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
}
+ print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
+#############################################################################
+INPUT
+T_OPAQUE_STRUCT
+ if (sv_derived_from($arg, \"${ntype}\")) {
+ STRLEN len;
+ char *s = SvPV((SV*)SvRV($arg), len);
+
+ if (len != sizeof($var))
+ croak(\"Size %d of packed data != expected %d\",
+ len, sizeof($var));
+ $var = *($type *)s;
+ }
+ else
+ croak(\"$var is not of type ${ntype}\")
+#############################################################################
+OUTPUT
+T_OPAQUE_STRUCT
+ sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
+EOP
+
close TM or die "Cannot close typemap file for write: $!";
}
print PL " 'NAME' => '$module',\n";
print PL " 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n";
if( ! $opt_X ){ # print C stuff, unless XS is disabled
+ $opt_F = '' unless defined $opt_F;
print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n";
- print PL " 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' \n";
+ print PL " 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING' \n";
print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n";
}
print PL ");\n";
close(EX) || die "Can't close $ext$modpname/test.pl: $!\n";
unless ($opt_C) {
- warn "Writing $ext$modpname/Changes\n";
- open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
- print EX "Revision history for Perl extension $module.\n\n";
- print EX "$TEMPLATE_VERSION ",scalar localtime,"\n";
- print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n";
- close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
+ warn "Writing $ext$modpname/Changes\n";
+ $" = ' ';
+ open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
+ @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
+ print EX <<EOP;
+Revision history for Perl extension $module.
+
+$TEMPLATE_VERSION @{[scalar localtime]}
+\t- original version; created by h2xs $H2XS_VERSION with options
+\t\t@ARGS
+
+EOP
+ close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
}
warn "Writing $ext$modpname/MANIFEST\n";
open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
-@files = <*>;
+my @files = <*>;
if (!@files) {
eval {opendir(D,'.');};
unless ($@) { @files = readdir(D); closedir(D); }
projects / p5sagit/p5-mst-13.2.git / commitdiff