summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xConfigure14
-rw-r--r--MANIFEST2
-rw-r--r--README.os39083
-rw-r--r--doio.c29
-rw-r--r--ebcdic.c32
-rw-r--r--ext/Errno/Errno_pm.PL5
-rw-r--r--gv.c30
-rw-r--r--handy.h28
-rw-r--r--hints/os390.sh29
-rw-r--r--lib/bigint.pl2
-rw-r--r--mg.c4
-rw-r--r--patchlevel.h1
-rw-r--r--perl.c3
-rw-r--r--perl.h80
-rw-r--r--perly.c340
-rw-r--r--perly.h1
-rw-r--r--perly.y8
-rw-r--r--perly_c.diff241
-rw-r--r--pod/perldelta.pod2
-rw-r--r--pod/perlport.pod15
-rw-r--r--pp.c75
-rw-r--r--pp_ctl.c8
-rw-r--r--pp_hot.c10
-rw-r--r--pp_sys.c7
-rw-r--r--sv.c14
-rwxr-xr-xt/base/term.t12
-rwxr-xr-xt/comp/package.t6
-rwxr-xr-xt/comp/require.t2
-rwxr-xr-xt/lib/bigintpm.t1
-rwxr-xr-xt/lib/cgi-html.t3
-rwxr-xr-xt/lib/filehand.t2
-rwxr-xr-xt/lib/ph.t2
-rwxr-xr-xt/op/auto.t6
-rwxr-xr-xt/op/bop.t21
-rwxr-xr-xt/op/each.t3
-rwxr-xr-xt/op/magic.t6
-rwxr-xr-xt/op/misc.t1
-rwxr-xr-xt/op/ord.t8
-rwxr-xr-xt/op/pack.t26
-rwxr-xr-xt/op/quotemeta.t26
-rw-r--r--t/op/re_tests8
-rwxr-xr-xt/op/regexp.t5
-rwxr-xr-xt/op/sort.t37
-rwxr-xr-xt/op/sprintf.t2
-rwxr-xr-xt/op/subst.t22
-rwxr-xr-xt/op/taint.t8
-rwxr-xr-xt/op/universal.t12
-rwxr-xr-xt/pragma/constant.t2
-rwxr-xr-xt/pragma/overload.t2
-rwxr-xr-xt/pragma/subs.t1
-rw-r--r--toke.c29
-rw-r--r--x2p/a2p.h4
-rw-r--r--x2p/a2py.c8
53 files changed, 887 insertions, 441 deletions
diff --git a/Configure b/Configure
index 197295fe2f..3977b87a85 100755
--- a/Configure
+++ b/Configure
@@ -12026,7 +12026,7 @@ esac
case "$ebcdic" in
$define)
xxx=''
- echo "This is an EBCDIC system, checking if any parser files may need regenerating." >&4
+ echo "This is an EBCDIC system, checking if any parser files need regenerating." >&4
rm -f y.tab.c y.tab.h
yacc -d perly.y >/dev/null 2>&1
if cmp -s y.tab.c perly.c; then
@@ -12048,8 +12048,8 @@ $define)
fi
echo "x2p/a2p.y" >&4
cd x2p
- rm -f y.tab.c y.tab.h
- yacc -d a2p.y >/dev/null 2>&1
+ rm -f y.tab.c
+ yacc a2p.y >/dev/null 2>&1
if cmp -s y.tab.c a2p.c
then
rm -f y.tab.c
@@ -12061,14 +12061,6 @@ $define)
-e 's/y\.tab/a2p/g' a2p.c >a2p.tmp && mv a2p.tmp a2p.c
xxx="$xxx a2p.c"
fi
- if cmp -s y.tab.h a2p.h
- then
- rm -f y.tab.h
- else
- echo "a2p.h -> a2p.h" >&4
- mv -f y.tab.h a2p.h
- xxx="$xxx a2p.h"
- fi
cd ..
case "$xxx" in
'') echo "No parser files were regenerated. That's okay." >&4 ;;
diff --git a/MANIFEST b/MANIFEST
index e5cfd9a5fd..1bf477cd59 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -34,6 +34,7 @@ README.cygwin32 Notes about Cygwin32 port
README.dos Notes about dos/djgpp port
README.mpeix Notes about MPE/iX port
README.os2 Notes about OS/2 port
+README.os390 Notes about OS/390 (nee MVS) port
README.plan9 Notes about Plan9 port
README.qnx Notes about QNX port
README.threads Notes about multithreading
@@ -73,6 +74,7 @@ doio.c I/O operations
doop.c Support code for various operations
dosish.h Some defines for MS/DOSish machines
dump.c Debugging output
+ebcdic.c EBCDIC support routines
eg/ADB An adb wrapper to put in your crash dir
eg/README Intro to example perl scripts
eg/cgi/RunMeFirst Setup script for CGI examples
diff --git a/README.os390 b/README.os390
new file mode 100644
index 0000000000..b5ddaffacc
--- /dev/null
+++ b/README.os390
@@ -0,0 +1,83 @@
+This is a fully ported perl for OS/390 Release 3. It may work on
+other versions, but that's the one we've tested it on.
+
+If you've downloaded the binary distribution, it needs to be
+installed below /usr/local. Source code distributions have an
+automated `make install` step that means you do not need to extract
+the source code below /usr/local (though that is where it will be
+installed by default). You may need to worry about the networking
+configuration files discussed in the last bullet below.
+
+Gunzip/gzip for OS/390 is discussed at:
+
+ http://www.s390.ibm.com/products/oe/bpxqp1.html
+
+to extract an ASCII tar archive on OS/390, try this:
+
+ pax -o to=IBM-1047,from=ISO8859-1 -r < latest.tar
+
+GNU make for OS/390, which may be required for the build of perl,
+is available from:
+
+ http://www.mks.com/s390/gnu/index.htm
+
+Once you've unpacked the distribution, run Configure (see INSTALL for
+full discussion of the Configure options), and then run make, then
+"make test" then "make install" (this last step may require UID=0
+privileges)
+
+There is a "hints" file for os390 that specifies the correct values
+for most things. Some things to watch out for are
+
+ - this port doesn't support dynamic loading. Although
+ OS/390 has support for DLLs, there are some differences
+ that cause problems for perl.
+
+ - You may see a "WHOA THERE!!!" message for $d_shmatprototype
+ it is OK to keep the recommended "define".
+
+ - Don't turn on the compiler optimization flag "-O". There's
+ a bug in either the optimizer or perl that causes perl to
+ not work correctly when the optimizer is on.
+
+ - Some of the configuration files in /etc used by the
+ networking APIs are either missing or have the wrong
+ names. In particular, make sure that there's either
+ an /etc/resolv.conf or and /etc/hosts, so that
+ gethostbyname() works, and make sure that the file
+ /etc/proto has been renamed to /etc/protocol (NOT
+ /etc/protocols, as used by other Unix systems).
+
+When using perl on OS/390 please keep in mind that the EBCDIC and ASCII
+character sets are different. Perl builtin functions that may behave
+differently under EBCDIC are mentioned in the perlport.pod document.
+
+OpenEdition (UNIX System Services) does not (yet) support the #! means
+of script invokation.
+See:
+
+ head `whence perldoc`
+
+for an example of how to use the "eval exec" trick to ask the shell to
+have perl run your scripts for you.
+
+perl-mvs mailing list: The Perl Institute (http://www.perl.org/)
+maintains a mailing list of interest to all folks building and/or
+using perl on EBCDIC platforms. To subscibe, send a message of:
+
+ subscribe perl-mvs
+
+to majordomo@perl.org.
+
+Regression tests: as the 5.005 kit was was being assembled
+the following "failures" were known to appear on some machines
+during `make test` (mostly due to ASCII vs. EBCDIC conflicts),
+your results may differ:
+
+comp/cpp..........FAILED at test 0
+op/pack...........FAILED at test 58
+op/stat...........Out of memory!
+op/taint..........FAILED at test 73
+lib/errno.........FAILED at test 1
+lib/posix.........FAILED at test 19
+lib/searchdict....FAILED at test 1
diff --git a/doio.c b/doio.c
index ae35c6c385..85d604bc03 100644
--- a/doio.c
+++ b/doio.c
@@ -125,22 +125,37 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe
}
if (as_raw) {
- result = rawmode & 3;
- IoTYPE(io) = "<>++"[result];
+#ifndef O_ACCMODE
+#define O_ACCMODE 3 /* Assume traditional implementation */
+#endif
+ switch (result = rawmode & O_ACCMODE) {
+ case O_RDONLY:
+ IoTYPE(io) = '<';
+ break;
+ case O_WRONLY:
+ IoTYPE(io) = '>';
+ break;
+ case O_RDWR:
+ default:
+ IoTYPE(io) = '+';
+ break;
+ }
+
writing = (result > 0);
fd = PerlLIO_open3(name, rawmode, rawperm);
+
if (fd == -1)
fp = NULL;
else {
char *fpmode;
- if (result == 0)
+ if (result == O_RDONLY)
fpmode = "r";
#ifdef O_APPEND
else if (rawmode & O_APPEND)
- fpmode = (result == 1) ? "a" : "a+";
+ fpmode = (result == O_WRONLY) ? "a" : "a+";
#endif
else
- fpmode = (result == 1) ? "w" : "r+";
+ fpmode = (result == O_WRONLY) ? "w" : "r+";
fp = PerlIO_fdopen(fd, fpmode);
if (!fp)
PerlLIO_close(fd);
@@ -400,7 +415,7 @@ nextargv(register GV *gv)
sv_setsv(GvSV(gv),sv);
SvSETMAGIC(GvSV(gv));
PL_oldname = SvPVx(GvSV(gv), oldlen);
- if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,0,0,Nullfp)) {
+ if (do_open(gv,PL_oldname,oldlen,PL_inplace!=0,O_RDONLY,0,Nullfp)) {
if (PL_inplace) {
TAINT_PROPER("inplace open");
if (oldlen == 1 && *PL_oldname == '-') {
@@ -462,7 +477,7 @@ nextargv(register GV *gv)
do_close(gv,FALSE);
(void)PerlLIO_unlink(SvPVX(sv));
(void)PerlLIO_rename(PL_oldname,SvPVX(sv));
- do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,0,0,Nullfp);
+ do_open(gv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,O_RDONLY,0,Nullfp);
#endif /* DOSISH */
#else
(void)UNLINK(SvPVX(sv));
diff --git a/ebcdic.c b/ebcdic.c
new file mode 100644
index 0000000000..890bd086d2
--- /dev/null
+++ b/ebcdic.c
@@ -0,0 +1,32 @@
+#include "EXTERN.h"
+#include "perl.h"
+
+/* in ASCII order, not that it matters */
+static const char controllablechars[] = "?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
+
+int
+ebcdic_control(int ch)
+{
+ if (ch > 'a') {
+ char *ctlp;
+
+ if (islower(ch))
+ ch = toupper(ch);
+
+ if ((ctlp = strchr(controllablechars, ch)) == 0) {
+ die("unrecognised control character '%c'\n", ch);
+ }
+
+ if (ctlp == controllablechars)
+ return('\177'); /* DEL */
+ else
+ return((unsigned char)(ctlp - controllablechars - 1));
+ } else { /* Want uncontrol */
+ if (ch == '\177' || ch == -1)
+ return('?');
+ else if (0 < ch && ch < (sizeof(controllablechars) - 1))
+ return(controllablechars[ch+1]);
+ else
+ die("invalid control request: '\\%03o'\n", ch & 0xFF);
+ }
+}
diff --git a/ext/Errno/Errno_pm.PL b/ext/Errno/Errno_pm.PL
index a8a7cf73fe..f4d50206b5 100644
--- a/ext/Errno/Errno_pm.PL
+++ b/ext/Errno/Errno_pm.PL
@@ -53,6 +53,9 @@ sub get_files {
} elsif ($Config{vms_cc_type} eq 'gcc') {
$file{'gnu_cc_include:[000000]errno.h'} = 1;
}
+ } elsif ($^O eq 'os390') {
+ # OS/390 C compiler doesn't generate #file or #line directives
+ $file{'/usr/include/errno.h'} = 1;
} else {
open(CPPI,"> errno.c") or
die "Cannot open errno.c";
@@ -104,7 +107,7 @@ sub write_errno_pm {
$cpp =~ s/sys\$input//i;
open(CPPO,"$cpp errno.c |") or
die "Cannot exec $Config{cppstdin}";
- } elsif($^O eq 'next') {
+ } elsif(!$Config{'cpprun'} or $^O eq 'next') {
# NeXT will do syntax checking unless it is reading from stdin
my $cpp = "$Config{cppstdin} $Config{cppflags} $Config{cppminus}";
open(CPPO,"$cpp < errno.c |")
diff --git a/gv.c b/gv.c
index a01956fd25..531fbb55bb 100644
--- a/gv.c
+++ b/gv.c
@@ -502,25 +502,19 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
bool global = FALSE;
if (isUPPER(*name)) {
- if (*name > 'I') {
- if (*name == 'S' && (
- strEQ(name, "SIG") ||
- strEQ(name, "STDIN") ||
- strEQ(name, "STDOUT") ||
- strEQ(name, "STDERR") ))
- global = TRUE;
- }
- else if (*name > 'E') {
- if (*name == 'I' && strEQ(name, "INC"))
- global = TRUE;
- }
- else if (*name > 'A') {
- if (*name == 'E' && strEQ(name, "ENV"))
- global = TRUE;
- }
+ if (*name == 'S' && (
+ strEQ(name, "SIG") ||
+ strEQ(name, "STDIN") ||
+ strEQ(name, "STDOUT") ||
+ strEQ(name, "STDERR")))
+ global = TRUE;
+ else if (*name == 'I' && strEQ(name, "INC"))
+ global = TRUE;
+ else if (*name == 'E' && strEQ(name, "ENV"))
+ global = TRUE;
else if (*name == 'A' && (
strEQ(name, "ARGV") ||
- strEQ(name, "ARGVOUT") ))
+ strEQ(name, "ARGVOUT")))
global = TRUE;
}
else if (*name == '_' && !name[1])
@@ -759,8 +753,8 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
case '\005':
case '\006':
case '\010':
+ case '\011': /* NOT \t in EBCDIC */
case '\017':
- case '\t':
case '\020':
case '\024':
case '\027':
diff --git a/handy.h b/handy.h
index e74a3069a8..eb26ed8deb 100644
--- a/handy.h
+++ b/handy.h
@@ -183,11 +183,20 @@ typedef unsigned short U16;
#define isSPACE(c) \
((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) =='\r' || (c) == '\f')
#define isDIGIT(c) ((c) >= '0' && (c) <= '9')
-#define isUPPER(c) ((c) >= 'A' && (c) <= 'Z')
-#define isLOWER(c) ((c) >= 'a' && (c) <= 'z')
-#define isPRINT(c) (((c) > 32 && (c) < 127) || isSPACE(c))
-#define toUPPER(c) (isLOWER(c) ? (c) - ('a' - 'A') : (c))
-#define toLOWER(c) (isUPPER(c) ? (c) + ('a' - 'A') : (c))
+#ifdef EBCDIC
+ /* In EBCDIC we do not do locales: therefore() isupper() is fine. */
+# define isUPPER(c) isupper(c)
+# define isLOWER(c) islower(c)
+# define isPRINT(c) isprint(c)
+# define toUPPER(c) toupper(c)
+# define toLOWER(c) tolower(c)
+#else
+# define isUPPER(c) ((c) >= 'A' && (c) <= 'Z')
+# define isLOWER(c) ((c) >= 'a' && (c) <= 'z')
+# define isPRINT(c) (((c) > 32 && (c) < 127) || isSPACE(c))
+# define toUPPER(c) (isLOWER(c) ? (c) - ('a' - 'A') : (c))
+# define toLOWER(c) (isUPPER(c) ? (c) + ('a' - 'A') : (c))
+#endif
#ifdef USE_NEXT_CTYPE
@@ -238,8 +247,13 @@ typedef unsigned short U16;
# endif
#endif /* USE_NEXT_CTYPE */
-/* This conversion works both ways, strangely enough. */
-#define toCTRL(c) (toUPPER(c) ^ 64)
+#ifdef EBCDIC
+EXT int ebcdic_control _((int));
+# define toCTRL(c) ebcdic_control(c)
+#else
+ /* This conversion works both ways, strangely enough. */
+# define toCTRL(c) (toUPPER(c) ^ 64)
+#endif
/* Line numbers are unsigned, 16 bits. */
typedef U16 line_t;
diff --git a/hints/os390.sh b/hints/os390.sh
index fd590eaa4e..1cf945dca3 100644
--- a/hints/os390.sh
+++ b/hints/os390.sh
@@ -1,4 +1,7 @@
# hints/os390.sh
+#
+# OS/390 hints by David J. Fiander <davidf@mks.com>
+#
# OS/390 OpenEdition Release 3 Mon Sep 22 1997 thanks to:
#
# John Pfuntner <pfuntner@vnet.ibm.com>
@@ -11,23 +14,43 @@
# as well as the authors of the aix.sh file
#
+# To get ANSI C, we need to use c89, and ld doesn't exist
cc='c89'
-ccflags='-DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE'
+ld='c89'
+# c89 hides most of the useful header stuff, _ALL_SOURCE turns it on again,
+# YYDYNAMIC ensures that the OS/390 yacc generated parser is reentrant.
+# -DEBCDIC should come from Configure.
+ccflags='-DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE -DYYDYNAMIC'
+# Turning on optimization breaks perl
optimize='none'
+
alignbytes=8
-usemymalloc='y'
+
+usemymalloc='n'
+
so='a'
+
+# On OS/390, libc.a doesn't really hold anything at all,
+# so running nm on it is pretty useless.
+usenm='n'
+
+# Dynamic loading doesn't work on OS/390 quite yet
+usedl='n'
dlext='none'
+
+# Configure can't figure this out for some reason
d_shmatprototype='define'
+
usenm='false'
i_time='define'
i_systime='define'
-d_select='undef'
# (from aix.sh)
# uname -m output is too specific and not appropriate here
+# osname should come from Configure
#
case "$archname" in
'') archname="$osname" ;;
esac
+archobjs=ebcdic.o
diff --git a/lib/bigint.pl b/lib/bigint.pl
index bfd2efa88c..adeb17f28a 100644
--- a/lib/bigint.pl
+++ b/lib/bigint.pl
@@ -74,7 +74,7 @@ sub external { #(int_num_array) return num_str
sub main'bneg { #(num_str) return num_str
local($_) = &'bnorm(@_);
vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0';
- s/^H/N/;
+ s/^./N/ unless /^[-+]/; # works both in ASCII and EBCDIC
$_;
}
diff --git a/mg.c b/mg.c
index 35400e732b..1d78f1366e 100644
--- a/mg.c
+++ b/mg.c
@@ -422,7 +422,7 @@ magic_get(SV *sv, MAGIC *mg)
case '\010': /* ^H */
sv_setiv(sv, (IV)PL_hints);
break;
- case '\t': /* ^I */
+ case '\011': /* ^I */ /* NOT \t in EBCDIC */
if (PL_inplace)
sv_setpv(sv, PL_inplace);
else
@@ -1520,7 +1520,7 @@ magic_set(SV *sv, MAGIC *mg)
case '\010': /* ^H */
PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
break;
- case '\t': /* ^I */
+ case '\011': /* ^I */ /* NOT \t in EBCDIC */
if (PL_inplace)
Safefree(PL_inplace);
if (SvOK(sv))
diff --git a/patchlevel.h b/patchlevel.h
index 148b1b8607..135eeabb68 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -1,5 +1,6 @@
#ifndef __PATCHLEVEL_H_INCLUDED__
#define PATCHLEVEL 5
+#undef SUBVERSION /* OS/390 has a SUBVERSION in a system header */
#define SUBVERSION 1
/*
diff --git a/perl.c b/perl.c
index 27936cf64e..0e39dbeeab 100644
--- a/perl.c
+++ b/perl.c
@@ -1738,6 +1738,9 @@ moreswitches(char *s)
#ifdef MPE
printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n");
#endif
+#ifdef OEMVS
+ printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n");
+#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
diff --git a/perl.h b/perl.h
index c5597aaf7f..c6cc872ec5 100644
--- a/perl.h
+++ b/perl.h
@@ -1423,6 +1423,7 @@ Gid_t getegid _((void));
#ifndef Perl_debug_log
#define Perl_debug_log PerlIO_stderr()
#endif
+#undef YYDEBUG
#define YYDEBUG 1
#define DEB(a) a
#define DEBUG(a) if (PL_debug) a
@@ -1489,8 +1490,13 @@ double atof _((const char*));
/* All of these are in stdlib.h or time.h for ANSI C */
Time_t time();
struct tm *gmtime(), *localtime();
+#ifdef OEMVS
+char *(strchr)(), *(strrchr)();
+char *(strcpy)(), *(strcat)();
+#else
char *strchr(), *strrchr();
char *strcpy(), *strcat();
+#endif
#endif /* ! STANDARD_C */
@@ -1668,6 +1674,42 @@ EXT SV * psig_name[];
/* fast case folding tables */
#ifdef DOINIT
+#ifdef EBCDIC
+EXT unsigned char fold[] = { /* fast EBCDIC case folding table */
+ 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, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 65, 66, 67, 68, 69, 70, 71,
+ 72, 73, 74, 75, 76, 77, 78, 79,
+ 80, 81, 82, 83, 84, 85, 86, 87,
+ 88, 89, 90, 91, 92, 93, 94, 95,
+ 96, 97, 98, 99, 100, 101, 102, 103,
+ 104, 105, 106, 107, 108, 109, 110, 111,
+ 112, 113, 114, 115, 116, 117, 118, 119,
+ 120, 121, 122, 123, 124, 125, 126, 127,
+ 128, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 138, 139, 140, 141, 142, 143,
+ 144, 'J', 'K', 'L', 'M', 'N', 'O', 'P',
+ 'Q', 'R', 154, 155, 156, 157, 158, 159,
+ 160, 161, 'S', 'T', 'U', 'V', 'W', 'X',
+ 'Y', 'Z', 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 202, 203, 204, 205, 206, 207,
+ 208, 'j', 'k', 'l', 'm', 'n', 'o', 'p',
+ 'q', 'r', 218, 219, 220, 221, 222, 223,
+ 224, 225, 's', 't', 'u', 'v', 'w', 'x',
+ 'y', 'z', 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
+};
+#else /* ascii rather than ebcdic */
EXTCONST unsigned char fold[] = {
0, 1, 2, 3, 4, 5, 6, 7,
8, 9, 10, 11, 12, 13, 14, 15,
@@ -1702,6 +1744,7 @@ EXTCONST unsigned char fold[] = {
240, 241, 242, 243, 244, 245, 246, 247,
248, 249, 250, 251, 252, 253, 254, 255
};
+#endif /* !EBCDIC */
#else
EXTCONST unsigned char fold[];
#endif
@@ -1746,6 +1789,42 @@ EXT unsigned char fold_locale[];
#endif
#ifdef DOINIT
+#ifdef EBCDIC
+EXT unsigned char freq[] = {/* EBCDIC frequencies for mixed English/C */
+ 1, 2, 84, 151, 154, 155, 156, 157,
+ 165, 246, 250, 3, 158, 7, 18, 29,
+ 40, 51, 62, 73, 85, 96, 107, 118,
+ 129, 140, 147, 148, 149, 150, 152, 153,
+ 255, 6, 8, 9, 10, 11, 12, 13,
+ 14, 15, 24, 25, 26, 27, 28, 226,
+ 29, 30, 31, 32, 33, 43, 44, 45,
+ 46, 47, 48, 49, 50, 76, 77, 78,
+ 79, 80, 81, 82, 83, 84, 85, 86,
+ 87, 94, 95, 234, 181, 233, 187, 190,
+ 180, 96, 97, 98, 99, 100, 101, 102,
+ 104, 112, 182, 174, 236, 232, 229, 103,
+ 228, 226, 114, 115, 116, 117, 118, 119,
+ 120, 121, 122, 235, 176, 230, 194, 162,
+ 130, 131, 132, 133, 134, 135, 136, 137,
+ 138, 139, 201, 205, 163, 217, 220, 224,
+ 5, 248, 227, 244, 242, 255, 241, 231,
+ 240, 253, 16, 197, 19, 20, 21, 187,
+ 23, 169, 210, 245, 237, 249, 247, 239,
+ 168, 252, 34, 196, 36, 37, 38, 39,
+ 41, 42, 251, 254, 238, 223, 221, 213,
+ 225, 177, 52, 53, 54, 55, 56, 57,
+ 58, 59, 60, 61, 63, 64, 65, 66,
+ 67, 68, 69, 70, 71, 72, 74, 75,
+ 205, 208, 186, 202, 200, 218, 198, 179,
+ 178, 214, 88, 89, 90, 91, 92, 93,
+ 217, 166, 170, 207, 199, 209, 206, 204,
+ 160, 212, 105, 106, 108, 109, 110, 111,
+ 203, 113, 216, 215, 192, 175, 193, 243,
+ 172, 161, 123, 124, 125, 126, 127, 128,
+ 222, 219, 211, 195, 188, 193, 185, 184,
+ 191, 183, 141, 142, 143, 144, 145, 146
+};
+#else /* ascii rather than ebcdic */
EXTCONST unsigned char freq[] = { /* letter frequencies for mixed English/C */
1, 2, 84, 151, 154, 155, 156, 157,
165, 246, 250, 3, 158, 7, 18, 29,
@@ -1780,6 +1859,7 @@ EXTCONST unsigned char freq[] = { /* letter frequencies for mixed English/C */
130, 131, 132, 133, 134, 135, 136, 137,
138, 139, 141, 142, 143, 144, 145, 146
};
+#endif
#else
EXTCONST unsigned char freq[];
#endif
diff --git a/perly.c b/perly.c
index 9b2137f2bb..7a53d4b6f2 100644
--- a/perly.c
+++ b/perly.c
@@ -21,7 +21,7 @@ dep(void)
}
#endif
-#line 16 "perly.c"
+#line 30 "perly.y"
#define YYERRCODE 256
short yylhs[] = { -1,
45, 0, 9, 7, 10, 8, 11, 11, 11, 12,
@@ -1280,11 +1280,13 @@ int yydebug;
int yynerrs;
int yyerrflag;
int yychar;
+short *yyssp;
+YYSTYPE *yyvsp;
YYSTYPE yyval;
YYSTYPE yylval;
-#line 635 "perly.y"
+#line 643 "perly.y"
/* PROGRAM */
-#line 1349 "perly.c"
+#line 1353 "perly.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
@@ -1513,7 +1515,7 @@ yyreduce:
switch (yyn)
{
case 1:
-#line 86 "perly.y"
+#line 94 "perly.y"
{
#if defined(YYDEBUG) && defined(DEBUGGING)
yydebug = (PL_debug & 1);
@@ -1522,50 +1524,50 @@ case 1:
}
break;
case 2:
-#line 93 "perly.y"
+#line 101 "perly.y"
{ newPROG(yyvsp[0].opval); }
break;
case 3:
-#line 97 "perly.y"
+#line 105 "perly.y"
{ if (PL_copline > (line_t)yyvsp[-3].ival)
PL_copline = yyvsp[-3].ival;
yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
case 4:
-#line 103 "perly.y"
+#line 111 "perly.y"
{ yyval.ival = block_start(TRUE); }
break;
case 5:
-#line 107 "perly.y"
+#line 115 "perly.y"
{ if (PL_copline > (line_t)yyvsp[-3].ival)
PL_copline = yyvsp[-3].ival;
yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
case 6:
-#line 113 "perly.y"
+#line 121 "perly.y"
{ yyval.ival = block_start(FALSE); }
break;
case 7:
-#line 117 "perly.y"
+#line 125 "perly.y"
{ yyval.opval = Nullop; }
break;
case 8:
-#line 119 "perly.y"
+#line 127 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 9:
-#line 121 "perly.y"
+#line 129 "perly.y"
{ yyval.opval = append_list(OP_LINESEQ,
(LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval);
PL_pad_reset_pending = TRUE;
if (yyvsp[-1].opval && yyvsp[0].opval) PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 10:
-#line 128 "perly.y"
+#line 136 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
break;
case 12:
-#line 131 "perly.y"
+#line 139 "perly.y"
{ if (yyvsp[-1].pval != Nullch) {
yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
}
@@ -1576,76 +1578,76 @@ case 12:
PL_expect = XSTATE; }
break;
case 13:
-#line 140 "perly.y"
+#line 148 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval);
PL_expect = XSTATE; }
break;
case 14:
-#line 145 "perly.y"
+#line 153 "perly.y"
{ yyval.opval = Nullop; }
break;
case 15:
-#line 147 "perly.y"
+#line 155 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 16:
-#line 149 "perly.y"
+#line 157 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 17:
-#line 151 "perly.y"
+#line 159 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 18:
-#line 153 "perly.y"
+#line 161 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
break;
case 19:
-#line 155 "perly.y"
+#line 163 "perly.y"
{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);}
break;
case 20:
-#line 157 "perly.y"
+#line 165 "perly.y"
{ yyval.opval = newFOROP(0, Nullch, yyvsp[-1].ival,
Nullop, yyvsp[0].opval, yyvsp[-2].opval, Nullop); }
break;
case 21:
-#line 162 "perly.y"
+#line 170 "perly.y"
{ yyval.opval = Nullop; }
break;
case 22:
-#line 164 "perly.y"
+#line 172 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 23:
-#line 166 "perly.y"
+#line 174 "perly.y"
{ PL_copline = yyvsp[-5].ival;
yyval.opval = newSTATEOP(0, Nullch,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval));
PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 24:
-#line 173 "perly.y"
+#line 181 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 25:
-#line 177 "perly.y"
+#line 185 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval)); }
break;
case 26:
-#line 183 "perly.y"
+#line 191 "perly.y"
{ yyval.opval = Nullop; }
break;
case 27:
-#line 185 "perly.y"
+#line 193 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 28:
-#line 189 "perly.y"
+#line 197 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newSTATEOP(0, yyvsp[-7].pval,
@@ -1653,7 +1655,7 @@ case 28:
yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
break;
case 29:
-#line 195 "perly.y"
+#line 203 "perly.y"
{ PL_copline = yyvsp[-6].ival;
yyval.opval = block_end(yyvsp[-4].ival,
newSTATEOP(0, yyvsp[-7].pval,
@@ -1661,23 +1663,23 @@ case 29:
yyvsp[-6].ival, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval))); }
break;
case 30:
-#line 201 "perly.y"
+#line 209 "perly.y"
{ yyval.opval = block_end(yyvsp[-6].ival,
newFOROP(0, yyvsp[-9].pval, yyvsp[-8].ival, yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 31:
-#line 204 "perly.y"
+#line 212 "perly.y"
{ yyval.opval = block_end(yyvsp[-4].ival,
newFOROP(0, yyvsp[-8].pval, yyvsp[-7].ival, mod(yyvsp[-6].opval, OP_ENTERLOOP),
yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 32:
-#line 208 "perly.y"
+#line 216 "perly.y"
{ yyval.opval = block_end(yyvsp[-4].ival,
newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 33:
-#line 212 "perly.y"
+#line 220 "perly.y"
{ OP *forop = append_elem(OP_LINESEQ,
scalar(yyvsp[-6].opval),
newWHILEOP(0, 1, (LOOP*)Nullop,
@@ -1687,89 +1689,89 @@ case 33:
yyval.opval = block_end(yyvsp[-7].ival, newSTATEOP(0, yyvsp[-10].pval, forop)); }
break;
case 34:
-#line 220 "perly.y"
+#line 228 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval,
newWHILEOP(0, 1, (LOOP*)Nullop,
NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 35:
-#line 226 "perly.y"
+#line 234 "perly.y"
{ yyval.opval = Nullop; }
break;
case 37:
-#line 231 "perly.y"
+#line 239 "perly.y"
{ (void)scan_num("1"); yyval.opval = yylval.opval; }
break;
case 39:
-#line 236 "perly.y"
+#line 244 "perly.y"
{ yyval.opval = invert(scalar(yyvsp[0].opval)); }
break;
case 40:
-#line 240 "perly.y"
+#line 248 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 41:
-#line 244 "perly.y"
+#line 252 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 42:
-#line 248 "perly.y"
+#line 256 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 43:
-#line 252 "perly.y"
+#line 260 "perly.y"
{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 44:
-#line 256 "perly.y"
+#line 264 "perly.y"
{ yyval.pval = Nullch; }
break;
case 46:
-#line 261 "perly.y"
+#line 269 "perly.y"
{ yyval.ival = 0; }
break;
case 47:
-#line 263 "perly.y"
+#line 271 "perly.y"
{ yyval.ival = 0; }
break;
case 48:
-#line 265 "perly.y"
+#line 273 "perly.y"
{ yyval.ival = 0; }
break;
case 49:
-#line 267 "perly.y"
+#line 275 "perly.y"
{ yyval.ival = 0; }
break;
case 50:
-#line 271 "perly.y"
+#line 279 "perly.y"
{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 51:
-#line 274 "perly.y"
+#line 282 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 52:
-#line 275 "perly.y"
+#line 283 "perly.y"
{ yyval.opval = Nullop; }
break;
case 53:
-#line 279 "perly.y"
+#line 287 "perly.y"
{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 54:
-#line 283 "perly.y"
+#line 291 "perly.y"
{ yyval.ival = start_subparse(FALSE, 0); }
break;
case 55:
-#line 287 "perly.y"
+#line 295 "perly.y"
{ yyval.ival = start_subparse(FALSE, CVf_ANON); }
break;
case 56:
-#line 291 "perly.y"
+#line 299 "perly.y"
{ yyval.ival = start_subparse(TRUE, 0); }
break;
case 57:
-#line 294 "perly.y"
+#line 302 "perly.y"
{ char *name = SvPV(((SVOP*)yyvsp[0].opval)->op_sv, PL_na);
if (strEQ(name, "BEGIN") || strEQ(name, "END")
|| strEQ(name, "INIT"))
@@ -1777,297 +1779,297 @@ case 57:
yyval.opval = yyvsp[0].opval; }
break;
case 58:
-#line 302 "perly.y"
+#line 310 "perly.y"
{ yyval.opval = Nullop; }
break;
case 60:
-#line 306 "perly.y"
+#line 314 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 61:
-#line 307 "perly.y"
+#line 315 "perly.y"
{ yyval.opval = Nullop; PL_expect = XSTATE; }
break;
case 62:
-#line 311 "perly.y"
+#line 319 "perly.y"
{ package(yyvsp[-1].opval); }
break;
case 63:
-#line 313 "perly.y"
+#line 321 "perly.y"
{ package(Nullop); }
break;
case 64:
-#line 317 "perly.y"
+#line 325 "perly.y"
{ CvUNIQUE_on(PL_compcv); /* It's a BEGIN {} */ }
break;
case 65:
-#line 319 "perly.y"
+#line 327 "perly.y"
{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
case 66:
-#line 323 "perly.y"
+#line 331 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 67:
-#line 325 "perly.y"
+#line 333 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 69:
-#line 330 "perly.y"
+#line 338 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 70:
-#line 332 "perly.y"
+#line 340 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 72:
-#line 337 "perly.y"
+#line 345 "perly.y"
{ yyval.opval = convert(yyvsp[-2].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-2].ival,yyvsp[-1].opval), yyvsp[0].opval) ); }
break;
case 73:
-#line 340 "perly.y"
+#line 348 "perly.y"
{ yyval.opval = convert(yyvsp[-4].ival, OPf_STACKED,
prepend_elem(OP_LIST, newGVREF(yyvsp[-4].ival,yyvsp[-2].opval), yyvsp[-1].opval) ); }
break;
case 74:
-#line 343 "perly.y"
+#line 351 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval),
newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
break;
case 75:
-#line 348 "perly.y"
+#line 356 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-1].opval, yyvsp[0].opval),
newUNOP(OP_METHOD, 0, yyvsp[-2].opval))); }
break;
case 76:
-#line 353 "perly.y"
+#line 361 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-3].opval, yyvsp[-1].opval),
newUNOP(OP_METHOD, 0, yyvsp[-4].opval))); }
break;
case 77:
-#line 358 "perly.y"
+#line 366 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 78:
-#line 360 "perly.y"
+#line 368 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 79:
-#line 362 "perly.y"
+#line 370 "perly.y"
{ yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 80:
-#line 364 "perly.y"
+#line 372 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); }
break;
case 83:
-#line 374 "perly.y"
+#line 382 "perly.y"
{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
break;
case 84:
-#line 376 "perly.y"
+#line 384 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 85:
-#line 378 "perly.y"
+#line 386 "perly.y"
{ if (yyvsp[-1].ival != OP_REPEAT)
scalar(yyvsp[-2].opval);
yyval.opval = newBINOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, scalar(yyvsp[0].opval)); }
break;
case 86:
-#line 382 "perly.y"
+#line 390 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 87:
-#line 384 "perly.y"
+#line 392 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 88:
-#line 386 "perly.y"
+#line 394 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 89:
-#line 388 "perly.y"
+#line 396 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 90:
-#line 390 "perly.y"
+#line 398 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 91:
-#line 392 "perly.y"
+#line 400 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
case 92:
-#line 394 "perly.y"
+#line 402 "perly.y"
{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
break;
case 93:
-#line 396 "perly.y"
+#line 404 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 94:
-#line 398 "perly.y"
+#line 406 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 95:
-#line 400 "perly.y"
+#line 408 "perly.y"
{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 96:
-#line 402 "perly.y"
+#line 410 "perly.y"
{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
break;
case 97:
-#line 405 "perly.y"
+#line 413 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
case 98:
-#line 407 "perly.y"
+#line 415 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 99:
-#line 409 "perly.y"
+#line 417 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
case 100:
-#line 411 "perly.y"
+#line 419 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
case 101:
-#line 413 "perly.y"
+#line 421 "perly.y"
{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
break;
case 102:
-#line 415 "perly.y"
+#line 423 "perly.y"
{ yyval.opval = newUNOP(OP_POSTINC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
break;
case 103:
-#line 418 "perly.y"
+#line 426 "perly.y"
{ yyval.opval = newUNOP(OP_POSTDEC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
break;
case 104:
-#line 421 "perly.y"
+#line 429 "perly.y"
{ yyval.opval = newUNOP(OP_PREINC, 0,
mod(scalar(yyvsp[0].opval), OP_PREINC)); }
break;
case 105:
-#line 424 "perly.y"
+#line 432 "perly.y"
{ yyval.opval = newUNOP(OP_PREDEC, 0,
mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
break;
case 106:
-#line 427 "perly.y"
+#line 435 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
case 107:
-#line 429 "perly.y"
+#line 437 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
case 108:
-#line 431 "perly.y"
+#line 439 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
case 109:
-#line 433 "perly.y"
+#line 441 "perly.y"
{ yyval.opval = newANONLIST(yyvsp[-1].opval); }
break;
case 110:
-#line 435 "perly.y"
+#line 443 "perly.y"
{ yyval.opval = newANONLIST(Nullop); }
break;
case 111:
-#line 437 "perly.y"
+#line 445 "perly.y"
{ yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
case 112:
-#line 439 "perly.y"
+#line 447 "perly.y"
{ yyval.opval = newANONHASH(Nullop); }
break;
case 113:
-#line 441 "perly.y"
+#line 449 "perly.y"
{ yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 114:
-#line 443 "perly.y"
+#line 451 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 115:
-#line 445 "perly.y"
+#line 453 "perly.y"
{ yyval.opval = newBINOP(OP_GELEM, 0, yyvsp[-4].opval, scalar(yyvsp[-2].opval)); }
break;
case 116:
-#line 447 "perly.y"
+#line 455 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 117:
-#line 449 "perly.y"
+#line 457 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
break;
case 118:
-#line 451 "perly.y"
+#line 459 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 119:
-#line 455 "perly.y"
+#line 463 "perly.y"
{ assertref(yyvsp[-3].opval); yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-3].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
case 120:
-#line 459 "perly.y"
+#line 467 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 121:
-#line 461 "perly.y"
+#line 469 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 122:
-#line 463 "perly.y"
+#line 471 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
case 123:
-#line 465 "perly.y"
+#line 473 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
PL_expect = XOPERATOR; }
break;
case 124:
-#line 468 "perly.y"
+#line 476 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
PL_expect = XOPERATOR; }
break;
case 125:
-#line 473 "perly.y"
+#line 481 "perly.y"
{ assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
PL_expect = XOPERATOR; }
break;
case 126:
-#line 478 "perly.y"
+#line 486 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
case 127:
-#line 480 "perly.y"
+#line 488 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
case 128:
-#line 482 "perly.y"
+#line 490 "perly.y"
{ yyval.opval = prepend_elem(OP_ASLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_ASLICE, 0,
@@ -2075,7 +2077,7 @@ case 128:
ref(yyvsp[-3].opval, OP_ASLICE))); }
break;
case 129:
-#line 488 "perly.y"
+#line 496 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
@@ -2084,37 +2086,37 @@ case 129:
PL_expect = XOPERATOR; }
break;
case 130:
-#line 495 "perly.y"
+#line 503 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 131:
-#line 497 "perly.y"
+#line 505 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
case 132:
-#line 499 "perly.y"
+#line 507 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
case 133:
-#line 501 "perly.y"
+#line 509 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); }
break;
case 134:
-#line 504 "perly.y"
+#line 512 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
case 135:
-#line 507 "perly.y"
+#line 515 "perly.y"
{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); }
break;
case 136:
-#line 509 "perly.y"
+#line 517 "perly.y"
{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
break;
case 137:
-#line 511 "perly.y"
+#line 519 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
@@ -2124,7 +2126,7 @@ case 137:
)),Nullop)); dep();}
break;
case 138:
-#line 519 "perly.y"
+#line 527 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
append_elem(OP_LIST,
@@ -2135,161 +2137,161 @@ case 138:
)))); dep();}
break;
case 139:
-#line 528 "perly.y"
+#line 536 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
scalar(newCVREF(0,scalar(yyvsp[-2].opval))), Nullop)); dep();}
break;
case 140:
-#line 532 "perly.y"
+#line 540 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
yyvsp[-1].opval,
scalar(newCVREF(0,scalar(yyvsp[-3].opval))))); dep();}
break;
case 141:
-#line 537 "perly.y"
+#line 545 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
newCVREF(0, scalar(yyvsp[-3].opval))); }
break;
case 142:
-#line 540 "perly.y"
+#line 548 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval,
newCVREF(0, scalar(yyvsp[-4].opval)))); }
break;
case 143:
-#line 544 "perly.y"
+#line 552 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
PL_hints |= HINT_BLOCK_SCOPE; }
break;
case 144:
-#line 547 "perly.y"
+#line 555 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
case 145:
-#line 549 "perly.y"
+#line 557 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
case 146:
-#line 551 "perly.y"
+#line 559 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
case 147:
-#line 553 "perly.y"
+#line 561 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 148:
-#line 555 "perly.y"
+#line 563 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
case 149:
-#line 557 "perly.y"
+#line 565 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
case 150:
-#line 560 "perly.y"
+#line 568 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
case 151:
-#line 562 "perly.y"
+#line 570 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
case 152:
-#line 564 "perly.y"
+#line 572 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar(yyvsp[0].opval)); }
break;
case 153:
-#line 567 "perly.y"
+#line 575 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
case 154:
-#line 569 "perly.y"
+#line 577 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
case 155:
-#line 571 "perly.y"
+#line 579 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
case 156:
-#line 573 "perly.y"
+#line 581 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
case 159:
-#line 579 "perly.y"
+#line 587 "perly.y"
{ yyval.opval = Nullop; }
break;
case 160:
-#line 581 "perly.y"
+#line 589 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 161:
-#line 585 "perly.y"
+#line 593 "perly.y"
{ yyval.opval = Nullop; }
break;
case 162:
-#line 587 "perly.y"
+#line 595 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
case 163:
-#line 589 "perly.y"
+#line 597 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
case 164:
-#line 592 "perly.y"
+#line 600 "perly.y"
{ yyval.ival = 0; }
break;
case 165:
-#line 593 "perly.y"
+#line 601 "perly.y"
{ yyval.ival = 1; }
break;
case 166:
-#line 597 "perly.y"
+#line 605 "perly.y"
{ PL_in_my = 0; yyval.opval = my(yyvsp[0].opval); }
break;
case 167:
-#line 601 "perly.y"
+#line 609 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
case 168:
-#line 605 "perly.y"
+#line 613 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
case 169:
-#line 609 "perly.y"
+#line 617 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
case 170:
-#line 613 "perly.y"
+#line 621 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
case 171:
-#line 617 "perly.y"
+#line 625 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
case 172:
-#line 621 "perly.y"
+#line 629 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
case 173:
-#line 625 "perly.y"
+#line 633 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
case 174:
-#line 627 "perly.y"
+#line 635 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
case 175:
-#line 629 "perly.y"
+#line 637 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 176:
-#line 632 "perly.y"
+#line 640 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-#line 2266 "perly.c"
+#line 2270 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
diff --git a/perly.h b/perly.h
index 9907727001..c1f7806e3f 100644
--- a/perly.h
+++ b/perly.h
@@ -63,4 +63,3 @@ typedef union {
GV *gvval;
} YYSTYPE;
extern YYSTYPE yylval;
-extern YYSTYPE yylval;
diff --git a/perly.y b/perly.y
index f9c5f74c15..e016cf431d 100644
--- a/perly.y
+++ b/perly.y
@@ -26,6 +26,10 @@ dep(void)
%start prog
+%{
+#ifndef OEMVS
+%}
+
%union {
I32 ival;
char *pval;
@@ -33,6 +37,10 @@ dep(void)
GV *gvval;
}
+%{
+#endif /* OEMVS */
+%}
+
%token <ival> '{' ')'
%token <opval> WORD METHOD FUNCMETH THING PMFUNC PRIVATEREF
diff --git a/perly_c.diff b/perly_c.diff
index 0ee7cb2d7f..aa0555b034 100644
--- a/perly_c.diff
+++ b/perly_c.diff
@@ -1,92 +1,96 @@
-Index: perly.c
-*** perly.c.old Wed Jun 10 03:48:43 1998
---- perly.c Wed Jun 10 03:55:10 1998
+*** perly.c.orig Tue Jul 28 15:02:41 1998
+--- perly.c Tue Jul 28 15:14:54 1998
***************
-*** 7,10 ****
---- 7,18 ----
+*** 7,11 ****
+--- 7,19 ----
#include "perl.h"
+ #ifdef PERL_OBJECT
-+ static void
+ static void
+ Dep(CPerlObj *pPerl)
+ {
+ pPerl->deprecate("\"do\" to call subroutines");
+ }
+ #define dep() Dep(this)
+ #else
- static void
++ static void
dep(void)
+ {
***************
-*** 12,82 ****
+*** 12,86 ****
deprecate("\"do\" to call subroutines");
}
-! #line 29 "perly.y"
-! typedef union {
-! I32 ival;
-! char *pval;
-! OP *opval;
-! GV *gvval;
-! } YYSTYPE;
-! #line 23 "y.tab.c"
-! #define WORD 257
-! #define METHOD 258
-! #define FUNCMETH 259
-! #define THING 260
-! #define PMFUNC 261
-! #define PRIVATEREF 262
-! #define FUNC0SUB 263
-! #define UNIOPSUB 264
-! #define LSTOPSUB 265
-! #define LABEL 266
-! #define FORMAT 267
-! #define SUB 268
-! #define ANONSUB 269
-! #define PACKAGE 270
-! #define USE 271
-! #define WHILE 272
-! #define UNTIL 273
-! #define IF 274
-! #define UNLESS 275
-! #define ELSE 276
-! #define ELSIF 277
-! #define CONTINUE 278
-! #define FOR 279
-! #define LOOPEX 280
-! #define DOTDOT 281
-! #define FUNC0 282
-! #define FUNC1 283
-! #define FUNC 284
-! #define UNIOP 285
-! #define LSTOP 286
-! #define RELOP 287
-! #define EQOP 288
-! #define MULOP 289
-! #define ADDOP 290
-! #define DOLSHARP 291
-! #define DO 292
-! #define HASHBRACK 293
-! #define NOAMP 294
-! #define LOCAL 295
-! #define MY 296
-! #define OROP 297
-! #define ANDOP 298
-! #define NOTOP 299
-! #define ASSIGNOP 300
-! #define OROR 301
-! #define ANDAND 302
-! #define BITOROP 303
-! #define BITANDOP 304
-! #define SHIFTOP 305
-! #define MATCHOP 306
-! #define UMINUS 307
-! #define REFGEN 308
-! #define POWOP 309
-! #define PREINC 310
-! #define PREDEC 311
-! #define POSTINC 312
-! #define POSTDEC 313
-! #define ARROW 314
+ #line 30 "perly.y"
+- #ifndef OEMVS
+- #line 33 "perly.y"
+- typedef union {
+- I32 ival;
+- char *pval;
+- OP *opval;
+- GV *gvval;
+- } YYSTYPE;
+- #line 41 "perly.y"
+- #endif /* OEMVS */
+- #line 27 "y.tab.c"
+- #define WORD 257
+- #define METHOD 258
+- #define FUNCMETH 259
+- #define THING 260
+- #define PMFUNC 261
+- #define PRIVATEREF 262
+- #define FUNC0SUB 263
+- #define UNIOPSUB 264
+- #define LSTOPSUB 265
+- #define LABEL 266
+- #define FORMAT 267
+- #define SUB 268
+- #define ANONSUB 269
+- #define PACKAGE 270
+- #define USE 271
+- #define WHILE 272
+- #define UNTIL 273
+- #define IF 274
+- #define UNLESS 275
+- #define ELSE 276
+- #define ELSIF 277
+- #define CONTINUE 278
+- #define FOR 279
+- #define LOOPEX 280
+- #define DOTDOT 281
+- #define FUNC0 282
+- #define FUNC1 283
+- #define FUNC 284
+- #define UNIOP 285
+- #define LSTOP 286
+- #define RELOP 287
+- #define EQOP 288
+- #define MULOP 289
+- #define ADDOP 290
+- #define DOLSHARP 291
+- #define DO 292
+- #define HASHBRACK 293
+- #define NOAMP 294
+- #define LOCAL 295
+- #define MY 296
+- #define OROP 297
+- #define ANDOP 298
+- #define NOTOP 299
+- #define ASSIGNOP 300
+- #define OROR 301
+- #define ANDAND 302
+- #define BITOROP 303
+- #define BITANDOP 304
+- #define SHIFTOP 305
+- #define MATCHOP 306
+- #define UMINUS 307
+- #define REFGEN 308
+- #define POWOP 309
+- #define PREINC 310
+- #define PREDEC 311
+- #define POSTINC 312
+- #define POSTDEC 313
+- #define ARROW 314
#define YYERRCODE 256
short yylhs[] = { -1,
--- 20,26 ----
@@ -94,23 +98,19 @@ Index: perly.c
}
+ #endif
-! #line 16 "perly.c"
+ #line 30 "perly.y"
#define YYERRCODE 256
short yylhs[] = { -1,
***************
-*** 1337,1361 ****
- int yyerrflag;
- int yychar;
-- short *yyssp;
-- YYSTYPE *yyvsp;
+*** 1345,1365 ****
YYSTYPE yyval;
YYSTYPE yylval;
- short yyss[YYSTACKSIZE];
- YYSTYPE yyvs[YYSTACKSIZE];
- #define yystacksize YYSTACKSIZE
- #line 635 "perly.y"
+ #line 643 "perly.y"
/* PROGRAM */
-! #line 1349 "y.tab.c"
+! #line 1353 "y.tab.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
@@ -124,14 +124,12 @@ Index: perly.c
if (yys = getenv("YYDEBUG"))
{
---- 1281,1347 ----
- int yyerrflag;
- int yychar;
+--- 1285,1349 ----
YYSTYPE yyval;
YYSTYPE yylval;
- #line 635 "perly.y"
+ #line 643 "perly.y"
/* PROGRAM */
-! #line 1349 "perly.c"
+! #line 1353 "perly.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
@@ -178,7 +176,7 @@ Index: perly.c
extern char *getenv();
+ #endif
+ #endif
-+
+
+ struct ysv *ysave;
+ New(73, ysave, 1, struct ysv);
+ SAVEDESTRUCTOR(yydestruct, ysave);
@@ -188,13 +186,13 @@ Index: perly.c
+ ysave->oldyychar = yychar;
+ ysave->oldyyval = yyval;
+ ysave->oldyylval = yylval;
-
++
+ #if YYDEBUG
if (yys = getenv("YYDEBUG"))
{
***************
-*** 1370,1373 ****
---- 1356,1369 ----
+*** 1374,1377 ****
+--- 1358,1371 ----
yychar = (-1);
+ /*
@@ -210,36 +208,39 @@ Index: perly.c
yyssp = yyss;
yyvsp = yyvs;
***************
-*** 1385,1389 ****
+*** 1389,1393 ****
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! printf("yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
---- 1381,1385 ----
+--- 1383,1387 ----
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
***************
-*** 1395,1404 ****
+*** 1399,1403 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: state %d, shifting to state %d\n",
yystate, yytable[yyn]);
#endif
- if (yyssp >= yyss + yystacksize - 1)
- {
-! goto yyoverflow;
- }
- *++yyssp = yystate = yytable[yyn];
---- 1391,1414 ----
+--- 1393,1397 ----
#if YYDEBUG
if (yydebug)
! PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n",
yystate, yytable[yyn]);
#endif
+***************
+*** 1404,1408 ****
+ if (yyssp >= yyss + yystacksize - 1)
+ {
+! goto yyoverflow;
+ }
+ *++yyssp = yystate = yytable[yyn];
+--- 1398,1416 ----
if (yyssp >= yyss + yystacksize - 1)
{
! /*
@@ -260,7 +261,7 @@ Index: perly.c
}
*++yyssp = yystate = yytable[yyn];
***************
-*** 1436,1445 ****
+*** 1440,1449 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: state %d, error recovery shifting\
@@ -271,7 +272,7 @@ Index: perly.c
! goto yyoverflow;
}
*++yyssp = yystate = yytable[yyn];
---- 1446,1470 ----
+--- 1448,1472 ----
#if YYDEBUG
if (yydebug)
! PerlIO_printf(Perl_debug_log,
@@ -298,14 +299,14 @@ Index: perly.c
}
*++yyssp = yystate = yytable[yyn];
***************
-*** 1451,1456 ****
+*** 1455,1460 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: error recovery discarding state %d\n",
! *yyssp);
#endif
if (yyssp <= yyss) goto yyabort;
---- 1476,1482 ----
+--- 1478,1484 ----
#if YYDEBUG
if (yydebug)
! PerlIO_printf(Perl_debug_log,
@@ -314,14 +315,14 @@ Index: perly.c
#endif
if (yyssp <= yyss) goto yyabort;
***************
-*** 1469,1474 ****
+*** 1473,1478 ****
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! printf("yydebug: state %d, error recovery discards token %d (%s)\n",
! yystate, yychar, yys);
}
#endif
---- 1495,1501 ----
+--- 1497,1503 ----
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! PerlIO_printf(Perl_debug_log,
@@ -330,40 +331,40 @@ Index: perly.c
}
#endif
***************
-*** 1479,1483 ****
+*** 1483,1487 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
---- 1506,1510 ----
+--- 1508,1512 ----
#if YYDEBUG
if (yydebug)
! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
***************
-*** 2263,2267 ****
+*** 2267,2271 ****
{ yyval.opval = yyvsp[0].opval; }
break;
-! #line 2266 "y.tab.c"
+! #line 2270 "y.tab.c"
}
yyssp -= yym;
---- 2290,2294 ----
+--- 2292,2296 ----
{ yyval.opval = yyvsp[0].opval; }
break;
-! #line 2266 "perly.c"
+! #line 2270 "perly.c"
}
yyssp -= yym;
***************
-*** 2273,2278 ****
+*** 2277,2282 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: after reduction, shifting from state 0 to\
! state %d\n", YYFINAL);
#endif
yystate = YYFINAL;
---- 2300,2306 ----
+--- 2302,2308 ----
#if YYDEBUG
if (yydebug)
! PerlIO_printf(Perl_debug_log,
@@ -372,20 +373,20 @@ Index: perly.c
#endif
yystate = YYFINAL;
***************
-*** 2288,2292 ****
+*** 2292,2296 ****
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! printf("yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
---- 2316,2320 ----
+--- 2318,2322 ----
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
***************
-*** 2303,2312 ****
+*** 2307,2316 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: after reduction, shifting from state %d \
@@ -396,7 +397,7 @@ Index: perly.c
! goto yyoverflow;
}
*++yyssp = yystate;
---- 2331,2355 ----
+--- 2333,2357 ----
#if YYDEBUG
if (yydebug)
! PerlIO_printf(Perl_debug_log,
@@ -423,7 +424,7 @@ Index: perly.c
}
*++yyssp = yystate;
***************
-*** 2314,2321 ****
+*** 2318,2325 ****
goto yyloop;
yyoverflow:
! yyerror("yacc stack overflow");
@@ -432,7 +433,7 @@ Index: perly.c
yyaccept:
! return (0);
}
---- 2357,2364 ----
+--- 2359,2366 ----
goto yyloop;
yyoverflow:
! yyerror("Out of memory for yacc stack");
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 2816665ced..a3c6b6cc05 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -502,6 +502,8 @@ DOS is now supported under the DJGPP tools. See L<README.dos>.
MPE/iX is now supported. See L<README.mpeix>.
+MVS (OS390) is now supported. See L<README.os390>.
+
=head2 Changes in existing support
Win32 support has been vastly enhanced. Support for Perl Object, a C++
diff --git a/pod/perlport.pod b/pod/perlport.pod
index 83654689a6..d4c4db8c27 100644
--- a/pod/perlport.pod
+++ b/pod/perlport.pod
@@ -681,13 +681,14 @@ general usage issues for all EBCDIC Perls. Send a message body of
=head2 Other perls
-Perl has been ported to a variety of platforms that do not fit into any of
-the above categories. Some, such as AmigaOS, BeOS, QNX, and Plan 9, have
-been well integrated into the standard Perl source code kit. You may need
-to see the F<ports/> directory on CPAN for information, and possibly
-binaries, for the likes of: acorn, aos, atari, lynxos, HP-MPE/iX, riscos,
-Tandem Guardian, vos, I<etc.> (yes we know that some of these OSes may fall
-under the Unix category but we are not a standards body.)
+Perl has been ported to a variety of platforms that do not fit into
+any of the above categories. Some, such as AmigaOS, BeOS, MPE/iX,
+OS/390 (MVS), QNX, and Plan 9, have been well integrated into the
+standard Perl source code kit. You may need to see the F<ports/>
+directory on CPAN for information, and possibly binaries, for the
+likes of: acorn, aos, atari, lynxos, riscos, Tandem Guardian, vos,
+I<etc.> (yes we know that some of these OSes may fall under the Unix
+category but we are not a standards body.)
See also:
diff --git a/pp.c b/pp.c
index 4eb8f2f09f..35c76bc44f 100644
--- a/pp.c
+++ b/pp.c
@@ -2908,6 +2908,20 @@ mul128(SV *sv, U8 m)
/* Explosives and implosives. */
+static const char uuemap[] =
+ "`!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
+static char uudmap[256]; /* Initialised on first use */
+#if 'I' == 73 && 'J' == 74
+/* On an ASCII/ISO kind of system */
+#define ISUUCHAR(ch) ((ch) > ' ' && (ch) < 'a')
+#else
+/*
+ Some other sort of character set - use memchr() so we don't match
+ the null byte.
+ */
+#define ISUUCHAR(ch) (memchr(uuemap, (ch), sizeof(uuemap)-1))
+#endif
+
PP(pp_unpack)
{
djSP;
@@ -3534,31 +3548,48 @@ PP(pp_unpack)
}
break;
case 'u':
+ /* MKS:
+ * Initialise the decode mapping. By using a table driven
+ * algorithm, the code will be character-set independent
+ * (and just as fast as doing character arithmetic)
+ */
+ if (uudmap['M'] == 0) {
+ int i;
+
+ for (i = 0; i < sizeof(uuemap); i += 1)
+ uudmap[uuemap[i]] = i;
+ /*
+ * Because ' ' and '`' map to the same value,
+ * we need to decode them both the same.
+ */
+ uudmap[' '] = 0;
+ }
+
along = (strend - s) * 3 / 4;
sv = NEWSV(42, along);
if (along)
SvPOK_on(sv);
- while (s < strend && *s > ' ' && *s < 'a') {
+ while (s < strend && *s > ' ' && ISUUCHAR(*s)) {
I32 a, b, c, d;
char hunk[4];
hunk[3] = '\0';
len = (*s++ - ' ') & 077;
while (len > 0) {
- if (s < strend && *s >= ' ')
- a = (*s++ - ' ') & 077;
- else
- a = 0;
- if (s < strend && *s >= ' ')
- b = (*s++ - ' ') & 077;
- else
- b = 0;
- if (s < strend && *s >= ' ')
- c = (*s++ - ' ') & 077;
- else
- c = 0;
- if (s < strend && *s >= ' ')
- d = (*s++ - ' ') & 077;
+ if (s < strend && ISUUCHAR(*s))
+ a = uudmap[*s++] & 077;
+ else
+ a = 0;
+ if (s < strend && ISUUCHAR(*s))
+ b = uudmap[*s++] & 077;
+ else
+ b = 0;
+ if (s < strend && ISUUCHAR(*s))
+ c = uudmap[*s++] & 077;
+ else
+ c = 0;
+ if (s < strend && ISUUCHAR(*s))
+ d = uudmap[*s++] & 077;
else
d = 0;
hunk[0] = (a << 2) | (b >> 4);
@@ -3619,22 +3650,18 @@ doencodes(register SV *sv, register char *s, register I32 len)
{
char hunk[5];
- *hunk = len + ' ';
+ *hunk = uuemap[len];
sv_catpvn(sv, hunk, 1);
hunk[4] = '\0';
while (len > 0) {
- hunk[0] = ' ' + (077 & (*s >> 2));
- hunk[1] = ' ' + (077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)));
- hunk[2] = ' ' + (077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)));
- hunk[3] = ' ' + (077 & (s[2] & 077));
+ hunk[0] = uuemap[(077 & (*s >> 2))];
+ hunk[1] = uuemap[(077 & ((*s << 4) & 060 | (s[1] >> 4) & 017))];
+ hunk[2] = uuemap[(077 & ((s[1] << 2) & 074 | (s[2] >> 6) & 03))];
+ hunk[3] = uuemap[(077 & (s[2] & 077))];
sv_catpvn(sv, hunk, 4);
s += 3;
len -= 3;
}
- for (s = SvPVX(sv); *s; s++) {
- if (*s == ' ')
- *s = '`';
- }
sv_catpvn(sv, "\n", 1);
}
diff --git a/pp_ctl.c b/pp_ctl.c
index 8d4b7f71ab..7a1ad799b8 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -436,15 +436,13 @@ PP(pp_formline)
arg = itemsize;
s = item;
while (arg--) {
-#if 'z' - 'a' != 25
+#ifdef EBCDIC
int ch = *t++ = *s++;
- if (!iscntrl(ch))
- t[-1] = ' ';
+ if (iscntrl(ch))
#else
if ( !((*t++ = *s++) & ~31) )
- t[-1] = ' ';
#endif
-
+ t[-1] = ' ';
}
break;
diff --git a/pp_hot.c b/pp_hot.c
index 29f654219a..9b68c1caa7 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -21,6 +21,12 @@
#ifdef I_UNISTD
#include <unistd.h>
#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
+#ifdef I_SYS_FILE
+#include <sys/file.h>
+#endif
/* Hot code. */
@@ -1063,7 +1069,7 @@ do_readline(void)
IoFLAGS(io) &= ~IOf_START;
IoLINES(io) = 0;
if (av_len(GvAVn(PL_last_in_gv)) < 0) {
- do_open(PL_last_in_gv,"-",1,FALSE,0,0,Nullfp);
+ do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
SvSETMAGIC(GvSV(PL_last_in_gv));
fp = IoIFP(io);
@@ -1197,7 +1203,7 @@ do_readline(void)
#endif /* !CSH */
#endif /* !DOSISH */
(void)do_open(PL_last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
- FALSE, 0, 0, Nullfp);
+ FALSE, O_RDONLY, 0, Nullfp);
fp = IoIFP(io);
#endif /* !VMS */
LEAVE;
diff --git a/pp_sys.c b/pp_sys.c
index 5e570754c5..2630e050b8 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -382,7 +382,7 @@ PP(pp_open)
if (GvIOp(gv))
IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
tmps = SvPV(sv, len);
- if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
+ if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
PUSHi( (I32)PL_forkprocess );
else if (PL_forkprocess == 0) /* we are a new child */
PUSHi(0);
@@ -2608,12 +2608,17 @@ PP(pp_fttext)
odd += len;
break;
}
+#ifdef EBCDIC
+ else if (!(isPRINT(*s) || isSPACE(*s)))
+ odd++;
+#else
else if (*s & 128)
odd++;
else if (*s < 32 &&
*s != '\n' && *s != '\r' && *s != '\b' &&
*s != '\t' && *s != '\f' && *s != 27)
odd++;
+#endif
}
if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
diff --git a/sv.c b/sv.c
index d669ee71a6..a53e76979e 100644
--- a/sv.c
+++ b/sv.c
@@ -3540,10 +3540,24 @@ sv_inc(register SV *sv)
*(d--) = '0';
}
else {
+#ifdef EBCDIC
+ /* MKS: The original code here died if letters weren't consecutive.
+ * at least it didn't have to worry about non-C locales. The
+ * new code assumes that ('z'-'a')==('Z'-'A'), letters are
+ * arranged in order (although not consecutively) and that only
+ * [A-Za-z] are accepted by isALPHA in the C locale.
+ */
+ if (*d != 'z' && *d != 'Z') {
+ do { ++*d; } while (!isALPHA(*d));
+ return;
+ }
+ *(d--) -= 'z' - 'a';
+#else
++*d;
if (isALPHA(*d))
return;
*(d--) -= 'z' - 'a' + 1;
+#endif
}
}
/* oh,oh, the number grew */
diff --git a/t/base/term.t b/t/base/term.t
index 782ad397d3..e96313dec5 100755
--- a/t/base/term.t
+++ b/t/base/term.t
@@ -2,12 +2,22 @@
# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:07 $
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+
print "1..7\n";
# check "" interpretation
$x = "\n";
-if ($x eq chr(10)) {print "ok 1\n";} else {print "not ok 1\n";}
+# 10 is ASCII/Iso Latin, 21 is EBCDIC.
+if ($x eq chr(10) ||
+ ($Config{ebcdic} eq 'define' && $x eq chr(21))) {print "ok 1\n";}
+else {print "not ok 1\n";}
# check `` processing
diff --git a/t/comp/package.t b/t/comp/package.t
index cef02c5cb4..d7d19ae882 100755
--- a/t/comp/package.t
+++ b/t/comp/package.t
@@ -23,7 +23,11 @@ $main = join(':', sort(keys %main::));
$xyz = join(':', sort(keys %xyz::));
$ABC = join(':', sort(keys %ABC::));
-print $xyz eq 'ABC:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n";
+if ('a' lt 'A') {
+ print $xyz eq 'bar:main:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n";
+} else {
+ print $xyz eq 'ABC:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n";
+}
print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\n";
print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n";
diff --git a/t/comp/require.t b/t/comp/require.t
index bae0712dfa..819c7774b2 100755
--- a/t/comp/require.t
+++ b/t/comp/require.t
@@ -25,7 +25,7 @@ print "ok ",$i++,"\n";
# compile-time failure in require
do_require "1)\n";
-print "# $@\nnot " unless $@ =~ /syntax error/;
+print "# $@\nnot " unless $@ =~ /syntax error/i;
print "ok ",$i++,"\n";
# successful require
diff --git a/t/lib/bigintpm.t b/t/lib/bigintpm.t
index 4357975f2b..e7cac26323 100755
--- a/t/lib/bigintpm.t
+++ b/t/lib/bigintpm.t
@@ -5,7 +5,6 @@ BEGIN {
@INC = '../lib';
}
-use Config;
use Math::BigInt;
$test = 0;
diff --git a/t/lib/cgi-html.t b/t/lib/cgi-html.t
index d7f3ffb4aa..16aa824c51 100755
--- a/t/lib/cgi-html.t
+++ b/t/lib/cgi-html.t
@@ -9,7 +9,8 @@ BEGIN {
}
BEGIN {$| = 1; print "1..17\n"; }
-BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ";}
+BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ";
+ $eol = "\r\n" if $^O eq 'os390'; }
END {print "not ok 1\n" unless $loaded;}
use CGI (':standard','-no_debug');
$loaded = 1;
diff --git a/t/lib/filehand.t b/t/lib/filehand.t
index 08cae71872..b8ec95f320 100755
--- a/t/lib/filehand.t
+++ b/t/lib/filehand.t
@@ -31,7 +31,7 @@ $buffer = <$fh>;
print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n";
-ungetc $fh 65;
+ungetc $fh ord 'A';
CORE::read($fh, $buf,1);
print $buf eq 'A' ? "ok 4\n" : "not ok 4\n";
diff --git a/t/lib/ph.t b/t/lib/ph.t
index d0a48f6c51..de27dee5e2 100755
--- a/t/lib/ph.t
+++ b/t/lib/ph.t
@@ -9,8 +9,6 @@ BEGIN {
@INC = '../lib';
}
-use Config;
-
# All the constants which Socket.pm tries to make available:
my @possibly_defined = qw(
INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT
diff --git a/t/op/auto.t b/t/op/auto.t
index 93a42f8472..2eb0097650 100755
--- a/t/op/auto.t
+++ b/t/op/auto.t
@@ -2,7 +2,7 @@
# $RCSfile: auto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:39 $
-print "1..34\n";
+print "1..37\n";
$x = 10000;
if (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";}
@@ -46,3 +46,7 @@ if (++($foo = '99') eq '100') {print "ok 31\n";} else {print "not ok 31\n";}
if (++($foo = 'a0') eq 'a1') {print "ok 32\n";} else {print "not ok 32\n";}
if (++($foo = 'Az') eq 'Ba') {print "ok 33\n";} else {print "not ok 33\n";}
if (++($foo = 'zz') eq 'aaa') {print "ok 34\n";} else {print "not ok 34\n";}
+if (++($foo = 'A99') eq 'B00') {print "ok 35\n";} else {print "not ok 35\n";}
+# EBCDIC guards: i and j, r and s, are not contiguous.
+if (++($foo = 'zi') eq 'zj') {print "ok 36\n";} else {print "not ok 36\n";}
+if (++($foo = 'zr') eq 'zs') {print "ok 37\n";} else {print "not ok 37\n";}
diff --git a/t/op/bop.t b/t/op/bop.t
index 0c55029b93..b247341417 100755
--- a/t/op/bop.t
+++ b/t/op/bop.t
@@ -42,14 +42,23 @@ print ((($cusp >> 1) == ($cusp / 2) &&
do { use integer; $cusp >> 1 } == -($cusp / 2))
? "ok 12\n" : "not ok 12\n");
+$Aaz = chr(ord("A") & ord("z"));
+$Aoz = chr(ord("A") | ord("z"));
+$Axz = chr(ord("A") ^ ord("z"));
+
# short strings
-print (("AAAAA" & "zzzzz") eq '@@@@@' ? "ok 13\n" : "not ok 13\n");
-print (("AAAAA" | "zzzzz") eq '{{{{{' ? "ok 14\n" : "not ok 14\n");
-print (("AAAAA" ^ "zzzzz") eq ';;;;;' ? "ok 15\n" : "not ok 15\n");
+print (("AAAAA" & "zzzzz") eq ($Aaz x 5) ? "ok 13\n" : "not ok 13\n");
+print (("AAAAA" | "zzzzz") eq ($Aoz x 5) ? "ok 14\n" : "not ok 14\n");
+print (("AAAAA" ^ "zzzzz") eq ($Axz x 5) ? "ok 15\n" : "not ok 15\n");
# long strings
$foo = "A" x 150;
$bar = "z" x 75;
-print (($foo & $bar) eq ('@'x75 ) ? "ok 16\n" : "not ok 16\n");
-print (($foo | $bar) eq ('{'x75 . 'A'x75) ? "ok 17\n" : "not ok 17\n");
-print (($foo ^ $bar) eq (';'x75 . 'A'x75) ? "ok 18\n" : "not ok 18\n");
+$zap = "A" x 75;
+# & truncates
+print (($foo & $bar) eq ($Aaz x 75 ) ? "ok 16\n" : "not ok 16\n");
+# | does not truncate
+print (($foo | $bar) eq ($Aoz x 75 . $zap) ? "ok 17\n" : "not ok 17\n");
+# ^ does not truncate
+print (($foo ^ $bar) eq ($Axz x 75 . $zap) ? "ok 18\n" : "not ok 18\n");
+
diff --git a/t/op/each.t b/t/op/each.t
index 420fdc09c3..9063c2c3ed 100755
--- a/t/op/each.t
+++ b/t/op/each.t
@@ -43,7 +43,8 @@ if ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";}
$i = 0; # stop -w complaints
while (($key,$value) = each(%h)) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
+ if ($key eq $keys[$i] && $value eq $values[$i]
+ && (('a' lt 'A' && $key lt $value) || $key gt $value)) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
}
diff --git a/t/op/magic.t b/t/op/magic.t
index 61e4522913..7f08e06f85 100755
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -135,6 +135,12 @@ __END__
:endofperl
EOT
}
+ if ($^O eq 'os390') { # no shebang
+ $headmaybe = <<EOH ;
+ eval 'exec ./perl -S \$0 \${1+"\$\@"}'
+ if 0;
+EOH
+ }
$s1 = $s2 = "\$^X is $perl, \$0 is $script\n";
ok 19, open(SCRIPT, ">$script"), $!;
ok 20, print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!;
diff --git a/t/op/misc.t b/t/op/misc.t
index 449d87cea1..7292ffebd4 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -36,6 +36,7 @@ for (@prgs){
$status = $?;
$results = `$CAT $tmpfile`;
$results =~ s/\n+$//;
+ $results =~ s/syntax error/syntax error/i;
$expected =~ s/\n+$//;
if ( $results ne $expected){
print STDERR "PROG: $switch\n$prog\n";
diff --git a/t/op/ord.t b/t/op/ord.t
index 37128382d8..ba943f4e8c 100755
--- a/t/op/ord.t
+++ b/t/op/ord.t
@@ -6,11 +6,13 @@ print "1..3\n";
# compile time evaluation
-if (ord('A') == 65) {print "ok 1\n";} else {print "not ok 1\n";}
+# 65 ASCII
+# 193 EBCDIC
+if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n";}
# run time evaluation
$x = 'ABC';
-if (ord($x) == 65) {print "ok 2\n";} else {print "not ok 2\n";}
+if (ord($x) == 65 || ord($x) == 193) {print "ok 2\n";} else {print "not ok 2\n";}
-if (chr 65 == A) {print "ok 3\n";} else {print "not ok 3\n";}
+if (chr 65 == 'A' || chr 193 == 'A') {print "ok 3\n";} else {print "not ok 3\n";}
diff --git a/t/op/pack.t b/t/op/pack.t
index b8aece6b6b..02efb66717 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -2,7 +2,7 @@
# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
-print "1..56\n";
+print "1..58\n";
$format = "c2 x5 C C x s d i l a6";
# Need the expression in here to force ary[5] to be numeric. This avoids
@@ -30,7 +30,10 @@ print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12
print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9
? "ok 6\n" : "not ok 6 $x\n";
-print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == 129
+my $sum = 129; # ASCII
+$sum = 103 if ($^O eq 'os390'); # An EBCDIC variant.
+
+print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum
? "ok 7\n" : "not ok 7 $x\n";
open(BIN, "./perl") || open(BIN, "./perl.exe")
@@ -154,3 +157,22 @@ foreach my $t (@templates) {
unless @t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i));
print "ok ", $test++, "\n";
}
+
+# 57..58: uuencode/decode
+
+$in = join "", map { chr } 0..255;
+$uu = <<'EOUU';
+M``$"`P0%!@<("0H+#`T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL
+M+2XO,#$R,S0U-C<X.3H[/#T^/T!!0D-$149'2$E*2TQ-3D]045)35%565UA9
+M6EM<75Y?8&%B8V1E9F=H:6IK;&UN;W!Q<G-T=79W>'EZ>WQ]?G^`@8*#A(6&
+MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S
+MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R<K+S,W.S]#1TM/4U=;7V-G:V]S=WM_@
+?X>+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P``
+EOUU
+
+print "not " unless pack('u', $in) eq $uu;
+print "ok ", $test++, "\n";
+
+print "not " unless unpack('u', $uu) eq $in;
+print "ok ", $test++, "\n";
+
diff --git a/t/op/quotemeta.t b/t/op/quotemeta.t
index 20dd312b31..913e07cdd6 100755
--- a/t/op/quotemeta.t
+++ b/t/op/quotemeta.t
@@ -1,14 +1,26 @@
#!./perl
+
print "1..15\n";
-$_=join "", map chr($_), 32..127;
+if ($^O eq 'os390') { # An EBCDIC variant.
+ $_=join "", map chr($_), 129..233;
+
+ # 105 characters - 52 letters = 53 backslashes
+ # 105 characters + 53 backslashes = 158 characters
+ $_=quotemeta $_;
+ if ( length == 158 ){print "ok 1\n"} else {print "not ok 1\n"}
+ # 104 non-backslash characters
+ if (tr/\\//cd == 104){print "ok 2\n"} else {print "not ok 2\n"}
+} else { # some ASCII descendant, then.
+ $_=join "", map chr($_), 32..127;
-# 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes
-# 96 characters + 33 backslashes = 129 characters
-$_=quotemeta $_;
-if ( length == 129 ){print "ok 1\n"} else {print "not ok 1\n"}
-# 95 non-backslash characters
-if (tr/\\//cd == 95){print "ok 2\n"} else {print "not ok 2\n"}
+ # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes
+ # 96 characters + 33 backslashes = 129 characters
+ $_=quotemeta $_;
+ if ( length == 129 ){print "ok 1\n"} else {print "not ok 1\n"}
+ # 95 non-backslash characters
+ if (tr/\\//cd == 95){print "ok 2\n"} else {print "not ok 2\n"}
+}
if (length quotemeta "" == 0){print "ok 3\n"} else {print "not ok 3\n"}
diff --git a/t/op/re_tests b/t/op/re_tests
index 7ac20c3852..a5295f5aae 100644
--- a/t/op/re_tests
+++ b/t/op/re_tests
@@ -151,8 +151,8 @@ a[bcd]+dcdcde adcdcde n - -
(bc+d$|ef*g.|h?i(j|k)) reffgz y $&-$1-$2 effgz-effgz-
((((((((((a)))))))))) a y $10 a
((((((((((a))))))))))\10 aa y $& aa
-((((((((((a))))))))))\41 aa n - -
-((((((((((a))))))))))\41 a! y $& a!
+((((((((((a))))))))))${bang} aa n - -
+((((((((((a))))))))))${bang} a! y $& a!
(((((((((a))))))))) a y $& a
multiple words of text uh-uh n - -
multiple words multiple words, yeah y $& multiple words
@@ -291,8 +291,8 @@ a[-]?c ac y $& ac
'(bc+d$|ef*g.|h?i(j|k))'i REFFGZ y $&-$1-$2 EFFGZ-EFFGZ-
'((((((((((a))))))))))'i A y $10 A
'((((((((((a))))))))))\10'i AA y $& AA
-'((((((((((a))))))))))\41'i AA n - -
-'((((((((((a))))))))))\41'i A! y $& A!
+'((((((((((a))))))))))${bang}'i AA n - -
+'((((((((((a))))))))))${bang}'i A! y $& A!
'(((((((((a)))))))))'i A y $& A
'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a))))))))))'i A y $1 A
'(?:(?:(?:(?:(?:(?:(?:(?:(?:(a|b|c))))))))))'i C y $1 C
diff --git a/t/op/regexp.t b/t/op/regexp.t
index 0ec069b19a..b0b08855b8 100755
--- a/t/op/regexp.t
+++ b/t/op/regexp.t
@@ -24,7 +24,7 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
# Column 5 contains the expected result of double-quote
# interpolating that string after the match, or start of error message.
#
-# \n in the tests are interpolated.
+# \n in the tests are interpolated, as are variables of the form ${\w+}.
#
# If you want to add a regular expression test that can't be expressed
# in this format, don't add it here: put it in op/pat.t instead.
@@ -46,6 +46,8 @@ $numtests = $.;
seek(TESTS,0,0);
$. = 0;
+$bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
+
$| = 1;
print "1..$numtests\n# $iters iterations\n";
TEST:
@@ -58,6 +60,7 @@ while (<TESTS>) {
infty_subst(\$expect);
$pat = "'$pat'" unless $pat =~ /^[:']/;
$pat =~ s/\\n/\n/g;
+ $pat =~ s/(\$\{\w+\})/$1/eeg;
$subject =~ s/\\n/\n/g;
$expect =~ s/\\n/\n/g;
$expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
diff --git a/t/op/sort.t b/t/op/sort.t
index a6829e01e4..70341b9106 100755
--- a/t/op/sort.t
+++ b/t/op/sort.t
@@ -6,20 +6,41 @@ print "1..21\n";
sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
+my $upperfirst = 'A' lt 'a';
+
+# Beware: in future this may become hairier because of possible
+# collation complications: qw(A a B c) can be sorted at least as
+# any of the following
+#
+# A a B b
+# A B a b
+# a b A B
+# a A b B
+#
+# All the above orders make sense.
+#
+# That said, EBCDIC sorts all small letters first, as opposed
+# to ASCII which sorts all big letters first.
+
@harry = ('dog','cat','x','Cain','Abel');
@george = ('gone','chased','yz','punished','Axed');
$x = join('', sort @harry);
-print ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n");
-print "# x = '$x'\n";
+$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain';
+print "# 1: x = '$x', expected = '$expected'\n";
+print ($x eq $expected ? "ok 1\n" : "not ok 1\n");
$x = join('', sort( backwards @harry));
-print ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n");
-print "# x = '$x'\n";
+$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
+print "# 2: x = '$x', expected = '$expected'\n";
+print ($x eq $expected ? "ok 2\n" : "not ok 2\n");
$x = join('', sort @george, 'to', @harry);
-print ($x eq 'AbelAxedCaincatchaseddoggonepunishedtoxyz'?"ok 3\n":"not ok 3\n");
-print "# x = '$x'\n";
+$expected = $upperfirst ?
+ 'AbelAxedCaincatchaseddoggonepunishedtoxyz' :
+ 'catchaseddoggonepunishedtoxyzAbelAxedCain' ;
+print "# 3: x = '$x', expected = '$expected'\n";
+print ($x eq $expected ?"ok 3\n":"not ok 3\n");
@a = ();
@b = reverse @a;
@@ -47,7 +68,9 @@ print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n");
$sub = 'backwards';
$x = join('', sort $sub @harry);
-print ($x eq 'xdogcatCainAbel' ? "ok 10\n" : "not ok 10\n");
+$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat';
+print "# 10: x = $x, expected = '$expected'\n";
+print ($x eq $expected ? "ok 10\n" : "not ok 10\n");
# literals, combinations
diff --git a/t/op/sprintf.t b/t/op/sprintf.t
index 7556c80a41..b9b4751c79 100755
--- a/t/op/sprintf.t
+++ b/t/op/sprintf.t
@@ -14,7 +14,7 @@ $SIG{__WARN__} = sub {
};
$w = 0;
-$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,65,3.0999);
+$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,ord('A'),3.0999);
if ($x eq ' hi 123 %foo 456 0A3.1' && $w == 0) {
print "ok 1\n";
} else {
diff --git a/t/op/subst.t b/t/op/subst.t
index 2d42eeb386..afa06ab772 100755
--- a/t/op/subst.t
+++ b/t/op/subst.t
@@ -1,11 +1,5 @@
#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib' if -d '../lib';
-}
-
print "1..71\n";
$x = 'foo';
@@ -187,13 +181,21 @@ tr/a-z/A-Z/;
print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n";
# same as tr/A-Z/a-z/;
-y[\101-\132][\141-\172];
+if ($^O eq 'os390') { # An EBCDIC variant.
+ y[\301-\351][\201-\251];
+} else { # Ye Olde ASCII. Or something like it.
+ y[\101-\132][\141-\172];
+}
print $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ? "ok 53\n" : "not ok 53\n";
-$_ = '+,-';
-tr/+--/a-c/;
-print $_ eq 'abc' ? "ok 54\n" : "not ok 54\n";
+if (ord("+") == ord(",") - 1 && ord(",") == ord("-") - 1 &&
+ ord("a") == ord("b") - 1 && ord("b") == ord("c") - 1) {
+ $_ = '+,-';
+ tr/+--/a-c/;
+ print "not " unless $_ eq 'abc';
+}
+print "ok 54\n";
$_ = '+,-';
tr/+\--/a\/c/;
diff --git a/t/op/taint.t b/t/op/taint.t
index f2181d82fd..d2cae8e70a 100755
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -15,6 +15,10 @@ BEGIN {
use strict;
use Config;
+# We do not want the whole taint.t to fail
+# just because Errno possibly failing.
+eval { require Errno; import Errno };
+
my $Is_VMS = $^O eq 'VMS';
my $Is_MSWin32 = $^O eq 'MSWin32';
my $Is_Dos = $^O eq 'dos';
@@ -360,7 +364,9 @@ else {
test 71, eval { open FOO, $foo } eq '', 'open for read';
test 72, $@ eq '', $@; # NB: This should be allowed
- test 73, $! == 2 || ($Is_Dos && $! == 22); # File not found
+
+ # Try first new style but allow also old style.
+ test 73, $!{ENOENT} || $! == 2 || ($Is_Dos && $! == 22); # File not found
test 74, eval { open FOO, "> $foo" } eq '', 'open for write';
test 75, $@ =~ /^Insecure dependency/, $@;
diff --git a/t/op/universal.t b/t/op/universal.t
index bd6c73afe9..bde78fd04c 100755
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -75,7 +75,11 @@ test ! (eval { $a->VERSION(2.719) }) &&
test (eval { $a->VERSION(2.718) }) && ! $@;
my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
-test $subs eq "VERSION can isa";
+if ('a' lt 'A') {
+ test $subs eq "can isa VERSION";
+} else {
+ test $subs eq "VERSION can isa";
+}
test $a->isa("UNIVERSAL");
@@ -86,7 +90,11 @@ test $a->isa("UNIVERSAL");
my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
# XXX import being here is really a bug
-test $sub2 eq "VERSION can import isa";
+if ('a' lt 'A') {
+ test $sub2 eq "can import isa VERSION";
+} else {
+ test $sub2 eq "VERSION can import isa";
+}
eval 'sub UNIVERSAL::sleep {}';
test $a->can("sleep");
diff --git a/t/pragma/constant.t b/t/pragma/constant.t
index 0095f3b627..0b58bae607 100755
--- a/t/pragma/constant.t
+++ b/t/pragma/constant.t
@@ -81,7 +81,7 @@ test 18, (COUNTLIST)[1] == 4;
use constant ABC => 'ABC';
test 19, "abc${\( ABC )}abc" eq "abcABCabc";
-use constant DEF => 'D', "\x45", chr 70;
+use constant DEF => 'D', 'E', chr ord 'F';
test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f";
use constant SINGLE => "'";
diff --git a/t/pragma/overload.t b/t/pragma/overload.t
index 64ab7ab6e2..afba8a3221 100755
--- a/t/pragma/overload.t
+++ b/t/pragma/overload.t
@@ -5,8 +5,6 @@ BEGIN {
@INC = '../lib';
}
-use Config;
-
package Oscalar;
use overload (
# Anonymous subroutines:
diff --git a/t/pragma/subs.t b/t/pragma/subs.t
index 056c4bd7cf..680564f843 100755
--- a/t/pragma/subs.t
+++ b/t/pragma/subs.t
@@ -55,6 +55,7 @@ for (@prgs){
# allow expected output to be written as if $prog is on STDIN
$results =~ s/tmp\d+/-/g;
$results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
+ $results =~ s/Syntax/syntax/; # non-standard yacc
$expected =~ s/\n+$//;
my $prefix = ($results =~ s/^PREFIX\n//) ;
if ( $results =~ s/^SKIPPED\n//) {
diff --git a/toke.c b/toke.c
index 9475b25fcf..b5315fa06a 100644
--- a/toke.c
+++ b/toke.c
@@ -185,7 +185,13 @@ missingterm(char *s)
if (nl)
*nl = '\0';
}
- else if (PL_multi_close < 32 || PL_multi_close == 127) {
+ else if (
+#ifdef EBCDIC
+ iscntrl(PL_multi_close)
+#else
+ PL_multi_close < 32 || PL_multi_close == 127
+#endif
+ ) {
*tmpbuf = '^';
tmpbuf[1] = toCTRL(PL_multi_close);
s = "\\n";
@@ -989,8 +995,15 @@ scan_const(char *start)
/* \c is a control character */
case 'c':
s++;
+#ifdef EBCDIC
+ *d = *s++;
+ if (isLOWER(*d))
+ *d = toUPPER(*d);
+ *d++ = toCTRL(*d);
+#else
len = *s++;
*d++ = toCTRL(len);
+#endif
continue;
/* printf-style backslashes, formfeeds, newlines, etc */
@@ -1390,7 +1403,7 @@ filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
else
return Nullch ;
}
- else
+ else
return (sv_gets(sv, fp, append));
}
@@ -4057,7 +4070,17 @@ yylex(void)
FUN0(OP_WANTARRAY);
case KEY_write:
- gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
+#ifdef EBCDIC
+ {
+ static char ctl_l[2];
+
+ if (ctl_l[0] == '\0')
+ ctl_l[0] = toCTRL('L');
+ gv_fetchpv(ctl_l,TRUE, SVt_PV);
+ }
+#else
+ gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
+#endif
UNI(OP_ENTERWRITE);
case KEY_x:
diff --git a/x2p/a2p.h b/x2p/a2p.h
index 2db5f36ebc..80530469ed 100644
--- a/x2p/a2p.h
+++ b/x2p/a2p.h
@@ -412,6 +412,10 @@ EXT int debug INIT(0);
EXT int dlevel INIT(0);
#define YYDEBUG 1
extern int yydebug;
+#else
+# ifndef YYDEBUG
+# define YYDEBUG 0
+# endif
#endif
EXT STR *freestrroot INIT(Nullstr);
diff --git a/x2p/a2py.c b/x2p/a2py.c
index a4753ab864..8a6155f455 100644
--- a/x2p/a2py.c
+++ b/x2p/a2py.c
@@ -66,7 +66,7 @@ main(register int argc, register char **argv, register char **env)
#ifdef DEBUGGING
case 'D':
debug = atoi(argv[0]+2);
-#ifdef YYDEBUG
+#if YYDEBUG
yydebug = (debug & 1);
#endif
break;
@@ -211,7 +211,7 @@ yylex(void)
register int tmp;
retry:
-#ifdef YYDEBUG
+#if YYDEBUG
if (yydebug)
if (strchr(s,'\n'))
fprintf(stderr,"Tokener at %s",s);
@@ -273,7 +273,11 @@ yylex(void)
case ':':
tmp = *s++;
XOP(tmp);
+#ifdef EBCDIC
+ case 7:
+#else
case 127:
+#endif
s++;
XTERM('}');
case '}':
View Lorry Controller Status