See patch #16.
-/* $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
*
* 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)
#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[];
"GETPEERNAME",
"LSLICE",
"SPLICE",
- "243"
+ "BINMODE",
+ "244"
};
#endif
A(1,0,0), /* GETPEERNAME */
A(0,3,3), /* LSLICE */
A(0,3,1), /* SPLICE */
+ A(1,0,0), /* BINMODE */
0
};
#undef A
-/* $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
*
* 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
*
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;
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 */
}
--- /dev/null
+#
+# 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;
--- /dev/null
+ 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
--- /dev/null
+@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;
+ }
+}
--- /dev/null
+/* $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;
+}
-#define PATCHLEVEL 17
+#define PATCHLEVEL 18
-/* $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
*
* 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
*
#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
#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
#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();
.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
.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.)
''' 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/
'''
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.
''' 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)
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,
''' 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
'''
($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\}
($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");
.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
-/* $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
*
* 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
%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
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
-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
*
* 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
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 */
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);
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;
-/* $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
*
* 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
*
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? */
-/* $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
*
* 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
*
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;
{
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);
register STR *sstr;
{
#ifdef TAINT
- tainted |= sstr->str_tainted;
+ if (sstr)
+ tainted |= sstr->str_tainted;
#endif
if (sstr == dstr)
return;
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
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 */
#!./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);
$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';
#!./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";
$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";
#!./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";
#!./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 @<<
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"; }
+
-/* $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
*
* 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)
}
}
if (in_format) {
+ bufptr = bufend;
yylval.formval = load_format();
in_format = FALSE;
oldoldbufptr = oldbufptr = s = str_get(linestr) + 1;
(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;
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';
SNARFWORD;
if (strEQ(d,"bind"))
FOP2(O_BIND);
+ if (strEQ(d,"binmode"))
+ FOP(O_BINMODE);
break;
case 'c': case 'C':
SNARFWORD;
{
FCMD froot;
FCMD *flinebeg;
+ char *eol;
register FCMD *fprev = &froot;
register FCMD *fcmd;
register char *s;
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);
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 = ' ';
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)
}
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) {
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:
-/* $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
*
* 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
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 */
#endif /* BYTEORDER != 0x4321 */
#endif /* HTONS */
+#ifndef MSDOS
FILE *
mypopen(cmd,mode)
char *cmd;
forkprocess = pid;
return fdopen(p[this], mode);
}
+#endif /* !MSDOS */
#ifdef NOTDEF
dumpfds(s)
}
#endif
+#ifndef MSDOS
int
mypclose(ptr)
FILE *ptr;
str_numset(str,0.0);
return(status);
}
+#endif /* !MSDOS */
pidgone(pid,status)
int pid;
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
https://perl5.git.perl.org / perl5.git / commitdiff