diff options
| -rw-r--r-- | eg/sysvipc/ipcmsg | 47 | ||||
| -rw-r--r-- | eg/sysvipc/ipcsem | 46 | ||||
| -rw-r--r-- | eg/sysvipc/ipcshm | 50 | ||||
| -rw-r--r-- | evalargs.xc | 12 | ||||
| -rw-r--r-- | form.c | 30 | ||||
| -rw-r--r-- | form.h | 8 | ||||
| -rw-r--r-- | h2ph.SH | 3 | ||||
| -rw-r--r-- | hash.c | 87 | ||||
| -rw-r--r-- | hash.h | 6 | ||||
| -rw-r--r-- | malloc.c | 7 | ||||
| -rw-r--r-- | os2/makefile | 125 | ||||
| -rw-r--r-- | os2/mktemp.c | 28 | ||||
| -rw-r--r-- | os2/os2.c | 273 | ||||
| -rw-r--r-- | os2/perl.bad | 6 | ||||
| -rw-r--r-- | os2/perl.cs | 13 | ||||
| -rw-r--r-- | os2/perl.def | 2 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.h | 36 | ||||
| -rw-r--r-- | perl.y | 50 | ||||
| -rw-r--r-- | t/op.index | 20 | ||||
| -rw-r--r-- | t/op.s | 179 | ||||
| -rw-r--r-- | t/op.stat | 4 | ||||
| -rw-r--r-- | t/op.substr | 9 | ||||
| -rw-r--r-- | usub/mus | 2 |
24 files changed, 974 insertions, 71 deletions
diff --git a/eg/sysvipc/ipcmsg b/eg/sysvipc/ipcmsg new file mode 100644 index 0000000000..317e027ea7 --- /dev/null +++ b/eg/sysvipc/ipcmsg @@ -0,0 +1,47 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if 0; + +require 'sys/ipc.ph'; +require 'sys/msg.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/; +$send = ($mode eq "s"); + +$id = msgget(0x1234, ($send ? 0 : &IPC_CREAT) | 0644); +die "Can't get message queue: $!\n" unless defined($id); +print "message queue id: $id\n"; + +if ($send) { + while (<STDIN>) { + chop; + unless (msgsnd($id, pack("LA*", $., $_), 0)) { + die "Can't send message: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + unless (msgrcv($id, $_, 512, 0, 0)) { + die "Can't receive message: $!\n"; + } + ($type, $message) = unpack("La*", $_); + printf "[%d] %s\n", $type, $message; + } +} + +&leave; + +sub leave { + if (!$send) { + $x = msgctl($id, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove message queue: $!\n"; + } + } + exit; +} diff --git a/eg/sysvipc/ipcsem b/eg/sysvipc/ipcsem new file mode 100644 index 0000000000..d72a2dd77c --- /dev/null +++ b/eg/sysvipc/ipcsem @@ -0,0 +1,46 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if 0; + +require 'sys/ipc.ph'; +require 'sys/msg.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/; +$signal = ($mode eq "s"); + +$id = semget(0x1234, 1, ($signal ? 0 : &IPC_CREAT) | 0644); +die "Can't get semaphore: $!\n" unless defined($id); +print "semaphore id: $id\n"; + +if ($signal) { + while (<STDIN>) { + print "Signalling\n"; + unless (semop($id, 0, pack("sss", 0, 1, 0))) { + die "Can't signal semaphore: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + unless (semop($id, 0, pack("sss", 0, -1, 0))) { + die "Can't wait for semaphore: $!\n"; + } + print "Unblocked\n"; + } +} + +&leave; + +sub leave { + if (!$signal) { + $x = semctl($id, 0, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove semaphore: $!\n"; + } + } + exit; +} diff --git a/eg/sysvipc/ipcshm b/eg/sysvipc/ipcshm new file mode 100644 index 0000000000..70588ff865 --- /dev/null +++ b/eg/sysvipc/ipcshm @@ -0,0 +1,50 @@ +#!/usr/bin/perl +eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + if 0; + +require 'sys/ipc.ph'; +require 'sys/shm.ph'; + +$| = 1; + +$mode = shift; +die "usage: ipcshm {r|s}\n" unless $mode =~ /^[rs]$/; +$send = ($mode eq "s"); + +$SIZE = 32; +$id = shmget(0x1234, $SIZE, ($send ? 0 : &IPC_CREAT) | 0644); +die "Can't get message queue: $!\n" unless defined($id); +print "message queue id: $id\n"; + +if ($send) { + while (<STDIN>) { + chop; + unless (shmwrite($id, pack("La*", length($_), $_), 0, $SIZE)) { + die "Can't write to shared memory: $!\n"; + } + } +} +else { + $SIG{'INT'} = $SIG{'QUIT'} = "leave"; + for (;;) { + $_ = <STDIN>; + unless (shmread($id, $_, 0, $SIZE)) { + die "Can't read shared memory: $!\n"; + } + $len = unpack("L", $_); + $message = substr($_, length(pack("L",0)), $len); + printf "[%d] %s\n", $len, $message; + } +} + +&leave; + +sub leave { + if (!$send) { + $x = shmctl($id, &IPC_RMID, 0); + if (!defined($x) || $x < 0) { + die "Can't remove shared memory: $!\n"; + } + } + exit; +} diff --git a/evalargs.xc b/evalargs.xc index 5d4458dde4..09e1a509c7 100644 --- a/evalargs.xc +++ b/evalargs.xc @@ -2,9 +2,13 @@ * kit sizes from getting too big. */ -/* $Header: evalargs.xc,v 3.0.1.6 90/08/09 03:37:15 lwall Locked $ +/* $Header: evalargs.xc,v 3.0.1.7 90/10/15 16:48:11 lwall Locked $ * * $Log: evalargs.xc,v $ + * Revision 3.0.1.7 90/10/15 16:48:11 lwall + * patch29: non-existent array values no longer cause core dumps + * patch29: added caller + * * Revision 3.0.1.6 90/08/09 03:37:15 lwall * patch19: passing *name to subroutine now forces filehandle and array creation * patch19: `command` in array context now returns array of lines @@ -92,8 +96,6 @@ } st[++sp] = afetch(stab_array(argptr.arg_stab), arg[argtype].arg_len - arybase, FALSE); - if (!st[sp]) - st[sp] = &str_undef; #ifdef DEBUGGING if (debug & 8) { (void)sprintf(buf,"ARYSTAB $%s[%d]",stab_name(argptr.arg_stab), @@ -263,7 +265,7 @@ break; case A_WANTARRAY: { - if (wantarray == G_ARRAY) + if (curcsv->wantarray == G_ARRAY) st[++sp] = &str_yes; else st[++sp] = &str_no; @@ -323,7 +325,7 @@ st = stack->ary_array; tmpstr = Str_new(55,0); #ifdef MSDOS - str_set(tmpstr, "glob "); + str_set(tmpstr, "perlglob "); str_scat(tmpstr,str); str_cat(tmpstr," |"); #else @@ -1,4 +1,4 @@ -/* $Header: form.c,v 3.0.1.2 90/08/09 03:38:40 lwall Locked $ +/* $Header: form.c,v 3.0.1.3 90/10/15 17:26:24 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: form.c,v $ + * Revision 3.0.1.3 90/10/15 17:26:24 lwall + * patch29: added @###.## fields to format + * * Revision 3.0.1.2 90/08/09 03:38:40 lwall * patch19: did preliminary work toward debugging packages and evals * @@ -281,6 +284,31 @@ int sp; d += size; linebeg = fcmd->f_next; break; + case F_DECIMAL: { + double value; + + (void)eval(fcmd->f_expr,G_SCALAR,sp); + str = stack->ary_array[sp+1]; + /* If the field is marked with ^ and the value is undefined, + blank it out. */ + if ((fcmd->f_flags & FC_CHOP) && !str->str_pok && !str->str_nok) { + while (size) { + size--; + *d++ = ' '; + } + break; + } + value = str_gnum(str); + size = fcmd->f_size; + CHKLEN(size); + if (fcmd->f_flags & FC_DP) { + sprintf(d, "%#*.*f", size, fcmd->f_decimals, value); + } else { + sprintf(d, "%*.0f", size, value); + } + d += size; + break; + } } } CHKLEN(1); @@ -1,4 +1,4 @@ -/* $Header: form.h,v 3.0 89/10/18 15:17:39 lwall Locked $ +/* $Header: form.h,v 3.0.1.1 90/10/15 17:26:57 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: form.h,v $ + * Revision 3.0.1.1 90/10/15 17:26:57 lwall + * patch29: added @###.## fields to format + * * Revision 3.0 89/10/18 15:17:39 lwall * 3.0 baseline * @@ -16,6 +19,7 @@ #define F_RIGHT 2 #define F_CENTER 3 #define F_LINES 4 +#define F_DECIMAL 5 struct formcmd { struct formcmd *f_next; @@ -25,6 +29,7 @@ struct formcmd { char *f_pre; short f_presize; short f_size; + short f_decimals; char f_type; char f_flags; }; @@ -33,6 +38,7 @@ struct formcmd { #define FC_NOBLANK 2 #define FC_MORE 4 #define FC_REPEAT 8 +#define FC_DP 16 #define Nullfcmd Null(FCMD*) @@ -102,7 +102,8 @@ foreach $file (@ARGV) { } } elsif (/^include <(.*)>/) { - print OUT $t,"do '$1' || die \"Can't include $1: \$!\";\n"; + ($incl = $1) =~ s/\.h$/.ph/; + print OUT $t,"require '$incl';\n"; } elsif (/^ifdef\s+(\w+)/) { print OUT $t,"if (defined &$1) {\n"; @@ -1,4 +1,4 @@ -/* $Header: hash.c,v 3.0.1.5 90/08/13 22:18:27 lwall Locked $ +/* $Header: hash.c,v 3.0.1.6 90/10/15 17:32:52 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,12 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: hash.c,v $ + * Revision 3.0.1.6 90/10/15 17:32:52 lwall + * patch29: non-existent array values no longer cause core dumps + * patch29: %foo = () will now clear dbm files + * patch29: dbm files couldn't be opened read only + * patch29: the cache array for dbm files wasn't correctly created on fetches + * * Revision 3.0.1.5 90/08/13 22:18:27 lwall * patch28: defined(@array) and defined(%array) didn't work right * @@ -39,11 +45,13 @@ static char coeff[] = { 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1, 61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1}; +static void hfreeentries(); + STR * hfetch(tb,key,klen,lval) register HASH *tb; char *key; -int klen; +unsigned int klen; int lval; { register char *s; @@ -57,12 +65,12 @@ int lval; #endif if (!tb) - return Nullstr; + return &str_undef; if (!tb->tbl_array) { if (lval) Newz(503,tb->tbl_array, tb->tbl_max + 1, HENT*); else - return Nullstr; + return &str_undef; } /* The hash function we use on symbols has to be equal to the first @@ -114,14 +122,14 @@ int lval; hstore(tb,key,klen,str,hash); return str; } - return Nullstr; + return &str_undef; } bool hstore(tb,key,klen,val,hash) register HASH *tb; char *key; -int klen; +unsigned int klen; STR *val; register int hash; { @@ -209,7 +217,7 @@ STR * hdelete(tb,key,klen) register HASH *tb; char *key; -int klen; +unsigned int klen; { register char *s; register int i; @@ -357,41 +365,70 @@ register HENT *hent; } void -hclear(tb) +hclear(tb,dodbm) +register HASH *tb; +int dodbm; +{ + if (!tb) + return; + hfreeentries(tb,dodbm); + tb->tbl_fill = 0; +#ifndef lint + if (tb->tbl_array) + (void)bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*)); +#endif +} + +static void +hfreeentries(tb,dodbm) register HASH *tb; +int dodbm; { register HENT *hent; register HENT *ohent = Null(HENT*); +#ifdef SOME_DBM + datum dkey; + datum nextdkey; +#ifdef NDBM + DBM *old_dbm; +#else + int old_dbm; +#endif +#endif if (!tb || !tb->tbl_array) return; +#ifdef SOME_DBM + if ((old_dbm = tb->tbl_dbm) && dodbm) { + while (dkey = dbm_firstkey(tb->tbl_dbm), dkey.dptr) { + do { + nextdkey = dbm_nextkey(tb->tbl_dbm, dkey); + dbm_delete(tb->tbl_dbm,dkey); + dkey = nextdkey; + } while (dkey.dptr); /* one way or another, this works */ + } + } + tb->tbl_dbm = 0; /* now clear just cache */ +#endif (void)hiterinit(tb); while (hent = hiternext(tb)) { /* concise but not very efficient */ hentfree(ohent); ohent = hent; } hentfree(ohent); - tb->tbl_fill = 0; -#ifndef lint - (void)bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*)); +#ifdef SOME_DBM + tb->tbl_dbm = old_dbm; #endif } void -hfree(tb) +hfree(tb,dodbm) register HASH *tb; +int dodbm; { - register HENT *hent; - register HENT *ohent = Null(HENT*); - if (!tb) return; - (void)hiterinit(tb); - while (hent = hiternext(tb)) { - hentfree(ohent); - ohent = hent; - } - hentfree(ohent); + hfreeentries(tb,dodbm); Safefree(tb->tbl_array); Safefree(tb); } @@ -532,12 +569,14 @@ int mode; hdbmclose(tb); tb->tbl_dbm = 0; } - hclear(tb); + hclear(tb, FALSE); /* clear cache */ #ifdef NDBM if (mode >= 0) tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode); if (!tb->tbl_dbm) tb->tbl_dbm = dbm_open(fname, O_RDWR, mode); + if (!tb->tbl_dbm) + tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode); #else if (dbmrefcnt++) fatal("Old dbm can only open one database"); @@ -551,6 +590,8 @@ int mode; } tb->tbl_dbm = dbminit(fname) >= 0; #endif + if (!tb->tbl_array && tb->tbl_dbm != 0) + Newz(507,tb->tbl_array, tb->tbl_max + 1, HENT*); return tb->tbl_dbm != 0; } @@ -574,7 +615,7 @@ bool hdbmstore(tb,key,klen,str) register HASH *tb; char *key; -int klen; +unsigned int klen; register STR *str; { datum dkey, dcontent; @@ -1,4 +1,4 @@ -/* $Header: hash.h,v 3.0.1.1 90/08/09 03:51:34 lwall Locked $ +/* $Header: hash.h,v 3.0.1.2 90/10/15 17:33:58 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: hash.h,v $ + * Revision 3.0.1.2 90/10/15 17:33:58 lwall + * patch29: the debugger now understands packages and evals + * * Revision 3.0.1.1 90/08/09 03:51:34 lwall * patch19: various MSDOS and OS/2 patches folded in * @@ -38,6 +41,7 @@ struct htbl { int tbl_riter; /* current root of iterator */ HENT *tbl_eiter; /* current entry of iterator */ SPAT *tbl_spatroot; /* list of spats for this package */ + char *tbl_name; /* name, if a symbol table */ #ifdef SOME_DBM #ifdef NDBM DBM *tbl_dbm; @@ -1,6 +1,9 @@ -/* $Header: malloc.c,v 3.0.1.2 89/11/11 04:36:37 lwall Locked $ +/* $Header: malloc.c,v 3.0.1.3 90/10/16 15:27:47 lwall Locked $ * * $Log: malloc.c,v $ + * Revision 3.0.1.3 90/10/16 15:27:47 lwall + * patch29: various portability fixes + * * Revision 3.0.1.2 89/11/11 04:36:37 lwall * patch2: malloc pointer corruption check made more portable * @@ -53,7 +56,7 @@ static findbucket(), morecore(); */ union overhead { union overhead *ov_next; /* when free */ -#if defined (mips) || defined (sparc) +#if defined(mips) || defined(sparc) || defined(luna88k) double strut; /* alignment problems */ #endif struct { diff --git a/os2/makefile b/os2/makefile new file mode 100644 index 0000000000..9d5fac42b0 --- /dev/null +++ b/os2/makefile @@ -0,0 +1,125 @@ +# +# Makefile for compiling Perl under OS/2 +# +# Needs a Unix compatible make. +# This makefile works for an initial compilation. It does not +# include all dependencies and thus is unsuitable for serious +# development work. Hey, I'm just inheriting what Diomidis gave me. +# +# Originally by Diomidis Spinellis, March 1990 +# Adjusted for OS/2 port by Raymond Chen, June 1990 +# + +# Source files +SRC = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c \ +eval.c form.c hash.c perl.y perly.c regcomp.c regexec.c \ +stab.c str.c toke.c util.c os2.c popen.c director.c suffix.c mktemp.c + +# Object files +OBJ = perl.obj array.obj cmd.obj cons.obj consarg.obj doarg.obj doio.obj \ +dolist.obj dump.obj eval.obj form.obj hash.obj perly.obj regcomp.obj \ +regexec.obj stab.obj str.obj toke.obj util.obj os2.obj popen.obj \ +director.obj suffix.obj mktemp.obj + +# Files in the OS/2 distribution +DOSFILES=config.h director.c dir.h makefile os2.c popen.c suffix.c \ +mktemp.c readme.os2 + +# Yacc flags +YFLAGS=-d + +# Manual pages +MAN=perlman.1 perlman.2 perlman.3 perlman.4 + +CC=cl +# CBASE = flags everybody gets +# CPLAIN = flags for modules that give the compiler indigestion +# CFLAGS = flags for milder modules +# PERL = which version of perl to build +# +# For preliminary building: No optimization, DEBUGGING set, symbols included. +#CBASE=-AL -Zi -G2 -Gs -DDEBUGGING +#CPLAIN=$(CBASE) -Od +#CFLAGS=$(CBASE) -Od +#PERL=perlsym.exe + +# For the final build: Optimization on, symbols stripped. +CBASE=-AL -Zi -G2 -Gs -DDEBUGGING +CPLAIN=$(CBASE) -Olt +CFLAGS=$(CBASE) -Oeglt +PERL=perl.exe + +# Destination directory for executables +DESTDIR=\usr\bin + +# Deliverables +# +all: $(PERL) glob.exe + +perl.exe: $(OBJ) perl.arp + link @perl.arp,perl,nul,/stack:32767 /NOE; + exehdr /nologo /newfiles /pmtype:windowcompat perl.exe >nul + +perlsym.exe: $(OBJ) perl.arp + link @perl.arp,perlsym,nul,/stack:32767 /NOE /CODE; + exehdr /nologo /newfiles /pmtype:windowcompat perlsym.exe >nul + +perl.arp: + echo array+cmd+cons+consarg+doarg+doio+dolist+dump+ >perl.arp + echo eval+form+hash+perl+perly+regcomp+regexec+stab+suffix+ >>perl.arp + echo str+toke+util+os2+popen+director+\c600\lib\setargv >>perl.arp + +glob.exe: glob.c + $(CC) glob.c setargv.obj -link /NOE + exehdr /nologo /newfiles /pmtype:windowcompat glob.exe >nul + +array.obj: array.c + $(CC) $(CPLAIN) -c array.c +cmd.obj: cmd.c +cons.obj: cons.c perly.h +consarg.obj: consarg.c +# $(CC) $(CPLAIN) -c consarg.c +doarg.obj: doarg.c +doio.obj: doio.c +dolist.obj: dolist.c +dump.obj: dump.c +eval.obj: eval.c evalargs.xc + $(CC) /B2c2l /B3c3l $(CFLAGS) -c eval.c +form.obj: form.c +hash.obj: hash.c +perl.obj: perl.y +perly.obj: perly.c +regcomp.obj: regcomp.c +regexec.obj: regexec.c +stab.obj: stab.c + $(CC) $(CPLAIN) -c stab.c +str.obj: str.c +suffix.obj: suffix.c +toke.obj: toke.c + $(CC) /B3c3l $(CFLAGS) -c toke.c +util.obj: util.c +# $(CC) $(CPLAIN) -c util.c +perly.h: ytab.h + cp ytab.h perly.h +director.obj: director.c +popen.obj: popen.c +os2.obj: os2.c + +perl.1: $(MAN) + nroff -man $(MAN) >perl.1 + +install: all + exepack perl.exe $(DESTDIR)\perl.exe + exepack glob.exe $(DESTDIR)\glob.exe + +clean: + rm -f *.obj *.exe perl.1 perly.h perl.arp + +tags: + ctags *.c *.h *.xc + +dosperl: + mv $(DOSFILES) ../perl30.new + +doskit: + mv $(DOSFILES) ../os2 diff --git a/os2/mktemp.c b/os2/mktemp.c new file mode 100644 index 0000000000..e70507aaee --- /dev/null +++ b/os2/mktemp.c @@ -0,0 +1,28 @@ +/* MKTEMP.C using TMP environment variable */ + +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <io.h> + +void Mktemp(char *file) +{ + char fname[32], *tmp; + + tmp = getenv("TMP"); + + if ( tmp != NULL ) + { + strcpy(fname, file); + strcpy(file, tmp); + + if ( file[strlen(file) - 1] != '\\' ) + strcat(file, "\\"); + + strcat(file, fname); + } + + mktemp(file); +} + +/* End of MKTEMP.C */ diff --git a/os2/os2.c b/os2/os2.c new file mode 100644 index 0000000000..279a88f88b --- /dev/null +++ b/os2/os2.c @@ -0,0 +1,273 @@ +/* $Header: os2.c,v 3.0.1.1 90/10/15 17:49:55 lwall Locked $ + * + * (C) Copyright 1989, 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: os2.c,v $ + * Revision 3.0.1.1 90/10/15 17:49:55 lwall + * patch29: Initial revision + * + * Revision 3.0.1.1 90/03/27 16:10:41 lwall + * patch16: MSDOS support + * + * Revision 1.1 90/03/18 20:32:01 dds + * Initial revision + * + */ + +#define INCL_DOS +#define INCL_NOPM +#include <os2.h> + +/* + * Various Unix compatibility functions for OS/2 + */ + +#include <stdio.h> +#include <errno.h> +#include <process.h> + +#include "EXTERN.h" +#include "perl.h" + + +/* dummies */ + +int ioctl(int handle, unsigned int function, char *data) +{ return -1; } + +int userinit() +{ return -1; } + +int syscall() +{ return -1; } + + +/* extendd chdir() */ + +int chdir(char *path) +{ + if ( path[0] != 0 && path[1] == ':' ) + DosSelectDisk(tolower(path[0]) - '@'); + + DosChDir(path, 0L); +} + + +/* priorities */ + +int setpriority(int class, int pid, int val) +{ + int flag = 0; + + if ( pid < 0 ) + { + flag++; + pid = -pid; + } + + return DosSetPrty(flag ? PRTYS_PROCESSTREE : PRTYS_PROCESS, class, val, pid); +} + +int getpriority(int which /* ignored */, int pid) +{ + USHORT val; + + if ( DosGetPrty(PRTYS_PROCESS, &val, pid) ) + return -1; + else + return val; +} + + +/* get parent process id */ + +int getppid(void) +{ + PIDINFO pi; + + DosGetPID(&pi); + return pi.pidParent; +} + + +/* kill */ + +int kill(int pid, int sig) +{ + int flag = 0; + + if ( pid < 0 ) + { + flag++; + pid = -pid; + } + + switch ( sig & 3 ) + { + + case 0: + DosKillProcess(flag ? DKP_PROCESSTREE : DKP_PROCESS, pid); + break; + + case 1: /* FLAG A */ + DosFlagProcess(pid, flag ? FLGP_SUBTREE : FLGP_PID, PFLG_A, 0); + break; + + case 2: /* FLAG B */ + DosFlagProcess(pid, flag ? FLGP_SUBTREE : FLGP_PID, PFLG_B, 0); + break; + + case 3: /* FLAG C */ + DosFlagProcess(pid, flag ? FLGP_SUBTREE : FLGP_PID, PFLG_C, 0); + break; + + } +} + + +/* Sleep function. */ +void +sleep(unsigned len) +{ + DosSleep(len * 1000L); +} + +/* Just pretend that everyone is a superuser */ + +int setuid() +{ return 0; } + +int setgid() +{ return 0; } + +int getuid(void) +{ return 0; } + +int geteuid(void) +{ return 0; } + +int getgid(void) +{ return 0; } + +int getegid(void) +{ return 0; } + +/* + * The following code is based on the do_exec and do_aexec functions + * in file doio.c + */ +int +do_aspawn(really,arglast) +STR *really; +int *arglast; +{ + register STR **st = stack->ary_array; + register int sp = arglast[1]; + register int items = arglast[2] - sp; + register char **a; + char **argv; + char *tmps; + int status; + + if (items) { + New(1101,argv, items+1, char*); + a = argv; + for (st += ++sp; items > 0; items--,st++) { + if (*st) + *a++ = str_get(*st); + else + *a++ = ""; + } + *a = Nullch; + if (really && *(tmps = str_get(really))) + status = spawnvp(P_WAIT,tmps,argv); + else + status = spawnvp(P_WAIT,argv[0],argv); + Safefree(argv); + } + return status; +} + +char *getenv(char *name); + +int +do_spawn(cmd) +char *cmd; +{ + register char **a; + register char *s; + char **argv; + char flags[10]; + int status; + char *shell, *cmd2; + + /* save an extra exec if possible */ + if ((shell = getenv("COMSPEC")) == 0) + shell = "C:\\OS2\\CMD.EXE"; + + /* see if there are shell metacharacters in it */ + if (strchr(cmd, '>') || strchr(cmd, '<') || strchr(cmd, '|') + || strchr(cmd, '&') || strchr(cmd, '^')) + doshell: + return spawnl(P_WAIT,shell,shell,"/C",cmd,(char*)0); + + New(1102,argv, strlen(cmd) / 2 + 2, char*); + + New(1103,cmd2, strlen(cmd) + 1, char); + strcpy(cmd2, cmd); + a = argv; + for (s = cmd2; *s;) { + while (*s && isspace(*s)) s++; + if (*s) + *(a++) = s; + while (*s && !isspace(*s)) s++; + if (*s) + *s++ = '\0'; + } + *a = Nullch; + if (argv[0]) + if ((status = spawnvp(P_WAIT,argv[0],argv)) == -1) { + Safefree(argv); + Safefree(cmd2); + goto doshell; + } + Safefree(cmd2); + Safefree(argv); + return status; +} + +usage(char *myname) +{ +#ifdef MSDOS + printf("\nUsage: %s [-acdnpsSvw] [-Dnumber] [-i[extension]] [-Idirectory]" +#else + printf("\nUsage: %s [-acdnpPsSuUvw] [-Dnumber] [-i[extension]] [-Idirectory]" +#endif + "\n [-e \"command\"] [-x[directory]] [filename] [arguments]\n", myname); + + printf("\n -a autosplit mode with -n or -p" + "\n -c syntaxcheck only" + "\n -d run scripts under debugger" + "\n -n assume 'while (<>) { ...script... }' loop arround your script" + "\n -p assume loop like -n but print line also like sed" +#ifndef MSDOS + "\n -P run script through C preprocessor befor compilation" +#endif + "\n -s enable some switch parsing for switches after script name" + "\n -S look for the script using PATH environment variable"); +#ifndef MSDOS + printf("\n -u dump core after compiling the script" + "\n -U allow unsafe operations"); +#endif + printf("\n -v print version number and patchlevel of perl" + "\n -w turn warnings on for compilation of your script\n" + "\n -Dnumber set debugging flags" + "\n -i[extension] edit <> files in place (make backup if extension supplied)" + "\n -Idirectory specify include directory in conjunction with -P" + "\n -e command one line of script, multiple -e options are allowed" + "\n [filename] can be ommitted, when -e is used" + "\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n"); +} diff --git a/os2/perl.bad b/os2/perl.bad new file mode 100644 index 0000000000..bec21328fc --- /dev/null +++ b/os2/perl.bad @@ -0,0 +1,6 @@ +DOSMAKEPIPE +DOSCWAIT +DOSKILLPROCESS +DOSFLAGPROCESS +DOSSETPRTY +DOSGETPRTY diff --git a/os2/perl.cs b/os2/perl.cs new file mode 100644 index 0000000000..530f0930df --- /dev/null +++ b/os2/perl.cs @@ -0,0 +1,13 @@ +(-W1 -Od -Olt -DDEBUGGING -Gt2048 +array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c form.c +hash.c perl.c perly.c regcomp.c regexec.c stab.c str.c util.c +) +(-W1 -Od -Olt -B2C2L -B3C3L -DDEBUGGING eval.c{evalargs.xc} toke.c) +(-W1 -Od -Olt os2.c popen.c mktemp.c director.c suffix.c) + +setargv.obj +perl.def +perl.bad +perl.exe + +-AL -LB -S0x9000 diff --git a/os2/perl.def b/os2/perl.def new file mode 100644 index 0000000000..2b49370937 --- /dev/null +++ b/os2/perl.def @@ -0,0 +1,2 @@ +NAME PERL WINDOWCOMPAT NEWFILES +DESCRIPTION 'PERL 3.0, patchlevel 28 - for MS-DOS and OS/2' diff --git a/patchlevel.h b/patchlevel.h index dd91c28f63..1d54f19971 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 31 +#define PATCHLEVEL 32 @@ -1,4 +1,4 @@ -/* $Header: perl.h,v 3.0.1.8 90/08/09 04:10:53 lwall Locked $ +/* $Header: perl.h,v 3.0.1.9 90/10/15 17:59: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: perl.h,v $ + * Revision 3.0.1.9 90/10/15 17:59:41 lwall + * patch29: some machines didn't like unsigned C preprocessor values + * * Revision 3.0.1.8 90/08/09 04:10:53 lwall * patch19: various MSDOS and OS/2 patches folded in * patch19: did preliminary work toward debugging packages and evals @@ -76,6 +79,8 @@ */ #define BINARY /**/ +#define I_FCNTL + #else /* !MSDOS */ /* @@ -156,7 +161,9 @@ extern int memcmp(); #include <stdio.h> #include <ctype.h> #include <setjmp.h> +#ifndef MSDOS #include <sys/param.h> /* if this needs types.h we're still wrong */ +#endif #ifndef _TYPES_ /* If types.h defines this it's easy. */ #ifndef major /* Does everyone's types.h define this? */ @@ -184,16 +191,20 @@ extern int memcmp(); # endif #endif +#ifndef MSDOS #include <sys/times.h> +#endif #if defined(STRERROR) && (!defined(MKDIR) || !defined(RMDIR)) #undef STRERROR #endif #include <errno.h> +#ifndef MSDOS #ifndef errno extern int errno; /* ANSI allows errno to be an lvalue expr */ #endif +#endif #ifdef STRERROR char *strerror(); @@ -288,6 +299,7 @@ typedef struct htbl HASH; typedef struct regexp REGEXP; typedef struct stabptrs STBP; typedef struct stab STAB; +typedef struct callsave CSV; #include "handy.h" #include "regexp.h" @@ -396,7 +408,7 @@ EXT STR *Str; #define NTOHS #endif #ifndef HTONL -#if (BYTEORDER != 0x4321) && (BYTEORDER != 0x87654321) +#if (BYTEORDER & 0xffff) != 0x4321 #define HTONS #define HTONL #define NTOHS @@ -408,7 +420,7 @@ EXT STR *Str; #define ntohl my_ntohl #endif #else -#if (BYTEORDER == 0x4321) || (BYTEORDER == 0x87654321) +#if (BYTEORDER & 0xffff) == 0x4321 #undef HTONS #undef HTONL #undef NTOHS @@ -525,9 +537,9 @@ EXT STR *subname INIT(Nullstr); EXT int arybase INIT(0); struct outrec { - line_t o_lines; - char *o_str; - int o_len; + long o_lines; + char *o_str; + int o_len; }; EXT struct outrec outrec; @@ -547,6 +559,7 @@ EXT STAB *leftstab INIT(Nullstab); EXT STAB *amperstab INIT(Nullstab); EXT STAB *rightstab INIT(Nullstab); EXT STAB *DBstab INIT(Nullstab); +EXT STAB *DBline INIT(Nullstab); EXT STAB *DBsub INIT(Nullstab); EXT HASH *defstash; /* main symbol table */ @@ -558,12 +571,12 @@ EXT STR *curstname; /* name of current package */ EXT STR *freestrroot INIT(Nullstr); EXT STR *lastretstr INIT(Nullstr); EXT STR *DBsingle INIT(Nullstr); +EXT STR *DBtrace INIT(Nullstr); +EXT STR *DBsignal INIT(Nullstr); EXT int lastspbase; EXT int lastsize; -EXT char *curpack; -EXT char *filename; EXT char *origfilename; EXT FILE * VOLATILE rsfp; EXT char buf[1024]; @@ -637,7 +650,9 @@ EXT struct stat statbuf; EXT struct stat statcache; STAB *statstab INIT(Nullstab); STR *statname; +#ifndef MSDOS EXT struct tms timesbuf; +#endif EXT int uid; EXT int euid; EXT int gid; @@ -692,8 +707,10 @@ EXT ARRAY * VOLATILE savestack; /* to save non-local values on */ EXT ARRAY *tosave; /* strings to save on recursive subroutine */ EXT ARRAY *lineary; /* lines of script for debugger */ +EXT ARRAY *dbargs; /* args to call listed by caller function */ -EXT ARRAY *pidstatary; /* keep pids and statuses by fd for mypopen */ +EXT ARRAY *fdpid; /* keep fd-to-pid mappings for mypopen */ +EXT HASH *pidstatus; /* keep pid-to-status mappings for waitpid */ EXT int *di; /* for tmp use in debuggers */ EXT char *dc; @@ -701,6 +718,7 @@ EXT short *ds; double atof(); long time(); +EXT long basetime INIT(0); struct tm *gmtime(), *localtime(); char *mktemp(); char *index(), *rindex(); @@ -1,4 +1,4 @@ -/* $Header: perl.y,v 3.0.1.8 90/08/13 22:19:55 lwall Locked $ +/* $Header: perl.y,v 3.0.1.9 90/10/15 18:01:45 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: perl.y,v $ + * Revision 3.0.1.9 90/10/15 18:01:45 lwall + * patch29: added SysV IPC + * patch29: package behavior is now more consistent + * patch29: index and substr now have optional 3rd args + * * Revision 3.0.1.8 90/08/13 22:19:55 lwall * patch28: lowercase unquoted strings caused infinite loop * @@ -71,9 +76,9 @@ ARG *arg5; %token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN %token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST %token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25 -%token <ival> FUNC0 FUNC1 FUNC2 FUNC3 HSHFUN HSHFUN3 +%token <ival> FUNC0 FUNC1 FUNC2 FUNC2x FUNC3 FUNC4 FUNC5 HSHFUN HSHFUN3 %token <ival> FLIST2 SUB FILETEST LOCAL DELETE -%token <ival> RELOP EQOP MULOP ADDOP PACKAGE AMPER LFUNC4 +%token <ival> RELOP EQOP MULOP ADDOP PACKAGE AMPER %token <formval> FORMLIST %token <stabval> REG ARYLEN ARY HSH STAR %token <arg> SUBST PATTERN @@ -346,9 +351,11 @@ package : PACKAGE WORD ';' sprintf(tmpbuf,"'_%s",$2); tmpstab = hadd(stabent(tmpbuf,TRUE)); curstash = stab_xhash(tmpstab); - curpack = stab_name(tmpstab); + if (!curstash->tbl_name) + curstash->tbl_name = savestr($2); curstash->tbl_coeffsize = 0; Safefree($2); + cmdline = NOLINE; } ; @@ -473,8 +480,7 @@ term : '-' term %prec UMINUS | '(' ')' { $$ = make_list(Nullarg); } | DO sexpr %prec FILETEST - { $$ = fixeval( - make_op(O_DOFILE,2,$2,Nullarg,Nullarg) ); + { $$ = make_op(O_DOFILE,2,$2,Nullarg,Nullarg); allstabs = TRUE;} | DO block %prec '(' { $$ = cmd_to_arg($2); } @@ -584,13 +590,9 @@ term : '-' term %prec UMINUS { $$ = make_op($1,1,cval_to_arg($2), Nullarg,Nullarg); } | UNIOP - { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); - if ($1 == O_EVAL || $1 == O_RESET || $1 == O_REQUIRE) - $$ = fixeval($$); } + { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); } | UNIOP sexpr - { $$ = make_op($1,1,$2,Nullarg,Nullarg); - if ($1 == O_EVAL || $1 == O_RESET || $1 == O_REQUIRE) - $$ = fixeval($$); } + { $$ = make_op($1,1,$2,Nullarg,Nullarg); } | SSELECT { $$ = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);} | SSELECT '(' handle ')' @@ -696,21 +698,29 @@ term : '-' term %prec UMINUS | FUNC0 '(' ')' { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); } | FUNC1 '(' ')' - { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); - if ($1 == O_EVAL || $1 == O_RESET || $1 == O_REQUIRE) - $$ = fixeval($$); } + { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); } | FUNC1 '(' expr ')' - { $$ = make_op($1, 1, $3, Nullarg, Nullarg); - if ($1 == O_EVAL || $1 == O_RESET || $1 == O_REQUIRE) - $$ = fixeval($$); } + { $$ = make_op($1, 1, $3, Nullarg, Nullarg); } | FUNC2 '(' sexpr cexpr ')' { $$ = make_op($1, 2, $3, $4, Nullarg); if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE) fbmcompile($$[2].arg_ptr.arg_str,0); } + | FUNC2x '(' sexpr csexpr ')' + { $$ = make_op($1, 2, $3, $4, Nullarg); + if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE) + fbmcompile($$[2].arg_ptr.arg_str,0); } + | FUNC2x '(' sexpr csexpr cexpr ')' + { $$ = make_op($1, 3, $3, $4, $5); + if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE) + fbmcompile($$[2].arg_ptr.arg_str,0); } | FUNC3 '(' sexpr csexpr cexpr ')' { $$ = make_op($1, 3, $3, $4, $5); } - | LFUNC4 '(' sexpr csexpr csexpr cexpr ')' - { arg4 = $6; $$ = make_op($1, 4, l($3), $4, $5); } + | FUNC4 '(' sexpr csexpr csexpr cexpr ')' + { arg4 = $6; + $$ = make_op($1, 4, $3, $4, $5); } + | FUNC5 '(' sexpr csexpr csexpr csexpr cexpr ')' + { arg4 = $6; arg5 = $7; + $$ = make_op($1, 5, $3, $4, $5); } | HSHFUN '(' hshword ')' { $$ = make_op($1, 1, $3, diff --git a/t/op.index b/t/op.index index af227457ef..da822065cd 100644 --- a/t/op.index +++ b/t/op.index @@ -1,8 +1,8 @@ #!./perl -# $Header: op.index,v 3.0 89/10/18 15:29:29 lwall Locked $ +# $Header: op.index,v 3.0.1.1 90/10/16 10:50:28 lwall Locked $ -print "1..6\n"; +print "1..20\n"; $foo = 'Now is the time for all good men to come to the aid of their country.'; @@ -24,3 +24,19 @@ print ($last eq "." ? "ok 5\n" : "not ok 5\n"); $last = substr($foo,rindex($foo,'.'),100); print ($last eq "." ? "ok 6\n" : "not ok 6\n"); + +print index("ababa","a",-1) == 0 ? "ok 7\n" : "not ok 7\n"; +print index("ababa","a",0) == 0 ? "ok 8\n" : "not ok 8\n"; +print index("ababa","a",1) == 2 ? "ok 9\n" : "not ok 9\n"; +print index("ababa","a",2) == 2 ? "ok 10\n" : "not ok 10\n"; +print index("ababa","a",3) == 4 ? "ok 11\n" : "not ok 11\n"; +print index("ababa","a",4) == 4 ? "ok 12\n" : "not ok 12\n"; +print index("ababa","a",5) == -1 ? "ok 13\n" : "not ok 13\n"; + +print rindex("ababa","a",-1) == -1 ? "ok 14\n" : "not ok 14\n"; +print rindex("ababa","a",0) == 0 ? "ok 15\n" : "not ok 15\n"; +print rindex("ababa","a",1) == 0 ? "ok 16\n" : "not ok 16\n"; +print rindex("ababa","a",2) == 2 ? "ok 17\n" : "not ok 17\n"; +print rindex("ababa","a",3) == 2 ? "ok 18\n" : "not ok 18\n"; +print rindex("ababa","a",4) == 4 ? "ok 19\n" : "not ok 19\n"; +print rindex("ababa","a",5) == 4 ? "ok 20\n" : "not ok 20\n"; diff --git a/t/op.s b/t/op.s new file mode 100644 index 0000000000..c5d85611fa --- /dev/null +++ b/t/op.s @@ -0,0 +1,179 @@ +#!./perl + +# $Header: op.s,v 3.0.1.2 90/10/16 10:51:50 lwall Locked $ + +print "1..51\n"; + +$x = 'foo'; +$_ = "x"; +s/x/\$x/; +print "#1\t:$_: eq :\$x:\n"; +if ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";} + +$_ = "x"; +s/x/$x/; +print "#2\t:$_: eq :foo:\n"; +if ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";} + +$_ = "x"; +s/x/\$x $x/; +print "#3\t:$_: eq :\$x foo:\n"; +if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";} + +$b = 'cd'; +($a = 'abcdef') =~ s'(b${b}e)'\n$1'; +print "#4\t:$1: eq :bcde:\n"; +print "#4\t:$a: eq :a\\n\$1f:\n"; +if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";} + +$a = 'abacada'; +if (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx') + {print "ok 5\n";} else {print "not ok 5\n";} + +if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx') + {print "ok 6\n";} else {print "not ok 6 $a\n";} + +if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx') + {print "ok 7\n";} else {print "not ok 7 $a\n";} + +$_ = 'ABACADA'; +if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";} + +$_ = '\\' x 4; +if (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";} +s/\\/\\\\/g; +if ($_ eq '\\' x 8) {print "ok 10\n";} else {print "not ok 10 $_\n";} + +$_ = '\/' x 4; +if (length($_) == 8) {print "ok 11\n";} else {print "not ok 11\n";} +s/\//\/\//g; +if ($_ eq '\\//' x 4) {print "ok 12\n";} else {print "not ok 12\n";} +if (length($_) == 12) {print "ok 13\n";} else {print "not ok 13\n";} + +$_ = 'aaaXXXXbbb'; +s/^a//; +print $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n"; + +$_ = 'aaaXXXXbbb'; +s/a//; +print $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n"; + +$_ = 'aaaXXXXbbb'; +s/^a/b/; +print $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n"; + +$_ = 'aaaXXXXbbb'; +s/a/b/; +print $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n"; + +$_ = 'aaaXXXXbbb'; +s/aa//; +print $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n"; + +$_ = 'aaaXXXXbbb'; +s/aa/b/; +print $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n"; + +$_ = 'aaaXXXXbbb'; +s/b$//; +print $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n"; + +$_ = 'aaaXXXXbbb'; +s/b//; +print $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n"; + +$_ = 'aaaXXXXbbb'; +s/bb//; +print $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n"; + +$_ = 'aaaXXXXbbb'; +s/aX/y/; +print $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n"; + +$_ = 'aaaXXXXbbb'; +s/Xb/z/; +print $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n"; + +$_ = 'aaaXXXXbbb'; +s/aaX.*Xbb//; +print $_ eq 'ab' ? "ok 25\n" : "not ok 25\n"; + +$_ = 'aaaXXXXbbb'; +s/bb/x/; +print $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n"; + +# now for some unoptimized versions of the same. + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/^a//; +print $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/a//; +print $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/^a/b/; +print $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/a/b/; +print $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/aa//; +print $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/aa/b/; +print $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/b$//; +print $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/b//; +print $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/bb//; +print $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/aX/y/; +print $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/Xb/z/; +print $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/aaX.*Xbb//; +print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n"; + +$_ = 'aaaXXXXbbb'; +$x ne $x || s/bb/x/; +print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n"; + +$_ = 'abc123xyz'; +s/\d+/$&*2/e; # yields 'abc246xyz' +print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n"; +s/\d+/sprintf("%5d",$&)/e; # yields 'abc 246xyz' +print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n"; +s/\w/$& x 2/eg; # yields 'aabbcc 224466xxyyzz' +print $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" : "not ok 42\n"; + +$_ = "aaaaa"; +print y/a/b/ == 5 ? "ok 43\n" : "not ok 43\n"; +print y/a/b/ == 0 ? "ok 44\n" : "not ok 44\n"; +print y/b// == 5 ? "ok 45\n" : "not ok 45\n"; +print y/b/c/s == 5 ? "ok 46\n" : "not ok 46\n"; +print y/c// == 1 ? "ok 47\n" : "not ok 47\n"; +print y/c//d == 1 ? "ok 48\n" : "not ok 48\n"; +print $_ eq "" ? "ok 49\n" : "not ok 49\n"; + +$_ = "Now is the %#*! time for all good men..."; +print (($x=(y/a-zA-Z //cd)) == 7 ? "ok 50\n" : "not ok 50\n"); +print y/ / /s == 8 ? "ok 51\n" : "not ok 51\n"; + @@ -1,6 +1,6 @@ #!./perl -# $Header: op.stat,v 3.0.1.4 90/08/13 22:31:36 lwall Locked $ +# $Header: op.stat,v 3.0.1.5 90/10/16 10:55:42 lwall Locked $ print "1..56\n"; @@ -97,7 +97,7 @@ $cnt = $uid = 0; die "Can't run op.stat test 35 without pwd working" unless $cwd; chdir '/usr/bin' || die "Can't cd to /usr/bin"; -while (<*>) { +while (defined($_ = <*>)) { $cnt++; $uid++ if -u; last if $uid && $uid < $cnt; diff --git a/t/op.substr b/t/op.substr index c91c377330..bbe2c046b0 100644 --- a/t/op.substr +++ b/t/op.substr @@ -1,8 +1,8 @@ #!./perl -# $Header: op.substr,v 3.0 89/10/18 15:31:52 lwall Locked $ +# $Header: op.substr,v 3.0.1.1 90/10/16 10:56:35 lwall Locked $ -print "1..19\n"; +print "1..22\n"; $a = 'abcdefxyz'; @@ -40,3 +40,8 @@ print $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n"; substr($a,-1,1) = '12345678'; print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n"; +$a = 'abcdefxyz'; + +print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n"); +print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); +print (substr($a,999) eq '' ? "ok 22\n" : "not ok 22\n"); @@ -103,7 +103,7 @@ EOF } elsif ($rettype =~ /^[A-Z]+\s*\*$/) { print <<EOF; - str_set(st[0], (char*) &retval, sizeof retval); + str_nset(st[0], (char*) &retval, sizeof retval); EOF } else { |