See patch #29.
--- /dev/null
+#!/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;
+}
--- /dev/null
+#!/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;
+}
--- /dev/null
+#!/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;
+}
* 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
}
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),
break;
case A_WANTARRAY:
{
- if (wantarray == G_ARRAY)
+ if (curcsv->wantarray == G_ARRAY)
st[++sp] = &str_yes;
else
st[++sp] = &str_no;
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
-/* $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
*
* 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
*
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);
-/* $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
*
* 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
*
#define F_RIGHT 2
#define F_CENTER 3
#define F_LINES 4
+#define F_DECIMAL 5
struct formcmd {
struct formcmd *f_next;
char *f_pre;
short f_presize;
short f_size;
+ short f_decimals;
char f_type;
char f_flags;
};
#define FC_NOBLANK 2
#define FC_MORE 4
#define FC_REPEAT 8
+#define FC_DP 16
#define Nullfcmd Null(FCMD*)
}
}
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";
-/* $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
*
* 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
*
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;
#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
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;
{
hdelete(tb,key,klen)
register HASH *tb;
char *key;
-int klen;
+unsigned int klen;
{
register char *s;
register int i;
}
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);
}
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");
}
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;
}
hdbmstore(tb,key,klen,str)
register HASH *tb;
char *key;
-int klen;
+unsigned int klen;
register STR *str;
{
datum dkey, dcontent;
-/* $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
*
* 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
*
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;
-/* $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
*
*/
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 {
--- /dev/null
+#
+# 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
--- /dev/null
+/* 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 */
--- /dev/null
+/* $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");
+}
--- /dev/null
+DOSMAKEPIPE
+DOSCWAIT
+DOSKILLPROCESS
+DOSFLAGPROCESS
+DOSSETPRTY
+DOSGETPRTY
--- /dev/null
+(-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
--- /dev/null
+NAME PERL WINDOWCOMPAT NEWFILES
+DESCRIPTION 'PERL 3.0, patchlevel 28 - for MS-DOS and OS/2'
-#define PATCHLEVEL 31
+#define PATCHLEVEL 32
-/* $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
*
* 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
*/
#define BINARY /**/
+#define I_FCNTL
+
#else /* !MSDOS */
/*
#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? */
# 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();
typedef struct regexp REGEXP;
typedef struct stabptrs STBP;
typedef struct stab STAB;
+typedef struct callsave CSV;
#include "handy.h"
#include "regexp.h"
#define NTOHS
#endif
#ifndef HTONL
-#if (BYTEORDER != 0x4321) && (BYTEORDER != 0x87654321)
+#if (BYTEORDER & 0xffff) != 0x4321
#define HTONS
#define HTONL
#define NTOHS
#define ntohl my_ntohl
#endif
#else
-#if (BYTEORDER == 0x4321) || (BYTEORDER == 0x87654321)
+#if (BYTEORDER & 0xffff) == 0x4321
#undef HTONS
#undef HTONL
#undef NTOHS
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;
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 */
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];
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;
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;
double atof();
long time();
+EXT long basetime INIT(0);
struct tm *gmtime(), *localtime();
char *mktemp();
char *index(), *rindex();
-/* $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
*
* 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
*
%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
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;
}
;
| '(' ')'
{ $$ = 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); }
{ $$ = 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 ')'
| 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,
#!./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.';
$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";
--- /dev/null
+#!./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";
+
#!./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";
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;
#!./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';
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");
}
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 {
https://perl5.git.perl.org / perl5.git / commitdiff