diff options
| author | Gurusamy Sarathy <gsar@cpan.org> | 1999-10-01 22:33:02 +0000 |
|---|---|---|
| committer | Gurusamy Sarathy <gsar@cpan.org> | 1999-10-01 22:33:02 +0000 |
| commit | 51fac20b958150820bb3d04d5df0bd1d0272854e (patch) | |
| tree | 67300941637498420e03a3bbf861f7dd9fce4e34 | |
| parent | a80b8354f5981907f826ef236ecd80cb746b2ace (diff) | |
| parent | b3c0bf3602cfb95d459cdd04ae7ddfd23779e14e (diff) | |
| download | perl-51fac20b958150820bb3d04d5df0bd1d0272854e.tar.gz | |
integrate cfgperl contents into mainline; resolve h2xs.PL conflict
by declaring new globals "our" (XXX this means h2xs generated code
won't run on earlier versions; a switch to generate compatible
source is needed)
p4raw-id: //depot/perl@4271
| -rwxr-xr-x | Configure | 13 | ||||
| -rw-r--r-- | Makefile.SH | 3 | ||||
| -rw-r--r-- | Porting/Glossary | 84 | ||||
| -rw-r--r-- | Porting/config.sh | 14 | ||||
| -rw-r--r-- | Porting/config_H | 8 | ||||
| -rwxr-xr-x | Porting/findvars | 1 | ||||
| -rw-r--r-- | XSUB.h | 2 | ||||
| -rw-r--r-- | embedvar.h | 3 | ||||
| -rw-r--r-- | ext/B/defsubs_h.PL | 2 | ||||
| -rw-r--r-- | hints/README.hints | 56 | ||||
| -rw-r--r-- | hints/amigaos.sh | 11 | ||||
| -rw-r--r-- | hints/cygwin.sh | 25 | ||||
| -rw-r--r-- | hints/dynixptx.sh | 10 | ||||
| -rw-r--r-- | hints/epix.sh | 6 | ||||
| -rw-r--r-- | hints/esix4.sh | 8 | ||||
| -rw-r--r-- | hints/mint.sh | 3 | ||||
| -rw-r--r-- | hints/mpeix.sh | 23 | ||||
| -rw-r--r-- | hints/next_3.sh | 2 | ||||
| -rw-r--r-- | hints/next_3_0.sh | 6 | ||||
| -rw-r--r-- | hints/next_4.sh | 6 | ||||
| -rw-r--r-- | intrpvar.h | 1 | ||||
| -rw-r--r-- | lib/Benchmark.pm | 339 | ||||
| -rwxr-xr-x | lib/ExtUtils/xsubpp | 62 | ||||
| -rw-r--r-- | mg.c | 2 | ||||
| -rw-r--r-- | objXSUB.h | 2 | ||||
| -rwxr-xr-x | opcode.pl | 4 | ||||
| -rw-r--r-- | perl.c | 2 | ||||
| -rw-r--r-- | pod/perldelta.pod | 12 | ||||
| -rw-r--r-- | pod/perlguts.pod | 9 | ||||
| -rwxr-xr-x | t/lib/filecopy.t | 4 | ||||
| -rwxr-xr-x | t/op/time.t | 2 | ||||
| -rw-r--r-- | utils/h2xs.PL | 696 |
32 files changed, 1118 insertions, 303 deletions
@@ -20,7 +20,7 @@ # $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 @@ -3576,9 +3576,11 @@ echo "Getting the current patchlevel..." >&4 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 @@ -3598,15 +3600,6 @@ else 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. diff --git a/Makefile.SH b/Makefile.SH index 09f7f9c8ec..bf98183e06 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -539,6 +539,8 @@ SYM = global.sym globvar.sym perlio.sym pp.sym 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 @@ -557,6 +559,7 @@ SYMH = perlvars.h intrpvar.h thrdvar.h # 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 diff --git a/Porting/Glossary b/Porting/Glossary index fe4b9c4fd4..46fb810f0a 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -38,16 +38,18 @@ aphostname (d_gethname.U): 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. @@ -77,7 +79,7 @@ archobjs (Unix.U): 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. @@ -107,7 +109,7 @@ bison (Loc.U): 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. @@ -131,7 +133,7 @@ castflags (d_castneg.U): 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. @@ -192,7 +194,7 @@ clocktype (d_times.U): 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. @@ -207,7 +209,7 @@ contains (contains.U): 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. @@ -216,7 +218,7 @@ cpio (Loc.U): 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. @@ -275,7 +277,7 @@ cryptlib (d_crypt.U): 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. @@ -1540,7 +1542,7 @@ d_xenix (Guess.U): 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. @@ -1597,12 +1599,12 @@ ebcdic (ebcdic.U): 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. @@ -1619,7 +1621,7 @@ exe_ext (Unix.U): 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. @@ -1697,7 +1699,7 @@ glibpth (libpth.U): 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. @@ -1713,7 +1715,7 @@ groupstype (groupstype.U): 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. @@ -2172,7 +2174,7 @@ ldlibpthname (libperl.U): 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. @@ -2216,7 +2218,7 @@ lkflags (ccflags.U): 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. @@ -2260,7 +2262,7 @@ lpr (Loc.U): 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. @@ -2283,7 +2285,7 @@ mailx (Loc.U): 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. @@ -2344,7 +2346,7 @@ man3ext (man3dir.U): 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. @@ -2359,7 +2361,7 @@ mips_type (usrinc.U): 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. @@ -2379,7 +2381,7 @@ modetype (modetype.U): 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. @@ -2441,7 +2443,7 @@ netdb_net_type (netdbtype.U): 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. @@ -2461,7 +2463,7 @@ nonxs_ext (Extensions.U): 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. @@ -2539,7 +2541,7 @@ perlpath (perlpath.U): 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. @@ -2620,7 +2622,7 @@ rd_nodata (nblock_io.U): 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. @@ -2649,7 +2651,7 @@ scriptdirexp (scriptdir.U): 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. @@ -2809,7 +2811,7 @@ socketlib (d_socket.U): 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. @@ -2976,7 +2978,7 @@ tee (Loc.U): 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. @@ -2989,12 +2991,12 @@ timetype (d_time.U): 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. @@ -3013,12 +3015,12 @@ uidtype (uidtype.U): 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. @@ -3031,7 +3033,7 @@ usedl (dlsrc.U): 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. @@ -3161,7 +3163,7 @@ zcat (Loc.U): 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. diff --git a/Porting/config.sh b/Porting/config.sh index 5dea400095..af71eadd3c 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -8,7 +8,7 @@ # 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 @@ -30,7 +30,7 @@ afs='false' 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' @@ -56,7 +56,7 @@ ccflags='-pthread -std -DLANGUAGE_C' 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='' @@ -478,7 +478,7 @@ installprefix='/opt/perl' 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' @@ -618,8 +618,8 @@ sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "TRAP", "ABRT", "EMT", "FPE" 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' @@ -667,7 +667,7 @@ uname='uname' uniq='uniq' use64bits='define' usedl='define' -uselfs='define' +uselargefiles='undef' uselongdouble='undef' usemorebits='undef' usemultiplicity='undef' diff --git a/Porting/config_H b/Porting/config_H index b6468df703..d099550d2b 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -17,7 +17,7 @@ /* * 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 */ @@ -1469,8 +1469,8 @@ * 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. @@ -2466,7 +2466,7 @@ * 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 diff --git a/Porting/findvars b/Porting/findvars index 2e81244ac8..b91753bbbe 100755 --- a/Porting/findvars +++ b/Porting/findvars @@ -238,7 +238,6 @@ osname pad_reset_pending padix padix_floor -parsehook patchlevel patleave pending_ident @@ -283,4 +283,4 @@ # endif /* NO_XSLOCKS */ #endif /* PERL_CAPI */ -#endif _INC_PERL_XSUB_H /* include guard */ +#endif /* _INC_PERL_XSUB_H */ /* include guard */ diff --git a/embedvar.h b/embedvar.h index fcaa0d4390..beaa960874 100644 --- a/embedvar.h +++ b/embedvar.h @@ -353,7 +353,6 @@ #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) @@ -630,7 +629,6 @@ #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) @@ -909,7 +907,6 @@ #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 diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL index 8dfa3a5fe2..78c82f20bd 100644 --- a/ext/B/defsubs_h.PL +++ b/ext/B/defsubs_h.PL @@ -6,7 +6,7 @@ my ($out) = __FILE__ =~ /(^.*)\.PL/; 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 diff --git a/hints/README.hints b/hints/README.hints index 015e1c12c2..5f23b29c2c 100644 --- a/hints/README.hints +++ b/hints/README.hints @@ -11,7 +11,9 @@ over from perl4. 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 '.' @@ -51,6 +53,56 @@ detect what is needed. 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 @@ -204,4 +256,4 @@ say things like "sh Configure -Dcc=gcc -Dusethreads" on the command line. Have the appropriate amount of fun :-) - Andy Dougherty doughera@lafcol.lafayette.edu + Andy Dougherty doughera@lafayette.edu diff --git a/hints/amigaos.sh b/hints/amigaos.sh index 9d86e52bc0..fff55b082c 100644 --- a/hints/amigaos.sh +++ b/hints/amigaos.sh @@ -22,15 +22,20 @@ libpth="$prefix/lib /local/lib" 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' diff --git a/hints/cygwin.sh b/hints/cygwin.sh index 23d055faa6..de48cdfeb2 100644 --- a/hints/cygwin.sh +++ b/hints/cygwin.sh @@ -1,6 +1,11 @@ #! /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' @@ -10,25 +15,31 @@ sharpbang='#!' 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 ;; diff --git a/hints/dynixptx.sh b/hints/dynixptx.sh index 2edf026305..5320030176 100644 --- a/hints/dynixptx.sh +++ b/hints/dynixptx.sh @@ -22,7 +22,9 @@ usenm='n' # 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. @@ -49,9 +51,9 @@ case "$osvers" in 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' diff --git a/hints/epix.sh b/hints/epix.sh index 03d5be536c..dcad3c5d47 100644 --- a/hints/epix.sh +++ b/hints/epix.sh @@ -43,9 +43,9 @@ d_flock='undef' # 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: diff --git a/hints/esix4.sh b/hints/esix4.sh index 695f8b870f..9967207d37 100644 --- a/hints/esix4.sh +++ b/hints/esix4.sh @@ -3,14 +3,18 @@ # 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 diff --git a/hints/mint.sh b/hints/mint.sh index 22d854c397..ab55e612e1 100644 --- a/hints/mint.sh +++ b/hints/mint.sh @@ -18,7 +18,7 @@ cc='gcc' # 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 @@ -44,6 +44,7 @@ util_cflags='ccflags="$ccflags -DLOCALE_ENVIRON_REQUIRED"' # # Some good answers to the questions in Configure: +# Does Configure really get all these wrong? usenm='true' d_suidsafe='true' clocktype='long' diff --git a/hints/mpeix.sh b/hints/mpeix.sh index 9ebb0bad1e..556d22148c 100644 --- a/hints/mpeix.sh +++ b/hints/mpeix.sh @@ -12,7 +12,7 @@ # 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 # @@ -24,7 +24,8 @@ usenm='true' # # 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" @@ -38,24 +39,30 @@ startsh='#!/bin/sh' # # 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' diff --git a/hints/next_3.sh b/hints/next_3.sh index 1a174b8d54..27c9bd9877 100644 --- a/hints/next_3.sh +++ b/hints/next_3.sh @@ -47,7 +47,7 @@ # 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' ###################################################################### diff --git a/hints/next_3_0.sh b/hints/next_3_0.sh index b8cc2c2d90..b444578830 100644 --- a/hints/next_3_0.sh +++ b/hints/next_3_0.sh @@ -16,11 +16,11 @@ echo find it. By default, it is placed in /usr/local/include/gdbm.h. >&4 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 diff --git a/hints/next_4.sh b/hints/next_4.sh index ba096ac9fd..d5c8ba7d64 100644 --- a/hints/next_4.sh +++ b/hints/next_4.sh @@ -6,9 +6,9 @@ libpth='/lib /usr/lib /usr/local/lib' 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' diff --git a/intrpvar.h b/intrpvar.h index a53d38b325..cc3eff5e0b 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -23,7 +23,6 @@ PERLVAR(Ihintgv, GV *) PERLVAR(Iorigfilename, char *) PERLVAR(Idiehook, SV *) PERLVAR(Iwarnhook, SV *) -PERLVAR(Iparsehook, SV *) PERLVAR(Icddir, char *) /* switches */ PERLVAR(Iminus_c, bool) PERLVARA(Ipatchlevel,10,char) diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm index 767cb67d13..a7debd73ee 100644 --- a/lib/Benchmark.pm +++ b/lib/Benchmark.pm @@ -8,8 +8,12 @@ timethis - run a chunk of code several times 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"); @@ -26,9 +30,34 @@ timeit - run a chunk of code and see how long it goes '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 @@ -57,6 +86,10 @@ Enables or disable debugging by setting the C<$Benchmark::Debug> flag: $t = timeit(10, ' 5 ** $Global '); debug Benchmark 0; +=item iters + +Returns the number of iterations. + =back =head2 Standard Exports @@ -66,6 +99,34 @@ if you use the Benchmark module: =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 @@ -119,6 +180,8 @@ The routines are called in string comparison order of KEY. 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 @@ -135,12 +198,13 @@ Returns a string that formats the times in the TIMEDIFF object in 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'. @@ -180,7 +244,7 @@ different COUNT used. 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). @@ -192,7 +256,7 @@ The time of the null loop (a loop with the same 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: @@ -202,6 +266,9 @@ 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 @@ -210,7 +277,7 @@ for Exporter. =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 @@ -241,6 +308,10 @@ documentation. 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 @@ -253,7 +324,7 @@ sub _doeval { eval shift } 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; @@ -290,6 +361,7 @@ sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; } 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) = @_; @@ -364,15 +436,16 @@ sub runloop { 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); @@ -386,18 +459,20 @@ sub timeit { 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); @@ -409,8 +484,9 @@ sub timeit { 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; @@ -418,52 +494,61 @@ sub runfor { $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 ]; @@ -486,14 +571,14 @@ sub timethis{ $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; @@ -513,25 +598,163 @@ sub timethese{ 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; diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index a9004f6505..6db993c521 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -367,7 +367,17 @@ sub INPUT_handler { $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) @@ -377,12 +387,16 @@ sub INPUT_handler { $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"; } @@ -1081,7 +1095,7 @@ EOF $_ = '' ; } 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; @@ -1305,15 +1319,22 @@ warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") &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 $@; @@ -1382,16 +1403,26 @@ sub generate_init { 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 $@; } @@ -1468,10 +1499,17 @@ sub generate_output { } 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; } @@ -905,8 +905,6 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) 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; @@ -372,8 +372,6 @@ #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 @@ -296,6 +296,8 @@ sub tab { # 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 @@ -479,7 +481,7 @@ vec vec ck_fun ist@ S S S 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? @@ -328,8 +328,6 @@ perl_destruct(pTHXx) 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) diff --git a/pod/perldelta.pod b/pod/perldelta.pod index e3a37dc741..9489c58acb 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -17,6 +17,18 @@ This document describes differences between the 5.005 release and this one. 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 diff --git a/pod/perlguts.pod b/pod/perlguts.pod index af12297ec3..d0f916786c 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -107,9 +107,10 @@ Also remember that C doesn't allow you to safely say C<foo(SvPV(s, len), 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: @@ -2907,15 +2908,17 @@ Test two strings to see if they are different. Returns true or false. 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 diff --git a/t/lib/filecopy.t b/t/lib/filecopy.t index e461595d9b..7ef68eb02b 100755 --- a/t/lib/filecopy.t +++ b/t/lib/filecopy.t @@ -88,3 +88,7 @@ print "not " unless $foo eq "ok 3\n" and not -e "file-$$";; print "ok 11\n"; unlink "lib/file-$$" or die "unlink: $!"; +END { + 1 while unlink "file-$$"; + 1 while unlink "lib/file-$$"; +} diff --git a/t/op/time.t b/t/op/time.t index 658f9f35b9..caf2c14a6c 100755 --- a/t/op/time.t +++ b/t/op/time.t @@ -47,7 +47,7 @@ else {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";} diff --git a/utils/h2xs.PL b/utils/h2xs.PL index ae266de3cb..b3031c3465 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -81,7 +81,11 @@ the POD template. =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> @@ -108,7 +112,7 @@ Turn on debugging messages. =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> @@ -118,6 +122,21 @@ Print the usage, help and version for this h2xs and exit. 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_> @@ -145,7 +164,8 @@ but XSUBs are emitted only for the declarations included from file NAME2. 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 @@ -198,6 +218,12 @@ pointer (like C<long long>), pointers to functions, or arrays. # 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. @@ -214,10 +240,74 @@ L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>. 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; @@ -228,6 +318,7 @@ version: $H2XS_VERSION -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). @@ -236,6 +327,7 @@ version: $H2XS_VERSION -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. @@ -247,7 +339,9 @@ extra_libraries } -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; @@ -261,7 +355,9 @@ $opt_c = 1 if $opt_A; # -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) { @@ -274,34 +370,68 @@ while (my $arg = shift) { 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) { @@ -310,10 +440,24 @@ if( @path_h ){ # 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)/) { @@ -323,17 +467,20 @@ if( @path_h ){ 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#^.*/##; @@ -342,6 +489,7 @@ $module = $opt_n || do { $name; }; +my ($ext, $nested, @modparts, $modfname, $modpname); (chdir 'ext', $ext = 'ext/') if -d 'ext'; if( $module =~ /::/ ){ @@ -363,7 +511,7 @@ if ($opt_O) { die "Won't overwrite existing $ext$modpname\n" if -e $modpname; } if( $nested ){ - $modpath = ""; + my $modpath = ""; foreach (@modparts){ mkdir("$modpath$_", 0777); $modpath .= "$_/"; @@ -376,19 +524,28 @@ my %types_seen; 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 = $'; } @@ -396,12 +553,71 @@ if( ! $opt_X ){ # use XS, unless it was disabled $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"; @@ -411,6 +627,7 @@ warn "Writing $ext$modpname/$modfname.pm\n"; print PM <<"END"; package $module; +require 5.005_62; use strict; END @@ -455,10 +672,22 @@ $myISA .= ' DynaLoader' unless $opt_X; # no XS $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 ); @@ -486,8 +715,15 @@ sub AUTOLOAD { 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; } @@ -499,6 +735,7 @@ bootstrap $module \$VERSION; END } +my $after; if( $opt_P ){ # if POD is disabled $after = '__END__'; } @@ -522,8 +759,8 @@ print PM <<"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; @@ -534,32 +771,45 @@ $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 @@ -578,7 +828,7 @@ $pod = <<"END" unless $opt_P; #unedited. # #Blah blah blah. -#$const_doc$fdecl_doc$revhist +#$exp_doc$revhist #=head1 AUTHOR # #$author, $email @@ -606,7 +856,7 @@ print XS <<"END"; 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#.*[:>\]]##; } @@ -615,54 +865,180 @@ if( @path_h ){ 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; @@ -673,9 +1049,26 @@ not_there: } 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"; @@ -706,14 +1099,22 @@ 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; @@ -722,7 +1123,7 @@ sub print_decl { 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 '...') { @@ -730,15 +1131,15 @@ sub print_decl { $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 @@ -752,9 +1153,11 @@ sub get_typemap { 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"; @@ -770,11 +1173,12 @@ sub get_typemap { 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; } } } @@ -785,24 +1189,54 @@ sub get_typemap { } -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; @@ -812,10 +1246,32 @@ if (%types_seen) { 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: $!"; } @@ -833,8 +1289,9 @@ print PL "WriteMakefile(\n"; 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"; @@ -871,17 +1328,24 @@ _END_ 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); } |