diff options
| -rw-r--r-- | arg.h | 12 | ||||
| -rw-r--r-- | cons.c | 32 | ||||
| -rw-r--r-- | lib/syslog.pl | 148 | ||||
| -rw-r--r-- | msdos/README.msdos | 100 | ||||
| -rw-r--r-- | msdos/eg/drives.bat | 41 | ||||
| -rw-r--r-- | msdos/popen.c | 175 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.h | 64 | ||||
| -rw-r--r-- | perl.man.1 | 24 | ||||
| -rw-r--r-- | perl.man.2 | 14 | ||||
| -rw-r--r-- | perl.man.3 | 7 | ||||
| -rw-r--r-- | perl.man.4 | 11 | ||||
| -rw-r--r-- | perl.y | 14 | ||||
| -rw-r--r-- | perly.c | 24 | ||||
| -rw-r--r-- | stab.c | 7 | ||||
| -rw-r--r-- | str.c | 23 | ||||
| -rw-r--r-- | t/op.dbm | 8 | ||||
| -rw-r--r-- | t/op.range | 10 | ||||
| -rw-r--r-- | t/op.subst | 2 | ||||
| -rw-r--r-- | t/op.write | 46 | ||||
| -rw-r--r-- | toke.c | 90 | ||||
| -rw-r--r-- | util.c | 27 |
22 files changed, 817 insertions, 64 deletions
@@ -1,4 +1,4 @@ -/* $Header: arg.h,v 3.0.1.4 90/03/12 16:18:21 lwall Locked $ +/* $Header: arg.h,v 3.0.1.5 90/03/27 15:29:41 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: arg.h,v $ + * Revision 3.0.1.5 90/03/27 15:29:41 lwall + * patch16: MSDOS support + * * Revision 3.0.1.4 90/03/12 16:18:21 lwall * patch13: added list slice operator (LIST)[LIST] * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST) @@ -267,7 +270,8 @@ #define O_GETPEERNAME 240 #define O_LSLICE 241 #define O_SPLICE 242 -#define MAXO 243 +#define O_BINMODE 243 +#define MAXO 244 #ifndef DOINIT extern char *opname[]; @@ -516,7 +520,8 @@ char *opname[] = { "GETPEERNAME", "LSLICE", "SPLICE", - "243" + "BINMODE", + "244" }; #endif @@ -892,6 +897,7 @@ char opargs[MAXO+1] = { A(1,0,0), /* GETPEERNAME */ A(0,3,3), /* LSLICE */ A(0,3,1), /* SPLICE */ + A(1,0,0), /* BINMODE */ 0 }; #undef A @@ -1,4 +1,4 @@ -/* $Header: cons.c,v 3.0.1.5 90/03/12 16:23:10 lwall Locked $ +/* $Header: cons.c,v 3.0.1.6 90/03/27 15:35:21 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: cons.c,v $ + * Revision 3.0.1.6 90/03/27 15:35:21 lwall + * patch16: formats didn't work inside eval + * patch16: $foo++ now optimized to ++$foo where value not required + * * Revision 3.0.1.5 90/03/12 16:23:10 lwall * patch13: perl -d coredumped on scripts with subs that did explicit return * @@ -95,6 +99,28 @@ CMD *cmd; return sub; } +make_form(stab,fcmd) +STAB *stab; +FCMD *fcmd; +{ + if (stab_form(stab)) { + FCMD *tmpfcmd; + FCMD *nextfcmd; + + for (tmpfcmd = stab_form(stab); tmpfcmd; tmpfcmd = nextfcmd) { + nextfcmd = tmpfcmd->f_next; + if (tmpfcmd->f_expr) + arg_free(tmpfcmd->f_expr); + if (tmpfcmd->f_unparsed) + str_free(tmpfcmd->f_unparsed); + if (tmpfcmd->f_pre) + Safefree(tmpfcmd->f_pre); + Safefree(tmpfcmd); + } + } + stab_form(stab) = fcmd; +} + CMD * block_head(tail) register CMD *tail; @@ -594,6 +620,10 @@ int acmd; if (arg[flp].arg_flags & (AF_PRE|AF_POST)) { cmd->c_flags |= opt; + if (acmd && !cmd->ucmd.acmd.ac_expr && !(cmd->c_flags & CF_TERM)) { + arg[flp].arg_flags &= ~AF_POST; /* prefer ++$foo to $foo++ */ + arg[flp].arg_flags |= AF_PRE; /* if value not wanted */ + } return; /* side effect, can't optimize */ } diff --git a/lib/syslog.pl b/lib/syslog.pl new file mode 100644 index 0000000000..46c8c86eda --- /dev/null +++ b/lib/syslog.pl @@ -0,0 +1,148 @@ +# +# syslog.pl +# +# tom christiansen <tchrist@convex.com> +# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> +# NOTE: openlog now takes three arguments, just like openlog(3) +# +# call syslog() with a string priority and a list of printf() args +# like syslog(3) +# +# usage: do 'syslog.pl' || die "syslog.pl: $@"; +# +# then (put these all in a script to test function) +# +# +# do openlog($program,'cons,pid','user'); +# do syslog('info','this is another test'); +# do syslog('warn','this is a better test: %d', time); +# do closelog(); +# +# do syslog('debug','this is the last test'); +# do openlog("$program $$",'ndelay','user'); +# do syslog('notice','fooprogram: this is really done'); +# +# $! = 55; +# do syslog('info','problem was %m'); # %m == $! in syslog(3) + +package syslog; + +$host = 'localhost' unless $host; # set $syslog'host to change + +do '/usr/local/lib/perl/syslog.h' + || die "syslog: Can't do syslog.h: ",($@||$!),"\n"; + +sub main'openlog { + ($ident, $logopt, $facility) = @_; # package vars + $lo_pid = $logopt =~ /\bpid\b/; + $lo_ndelay = $logopt =~ /\bndelay\b/; + $lo_cons = $logopt =~ /\bncons\b/; + $lo_nowait = $logopt =~ /\bnowait\b/; + &connect if $lo_ndelay; +} + +sub main'closelog { + $facility = $ident = ''; + &disconnect; +} + +sub main'syslog { + local($priority) = shift; + local($mask) = shift; + local($message, $whoami); + + &connect unless $connected; + + $whoami = $ident; + + die "syslog: expected both priority and mask" unless $mask && $priority; + + $facility = "user" unless $facility; + + if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { + $whoami = $1; + $mask = $2; + } + $whoami .= " [$$]" if $lo_pid; + + $mask =~ s/%m/$!/g; + $mask .= "\n" unless $mask =~ /\n$/; + $message = sprintf ($mask, @_); + + $whoami = sprintf ("%s %d",$ENV{'USER'}||$ENV{'LOGNAME'},$$) unless $whoami; + + $sum = &xlate($priority) + &xlate($facility); + unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { + if ($lo_cons) { + if ($pid = fork) { + unless ($lo_nowait) { + do {$died = wait;} until $died == $pid || $died < 0; + } + } + else { + open(CONS,">/dev/console"); + print CONS "$<facility.$priority>$whoami: $message\n"; + exit if defined $pid; # if fork failed, we're parent + close CONS; + } + } + } +} + +sub xlate { + local($name) = @_; + $name =~ y/a-z/A-Z/; + $name = "LOG_$name" unless $name =~ /^LOG_/; + $name = "syslog'$name"; + &$name; +} + +sub connect { + $pat = 'S n C4 x8'; + + $af_unix = 1; + $af_inet = 2; + + $stream = 1; + $datagram = 2; + + ($name,$aliases,$proto) = getprotobyname('udp'); + $udp = $proto; + + ($name,$aliase,$port,$proto) = getservbyname('syslog','udp'); + $syslog = $port; + + if (chop($myname = `hostname`)) { + ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname); + die "Can't lookup $myname\n" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + else { + @bytes = (0,0,0,0); + } + $this = pack($pat, $af_inet, 0, @bytes); + + if ($host =~ /^\d+\./) { + @bytes = split(/\./,$host); + } + else { + ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host); + die "Can't lookup $host\n" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + $that = pack($pat,$af_inet,$syslog,@bytes); + + socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n"; + bind(SYSLOG,$this) || die "bind: $!\n"; + connect(SYSLOG,$that) || die "connect: $!\n"; + + local($old) = select(SYSLOG); $| = 1; select($old); + $connected = 1; +} + +sub disconnect { + close SYSLOG; + $connected = 0; +} + +1; diff --git a/msdos/README.msdos b/msdos/README.msdos new file mode 100644 index 0000000000..fb7be1afe4 --- /dev/null +++ b/msdos/README.msdos @@ -0,0 +1,100 @@ + Notes on the MS-DOS Perl port + + Diomidis Spinellis + (dds@cc.ic.ac.uk) + +[0. First copy the files in the msdos directory into the parent +directory--law] + +1. Compiling. + + Perl has been compiled under MS-DOS using the Microsoft +C compiler version 5.1. Before compiling install dir.h as +<sys/dir.h>. You will need a Unix-like make program (e.g. +pdmake) and something like yacc (e.g. bison). You could get +away by running yacc and dry running make on a Unix host, +but I haven't tried it. Compilation takes 12 minutes on a +20MHz 386 machine (together with formating the manual), so +you will probably need something to do in the meantime. The +executable is 272k and the top level directory needs 1M for +sources and about the same ammount for the object code and +the executables. + + The makefile will compile glob for you which you will +need to place somewhere in your path so that perl globbing +will work correctly. I have not tried all the tests or the +examples, nor the awk and sed to Perl translators. You are +on your own with them. In the eg directory I have included +an example program that uses ioctl to display the charac- +teristics of the storage devices of the system. + +2. Using MS-DOS Perl + + The MS-DOS version of perl has most of the functional- +ity of the Unix version. Functions that can not be provided +under MS-DOS like sockets, password and host database +access, fork and wait have been ommited and will terminate +with a fatal error. Care has been taken to implement the +rest. In particular directory access, redirection (includ- +ing pipes, but excluding the pipe function), system, ioctl +and sleep have been provided. + +2.1. Interface to the MS-DOS ioctl system call. + + The function code of the ioctl function (the second +argument) is encoded as follows: + +- The lowest nibble of the function code goes to AL. +- The two middle nibbles go to CL. +- The high nibble goes to CH. + + The return code is -1 in the case of an error and if +successful: + +- for functions AL = 00, 09, 0a the value of the register DX +- for functions AL = 02 - 08, 0e the value of the register AX +- for functions AL = 01, 0b - 0f the number 0. + + See the perl manual for instruction on how to distin- +guish between the return value and the success of ioctl. + + Some ioctl functions need a number as the first argu- +ment. Provided that no other files have been opened the +number can be obtained if ioctl is called with +@fdnum[number] as the first argument after executing the +following code: + + @fdnum = ("STDIN", "STDOUT", "STDERR"); + $maxdrives = 15; + for ($i = 3; $i < $maxdrives; $i++) { + open("FD$i", "nul"); + @fdnum[$i - 1] = "FD$i"; + } + +2.2. Binary file access + + Files are opened in text mode by default. This means +that CR LF pairs are translated to LF. If binary access is +needed the `binary' function should be used. There is +currently no way to reverse the effect of the binary func- +tion. If that is needed close and reopen the file. + +2.3. Interpreter startup. + + The effect of the Unix #!/bin/perl interpreter startup +can be obtained under MS-DOS by giving the script a .bat +extension and using the following lines on its begining: + + @REM=(" + @perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 + @end ") if 0 ; + +(Note that you will probably want an absolute path name in +front of %0.bat). + + March 1990 + + Diomidis Spinellis <dds@cc.ic.ac.uk> + Myrsinis 1 + GR-145 62 Kifissia + Greece diff --git a/msdos/eg/drives.bat b/msdos/eg/drives.bat new file mode 100644 index 0000000000..c68306ed8d --- /dev/null +++ b/msdos/eg/drives.bat @@ -0,0 +1,41 @@ +@REM=(" +@perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9 +@end ") if 0 ; + +# +# Test the ioctl function for MS-DOS. Provide a list of drives and their +# characteristics. +# +# By Diomidis Spinellis. +# + +@fdnum = ("STDIN", "STDOUT", "STDERR"); +$maxdrives = 15; +for ($i = 3; $i < $maxdrives; $i++) { + open("FD$i", "nul"); + @fdnum[$i - 1] = "FD$i"; +} +@mediatype = ( + "320/360 k floppy drive", + "1.2M floppy", + "720K floppy", + "8'' single density floppy", + "8'' double density floppy", + "fixed disk", + "tape drive", + "1.44M floppy", + "other" +); +print "The system has the following drives:\n"; +for ($i = 1; $i < $maxdrives; $i++) { + if ($ret = ioctl(@fdnum[$i], 8, 0)) { + $type = ($ret == 0) ? "removable" : "fixed"; + $ret = ioctl(@fdnum[$i], 9, 0); + $location = ($ret & 0x800) ? "local" : "remote"; + ioctl(@fdnum[$i], 0x860d, $param); + @par = unpack("CCSSSC31S", $param); + $lock = (@par[2] & 2) ? "supporting door lock" : "not supporting door lock"; + printf "%c:$type $location @mediatype[@par[1]] @par[3] cylinders @par[6] + sectors/track $lock\n", ord('A') + $i - 1; + } +} diff --git a/msdos/popen.c b/msdos/popen.c new file mode 100644 index 0000000000..60b21790fc --- /dev/null +++ b/msdos/popen.c @@ -0,0 +1,175 @@ +/* $Header: popen.c,v 3.0.1.1 90/03/27 16:11:57 lwall Locked $ + * + * (C) Copyright 1988, 1990 Diomidis Spinellis. + * + * You may distribute under the terms of the GNU General Public License + * as specified in the README file that comes with the perl 3.0 kit. + * + * $Log: popen.c,v $ + * Revision 3.0.1.1 90/03/27 16:11:57 lwall + * patch16: MSDOS support + * + * Revision 1.1 90/03/18 20:32:20 dds + * Initial revision + * + */ + +/* + * Popen and pclose for MS-DOS + */ + +#include <stdlib.h> +#include <stdio.h> +#include <process.h> + +/* + * Possible actions on an popened file + */ +enum action { + delete, /* Used for "r". Delete the tmp file */ + execute /* Used for "w". Execute the command. */ +}; + +/* + * Linked list of things to do at the end of the program execution. + */ +static struct todo { + FILE *f; /* File we are working on (to fclose) */ + const char *name; /* Name of the file (to unlink) */ + const char *command; /* Command to execute */ + enum action what; /* What to do (execute or delete) */ + struct todo *next; /* Next structure */ +} *todolist; + + +/* Clean up function */ +static int close_pipes(void); + +/* + * Add a file f running the command command on file name to the list + * of actions to be done at the end. The action is specified in what. + * Return -1 on failure, 0 if ok. + */ +static int +add(FILE *f, const char *command, const char *name, enum action what) +{ + struct todo *p; + + if ((p = (struct todo *) malloc(sizeof(struct todo))) == NULL) + return -1; + p->f = f; + p->command = command; + p->name = name; + p->what = what; + p->next = todolist; + todolist = p; + return 0; +} + +FILE * +mypopen(const char *command, const char *t) +{ + char buff[256]; + char *name; + FILE *f; + static init = 0; + + if (!init) + if (onexit(close_pipes) == NULL) + return NULL; + else + init++; + + if ((name = tempnam(getenv("TMP"), "pp")) == NULL) + return NULL; + + switch (*t) { + case 'r': + sprintf(buff, "%s >%s", command, name); + if (system(buff) || (f = fopen(name, "r")) == NULL) { + free(name); + return NULL; + } + if (add(f, command, name, delete)) { + (void)fclose(f); + (void)unlink(name); + free(name); + return NULL; + } + return f; + case 'w': + if ((f = fopen(name, "w")) == NULL) { + free(name); + return NULL; + } + if (add(f, command, name, execute)) { + (void)fclose(f); + (void)unlink(name); + free(name); + return NULL; + } + return f; + default: + free(name); + return NULL; + } +} + +int +mypclose(FILE *f) +{ + struct todo *p, **prev; + char buff[256]; + const char *name; + int status; + + for (p = todolist, prev = &todolist; p; prev = &(p->next), p = p->next) + if (p->f == f) { + *prev = p->next; + name = p->name; + switch (p->what) { + case delete: + free(p); + if (fclose(f) == EOF) { + (void)unlink(name); + status = EOF; + } else if (unlink(name) < 0) + status = EOF; + else + status = 0; + free(name); + return status; + case execute: + (void)sprintf(buff, "%s <%s", p->command, p->name); + free(p); + if (system(buff)) { + (void)unlink(name); + status = EOF; + } else if (fclose(f) == EOF) { + (void)unlink(name); + status = EOF; + } else if (unlink(name) < 0) + status = EOF; + else + status = 0; + free(name); + return status; + default: + return EOF; + } + } + return EOF; +} + +/* + * Clean up at the end. Called by the onexit handler. + */ +static int +close_pipes(void) +{ + struct todo *p; + + for (p = todolist; p; p = p->next) + (void)mypclose(p->f); + return 0; +} diff --git a/patchlevel.h b/patchlevel.h index 6dbf0692d5..1af605efed 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 17 +#define PATCHLEVEL 18 @@ -1,4 +1,4 @@ -/* $Header: perl.h,v 3.0.1.6 90/03/12 16:40:43 lwall Locked $ +/* $Header: perl.h,v 3.0.1.7 90/03/27 16:12:52 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.h,v $ + * Revision 3.0.1.7 90/03/27 16:12:52 lwall + * patch16: MSDOS support + * patch16: support for machines that can't cast negative floats to unsigned ints + * * Revision 3.0.1.6 90/03/12 16:40:43 lwall * patch13: did some ndir straightening up for Xenix * @@ -49,6 +53,51 @@ #define VOIDUSED 1 #include "config.h" +#ifdef MSDOS +/* + * BUGGY_MSC: + * This symbol is defined if you are the unfortunate owner of a buggy + * Microsoft C compiler and want to use intrinsic functions. Versions + * up to 5.1 are known conform to this definition. This is not needed + * under Unix. + */ +#define BUGGY_MSC /**/ +/* + * BINARY: + * This symbol is defined if you run under an operating system that + * distinguishes between binary and text files. If so the function + * setmode will be used to set the file into binary mode. Unix + * doesn't distinguish. + */ +#define BINARY /**/ + +#else /* !MSDOS */ + +/* + * The following symbols are defined if your operating system supports + * functions by that name. All Unixes I know of support them, thus they + * are not checked by the configuration script, but are directly defined + * here. + */ +#define CHOWN +#define CHROOT +#define FORK +#define GETLOGIN +#define GETPPID +#define KILL +#define LINK +#define PIPE +#define WAIT +#define UMASK +/* + * The following symbols are defined if your operating system supports + * password and group functions in general. All Unix systems do. + */ +#define GROUP +#define PASSWD + +#endif /* !MSDOS */ + #if defined(HASVOLATILE) || defined(__STDC__) #define VOLATILE volatile #else @@ -244,7 +293,7 @@ typedef struct stab STAB; #include "array.h" #include "hash.h" -#if defined(iAPX286) || defined(M_I286) || defined(I80286) +#if defined(iAPX286) || defined(M_I286) || defined(I80286) || defined(M_I86) # define I286 #endif @@ -351,6 +400,17 @@ EXT STR *Str; #endif #endif +#ifdef CASTNEGFLOAT +#define U_S(what) ((unsigned short)(what)) +#define U_I(what) ((unsigned int)(what)) +#define U_L(what) ((unsigned long)(what)) +#else +unsigned long castulong(); +#define U_S(what) ((unsigned int)castulong(what)) +#define U_I(what) ((unsigned int)castulong(what)) +#define U_L(what) (castulong(what)) +#endif + CMD *add_label(); CMD *block_head(); CMD *append_line(); diff --git a/perl.man.1 b/perl.man.1 index dea4da6cfe..69f373ffe4 100644 --- a/perl.man.1 +++ b/perl.man.1 @@ -1,7 +1,10 @@ .rn '' }` -''' $Header: perl.man.1,v 3.0.1.4 90/03/12 16:44:33 lwall Locked $ +''' $Header: perl_man.1,v 3.0.1.5 90/03/27 16:14:37 lwall Locked $ ''' ''' $Log: perl.man.1,v $ +''' Revision 3.0.1.5 90/03/27 16:14:37 lwall +''' patch16: .. now works using magical string increment +''' ''' Revision 3.0.1.4 90/03/12 16:44:33 lwall ''' patch13: (LIST,) now legal ''' patch13: improved LIST documentation @@ -1450,3 +1453,22 @@ as a string, preserving each character within its range, with carry: .fi The autodecrement is not magical. +.PP +The range operator (in an array context) makes use of the magical +autoincrement algorithm if the minimum and maximum are strings. +You can say + + @alphabet = (\'A\' .. \'Z\'); + +to get all the letters of the alphabet, or + + $hexdigit = (0 .. 9, \'a\' .. \'f\')[$num & 15]; + +to get a hexadecimal digit, or + + @z2 = (\'01\' .. \'31\'); print @z2[$mday]; + +to get dates with leading zeros. +(If the final value specified is not in the sequence that the magical increment +would produce, the sequence goes until the next value would be longer than +the final value specified.) diff --git a/perl.man.2 b/perl.man.2 index 722dc8adb0..4f637f1db0 100644 --- a/perl.man.2 +++ b/perl.man.2 @@ -1,7 +1,10 @@ ''' Beginning of part 2 -''' $Header: perl.man.2,v 3.0.1.4 90/03/12 16:46:02 lwall Locked $ +''' $Header: perl_man.2,v 3.0.1.5 90/03/27 16:15:17 lwall Locked $ ''' ''' $Log: perl.man.2,v $ +''' Revision 3.0.1.5 90/03/27 16:15:17 lwall +''' patch16: MSDOS support +''' ''' Revision 3.0.1.4 90/03/12 16:46:02 lwall ''' patch13: documented behavior of @array = /noparens/ ''' @@ -62,6 +65,15 @@ See example in section on Interprocess Communication. Returns the arctangent of X/Y in the range .if t \-\(*p to \(*p. .if n \-PI to PI. +.Ip "binmode(FILEHANDLE)" 8 4 +.Ip "binmode FILEHANDLE" 8 4 +Arranges for the file to be read in \*(L"binary\*(R" mode in operating systems +that distinguish between binary and text files. +Files that are not read in binary mode have CR LF sequences translated +to LF on input and LF translated to CR LF on output. +Binmode has no effect under Unix. +If FILEHANDLE is an expression, the value is taken as the name of +the filehandle. .Ip "bind(SOCKET,NAME)" 8 2 Does the same thing that the bind system call does. Returns true if it succeeded, false otherwise. diff --git a/perl.man.3 b/perl.man.3 index 35a9c02270..e748679844 100644 --- a/perl.man.3 +++ b/perl.man.3 @@ -1,7 +1,10 @@ ''' Beginning of part 3 -''' $Header: perl.man.3,v 3.0.1.5 90/03/12 16:52:21 lwall Locked $ +''' $Header: perl_man.3,v 3.0.1.6 90/03/27 16:17:56 lwall Locked $ ''' ''' $Log: perl.man.3,v $ +''' Revision 3.0.1.6 90/03/27 16:17:56 lwall +''' patch16: MSDOS support +''' ''' Revision 3.0.1.5 90/03/12 16:52:21 lwall ''' patch13: documented that print $filehandle &foo is ambiguous ''' patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST) @@ -235,7 +238,7 @@ Returns true if successful. DIRHANDLEs have their own namespace separate from FILEHANDLEs. .Ip "ord(EXPR)" 8 4 .Ip "ord EXPR" 8 -Returns the ascii value of the first character of EXPR. +Returns the numeric ascii value of the first character of EXPR. If EXPR is omitted, uses $_. .Ip "pack(TEMPLATE,LIST)" 8 4 Takes an array or list of values and packs it into a binary structure, diff --git a/perl.man.4 b/perl.man.4 index 4269559b90..77a8a00597 100644 --- a/perl.man.4 +++ b/perl.man.4 @@ -1,7 +1,10 @@ ''' Beginning of part 4 -''' $Header: perl.man.4,v 3.0.1.7 90/03/14 12:29:50 lwall Locked $ +''' $Header: perl_man.4,v 3.0.1.8 90/03/27 16:19:31 lwall Locked $ ''' ''' $Log: perl.man.4,v $ +''' Revision 3.0.1.8 90/03/27 16:19:31 lwall +''' patch16: MSDOS support +''' ''' Revision 3.0.1.7 90/03/14 12:29:50 lwall ''' patch15: man page falsely states that you can't subscript array values ''' @@ -504,7 +507,7 @@ Here is a sample client (untested): ($name, $aliases, $proto) = getprotobyname('tcp'); ($name, $aliases, $port) = getservbyname($port, 'tcp') - unless $port =~ /^\ed+$/;; + unless $port =~ /^\ed+$/; .ie t \{\ ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($hostname); 'br\} @@ -549,7 +552,7 @@ And here's a server: ($name, $aliases, $proto) = getprotobyname('tcp'); ($name, $aliases, $port) = getservbyname($port, 'tcp') - unless $port =~ /^\ed+$/;; + unless $port =~ /^\ed+$/; $this = pack($sockaddr, &AF_INET, $port, "\e0\e0\e0\e0"); @@ -1318,6 +1321,8 @@ before doing anything else, just to keep people honest: .fi .SH AUTHOR Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov> +.br +MS-DOS port by Diomidis Spinellis <dds@cc.ic.ac.uk> .SH FILES /tmp/perl\-eXXXXXX temporary file for .B \-e @@ -1,4 +1,4 @@ -/* $Header: perl.y,v 3.0.1.5 90/03/12 16:55:56 lwall Locked $ +/* $Header: perl.y,v 3.0.1.6 90/03/27 16:13:45 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.y,v $ + * Revision 3.0.1.6 90/03/27 16:13:45 lwall + * patch16: formats didn't work inside eval + * * Revision 3.0.1.5 90/03/12 16:55:56 lwall * patch13: added list slice operator (LIST)[LIST] * patch13: (LIST,) now legal @@ -67,7 +70,6 @@ ARG *arg5; %token <arg> RSTRING TRANS %type <ival> prog decl format remember -%type <stabval> %type <cmdval> block lineseq line loop cond sideff nexpr else %type <arg> expr sexpr cexpr csexpr term handle aryword hshword %type <arg> texpr listop @@ -307,14 +309,14 @@ decl : format format : FORMAT WORD '=' FORMLIST { if (strEQ($2,"stdout")) - stab_form(stabent("STDOUT",TRUE)) = $4; + make_form(stabent("STDOUT",TRUE),$4); else if (strEQ($2,"stderr")) - stab_form(stabent("STDERR",TRUE)) = $4; + make_form(stabent("STDERR",TRUE),$4); else - stab_form(stabent($2,TRUE)) = $4; + make_form(stabent($2,TRUE),$4); Safefree($2);} | FORMAT '=' FORMLIST - { stab_form(stabent("STDOUT",TRUE)) = $3; } + { make_form(stabent("STDOUT",TRUE),$3); } ; subrout : SUB WORD block @@ -1,4 +1,4 @@ -char rcsid[] = "$Header: perly.c,v 3.0.1.4 90/02/28 18:06:41 lwall Locked $\nPatch level: ###\n"; +char rcsid[] = "$Header: perly.c,v 3.0.1.5 90/03/27 16:20:57 lwall Locked $\nPatch level: ###\n"; /* * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ char rcsid[] = "$Header: perly.c,v 3.0.1.4 90/02/28 18:06:41 lwall Locked $\nPat * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perly.c,v $ + * Revision 3.0.1.5 90/03/27 16:20:57 lwall + * patch16: MSDOS support + * patch16: do FILE inside eval blows up + * * Revision 3.0.1.4 90/02/28 18:06:41 lwall * patch9: perl can now start up other interpreters scripts * patch9: nested evals clobbered their longjmp environment @@ -71,6 +75,15 @@ setuid perl scripts securely.\n"); euid = (int)geteuid(); gid = (int)getgid(); egid = (int)getegid(); +#ifdef MSDOS + /* + * There is no way we can refer to them from Perl so close them to save + * space. The other alternative would be to provide STDAUX and STDPRN + * filehandles. + */ + (void)fclose(stdaux); + (void)fclose(stdprn); +#endif if (do_undump) { do_undump = 0; loop_ptr = -1; /* start label stack again */ @@ -195,7 +208,12 @@ setuid perl scripts securely.\n"); goto reswitch; case 'v': fputs(rcsid,stdout); - fputs("\nCopyright (c) 1989, Larry Wall\n\n\ + fputs("\nCopyright (c) 1989, 1990, Larry Wall\n",stdout); +#ifdef MSDOS + fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", + stdout); +#endif + fputs("\n\ Perl may be copied only under the terms of the GNU General Public License,\n\ a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); exit(0); @@ -748,7 +766,7 @@ int *arglast; str_cat(linestr,";"); /* be kind to them */ } else { - if (last_root) { + if (last_root && !in_eval) { Safefree(last_eval); cmd_free(last_root); last_root = Nullcmd; @@ -1,4 +1,4 @@ -/* $Header: stab.c,v 3.0.1.5 90/03/12 17:00:11 lwall Locked $ +/* $Header: stab.c,v 3.0.1.6 90/03/27 16:22:11 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,9 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: stab.c,v $ + * Revision 3.0.1.6 90/03/27 16:22:11 lwall + * patch16: support for machines that can't cast negative floats to unsigned ints + * * Revision 3.0.1.5 90/03/12 17:00:11 lwall * patch13: undef $/ didn't work as advertised * @@ -342,7 +345,7 @@ STR *str; arybase = (int)str_gnum(str); break; case '?': - statusvalue = (unsigned short)str_gnum(str); + statusvalue = U_S(str_gnum(str)); break; case '!': errno = (int)str_gnum(str); /* will anyone ever use this? */ @@ -1,4 +1,4 @@ -/* $Header: str.c,v 3.0.1.6 90/03/12 17:02:14 lwall Locked $ +/* $Header: str.c,v 3.0.1.7 90/03/27 16:24:11 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,10 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: str.c,v $ + * Revision 3.0.1.7 90/03/27 16:24:11 lwall + * patch16: strings with prefix chopped off sometimes freed wrong + * patch16: taint check blows up on undefined array element + * * Revision 3.0.1.6 90/03/12 17:02:14 lwall * patch13: substr as lvalue didn't invalidate old numeric value * @@ -122,9 +126,13 @@ str_numset(str,num) register STR *str; double num; { + if (str->str_pok) { + str->str_pok = 0; /* invalidate pointer */ + if (str->str_state == SS_INCR) + str_grow(str,0); + } str->str_u.str_nval = num; str->str_state = SS_NORM; - str->str_pok = 0; /* invalidate pointer */ str->str_nok = 1; /* validate number */ #ifdef TAINT str->str_tainted = tainted; @@ -197,6 +205,8 @@ register STR *str; { if (!str) return 0.0; + if (str->str_state == SS_INCR) + str_grow(str,0); /* just force copy down */ str->str_state = SS_NORM; if (str->str_len && str->str_pok) str->str_u.str_nval = atof(str->str_ptr); @@ -220,7 +230,8 @@ STR *dstr; register STR *sstr; { #ifdef TAINT - tainted |= sstr->str_tainted; + if (sstr) + tainted |= sstr->str_tainted; #endif if (sstr == dstr) return; @@ -245,6 +256,9 @@ register STR *sstr; else if (sstr->str_nok) str_numset(dstr,sstr->str_u.str_nval); else { + if (dstr->str_state == SS_INCR) + str_grow(dstr,0); /* just force copy down */ + #ifdef STRUCTCOPY dstr->str_u = sstr->str_u; #else @@ -260,7 +274,8 @@ register char *ptr; register int len; { STR_GROW(str, len + 1); - (void)bcopy(ptr,str->str_ptr,len); + if (ptr) + (void)bcopy(ptr,str->str_ptr,len); str->str_cur = len; *(str->str_ptr+str->str_cur) = '\0'; str->str_nok = 0; /* invalidate number */ @@ -1,13 +1,13 @@ #!./perl -# $Header: op.dbm,v 3.0 89/10/18 15:28:31 lwall Locked $ +# $Header: op.dbm,v 3.0.1.1 90/03/27 16:25:57 lwall Locked $ if (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') { print "1..0\n"; exit; } -print "1..9\n"; +print "1..10\n"; unlink 'Op.dbmx.dir', 'Op.dbmx.pag'; umask(0); @@ -92,4 +92,8 @@ print ($ok ? "ok 8\n" : "not ok 8\n"); $blksize,$blocks) = stat('Op.dbmx.pag'); print ($size > 0 ? "ok 9\n" : "not ok 9\n"); +@h{0..200} = 200..400; +@foo = @h{0..200}; +print join(':',200..400) eq join(':',@foo) ? "ok 10\n" : "no ok 10\n"; + unlink 'Op.dbmx.dir', 'Op.dbmx.pag'; diff --git a/t/op.range b/t/op.range index 4975c44441..d581b433cf 100644 --- a/t/op.range +++ b/t/op.range @@ -1,8 +1,8 @@ #!./perl -# $Header: op.range,v 3.0 89/10/18 15:30:53 lwall Locked $ +# $Header: op.range,v 3.0.1.1 90/03/27 16:27:58 lwall Locked $ -print "1..6\n"; +print "1..8\n"; print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; @@ -28,3 +28,9 @@ for ((100,2..99,1)) { $x += $_; } print $x == 5050 ? "ok 6\n" : "not ok 6 $x\n"; + +$x = join('','a'..'z'); +print $x eq 'abcdefghijklmnopqrstuvwxyz' ? "ok 7\n" : "not ok 7 $x\n"; + +@x = 'A'..'ZZ'; +print @x == 27 * 26 ? "ok 8\n" : "not ok 8\n"; diff --git a/t/op.subst b/t/op.subst index a3d45ea506..97ca2f8293 100644 --- a/t/op.subst +++ b/t/op.subst @@ -1,6 +1,6 @@ #!./perl -# $Header: op.subst,v 3.0.1.1 90/02/28 18:37:30 lwall Locked $ +# $Header: op.s,v 3.0.1.1 90/02/28 18:37:30 lwall Locked $ print "1..42\n"; diff --git a/t/op.write b/t/op.write index e1da85cc04..ef806da5b1 100644 --- a/t/op.write +++ b/t/op.write @@ -1,8 +1,8 @@ #!./perl -# $Header: op.write,v 3.0 89/10/18 15:32:16 lwall Locked $ +# $Header: op.write,v 3.0.1.1 90/03/27 16:29:00 lwall Locked $ -print "1..2\n"; +print "1..3\n"; format OUT = the quick brown @<< @@ -85,3 +85,45 @@ if (`cat Op.write.tmp` eq $right) else { print "not ok 2\n"; } +eval <<'EOFORMAT'; +format OUT2 = +the brown quick @<< +$fox +jumped +@* +$multiline +^<<<<<<<<< ~~ +$foo +now @<<the@>>>> for all@|||||men to come @<<<< +'i' . 's', "time\n", $good, 'to' +. +EOFORMAT + +open(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp"; + +$fox = 'foxiness'; +$good = 'good'; +$multiline = "forescore\nand\nseven years\n"; +$foo = 'when in the course of human events it becomes necessary'; +write(OUT2); +close OUT2; + +$right = +"the brown quick fox +jumped +forescore +and +seven years +when in +the course +of human +events it +becomes +necessary +now is the time for all good men to come to\n"; + +if (`cat Op.write.tmp` eq $right) + { print "ok 3\n"; unlink 'Op.write.tmp'; } +else + { print "not ok 3\n"; } + @@ -1,4 +1,4 @@ -/* $Header: toke.c,v 3.0.1.6 90/03/12 17:06:36 lwall Locked $ +/* $Header: toke.c,v 3.0.1.7 90/03/27 16:32:37 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,11 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: toke.c,v $ + * Revision 3.0.1.7 90/03/27 16:32:37 lwall + * patch16: MSDOS support + * patch16: formats didn't work inside eval + * patch16: final semicolon in program wasn't optional with -p or -n + * * Revision 3.0.1.6 90/03/12 17:06:36 lwall * patch13: last semicolon of program is now optional, just for Randal * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST) @@ -197,6 +202,7 @@ yylex() } } if (in_format) { + bufptr = bufend; yylval.formval = load_format(); in_format = FALSE; oldoldbufptr = oldbufptr = s = str_get(linestr) + 1; @@ -211,8 +217,8 @@ yylex() (void)fclose(rsfp); rsfp = Nullfp; if (minus_n || minus_p) { - str_set(linestr,minus_p ? "}continue{print;" : ""); - str_cat(linestr,"}"); + str_set(linestr,minus_p ? ";}continue{print" : ""); + str_cat(linestr,";}"); oldoldbufptr = oldbufptr = s = str_get(linestr); bufend = linestr->str_ptr + linestr->str_cur; minus_n = minus_p = 0; @@ -302,10 +308,16 @@ yylex() d = bufend; while (s < d && *s != '\n') s++; - if (s < d) { + if (s < d) s++; - line++; + if (in_format) { + bufptr = s; + yylval.formval = load_format(); + in_format = FALSE; + oldoldbufptr = oldbufptr = s = bufptr + 1; + TERM(FORMLIST); } + line++; } else { *s = '\0'; @@ -556,6 +568,8 @@ yylex() SNARFWORD; if (strEQ(d,"bind")) FOP2(O_BIND); + if (strEQ(d,"binmode")) + FOP(O_BINMODE); break; case 'c': case 'C': SNARFWORD; @@ -2074,6 +2088,7 @@ load_format() { FCMD froot; FCMD *flinebeg; + char *eol; register FCMD *fprev = &froot; register FCMD *fcmd; register char *s; @@ -2083,7 +2098,8 @@ load_format() bool repeater; Zero(&froot, 1, FCMD); - while ((s = str_gets(linestr,rsfp, 0)) != Nullch) { + s = bufptr; + while (s < bufend || (s = str_gets(linestr,rsfp, 0)) != Nullch) { line++; if (perldb) { STR *tmpstr = Str_new(89,0); @@ -2091,21 +2107,29 @@ load_format() str_sset(tmpstr,linestr); astore(lineary,(int)line,tmpstr); } - bufend = linestr->str_ptr + linestr->str_cur; - if (strEQ(s,".\n")) { + if (in_eval && !rsfp) { + eol = index(s,'\n'); + if (!eol++) + eol = bufend; + } + else + eol = bufend = linestr->str_ptr + linestr->str_cur; + if (strnEQ(s,".\n",2)) { bufptr = s; return froot.f_next; } - if (*s == '#') + if (*s == '#') { + s = eol; continue; + } flinebeg = Nullfcmd; noblank = FALSE; repeater = FALSE; - while (s < bufend) { + while (s < eol) { Newz(804,fcmd,1,FCMD); fprev->f_next = fcmd; fprev = fcmd; - for (t=s; t < bufend && *t != '@' && *t != '^'; t++) { + for (t=s; t < eol && *t != '@' && *t != '^'; t++) { if (*t == '~') { noblank = TRUE; *t = ' '; @@ -2118,7 +2142,7 @@ load_format() fcmd->f_pre = nsavestr(s, t-s); fcmd->f_presize = t-s; s = t; - if (s >= bufend) { + if (s >= eol) { if (noblank) fcmd->f_flags |= FC_NOBLANK; if (repeater) @@ -2162,7 +2186,7 @@ load_format() } if (flinebeg) { again: - if ((s = str_gets(linestr, rsfp, 0)) == Nullch) + if (s >= bufend && (s = str_gets(linestr, rsfp, 0)) == Nullch) goto badform; line++; if (perldb) { @@ -2171,55 +2195,67 @@ load_format() str_sset(tmpstr,linestr); astore(lineary,(int)line,tmpstr); } - if (strEQ(s,".\n")) { + if (in_eval && !rsfp) { + eol = index(s,'\n'); + if (!eol++) + eol = bufend; + } + else + eol = bufend = linestr->str_ptr + linestr->str_cur; + if (strnEQ(s,".\n",2)) { bufptr = s; yyerror("Missing values line"); return froot.f_next; } - if (*s == '#') + if (*s == '#') { + s = eol; goto again; - bufend = linestr->str_ptr + linestr->str_cur; - str = flinebeg->f_unparsed = Str_new(91,bufend - bufptr); + } + str = flinebeg->f_unparsed = Str_new(91,eol - s); str->str_u.str_hash = curstash; str_nset(str,"(",1); flinebeg->f_line = line; - if (!flinebeg->f_next->f_type || index(linestr->str_ptr, ',')) { - str_scat(str,linestr); + eol[-1] = '\0'; + if (!flinebeg->f_next->f_type || index(s, ',')) { + eol[-1] = '\n'; + str_ncat(str, s, eol - s - 1); str_ncat(str,",$$);",5); + s = eol; } else { - while (s < bufend && isspace(*s)) + eol[-1] = '\n'; + while (s < eol && isspace(*s)) s++; t = s; - while (s < bufend) { + while (s < eol) { switch (*s) { case ' ': case '\t': case '\n': case ';': str_ncat(str, t, s - t); str_ncat(str, "," ,1); - while (s < bufend && (isspace(*s) || *s == ';')) + while (s < eol && (isspace(*s) || *s == ';')) s++; t = s; break; case '$': str_ncat(str, t, s - t); t = s; - s = scanreg(s,bufend,tokenbuf); + s = scanreg(s,eol,tokenbuf); str_ncat(str, t, s - t); t = s; - if (s < bufend && *s && index("$'\"",*s)) + if (s < eol && *s && index("$'\"",*s)) str_ncat(str, ",", 1); break; case '"': case '\'': str_ncat(str, t, s - t); t = s; s++; - while (s < bufend && (*s != *t || s[-1] == '\\')) + while (s < eol && (*s != *t || s[-1] == '\\')) s++; - if (s < bufend) + if (s < eol) s++; str_ncat(str, t, s - t); t = s; - if (s < bufend && *s && index("$'\"",*s)) + if (s < eol && *s && index("$'\"",*s)) str_ncat(str, ",", 1); break; default: @@ -1,4 +1,4 @@ -/* $Header: util.c,v 3.0.1.4 90/03/01 10:26:48 lwall Locked $ +/* $Header: util.c,v 3.0.1.5 90/03/27 16:35:13 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,11 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: util.c,v $ + * Revision 3.0.1.5 90/03/27 16:35:13 lwall + * patch16: MSDOS support + * patch16: support for machines that can't cast negative floats to unsigned ints + * patch16: tail anchored pattern could dump if string to search was shorter + * * Revision 3.0.1.4 90/03/01 10:26:48 lwall * patch9: fbminstr() called instr() rather than ninstr() * patch9: nested evals clobbered their longjmp environment @@ -492,6 +497,8 @@ STR *littlestr; littlelen = littlestr->str_cur; #ifndef lint if (littlestr->str_pok & SP_TAIL && !multiline) { /* tail anchored? */ + if (littlelen > bigend - big) + return Nullch; little = (unsigned char*)littlestr->str_ptr; if (littlestr->str_pok & SP_CASEFOLD) { /* oops, fake it */ big = bigend - littlelen; /* just start near end */ @@ -1116,6 +1123,7 @@ register long l; #endif /* BYTEORDER != 0x4321 */ #endif /* HTONS */ +#ifndef MSDOS FILE * mypopen(cmd,mode) char *cmd; @@ -1175,6 +1183,7 @@ char *mode; forkprocess = pid; return fdopen(p[this], mode); } +#endif /* !MSDOS */ #ifdef NOTDEF dumpfds(s) @@ -1209,6 +1218,7 @@ int newfd; } #endif +#ifndef MSDOS int mypclose(ptr) FILE *ptr; @@ -1250,6 +1260,7 @@ FILE *ptr; str_numset(str,0.0); return(status); } +#endif /* !MSDOS */ pidgone(pid,status) int pid; @@ -1311,3 +1322,17 @@ register int count; from = frombase; } } + +#ifndef CASTNEGFLOAT +unsigned long +castulong(f) +double f; +{ + long along; + + if (f >= 0.0) + return (unsigned long)f; + along = (long)f; + return (unsigned long)along; +} +#endif |