Version v5.7.1 Development release working toward v5.8
--------------
____________________________________________________________________________
+[ 10610] By: jhi on 2001/06/15 14:20:33
+ Log: Upping the test count.
+ Branch: perl
+ ! t/lib/filefind.t
+____________________________________________________________________________
+[ 10609] By: jhi on 2001/06/15 14:13:29
+ Log: Integrate perlio.
+ Branch: perl
+ !> win32/config_H.bc win32/config_H.gc win32/config_H.vc
+____________________________________________________________________________
+[ 10608] By: jhi on 2001/06/15 14:12:31
+ Log: Subject: Re: [ID 20010608.010] File::Find re-entrancy
+ From: andreas.koenig@anima.de (Andreas J. Koenig)
+ Date: 15 Jun 2001 13:30:39 +0200
+ Message-ID: <m3hexikmjk.fsf@ak-71.mind.de>
+
+ Record the grim history.
+ Branch: perl
+ ! lib/File/Find.pm
+____________________________________________________________________________
+[ 10607] By: jhi on 2001/06/15 14:08:19
+ Log: Subject: Re: [ID 20010608.010] File::Find re-entrancy
+ From: Brian McCauley <nobull@mail.com>
+ Date: 15 Jun 2001 07:51:26 +0100
+ Message-Id: <200106150923.f5F9NpG02725@wcl-l.bham.ac.uk>
+ Branch: perl
+ ! lib/File/Find.pm t/lib/filefind.t
+____________________________________________________________________________
+[ 10606] By: nick on 2001/06/15 14:00:08
+ Log: regen_config_h for Win32.
+ Branch: perlio
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+____________________________________________________________________________
+[ 10605] By: jhi on 2001/06/15 13:49:55
+ Log: Subject: [PATCH: perl@10576] handle tri graphs in h2ph.PL -> h2ph*
+ From: Peter Prymmer <pvhp@forte.com>
+ Date: Thu, 14 Jun 2001 16:25:33 -0700 (PDT)
+ Message-ID: <Pine.OSF.4.10.10106141608080.110974-100000@aspara.forte.com>
+ Branch: perl
+ ! t/lib/h2ph.h t/lib/h2ph.pht t/lib/h2ph.t utils/h2ph.PL
+____________________________________________________________________________
+[ 10604] By: jhi on 2001/06/15 13:45:03
+ Log: Some filesystems require writability for rename/unlink.
+ Branch: perl
+ ! opcode.pl
+____________________________________________________________________________
+[ 10603] By: jhi on 2001/06/15 13:41:34
+ Log: Subject: Re: [PATCH} perlio and threading @ 10576 + report
+ From: "H.Merijn Brand" <h.m.brand@hccnet.nl>
+ Date: Fri, 15 Jun 2001 12:08:53 +0200
+ Message-Id: <20010615120320.F009.H.M.BRAND@hccnet.nl>
+ Branch: perl
+ ! perlio.c
+____________________________________________________________________________
+[ 10602] By: jhi on 2001/06/15 13:27:04
+ Log: Subject: Re: [PATCH] opcode.pl is chmod'ing the original source tree
+ From: Mike Guy <mjtg@cam.ac.uk>
+ Date: Fri, 15 Jun 2001 14:11:49 +0100
+ Message-Id: <E15AtO9-0006Nd-00@draco.cus.cam.ac.uk>
+ Branch: perl
+ ! opcode.pl
+____________________________________________________________________________
+[ 10601] By: jhi on 2001/06/15 13:21:18
+ Log: Subject: [PATCH ?] INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Thu, 14 Jun 2001 23:52:56 +0100
+ Message-ID: <20010614235256.G98663@plum.flirble.org>
+ Branch: perl
+ ! ext/Socket/Socket.pm ext/Socket/Socket.xs
+ ! lib/ExtUtils/Constant.pm t/lib/extutils.t
+____________________________________________________________________________
+[ 10600] By: jhi on 2001/06/15 13:16:56
+ Log: Subject: Re: [PATCH] GDBM_File (wasRe: ext/ + -Wall)
+ From: Russ Allbery <rra@stanford.edu>
+ Date: 14 Jun 2001 13:24:43 -0700
+ Message-ID: <ylzobaizck.fsf@windlord.stanford.edu>
+ Branch: perl
+ ! ext/GDBM_File/GDBM_File.pm
+____________________________________________________________________________
+[ 10599] By: jhi on 2001/06/15 13:15:26
+ Log: Subject: [PATCH] GDBM_File (wasRe: ext/ + -Wall)
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Thu, 14 Jun 2001 20:37:47 +0100
+ Message-ID: <20010614203747.F98663@plum.flirble.org>
+ Branch: perl
+ ! ext/GDBM_File/GDBM_File.pm ext/GDBM_File/GDBM_File.xs
+ ! t/lib/gdbm.t
+____________________________________________________________________________
+[ 10598] By: jhi on 2001/06/15 13:13:13
+ Log: Integrate perlio.
+ Branch: perl
+ !> makedef.pl sv.c
+____________________________________________________________________________
+[ 10597] By: nick on 2001/06/15 11:08:13
+ Log: Check that HVs with HvNAME() != NULL are really stashes before
+ treating them as such. Also be more defensive on the GvCV.
+ Win32 fork and dprof now working again.
+ Branch: perlio
+ ! sv.c
+____________________________________________________________________________
+[ 10596] By: nick on 2001/06/15 10:11:20
+ Log: Integrate mainline.
+ Branch: perlio
+ +> Cross/README
+ !> Configure Makefile.SH Porting/Glossary Porting/config.sh
+ !> Porting/config_H config_h.SH configure.com epoc/config.sh
+ !> hints/linux.sh pod/perltoc.pod uconfig.h uconfig.sh
+ !> vos/config.alpha.def vos/config.alpha.h vos/config.ga.def
+ !> vos/config.ga.h win32/config.bc win32/config.gc
+ !> win32/config.vc win32/config_H.bc win32/config_H.gc
+ !> win32/config_H.vc
+____________________________________________________________________________
+[ 10595] By: nick on 2001/06/15 09:37:17
+ Log: Skip Perl_my_bcopy in .def file as we do not provide it.
+ - Win32 (VC++) now builds but fails:
+ filefind.t - suspect Win32's builtin cwd is not doing insecure dir test
+ fork.t - No &___ENV_HV_NAME___::CLONE method ???
+ write.t - open(...,"|-") not implemented on Win32
+ Branch: perlio
+ ! makedef.pl
+____________________________________________________________________________
+[ 10594] By: jhi on 2001/06/15 00:17:16
+ Log: Integrate perlio.
+ Branch: perl
+ !> perlio.c win32/makefile.mk
+____________________________________________________________________________
+[ 10593] By: jhi on 2001/06/15 00:16:44
+ Log: Metaconfig unit changes for #10592.
+ Branch: metaconfig
+ + U/modified/i_varhdr.U U/modified/startsh.U
+ - U/a_dvisory/crosscompile.U U/target/Target.U
+ ! U/a_dvisory/intsize.U U/compline/alignbytes.U
+ ! U/compline/bitpbyte.U U/compline/byteorder.U
+ ! U/compline/ccflags.U U/compline/charsize.U
+ ! U/compline/d_casti32.U U/compline/d_castneg.U
+ ! U/compline/d_closedir.U U/compline/d_fd_set.U
+ ! U/compline/d_gconvert.U U/compline/d_gnulibc.U
+ ! U/compline/d_keepsig.U U/compline/d_open3.U
+ ! U/compline/d_safebcpy.U U/compline/d_safemcpy.U
+ ! U/compline/d_sanemcmp.U U/compline/d_scannl.U
+ ! U/compline/d_sgndchr.U U/compline/d_sigsetjmp.U
+ ! U/compline/d_stdstdio.U U/compline/d_vprintf.U
+ ! U/compline/doublesize.U U/compline/floatsize.U
+ ! U/compline/nblock_io.U U/compline/orderlib.U
+ ! U/compline/ptrsize.U U/compline/ssizetype.U U/ebcdic/ebcdic.U
+ ! U/modified/Cppsym.U U/modified/Oldconfig.U U/modified/Signal.U
+ ! U/modified/d_getpgrp.U U/modified/d_longdbl.U
+ ! U/modified/d_longlong.U U/modified/d_setpgrp.U
+ ! U/modified/d_strtoul.U U/modified/d_union_semun.U
+ ! U/modified/spitshell.U U/threads/archname.U
+ ! U/threads/d_pthreadj.U U/typedefs/gidsign.U
+ ! U/typedefs/gidsize.U U/typedefs/lseektype.U
+ ! U/typedefs/pidsign.U U/typedefs/pidsize.U
+ ! U/typedefs/sizesize.U U/typedefs/ssizesize.U
+ ! U/typedefs/uidsign.U U/typedefs/uidsize.U
+ Branch: metaconfig/U/perl
+ + Cross.U
+ ! d_dlsymun.U d_fcntl_can_lock.U d_modfl.U d_printfed.U
+ ! d_strtoll.U d_strtoull.U d_strtouq.U d_u32align.U dlsrc.U
+ ! fflushall.U fpossize.U gccvers.U i_db.U longdblfio.U
+ ! need_va_copy.U perlxv.U quadfio.U selectminbits.U
+ ! stdio_streams.U uselfs.U
+____________________________________________________________________________
+[ 10592] By: jhi on 2001/06/15 00:15:52
+ Log: The first steps towards cross-compilation.
+
+ Abstract execution of compiled test executables with $run,
+ and abstract transfer of files with $to and $from.
+
+ Under cross-compilation the $run, $to, and $from will point
+ to appropriate wrapper scripts, by default ssh and scp,
+ but also rsh, rcp, and cp are supported. If not
+ cross-compiling, they will be set to '', ':', and ':',
+ respectively.
+
+ With these patches I was able to get Configure for
+ iPAQ ARM Linux on an Intel Linux about 95% right
+ (only a few tests failed to execute or they produced
+ incorrect results), and I was able to compile
+ a functional miniperl.
+
+ The symbol crosscompile renamed to be usecrosscompile,
+ the corresponding C symbol from CROSSCOMPILE to
+ USE_CROSS_COMPILE.
+ Branch: perl
+ ! Configure Cross/README Makefile.SH Porting/Glossary
+ ! Porting/config.sh Porting/config_H config_h.SH configure.com
+ ! epoc/config.sh hints/linux.sh pod/perltoc.pod uconfig.h
+ ! uconfig.sh vos/config.alpha.def vos/config.alpha.h
+ ! vos/config.ga.def vos/config.ga.h win32/config.bc
+ ! win32/config.gc win32/config.vc win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc
+____________________________________________________________________________
+[ 10591] By: nick on 2001/06/14 20:00:12
+ Log: Steps along the road toward Win32 building again.
+ Branch: perlio
+ ! perlio.c win32/makefile.mk
+____________________________________________________________________________
+[ 10590] By: jhi on 2001/06/14 16:11:11
+ Log: Integrate perlio.
+ Branch: perl
+ !> win32/config_H.bc win32/config_H.gc win32/config_H.vc
+____________________________________________________________________________
+[ 10589] By: nick on 2001/06/14 13:54:07
+ Log: Routine regen_config_h for Win32
+ Branch: perlio
+ ! win32/config_H.bc win32/config_H.gc win32/config_H.vc
+____________________________________________________________________________
+[ 10588] By: jhi on 2001/06/14 12:30:46
+ Log: Integrate perlio.
+ Branch: perl
+ +> perlyline.pl
+ !> MANIFEST Makefile.SH perly.c t/lib/filefind.t
+____________________________________________________________________________
+[ 10587] By: jhi on 2001/06/14 12:23:24
+ Log: A placeholder.
+ Branch: perl
+ + Cross/README
+____________________________________________________________________________
+[ 10586] By: nick on 2001/06/14 08:25:07
+ Log: Add new step to run_byacc which:
+ A. Corrects #line NNN "perly.c" lines so warnings etc. are trackable
+ B. Adds extra () to the two if (var = ...) constructs gcc -Wall winges about.
+ Branch: perlio
+ + perlyline.pl
+ ! MANIFEST Makefile.SH perly.c
+____________________________________________________________________________
+[ 10585] By: nick on 2001/06/14 08:22:29
+ Log: Integrate mainline
+ Branch: perlio
+ +> locale.c numeric.c
+ !> Changes cygwin/Makefile.SHs embed.h embed.pl
+ !> ext/re/Makefile.PL lib/Math/BigFloat.pm lib/Math/BigInt.pm
+ !> objXSUB.h opcode.pl patchlevel.h perlapi.c pod/perlapi.pod
+ !> proto.h t/lib/bigfltpm.t t/lib/bigintpm.t util.c
+ !> x2p/Makefile.SH
+____________________________________________________________________________
+[ 10584] By: nick on 2001/06/14 08:05:53
+ Log: Hack to remove insecure directories from PATH so test will run.
+ Branch: perlio
+ ! t/lib/filefind.t
+____________________________________________________________________________
+[ 10583] By: jhi on 2001/06/14 03:11:16
+ Log: The test doesn't work (yet?), Math::BigInt::round_mode() is missing.
+ Branch: perl
+ - t/lib/mbimbf.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 10582] By: jhi on 2001/06/14 03:04:51
+ Log: Detypo.
+ Branch: perl
+ ! x2p/Makefile.SH
+____________________________________________________________________________
+[ 10581] By: jhi on 2001/06/14 03:03:14
+ Log: de-$CONFIG continues.
+ Branch: perl
+ ! cygwin/Makefile.SHs x2p/Makefile.SH
+____________________________________________________________________________
+[ 10580] By: jhi on 2001/06/13 23:56:59
+ Log: Subject: [PATCH] opcode.pl is chmod'ing the original source tree
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Wed, 13 Jun 2001 21:20:13 +0100
+ Message-ID: <20010613212013.D98663@plum.flirble.org>
+ Branch: perl
+ ! opcode.pl
+____________________________________________________________________________
+[ 10579] By: jhi on 2001/06/13 23:55:29
+ Log: Subject: splitting util.c
+ From: Hugo <hv@crypt.compulink.co.uk>
+ Date: Thu, 14 Jun 2001 00:41:08 +0100
+ Message-Id: <200106132341.AAA24935@crypt.compulink.co.uk>
+ Branch: perl
+ + locale.c numeric.c
+ ! MANIFEST Makefile.SH embed.h embed.pl objXSUB.h perlapi.c
+ ! pod/perlapi.pod proto.h util.c
+____________________________________________________________________________
+[ 10578] By: jhi on 2001/06/13 23:45:11
+ Log: Upgrade to Math::BigInt 1.34 from Tels.
+ Branch: perl
+ + t/lib/mbimbf.t
+ ! MANIFEST lib/Math/BigFloat.pm lib/Math/BigInt.pm
+ ! t/lib/bigfltpm.t t/lib/bigintpm.t
+____________________________________________________________________________
+[ 10577] By: nick on 2001/06/13 19:02:48
+ Log: Integrate mainline. Storable fail has gone, insecure dependancy still there.
+ Branch: perlio
+ !> (integrate 125 files)
+____________________________________________________________________________
+[ 10576] By: jhi on 2001/06/13 18:10:01
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+____________________________________________________________________________
[ 10575] By: jhi on 2001/06/13 18:05:09
Log: Subject: Re: [PATCH perl@10538] make ext/re play nice with DEBUGGING override
From: "Craig A. Berry" <craigberry@mac.com>
=head1 AVAILABILITY
-Gdbm is available from any GNU archive. The master site is
-C<prep.ai.mit.edu>, but your are strongly urged to use one of the many
-mirrors. You can obtain a list of mirror sites by issuing the
-command C<finger fsf@prep.ai.mit.edu>.
+gdbm is available from any GNU archive. The master site is
+C<ftp.gnu.org>, but you are strongly urged to use one of the many
+mirrors. You can obtain a list of mirror sites from
+http://www.gnu.org/order/ftp.html.
=head1 BUGS
require Carp;
require Tie::Hash;
require Exporter;
-use AutoLoader;
use XSLoader ();
@ISA = qw(Tie::Hash Exporter);
@EXPORT = qw(
GDBM_WRITER
);
-$VERSION = "1.05";
+$VERSION = "1.06";
sub AUTOLOAD {
my($constname);
($constname = $AUTOLOAD) =~ s/.*:://;
- my $val = constant($constname, @_ ? $_[0] : 0);
- if ($! != 0) {
- if ($! =~ /Invalid/ || $!{EINVAL}) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- Carp::croak("Your vendor has not defined GDBM_File macro $constname, used");
- }
- }
+ my ($error, $val) = constant($constname);
+ Carp::croak $error if $error;
eval "sub $AUTOLOAD { $val }";
goto &$AUTOLOAD;
}
XSLoader::load 'GDBM_File', $VERSION;
-# Preloaded methods go here. Autoload methods go after __END__, and are
-# processed by the autosplit program.
-
1;
-__END__
#define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
#endif
-static double
-constant(char *name, int arg)
-{
- errno = 0;
- switch (*name) {
- case 'A':
- break;
- case 'B':
- break;
- case 'C':
- break;
- case 'D':
- break;
- case 'E':
- break;
- case 'F':
- break;
- case 'G':
- if (strEQ(name, "GDBM_CACHESIZE"))
-#ifdef GDBM_CACHESIZE
- return GDBM_CACHESIZE;
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF 2
+#define PERL_constant_ISIV 3
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISUNDEF 8
+#define PERL_constant_ISUV 9
+#define PERL_constant_ISYES 10
+
+static int
+constant (const char *name, STRLEN len, IV *iv_return) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+#!../../perl -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw(IV)};
+my @names = (qw(GDBM_CACHESIZE GDBM_FAST GDBM_FASTMODE GDBM_INSERT GDBM_NEWDB
+ GDBM_NOLOCK GDBM_READER GDBM_REPLACE GDBM_WRCREAT GDBM_WRITER));
+
+print constant_types(); # macro defs
+foreach (C_constant ("GDBM_File", 'constant', 'IV', $types, undef, 8, @names) ) {
+ print $_, "\n"; # C constant subs
+}
+print "#### XS Section:\n";
+print XS_constant ("GDBM_File", $types);
+__END__
+ */
+
+ switch (len) {
+ case 9:
+ if (memEQ(name, "GDBM_FAST", 9)) {
+#ifdef GDBM_FAST
+ *iv_return = GDBM_FAST;
+ return PERL_constant_ISIV;
#else
- goto not_there;
+ return PERL_constant_NOTDEF;
#endif
- if (strEQ(name, "GDBM_FAST"))
-#ifdef GDBM_FAST
- return GDBM_FAST;
+ }
+ break;
+ case 10:
+ if (memEQ(name, "GDBM_NEWDB", 10)) {
+#ifdef GDBM_NEWDB
+ *iv_return = GDBM_NEWDB;
+ return PERL_constant_ISIV;
#else
- goto not_there;
+ return PERL_constant_NOTDEF;
#endif
- if (strEQ(name, "GDBM_FASTMODE"))
-#ifdef GDBM_FASTMODE
- return GDBM_FASTMODE;
+ }
+ break;
+ case 11:
+ /* Names all of length 11. */
+ /* GDBM_INSERT GDBM_NOLOCK GDBM_READER GDBM_WRITER */
+ /* Offset 6 gives the best switch position. */
+ switch (name[6]) {
+ case 'E':
+ if (memEQ(name, "GDBM_READER", 11)) {
+ /* ^ */
+#ifdef GDBM_READER
+ *iv_return = GDBM_READER;
+ return PERL_constant_ISIV;
#else
- goto not_there;
+ return PERL_constant_NOTDEF;
#endif
- if (strEQ(name, "GDBM_INSERT"))
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "GDBM_INSERT", 11)) {
+ /* ^ */
#ifdef GDBM_INSERT
- return GDBM_INSERT;
+ *iv_return = GDBM_INSERT;
+ return PERL_constant_ISIV;
#else
- goto not_there;
+ return PERL_constant_NOTDEF;
#endif
- if (strEQ(name, "GDBM_NEWDB"))
-#ifdef GDBM_NEWDB
- return GDBM_NEWDB;
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "GDBM_NOLOCK", 11)) {
+ /* ^ */
+#ifdef GDBM_NOLOCK
+ *iv_return = GDBM_NOLOCK;
+ return PERL_constant_ISIV;
#else
- goto not_there;
+ return PERL_constant_NOTDEF;
#endif
- if (strEQ(name, "GDBM_NOLOCK"))
-#ifdef GDBM_NOLOCK
- return GDBM_NOLOCK;
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "GDBM_WRITER", 11)) {
+ /* ^ */
+#ifdef GDBM_WRITER
+ *iv_return = GDBM_WRITER;
+ return PERL_constant_ISIV;
#else
- goto not_there;
+ return PERL_constant_NOTDEF;
#endif
- if (strEQ(name, "GDBM_READER"))
-#ifdef GDBM_READER
- return GDBM_READER;
+ }
+ break;
+ }
+ break;
+ case 12:
+ /* Names all of length 12. */
+ /* GDBM_REPLACE GDBM_WRCREAT */
+ /* Offset 10 gives the best switch position. */
+ switch (name[10]) {
+ case 'A':
+ if (memEQ(name, "GDBM_WRCREAT", 12)) {
+ /* ^ */
+#ifdef GDBM_WRCREAT
+ *iv_return = GDBM_WRCREAT;
+ return PERL_constant_ISIV;
#else
- goto not_there;
+ return PERL_constant_NOTDEF;
#endif
- if (strEQ(name, "GDBM_REPLACE"))
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "GDBM_REPLACE", 12)) {
+ /* ^ */
#ifdef GDBM_REPLACE
- return GDBM_REPLACE;
+ *iv_return = GDBM_REPLACE;
+ return PERL_constant_ISIV;
#else
- goto not_there;
+ return PERL_constant_NOTDEF;
#endif
- if (strEQ(name, "GDBM_WRCREAT"))
-#ifdef GDBM_WRCREAT
- return GDBM_WRCREAT;
+ }
+ break;
+ }
+ break;
+ case 13:
+ if (memEQ(name, "GDBM_FASTMODE", 13)) {
+#ifdef GDBM_FASTMODE
+ *iv_return = GDBM_FASTMODE;
+ return PERL_constant_ISIV;
#else
- goto not_there;
+ return PERL_constant_NOTDEF;
#endif
- if (strEQ(name, "GDBM_WRITER"))
-#ifdef GDBM_WRITER
- return GDBM_WRITER;
+ }
+ break;
+ case 14:
+ if (memEQ(name, "GDBM_CACHESIZE", 14)) {
+#ifdef GDBM_CACHESIZE
+ *iv_return = GDBM_CACHESIZE;
+ return PERL_constant_ISIV;
#else
- goto not_there;
+ return PERL_constant_NOTDEF;
#endif
- break;
- case 'H':
- break;
- case 'I':
- break;
- case 'J':
- break;
- case 'K':
- break;
- case 'L':
- break;
- case 'M':
- break;
- case 'N':
- break;
- case 'O':
- break;
- case 'P':
- break;
- case 'Q':
- break;
- case 'R':
- break;
- case 'S':
- break;
- case 'T':
- break;
- case 'U':
- break;
- case 'V':
- break;
- case 'W':
- break;
- case 'X':
- break;
- case 'Y':
- break;
- case 'Z':
- break;
}
- errno = EINVAL;
- return 0;
-
- if (0) {
- goto not_there; /* -Wall */
- }
-
-not_there:
- errno = ENOENT;
- return 0;
+ break;
+ }
+ return PERL_constant_NOTFOUND;
}
MODULE = GDBM_File PACKAGE = GDBM_File PREFIX = gdbm_
-double
-constant(name,arg)
- char * name
- int arg
+void
+constant(sv)
+ PREINIT:
+ dXSTARG;
+ STRLEN len;
+ int type;
+ IV iv;
+ /* NV nv; Uncomment this if you need to return NVs */
+ /* const char *pv; Uncomment this if you need to return PVs */
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ /* Change this to constant(s, len, &iv, &nv);
+ if you need to return both NVs and IVs */
+ type = constant(s, len, &iv);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid GDBM_File macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined GDBM_File macro %s, used", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break;
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing GDBM_File macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
GDBM_File
package Socket;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-$VERSION = "1.73";
+$VERSION = "1.74";
=head1 NAME
if ($error) {
croak $error;
}
- eval "sub $AUTOLOAD () { $val }";
+ *$AUTOLOAD = sub { $val };
goto &$AUTOLOAD;
}
#define PERL_constant_NOTFOUND 1
#define PERL_constant_NOTDEF 2
#define PERL_constant_ISIV 3
-#define PERL_constant_ISNV 4
-#define PERL_constant_ISPV 5
-#define PERL_constant_ISPVN 6
-#define PERL_constant_ISUV 7
-
-#ifndef NVTYPE
-typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
-#endif
-
-static int
-constant_5 (const char *name, IV *iv_return) {
- /* Names all of length 5. */
- /* When generated this function returned values for the list of names given
- here. However, subsequent manual editing may have added or removed some.
- AF_NS PF_NS */
- /* Offset 0 gives the best switch position. */
- switch (name[0]) {
- case 'A':
- if (memEQ(name, "AF_NS", 5)) {
- /* ^ */
-#ifdef AF_NS
- *iv_return = AF_NS;
- return PERL_constant_ISIV;
-#else
- return PERL_constant_NOTDEF;
-#endif
- }
- break;
- case 'P':
- if (memEQ(name, "PF_NS", 5)) {
- /* ^ */
-#ifdef PF_NS
- *iv_return = PF_NS;
- return PERL_constant_ISIV;
-#else
- return PERL_constant_NOTDEF;
-#endif
- }
- break;
- }
- return PERL_constant_NOTFOUND;
-}
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISSV 8
+#define PERL_constant_ISUNDEF 9
+#define PERL_constant_ISUV 10
+#define PERL_constant_ISYES 11
static int
-constant_6 (const char *name, IV *iv_return) {
- /* Names all of length 6. */
+constant_6 (const char *name, IV *iv_return, SV **sv_return) {
/* When generated this function returned values for the list of names given
here. However, subsequent manual editing may have added or removed some.
AF_802 AF_DLI AF_LAT AF_MAX AF_NBS AF_NIT AF_OSI AF_PUP AF_SNA AF_X25
}
static int
-constant_7 (const char *name, IV *iv_return) {
- /* Names all of length 7. */
+constant_7 (const char *name, IV *iv_return, SV **sv_return) {
/* When generated this function returned values for the list of names given
here. However, subsequent manual editing may have added or removed some.
AF_ECMA AF_INET AF_UNIX IOV_MAX MSG_EOF MSG_EOR MSG_FIN MSG_OOB MSG_RST
break;
case 'O':
if (memEQ(name, "MSG_OOB", 7)) {
- /* ^ */
+ /* ^ */
#if defined(MSG_OOB) || defined(HAS_MSG_OOB) /* might be an enum */
*iv_return = MSG_OOB;
return PERL_constant_ISIV;
}
static int
-constant_8 (const char *name, IV *iv_return) {
- /* Names all of length 8. */
+constant_8 (const char *name, IV *iv_return, SV **sv_return) {
/* When generated this function returned values for the list of names given
here. However, subsequent manual editing may have added or removed some.
AF_CCITT AF_CHAOS AF_GOSIP MSG_PEEK PF_CCITT PF_CHAOS PF_GOSIP SOCK_RAW
}
static int
-constant_9 (const char *name, IV *iv_return) {
- /* Names all of length 9. */
+constant_9 (const char *name, IV *iv_return, SV **sv_return) {
/* When generated this function returned values for the list of names given
here. However, subsequent manual editing may have added or removed some.
AF_DECnet AF_HYLINK AF_OSINET AF_UNSPEC MSG_BCAST MSG_MCAST MSG_PROXY
}
static int
-constant_10 (const char *name, IV *iv_return) {
- /* Names all of length 10. */
+constant_10 (const char *name, IV *iv_return, SV **sv_return) {
/* When generated this function returned values for the list of names given
here. However, subsequent manual editing may have added or removed some.
- AF_DATAKIT AF_IMPLINK MSG_CTRUNC PF_DATAKIT PF_IMPLINK SCM_RIGHTS
- SOCK_DGRAM SOL_SOCKET TCP_MAXSEG TCP_STDURG UIO_MAXIOV */
+ AF_DATAKIT AF_IMPLINK INADDR_ANY MSG_CTRUNC PF_DATAKIT PF_IMPLINK
+ SCM_RIGHTS SOCK_DGRAM SOL_SOCKET TCP_MAXSEG TCP_STDURG UIO_MAXIOV */
/* Offset 6 gives the best switch position. */
switch (name[6]) {
case 'A':
#endif
}
break;
+ case '_':
+ if (memEQ(name, "INADDR_ANY", 10)) {
+ /* ^ */
+#ifdef INADDR_ANY
+ {
+struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_ANY);
+ *sv_return = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ));
+ return PERL_constant_ISSV;
+ }
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
}
return PERL_constant_NOTFOUND;
}
static int
-constant_11 (const char *name, IV *iv_return) {
- /* Names all of length 11. */
+constant_11 (const char *name, IV *iv_return, SV **sv_return) {
/* When generated this function returned values for the list of names given
here. However, subsequent manual editing may have added or removed some.
- IPPROTO_TCP MSG_WAITALL SCM_CONNECT SOCK_STREAM SO_RCVLOWAT SO_RCVTIMEO
- SO_SNDLOWAT SO_SNDTIMEO TCP_NODELAY */
- /* Offset 7 gives the best switch position. */
- switch (name[7]) {
- case 'E':
- if (memEQ(name, "TCP_NODELAY", 11)) {
- /* ^ */
-#ifdef TCP_NODELAY
- *iv_return = TCP_NODELAY;
+ INADDR_NONE IPPROTO_TCP MSG_WAITALL SCM_CONNECT SOCK_STREAM SO_RCVLOWAT
+ SO_RCVTIMEO SO_SNDLOWAT SO_SNDTIMEO TCP_NODELAY */
+ /* Offset 5 gives the best switch position. */
+ switch (name[5]) {
+ case 'A':
+ if (memEQ(name, "MSG_WAITALL", 11)) {
+ /* ^ */
+#ifdef MSG_WAITALL
+ *iv_return = MSG_WAITALL;
return PERL_constant_ISIV;
#else
return PERL_constant_NOTDEF;
#endif
}
break;
- case 'I':
- if (memEQ(name, "SO_RCVTIMEO", 11)) {
- /* ^ */
-#ifdef SO_RCVTIMEO
- *iv_return = SO_RCVTIMEO;
+ case 'D':
+ if (memEQ(name, "SO_SNDLOWAT", 11)) {
+ /* ^ */
+#ifdef SO_SNDLOWAT
+ *iv_return = SO_SNDLOWAT;
return PERL_constant_ISIV;
#else
return PERL_constant_NOTDEF;
#endif
}
if (memEQ(name, "SO_SNDTIMEO", 11)) {
- /* ^ */
+ /* ^ */
#ifdef SO_SNDTIMEO
*iv_return = SO_SNDTIMEO;
return PERL_constant_ISIV;
#endif
}
break;
- case 'N':
+ case 'O':
if (memEQ(name, "SCM_CONNECT", 11)) {
- /* ^ */
+ /* ^ */
#ifdef SCM_CONNECT
*iv_return = SCM_CONNECT;
return PERL_constant_ISIV;
return PERL_constant_NOTDEF;
#endif
}
- break;
- case 'O':
- if (memEQ(name, "SO_RCVLOWAT", 11)) {
- /* ^ */
-#ifdef SO_RCVLOWAT
- *iv_return = SO_RCVLOWAT;
+ if (memEQ(name, "TCP_NODELAY", 11)) {
+ /* ^ */
+#ifdef TCP_NODELAY
+ *iv_return = TCP_NODELAY;
return PERL_constant_ISIV;
#else
return PERL_constant_NOTDEF;
#endif
}
- if (memEQ(name, "SO_SNDLOWAT", 11)) {
- /* ^ */
-#ifdef SO_SNDLOWAT
- *iv_return = SO_SNDLOWAT;
- return PERL_constant_ISIV;
+ break;
+ case 'R':
+ if (memEQ(name, "INADDR_NONE", 11)) {
+ /* ^ */
+#ifdef INADDR_NONE
+ {
+struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_NONE);
+ *sv_return = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ));
+ return PERL_constant_ISSV;
+ }
#else
return PERL_constant_NOTDEF;
#endif
}
break;
- case 'R':
+ case 'S':
if (memEQ(name, "SOCK_STREAM", 11)) {
- /* ^ */
+ /* ^ */
#ifdef SOCK_STREAM
*iv_return = SOCK_STREAM;
return PERL_constant_ISIV;
}
break;
case 'T':
- if (memEQ(name, "MSG_WAITALL", 11)) {
- /* ^ */
-#ifdef MSG_WAITALL
- *iv_return = MSG_WAITALL;
+ if (memEQ(name, "IPPROTO_TCP", 11)) {
+ /* ^ */
+#ifdef IPPROTO_TCP
+ *iv_return = IPPROTO_TCP;
return PERL_constant_ISIV;
#else
return PERL_constant_NOTDEF;
#endif
}
break;
- case '_':
- if (memEQ(name, "IPPROTO_TCP", 11)) {
- /* ^ */
-#ifdef IPPROTO_TCP
- *iv_return = IPPROTO_TCP;
+ case 'V':
+ if (memEQ(name, "SO_RCVLOWAT", 11)) {
+ /* ^ */
+#ifdef SO_RCVLOWAT
+ *iv_return = SO_RCVLOWAT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SO_RCVTIMEO", 11)) {
+ /* ^ */
+#ifdef SO_RCVTIMEO
+ *iv_return = SO_RCVTIMEO;
return PERL_constant_ISIV;
#else
return PERL_constant_NOTDEF;
}
static int
-constant_12 (const char *name, IV *iv_return) {
- /* Names all of length 12. */
+constant_12 (const char *name, IV *iv_return, SV **sv_return) {
/* When generated this function returned values for the list of names given
here. However, subsequent manual editing may have added or removed some.
AF_APPLETALK MSG_CTLFLAGS MSG_DONTWAIT MSG_ERRQUEUE MSG_NOSIGNAL
}
static int
-constant_13 (const char *name, IV *iv_return) {
- /* Names all of length 13. */
+constant_13 (const char *name, IV *iv_return, SV **sv_return) {
/* When generated this function returned values for the list of names given
here. However, subsequent manual editing may have added or removed some.
MSG_CTLIGNORE MSG_DONTROUTE MSG_MAXIOVLEN SCM_TIMESTAMP SO_ACCEPTCONN
}
static int
-constant_14 (const char *name, IV *iv_return) {
- /* Names all of length 14. */
- /* When generated this function returned values for the list of names given
- here. However, subsequent manual editing may have added or removed some.
- SOCK_SEQPACKET SO_USELOOPBACK */
- /* Offset 8 gives the best switch position. */
- switch (name[8]) {
- case 'O':
- if (memEQ(name, "SO_USELOOPBACK", 14)) {
- /* ^ */
-#ifdef SO_USELOOPBACK
- *iv_return = SO_USELOOPBACK;
- return PERL_constant_ISIV;
-#else
- return PERL_constant_NOTDEF;
-#endif
- }
- break;
- case 'P':
- if (memEQ(name, "SOCK_SEQPACKET", 14)) {
- /* ^ */
-#ifdef SOCK_SEQPACKET
- *iv_return = SOCK_SEQPACKET;
- return PERL_constant_ISIV;
-#else
- return PERL_constant_NOTDEF;
-#endif
- }
- break;
- }
- return PERL_constant_NOTFOUND;
-}
-
-static int
-constant (const char *name, STRLEN len, IV *iv_return) {
+constant (const char *name, STRLEN len, IV *iv_return, SV **sv_return) {
/* Initially switch on the length of the name. */
/* When generated this function returned values for the list of names given
in this section of perl code. Rather than manually editing these functions
Regenerate these constant functions by feeding this entire source file to
perl -x
-#!perl -w
+#!../../perl -w
use ExtUtils::Constant qw (constant_types C_constant XS_constant);
-my $types = {IV => 1};
+my $types = {map {($_, 1)} qw(IV SV)};
my @names = (qw(AF_802 AF_APPLETALK AF_CCITT AF_CHAOS AF_DATAKIT AF_DECnet
AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_LAT
AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP AF_SNA
AF_UNIX AF_UNSPEC AF_X25 IOV_MAX IPPROTO_TCP MSG_BCAST
MSG_CTLFLAGS MSG_CTLIGNORE MSG_DONTWAIT MSG_EOF MSG_EOR
MSG_ERRQUEUE MSG_FIN MSG_MAXIOVLEN MSG_MCAST MSG_NOSIGNAL
- MSG_RST MSG_SYN MSG_TRUNC MSG_WAITALL PF_802 PF_APPLETALK
- PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI PF_ECMA PF_GOSIP
- PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT PF_NS
- PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25
- SCM_CONNECT SCM_CREDENTIALS SCM_CREDS SCM_TIMESTAMP SOCK_DGRAM
- SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET
- SOMAXCONN SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER
- SO_DONTROUTE SO_ERROR SO_KEEPALIVE SO_LINGER SO_OOBINLINE
- SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT
- SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK
- TCP_KEEPALIVE TCP_MAXRT TCP_MAXSEG TCP_NODELAY TCP_STDURG
- UIO_MAXIOV MSG_URG),
+ MSG_RST MSG_SYN MSG_TRUNC MSG_URG MSG_WAITALL PF_802
+ PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI
+ PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX
+ PF_NBS PF_NIT PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX
+ PF_UNSPEC PF_X25 SCM_CONNECT SCM_CREDENTIALS SCM_CREDS
+ SCM_TIMESTAMP SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET
+ SOCK_STREAM SOL_SOCKET SOMAXCONN SO_ACCEPTCONN SO_BROADCAST
+ SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR SO_KEEPALIVE
+ SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO
+ SO_REUSEADDR SO_REUSEPORT SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO
+ SO_TYPE SO_USELOOPBACK TCP_KEEPALIVE TCP_MAXRT TCP_MAXSEG
+ TCP_NODELAY TCP_STDURG UIO_MAXIOV),
+ {name=>"INADDR_ANY", type=>"SV", value=>"sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ))", pre=>"struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_ANY);"},
+ {name=>"INADDR_BROADCAST", type=>"SV", value=>"sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ))", pre=>"struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_BROADCAST);"},
+ {name=>"INADDR_LOOPBACK", type=>"SV", value=>"sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ))", pre=>"struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_LOOPBACK);"},
+ {name=>"INADDR_NONE", type=>"SV", value=>"sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ))", pre=>"struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_NONE);"},
{name=>"MSG_CTRUNC", type=>"IV", macro=>["#if defined(MSG_CTRUNC) || defined(HAS_MSG_CTRUNC) /" . "* might be an enum *" . "/\n", "#endif\n"]},
{name=>"MSG_DONTROUTE", type=>"IV", macro=>["#if defined(MSG_DONTROUTE) || defined(HAS_MSG_DONTROUTE) /" . "* might be an enum *" . "/\n", "#endif\n"]},
{name=>"MSG_OOB", type=>"IV", macro=>["#if defined(MSG_OOB) || defined(HAS_MSG_OOB) /" . "* might be an enum *" . "/\n", "#endif\n"]},
{name=>"SHUT_WR", type=>"IV", default=>["IV", "1"]});
print constant_types(); # macro defs
-foreach (C_constant ("Socket", 'constant', 'IV', $types, undef, undef, @names) ) {
+foreach (C_constant ("Socket", 'constant', 'IV', $types, undef, 3, @names) ) {
print $_, "\n"; # C constant subs
}
print "#### XS Section:\n";
switch (len) {
case 5:
- return constant_5 (name, iv_return);
+ /* Names all of length 5. */
+ /* AF_NS PF_NS */
+ /* Offset 0 gives the best switch position. */
+ switch (name[0]) {
+ case 'A':
+ if (memEQ(name, "AF_NS", 5)) {
+ /* ^ */
+#ifdef AF_NS
+ *iv_return = AF_NS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "PF_NS", 5)) {
+ /* ^ */
+#ifdef PF_NS
+ *iv_return = PF_NS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
break;
case 6:
- return constant_6 (name, iv_return);
+ return constant_6 (name, iv_return, sv_return);
break;
case 7:
- return constant_7 (name, iv_return);
+ return constant_7 (name, iv_return, sv_return);
break;
case 8:
- return constant_8 (name, iv_return);
+ return constant_8 (name, iv_return, sv_return);
break;
case 9:
- return constant_9 (name, iv_return);
+ return constant_9 (name, iv_return, sv_return);
break;
case 10:
- return constant_10 (name, iv_return);
+ return constant_10 (name, iv_return, sv_return);
break;
case 11:
- return constant_11 (name, iv_return);
+ return constant_11 (name, iv_return, sv_return);
break;
case 12:
- return constant_12 (name, iv_return);
+ return constant_12 (name, iv_return, sv_return);
break;
case 13:
- return constant_13 (name, iv_return);
+ return constant_13 (name, iv_return, sv_return);
break;
case 14:
- return constant_14 (name, iv_return);
+ /* Names all of length 14. */
+ /* SOCK_SEQPACKET SO_USELOOPBACK */
+ /* Offset 8 gives the best switch position. */
+ switch (name[8]) {
+ case 'O':
+ if (memEQ(name, "SO_USELOOPBACK", 14)) {
+ /* ^ */
+#ifdef SO_USELOOPBACK
+ *iv_return = SO_USELOOPBACK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "SOCK_SEQPACKET", 14)) {
+ /* ^ */
+#ifdef SOCK_SEQPACKET
+ *iv_return = SOCK_SEQPACKET;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
break;
case 15:
- if (memEQ(name, "SCM_CREDENTIALS", 15)) {
+ /* Names all of length 15. */
+ /* INADDR_LOOPBACK SCM_CREDENTIALS */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'C':
+ if (memEQ(name, "SCM_CREDENTIALS", 15)) {
+ /* ^ */
#ifdef SCM_CREDENTIALS
- *iv_return = SCM_CREDENTIALS;
- return PERL_constant_ISIV;
+ *iv_return = SCM_CREDENTIALS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "INADDR_LOOPBACK", 15)) {
+ /* ^ */
+#ifdef INADDR_LOOPBACK
+ {
+struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_LOOPBACK);
+ *sv_return = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ));
+ return PERL_constant_ISSV;
+ }
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ break;
+ case 16:
+ if (memEQ(name, "INADDR_BROADCAST", 16)) {
+#ifdef INADDR_BROADCAST
+ {
+struct in_addr ip_address; ip_address.s_addr = htonl(INADDR_BROADCAST);
+ *sv_return = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ));
+ return PERL_constant_ISSV;
+ }
#else
return PERL_constant_NOTDEF;
#endif
void
constant(sv)
PREINIT:
-#ifdef dXSTARG
- dXSTARG; /* Faster if we have it. */
-#else
- dTARGET;
-#endif
+ dXSTARG;
STRLEN len;
int type;
IV iv;
PPCODE:
/* Change this to constant(s, len, &iv, &nv);
if you need to return both NVs and IVs */
- type = constant(s, len, &iv);
+ type = constant(s, len, &iv, &sv);
/* Return 1 or 2 items. First is error message, or undef if no error.
Second, if present, is found value */
switch (type) {
PUSHs(&PL_sv_undef);
PUSHi(iv);
break;
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break;
/* Uncomment this if you need to return UVs
case PERL_constant_ISUV:
EXTEND(SP, 1);
break; */
default:
sv = sv_2mortal(newSVpvf(
- "Unexpected return type %d while processing Socket macro %s used",
+ "Unexpected return type %d while processing Socket macro %s, used",
type, s));
PUSHs(sv);
}
PUSHs(sv_2mortal(newSViv((IV) port)));
PUSHs(sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address)));
}
-
-void
-INADDR_ANY()
- CODE:
- {
- struct in_addr ip_address;
- ip_address.s_addr = htonl(INADDR_ANY);
- ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address ));
- }
-
-void
-INADDR_LOOPBACK()
- CODE:
- {
- struct in_addr ip_address;
- ip_address.s_addr = htonl(INADDR_LOOPBACK);
- ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address));
- }
-
-void
-INADDR_NONE()
- CODE:
- {
- struct in_addr ip_address;
- ip_address.s_addr = htonl(INADDR_NONE);
- ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address));
- }
-
-void
-INADDR_BROADCAST()
- CODE:
- {
- struct in_addr ip_address;
- ip_address.s_addr = htonl(INADDR_BROADCAST);
- ST(0) = sv_2mortal(newSVpvn((char *)&ip_address,sizeof ip_address));
- }
package ExtUtils::Constant;
use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
-$VERSION = '0.05';
+$VERSION = '0.06';
=head1 NAME
A fixed length thing, given as a [pointer, length] pair. If you know the
length of a string at compile time you may use this instead of I<PV>
+=item PVN
+
+A B<mortal> SV.
+
=item YES
Truth. (C<PL_sv_yes>) The value is not needed (and ignored).
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
%XS_Constant = (
- IV => 'PUSHi(iv)',
- UV => 'PUSHu((UV)iv)',
- NV => 'PUSHn(nv)',
- PV => 'PUSHp(pv, strlen(pv))',
- PVN => 'PUSHp(pv, iv)',
- YES => 'PUSHs(&PL_sv_yes)',
- NO => 'PUSHs(&PL_sv_no)',
+ IV => 'PUSHi(iv)',
+ UV => 'PUSHu((UV)iv)',
+ NV => 'PUSHn(nv)',
+ PV => 'PUSHp(pv, strlen(pv))',
+ PVN => 'PUSHp(pv, iv)',
+ SV => 'PUSHs(sv)',
+ YES => 'PUSHs(&PL_sv_yes)',
+ NO => 'PUSHs(&PL_sv_no)',
UNDEF => '', # implicit undef
);
%XS_TypeSet = (
- IV => '*iv_return =',
- UV => '*iv_return = (IV)',
- NV => '*nv_return =',
- PV => '*pv_return =',
- PVN => ['*pv_return =', '*iv_return = (IV)'],
+ IV => '*iv_return =',
+ UV => '*iv_return = (IV)',
+ NV => '*nv_return =',
+ PV => '*pv_return =',
+ PVN => ['*pv_return =', '*iv_return = (IV)'],
+ SV => '*sv_return = ',
YES => undef,
NO => undef,
UNDEF => undef,
return $body;
}
-=item assign INDENT, TYPE, VALUE...
+=item assign INDENT, TYPE, PRE, POST, VALUE...
A function to return a suitable assignment clause. If I<TYPE> is aggregate
(eg I<PVN> expects both pointer and length) then there should be multiple
-I<VALUE>s for the components.
+I<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
+of C code to preceed and follow the assignment. I<PRE> will be at the start
+of a block, so variables may be defined in it.
=cut
sub assign {
my $indent = shift;
my $type = shift;
+ my $pre = shift;
+ my $post = shift || '';
my $clause;
+ my $close;
+ if ($pre) {
+ chomp $pre;
+ $clause = $indent . "{\n$pre";
+ $clause .= ";" unless $pre =~ /;$/;
+ $clause .= "\n";
+ $close = "$indent}\n";
+ $indent .= " ";
+ }
die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
my $typeset = $XS_TypeSet{$type};
if (ref $typeset) {
if @_ > 1;
$clause .= $indent . "$typeset $_[0];\n";
}
+ chomp $post;
+ if (length $post) {
+ $clause .= "$post";
+ $clause .= ";" unless $post =~ /;$/;
+ $clause .= "\n";
+ }
$clause .= "${indent}return PERL_constant_IS$type;\n";
+ $clause .= $close if $close;
return $clause;
}
-=item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT
+=item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both
this function with I<MACRO> defined, defaulting to the constant's name.
I<DEFAULT> if defined is an array reference giving default type and and
value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
+The two pairs I<PRE> and I<POST> if defined give C code snippets to proceed
+and follow the value, and the default value.
=cut
-sub return_clause ($$$$$) {
+sub return_clause ($$$$$$$$$) {
##ifdef thingy
# *iv_return = thingy;
# return PERL_constant_ISIV;
##else
# return PERL_constant_NOTDEF;
##endif
- my ($value, $type, $indent, $macro, $default) = @_;
+ my ($value, $type, $indent, $macro, $default, $pre, $post,
+ $def_pre, $def_post) = @_;
$macro = $value unless defined $macro;
$indent = ' ' x ($indent || 6);
# *iv_return = thingy;
# return PERL_constant_ISIV;
- $clause .= assign ($indent, $type, ref $value ? @$value : $value);
+ $clause .= assign ($indent, $type, $pre, $post,
+ ref $value ? @$value : $value);
##else
$clause .= "#else\n";
if (!defined $default) {
$clause .= "${indent}return PERL_constant_NOTDEF;\n";
} else {
- $clause .= assign ($indent, ref $default ? @$default : $default);
+ my @default = ref $default ? @$default : $default;
+ $type = shift @default;
+ $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
}
##endif
$body .= $indent . "case '" . C_stringify ($char) . "':\n";
foreach my $name (sort @{$best->{$char}}) {
my $thisone = $items->{$name};
- my ($value, $macro, $default) = @$thisone{qw (value macro default)};
+ my ($value, $macro, $default, $pre, $post, $def_pre, $def_post)
+ = @$thisone{qw (value macro default pre post def_pre def_post)};
$value = $name unless defined $value;
$macro = $name unless defined $macro;
# We have checked this offset.
$body .= memEQ_clause ($name, $offset, 2 + length $indent);
$body .= return_clause ($value, $thisone->{type}, 4 + length $indent,
- $macro, $default);
+ $macro, $default, $pre, $post,
+ $def_pre, $def_post);
$body .= $indent . " }\n";
}
$body .= $indent . " break;\n";
my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN};
my $use_nv = $what->{NV};
my $use_pv = $what->{PV} || $what->{PVN};
- return ($use_iv, $use_nv, $use_pv);
+ my $use_sv = $what->{SV};
+ return ($use_iv, $use_nv, $use_pv, $use_sv);
}
=item dump_names
my $type = $_->{type} || $default_type;
if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
and !defined ($_->{macro}) and !defined ($_->{value})
- and !defined ($_->{default})) {
+ and !defined ($_->{default}) and !defined ($_->{pre})
+ and !defined ($_->{post}) and !defined ($_->{def_pre})
+ and !defined ($_->{def_post})) {
# It's the default type, and the name consists only of A-Za-z0-9_
push @simple, $_->{name};
} else {
if (@complex) {
foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
my $name = C_stringify $item->{name};
- my ($macro, $value, $default) = @$item{qw (macro value default)};
my $line = ",\n {name=>\"$name\"";
$line .= ", type=>\"$item->{type}\"" if defined $item->{type};
- if (defined $macro) {
- if (ref $macro) {
- $line .= ', macro=>["'. join ('", "', map {C_stringify $_} @$macro)
- . '"]';
- } else {
- $line .= ", macro=>\"" . C_stringify($macro) . "\"";
- }
- }
- if (defined $value) {
- if (ref $value) {
- $line .= ', value=>["'. join ('", "', map {C_stringify $_} @$value)
- . '"]';
- } else {
- $line .= ", value=>\"" . C_stringify($value) . "\"";
- }
- }
- if (defined $default) {
- if (ref $default) {
- $line .= ', default=>["'. join ('", "', map {C_stringify $_}
- @$default)
- . '"]';
- } else {
- $line .= ", default=>\"" . C_stringify($default) . "\"";
+ foreach my $thing (qw (macro value default pre post def_pre def_post)) {
+ my $value = $item->{$thing};
+ if (defined $value) {
+ if (ref $value) {
+ $line .= ", $thing=>[\""
+ . join ('", "', map {C_stringify $_} @$value) . '"]';
+ } else {
+ $line .= ", $thing=>\"" . C_stringify($value) . "\"";
+ }
}
}
$line .= "}";
defined...") to return if the macro isn't defined. Specify a reference to
an array with type followed by value(s).
+=item pre
+
+C code to use before the assignment of the value of the constant. This allows
+you to use temporary variables to extract a value from part of a C<struct>
+and return this as I<value>. This C code is places at the start of a block,
+so you can declare variables in it.
+
+=item post
+
+C code to place between the assignment of value (to a temporary) and the
+return from the function. This allows you to clear up anything in I<pre>.
+Rarely needed.
+
+=item def_pre
+=item def_post
+
+Equivalents of I<pre> and I<post> for the default value.
+
=back
I<PACKAGE> is the name of the package, and is only used in comments inside the
foreach (@items) {
my $name;
if (ref $_) {
+ my $orig = $_;
# Make a copy which is a normalised version of the ref passed in.
$name = $_->{name};
- my ($type, $macro, $value, $default) = @$_{qw (type macro value default)};
+ my ($type, $macro, $value) = @$_{qw (type macro value)};
$type ||= $default_type;
$what->{$type} = 1;
$_ = {name=>$name, type=>$type};
$_->{macro} = $macro if defined $macro;
undef $value if defined $value and $value eq $name;
$_->{value} = $value if defined $value;
- $_->{default} = $default if defined $default;
+ foreach my $key (qw(default pre post def_pre def_post)) {
+ my $value = $orig->{$key};
+ $_->{$key} = $value if defined $value;
+ # warn "$key $value";
+ }
} else {
$name = $_;
$_ = {name=>$_, type=>$default_type};
}
$items{$name} = $_;
}
- my ($use_iv, $use_nv, $use_pv) = params ($what);
+ my ($use_iv, $use_nv, $use_pv, $use_sv) = params ($what);
my ($body, @subs) = "static int\n$subname (const char *name";
$body .= ", STRLEN len" unless defined $namelen;
$body .= ", IV *iv_return" if $use_iv;
$body .= ", NV *nv_return" if $use_nv;
$body .= ", const char **pv_return" if $use_pv;
+ $body .= ", SV **sv_return" if $use_sv;
$body .= ") {\n";
if (defined $namelen) {
$body .= " case $i:\n";
if (@{$by_length[$i]} == 1) {
my $thisone = $by_length[$i]->[0];
- my ($name, $value, $macro, $default)
- = @$thisone{qw (name value macro default)};
+ my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post)
+ = @$thisone{qw (name value macro default pre post def_pre def_post)};
$value = $name unless defined $value;
$macro = $name unless defined $macro;
$body .= memEQ_clause ($name);
$body .= return_clause ($value, $thisone->{type}, undef, $macro,
- $default);
+ $default, $pre, $post, $def_pre, $def_post);
$body .= " }\n";
} elsif (@{$by_length[$i]} < $breakout) {
$body .= switch_clause (4, '', $i, \%items, @{$by_length[$i]});
$body .= ", iv_return" if $use_iv;
$body .= ", nv_return" if $use_nv;
$body .= ", pv_return" if $use_pv;
+ $body .= ", sv_return" if $use_sv;
$body .= ");\n";
}
$body .= " break;\n";
# Convert line of the form IV,UV,NV to hash
$what = {map {$_ => 1} split /,\s*/, ($what)};
}
- my ($use_iv, $use_nv, $use_pv) = params ($what);
+ my ($use_iv, $use_nv, $use_pv, $use_sv) = params ($what);
my $type;
my $xs = <<"EOT";
$xs .= ', &iv' if $use_iv;
$xs .= ', &nv' if $use_nv;
$xs .= ', &pv' if $use_pv;
+ $xs .= ', &sv' if $use_sv;
$xs .= ");\n";
$xs .= << "EOT";
use strict;
use warnings;
use 5.6.0;
-our $VERSION = '1.00';
+our $VERSION = '1.01';
require Exporter;
require Cwd;
=back
+=head1 HISTORY
+
+File::Find used to produce incorrect results if called recursively.
+During the development of perl 5.8 this bug was fixed.
+The first fixed version of File::Find was 1.01.
+
=cut
our @ISA = qw(Exporter);
require File::Basename;
require File::Spec;
-my %SLnkSeen;
-my ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
+# Should ideally be my() not our() but local() currently
+# refuses to operate on lexicals
+
+our %SLnkSeen;
+our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
$follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
$pre_process, $post_process);
my $wanted = shift;
die "invalid top directory" unless defined $_[0];
+ # This function must local()ize everything because callbacks may
+ # call find() or finddepth()
+
+ local %SLnkSeen;
+ local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow,
+ $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat,
+ $pre_process, $post_process);
+ local($dir, $name, $fullname, $prune);
+
my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::cwd();
my $cwd_untainted = $cwd;
my $check_t_cwd = 1;
$untaint_skip = $wanted->{untaint_skip};
# for compatability reasons (find.pl, find2perl)
- our ($topdir, $topdev, $topino, $topmode, $topnlink);
+ local our ($topdir, $topdev, $topino, $topmode, $topnlink);
# a symbolic link to a directory doesn't increase the link count
$avoid_nlink = $follow || $File::Find::dont_use_nlink;
sub find {
my $wanted = shift;
- %SLnkSeen= (); # clear hash first
_find_opt(wrap_wanted($wanted), @_);
- %SLnkSeen= (); # free memory
}
sub finddepth {
my $wanted = wrap_wanted(shift);
- %SLnkSeen= (); # clear hash first
$wanted->{bydepth} = 1;
_find_opt($wanted, @_);
- %SLnkSeen= (); # free memory
}
# default
#!/usr/bin/perl
-unlink "opcode.h", "opnames.h";
-open(OC, ">opcode.h") || die "Can't create opcode.h: $!\n";
-open(ON, ">opnames.h") || die "Can't create opnames.h: $!\n";
+open(OC, ">opcode.h.new") || die "Can't create opcode.h.new: $!\n";
+open(ON, ">opnames.h.new") || die "Can't create opnames.h.new: $!\n";
select OC;
# Read data.
close OC or die "Error closing opcode.h: $!";
close ON or die "Error closing opnames.h: $!";
-unlink "pp_proto.h";
-unlink "pp.sym";
-open PP, '>pp_proto.h' or die "Error creating pp_proto.h: $!";
-open PPSYM, '>pp.sym' or die "Error creating pp.sym: $!";
+chmod 0600, 'opcode.h'; # required by dosish filesystems
+chmod 0600, 'opnames.h'; # required by dosish filesystems
+
+rename 'opcode.h.new', 'opcode.h' or die "renaming opcode.h: $!\n";
+rename 'opnames.h.new', 'opnames.h' or die "renaming opnames.h: $!\n";
+
+open PP, '>pp_proto.h.new' or die "Error creating pp_proto.h.new: $!";
+open PPSYM, '>pp.sym.new' or die "Error creating pp.sym.new: $!";
print PP <<"END";
/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
close PP or die "Error closing pp_proto.h: $!";
close PPSYM or die "Error closing pp.sym: $!";
+chmod 0600, 'pp_proto.h'; # required by dosish filesystems
+chmod 0600, 'pp.sym'; # required by dosish filesystems
+
+rename 'pp_proto.h.new', 'pp_proto.h' or die "rename pp_proto.h: $!\n";
+rename 'pp.sym.new', 'pp.sym' or die "rename pp.sym: $!\n";
+
###########################################################################
sub tab {
local($l, $t) = @_;
#if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
static char *local_patches[] = {
NULL
- ,"DEVEL10575"
+ ,"DEVEL10610"
,NULL
};
void
PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
{
+ dTHX;
PerlIO_pair_t *p;
if (list->cur >= list->len)
{
#!./perl -w
-print "1..24\n";
+print "1..26\n";
BEGIN {
chdir 't' if -d 't';
N => 0, NE => 45, E => 90, SE => 135, S => 180, SW => 225, W => 270, NW => 315
);
+my $parent_rfc1149 =
+ 'A Standard for the Transmission of IP Datagrams on Avian Carriers';
+
my @names = ("FIVE", {name=>"OK6", type=>"PV",},
{name=>"OK7", type=>"PVN",
value=>['"not ok 7\\n\\0ok 7\\n"', 15]},
{name => "Yes", type=>"YES"},
{name => "No", type=>"NO"},
{name => "Undef", type=>"UNDEF"},
+# OK. It wasn't really designed to allow the creation of dual valued constants.
+# It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
+ {name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)",
+ pre=>"SV *temp_sv = newSVpv(RFC1149, 0); "
+ . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); "
+ . "SvIVX(temp_sv) = 1149;"},
);
push @names, $_ foreach keys %compass;
my $header = catfile($dir, "test.h");
push @files, "test.h";
open FH, ">$header" or die "open >$header: $!\n";
-print FH <<'EOT';
+print FH <<"EOT";
#define FIVE 5
#define OK6 "ok 6\n"
#define OK7 1
#define Yes 0
#define No 1
#define Undef 1
-
+#define RFC1149 "$parent_rfc1149"
#undef NOTDEF
EOT
EOT
+print FH <<"EOT";
+my \$rfc1149 = RFC1149;
+if (\$rfc1149 ne "$parent_rfc1149") {
+ print "not ok 20 # '\$rfc1149' ne '$parent_rfc1149'\n";
+} else {
+ print "ok 20\n";
+}
+
+if (\$rfc1149 != 1149) {
+ printf "not ok 21 # %d != 1149\n", \$rfc1149;
+} else {
+ print "ok 21\n";
+}
+EOT
close FH or die "close $testpl: $!\n";
################ Makefile.PL
}
}
-my $test = 20;
+my $test = 22;
my $maketest = "$make test";
print "# make = '$maketest'\n";
$makeout = `$maketest`;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ unshift @INC => '../lib';
for (keys %ENV) { # untaint ENV
- ($ENV{$_}) = keys %{{ map {$_ => 1} $ENV{$_} }};
+ ($ENV{$_}) = $ENV{$_} =~ /(.*)/;
}
$SIG{'__WARN__'} = sub { $warn_msg = $_[0]; warn "# Warn: $_[0]"; }
}
-if ( $symlink_exists ) { print "1..184\n"; }
+if ( $symlink_exists ) { print "1..193\n"; }
else { print "1..75\n"; }
use File::Find;
File::Find::find( {wanted => \&wanted, untaint => 1},':fa' );
Check( scalar(keys %Expect) == 0 );
+ print "# check re-entancy\n";
+ %Expect = (':' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1,
+ 'faba' => 1, 'faa' => 1, 'faa_ord' => 1);
+ delete $Expect{'fsl'} unless $symlink_exists;
+ %Expect_Dir = (':' => 1, 'fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1,
+ 'fb' => 1, 'fba' => 1);
+ delete @Expect_Dir{'fb','fba'} unless $symlink_exists;
+ File::Find::find( {wanted => sub {
+ wanted();
+ File::Find::find( {wanted => sub {} , untaint => 1 },':' );
+ }, untaint => 1 }, ':fa' );
+ Check( scalar(keys %Expect) == 0 );
+
%Expect=(':fa' => 1, ':fa:fsl' => 1, ':fa:fa_ord' => 1, ':fa:fab' => 1,
':fa:fab:fab_ord' => 1, ':fa:fab:faba' => 1,
':fa:fab:faba:faba_ord' => 1, ':fa:faa' => 1, ':fa:faa:faa_ord' => 1);
File::Find::find( {wanted => \&wanted, untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' );
Check( scalar(keys %Expect) == 0 );
+ print "# check re-entancy\n";
+ %Expect = ('.' => 1, 'fsl' => 1, 'fa_ord' => 1, 'fab' => 1, 'fab_ord' => 1,
+ 'faba' => 1, 'faa' => 1, 'faa_ord' => 1);
+ delete $Expect{'fsl'} unless $symlink_exists;
+ %Expect_Dir = ('fa' => 1, 'faa' => 1, 'fab' => 1, 'faba' => 1,
+ 'fb' => 1, 'fba' => 1);
+ delete @Expect_Dir{'fb','fba'} unless $symlink_exists;
+ File::Find::find( {wanted => sub {
+ wanted();
+ File::Find::find( {wanted => sub {} , untaint => 1, untaint_pattern => qr|^(.+)$|},'.' );
+ }, untaint => 1, untaint_pattern => qr|^(.+)$|},'fa' );
+ Check( scalar(keys %Expect) == 0 );
+
%Expect=('fa' => 1, 'fa/fsl' => 1, 'fa/fa_ord' => 1, 'fa/fab' => 1,
'fa/fab/fab_ord' => 1, 'fa/fab/faba' => 1,
'fa/fab/faba/faba_ord' => 1, 'fa/faa' => 1, 'fa/faa/faa_ord' => 1);
# $RCSfile: dbm.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:43 $
BEGIN {
+ chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
if ($Config{'extensions'} !~ /\bGDBM_File\b/) {
typedef enum _days_of_week { sun, mon, tue, wed, thu, fri, sat, Sun=0, Mon,
Tue, Wed, Thu, Fri, Sat } days_of_week;
+/*
+ * Some moderate flexing of tri-graph pre substitution.
+ */
+??=ifndef _SOMETHING_TRIGRAPHIC
+??=define _SOMETHING_TRIGRAPHIC
+??= define SOMETHING_ELSE_TRIGRAPHIC_0 "??!" /* | ??!| || */
+ ??=define SOMETHING_ELSE_TRIGRAPHIC_1 "??'" /* | ??'| ^| */
+??= define SOMETHING_ELSE_TRIGRAPHIC_2 "??(" /* | ??(| [| */
+ ??= define SOMETHING_ELSE_TRIGRAPHIC_3 "??)" /* | ??)| ]| */
+??=define SOMETHING_ELSE_TRIGRAPHIC_4 "??-0" /* | ??-| ~| */
+ ??= define SOMETHING_ELSE_TRIGRAPHIC_5 "??/ " /* | ??/| \| */
+??= define SOMETHING_ELSE_TRIGRAPHIC_6 "??<" /* | ??<| {| */
+??=define SOMETHING_ELSE_TRIGRAPHIC_7 "??=" /* | ??=| #| */
+??= define SOMETHING_ELSE_TRIGRAPHIC_8 "??>" /* | ??>| }| */
+ ??=endif
+
#endif /* _H2PH_H_ */
eval("sub Thu () { 4; }") unless defined(&Thu);
eval("sub Fri () { 5; }") unless defined(&Fri);
eval("sub Sat () { 6; }") unless defined(&Sat);
+ unless(defined(&_SOMETHING_TRIGRAPHIC)) {
+ eval 'sub _SOMETHING_TRIGRAPHIC () {1;}' unless defined(&_SOMETHING_TRIGRAPHIC);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_0 () {"|";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_0);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_1 () {"^";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_1);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_2 () {"[";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_2);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_3 () {"]";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_3);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_4 () {"~0";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_4);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_5 () {"\\ ";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_5);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_6 () {"{";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_6);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_7 () {"#";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_7);
+ eval 'sub SOMETHING_ELSE_TRIGRAPHIC_8 () {"}";}' unless defined(&SOMETHING_ELSE_TRIGRAPHIC_8);
+ }
}
1;
@INC = '../lib';
}
+my $extracted_program = '../utils/h2ph'; # unix, nt, ...
+if ($^O eq 'VMS') { $extracted_program = '[-.utils]h2ph.com'; }
+if (!(-e $extracted_program)) {
+ print "1..0 # Skip: $extracted_program was not built\n";
+ exit 0;
+}
+
print "1..2\n";
# quickly compare two text files
$A cmp $B;
}
-unless(-e '../utils/h2ph') {
- print("ok 1\nok 2\n");
- # i'll probably get in trouble for this :)
-} else {
- # does it run?
- $ok = system("./perl -I../lib ../utils/h2ph -d. -Q lib/h2ph.h");
- print(($ok == 0 ? "" : "not "), "ok 1\n");
+# does it run?
+$ok = system("$^X \"-I../lib\" $extracted_program -d. \"-Q\" lib/h2ph.h");
+print(($ok == 0 ? "" : "not "), "ok 1\n");
- # does it work? well, does it do what we expect? :-)
- $ok = txt_compare("lib/h2ph.ph", "lib/h2ph.pht");
- print(($ok == 0 ? "" : "not "), "ok 2\n");
+# does it work? well, does it do what we expect? :-)
+$ok = txt_compare("lib/h2ph.ph", "lib/h2ph.pht");
+print(($ok == 0 ? "" : "not "), "ok 2\n");
- # cleanup - should this be in an END block?
- unlink("lib/h2ph.ph");
- unlink("_h2ph_pre.ph");
-}
+# cleanup - should this be in an END block?
+unlink("lib/h2ph.ph");
+unlink("_h2ph_pre.ph");
sub next_line
{
my ($in, $out);
+ my $pre_sub_tri_graphs = 1;
READ: while (not eof IN) {
$in .= <IN>;
next unless length $in;
while (length $in) {
+ if ($pre_sub_tri_graphs) {
+ # Preprocess all tri-graphs
+ # including things stuck in quoted string constants.
+ $in =~ s/\?\?=/#/g; # | ??=| #|
+ $in =~ s/\?\?\!/|/g; # | ??!| ||
+ $in =~ s/\?\?'/^/g; # | ??'| ^|
+ $in =~ s/\?\?\(/[/g; # | ??(| [|
+ $in =~ s/\?\?\)/]/g; # | ??)| ]|
+ $in =~ s/\?\?\-/~/g; # | ??-| ~|
+ $in =~ s/\?\?\//\\/g; # | ??/| \|
+ $in =~ s/\?\?</{/g; # | ??<| {|
+ $in =~ s/\?\?>/}/g; # | ??>| }|
+ }
if ($in =~ s/\\$//) { # \-newline
$out .= ' ';
next READ;
projects / p5sagit/p5-mst-13.2.git / commitdiff