From 9d116dd7c895b17badf4ad422ae44da0c4df7bc2 Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Sat, 1 Aug 1998 15:03:02 +0300 Subject: support OE/MVS Message-Id: <199808010903.MAA09371@alpha.hut.fi> Subject: [PATCH] 5.005_01: OE MVS p4raw-id: //depot/maint-5.005/perl@1697 --- Configure | 14 +-- MANIFEST | 2 + README.os390 | 83 ++++++++++++ doio.c | 29 +++-- ebcdic.c | 32 +++++ ext/Errno/Errno_pm.PL | 5 +- gv.c | 30 ++--- handy.h | 28 +++-- hints/os390.sh | 29 ++++- lib/bigint.pl | 2 +- mg.c | 4 +- patchlevel.h | 1 + perl.c | 3 + perl.h | 80 ++++++++++++ perly.c | 340 +++++++++++++++++++++++++------------------------- perly.h | 1 - perly.y | 8 ++ perly_c.diff | 241 +++++++++++++++++------------------ pod/perldelta.pod | 2 + pod/perlport.pod | 15 +-- pp.c | 75 +++++++---- pp_ctl.c | 8 +- pp_hot.c | 10 +- pp_sys.c | 7 +- sv.c | 14 +++ t/base/term.t | 12 +- t/comp/package.t | 6 +- t/comp/require.t | 2 +- t/lib/bigintpm.t | 1 - t/lib/cgi-html.t | 3 +- t/lib/filehand.t | 2 +- t/lib/ph.t | 2 - t/op/auto.t | 6 +- t/op/bop.t | 21 +++- t/op/each.t | 3 +- t/op/magic.t | 6 + t/op/misc.t | 1 + t/op/ord.t | 8 +- t/op/pack.t | 26 +++- t/op/quotemeta.t | 26 ++-- t/op/re_tests | 8 +- t/op/regexp.t | 5 +- t/op/sort.t | 37 ++++-- t/op/sprintf.t | 2 +- t/op/subst.t | 22 ++-- t/op/taint.t | 8 +- t/op/universal.t | 12 +- t/pragma/constant.t | 2 +- t/pragma/overload.t | 2 - t/pragma/subs.t | 1 + toke.c | 29 ++++- x2p/a2p.h | 4 + x2p/a2py.c | 8 +- 53 files changed, 887 insertions(+), 441 deletions(-) create mode 100644 README.os390 create mode 100644 ebcdic.c 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 +# # OS/390 OpenEdition Release 3 Mon Sep 22 1997 thanks to: # # John Pfuntner @@ -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 '{' ')' %token 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. MPE/iX is now supported. See L. +MVS (OS390) is now supported. See L. + =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 directory on CPAN for information, and possibly -binaries, for the likes of: acorn, aos, atari, lynxos, HP-MPE/iX, riscos, -Tandem Guardian, vos, I (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 +directory on CPAN for information, and possibly binaries, for the +likes of: acorn, aos, atari, lynxos, riscos, Tandem Guardian, vos, +I (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 #endif +#ifdef I_FCNTL +#include +#endif +#ifdef I_SYS_FILE +#include +#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 @@ -134,6 +134,12 @@ EOH __END__ :endofperl EOT + } + if ($^O eq 'os390') { # no shebang + $headmaybe = <$script"), $!; 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'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+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 () { 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 '}': -- cgit v1.2.1