See patch #13.
#! /usr/bin/perl
-# $Header: gsh,v 3.0.1.1 90/02/28 17:14:10 lwall Locked $
+# $Header: gsh,v 3.0.1.2 90/03/12 16:34:11 lwall Locked $
# Do rsh globally--see man page
if ($wanted > 0) {
print "rsh $host$l$n '$cmd'\n" unless $silent;
$SIG{'INT'} = 'DEFAULT';
- if (open(pipe,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh
+ if (open(PIPE,"rsh $host$l$n '$cmd'$dist 2>&1|")) { # start an rsh
$SIG{'INT'} = 'cont';
- for ($iter=0; <pipe>; $iter++) {
+ for ($iter=0; <PIPE>; $iter++) {
unless ($iter) {
$remainder .= "$host+"
if /Connection timed out|Permission denied/;
}
print $showhost,$_;
}
- close(pipe);
+ close(PIPE);
} else {
print "(Can't execute rsh: $!)\n";
$SIG{'INT'} = 'cont';
#!/usr/bin/perl
-# $Header: scanner,v 3.0 89/10/18 15:16:02 lwall Locked $
+# $Header: scanner,v 3.0.1.1 90/03/12 16:35:15 lwall Locked $
# This runs all the scan_* routines on all the machines in /etc/ghosts.
# We run this every morning at about 6 am:
$cmd = '/usr/bin/perl';
}
close(scan);
- if (open(pipe,"exec rsh $host '$cmd' <.x|")) {
+ if (open(PIPE,"exec rsh $host '$cmd' <.x|")) {
sleep(5);
unlink '.x';
- while (<pipe>) {
+ while (<PIPE>) {
last if $iter++ > 1000; # must be looping
next if /^[0-9.]+u [0-9.]+s/;
print $showhost,$_;
}
- close(pipe);
+ close(PIPE);
} else {
print "(Can't execute rsh: $!)\n";
}
-/* $Header: eval.c,v 3.0.1.4 90/02/28 17:36:59 lwall Locked $
+/* $Header: eval.c,v 3.0.1.5 90/03/12 16:37:40 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: eval.c,v $
+ * Revision 3.0.1.5 90/03/12 16:37:40 lwall
+ * patch13: undef $/ didn't work as advertised
+ * patch13: added list slice operator (LIST)[LIST]
+ * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST)
+ *
* Revision 3.0.1.4 90/02/28 17:36:59 lwall
* patch9: added pipe function
* patch9: a return in scalar context wouldn't return array
static STAB *stab2;
static STIO *stio;
static struct lstring *lstr;
-static char old_record_separator;
+static int old_record_separator;
extern int wantarray;
double sin(), cos(), atan2(), pow();
tmps = str_get(tmpstr); /* force to be string */
STR_GROW(str, (anum * str->str_cur) + 1);
repeatcpy(str->str_ptr, tmps, tmpstr->str_cur, anum);
- str->str_cur *= anum; str->str_ptr[str->str_cur] = '\0';
+ str->str_cur *= anum;
+ str->str_ptr[str->str_cur] = '\0';
}
else
str_sset(str,&str_no);
str_magic(str, tmpstab, 'D', tmps, anum);
#endif
break;
+ case O_LSLICE:
+ anum = 2;
+ argtype = FALSE;
+ goto do_slice_already;
case O_ASLICE:
- anum = TRUE;
+ anum = 1;
argtype = FALSE;
goto do_slice_already;
case O_HSLICE:
- anum = FALSE;
+ anum = 0;
argtype = FALSE;
goto do_slice_already;
case O_LASLICE:
- anum = TRUE;
+ anum = 1;
argtype = TRUE;
goto do_slice_already;
case O_LHSLICE:
- anum = FALSE;
+ anum = 0;
argtype = TRUE;
do_slice_already:
- sp = do_slice(arg[1].arg_ptr.arg_stab,anum,argtype,
+ sp = do_slice(arg[1].arg_ptr.arg_stab,str,anum,argtype,
gimme,arglast);
goto array_return;
+ case O_SPLICE:
+ sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),str,gimme,arglast);
+ goto array_return;
case O_PUSH:
if (arglast[2] - arglast[1] != 1)
str = do_push(stab_array(arg[1].arg_ptr.arg_stab),arglast);
package DB;
-$header = '$Header: perldb.pl,v 3.0.1.1 89/10/26 23:14:02 lwall Locked $';
+$header = '$Header: perldb.pl,v 3.0.1.2 90/03/12 16:39:39 lwall Locked $';
#
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
# have a breakpoint. It also inserts a do 'perldb.pl' before the first line.
#
# $Log: perldb.pl,v $
+# Revision 3.0.1.2 90/03/12 16:39:39 lwall
+# patch13: perl -d didn't format stack traces of *foo right
+# patch13: perl -d wiped out scalar return values of subroutines
+#
# Revision 3.0.1.1 89/10/26 23:14:02 lwall
# patch1: RCS expanded an unintended $Header in lib/perldb.pl
#
$single |= 4 if $#stack == $deep;
local(@args) = @_;
for (@args) {
- if (/^Stab/ && length($_) == length($_main{'_main'})) {
+ if (/^StB\000/ && length($_) == length($_main{'_main'})) {
$_ = sprintf("%s",$_);
- print "ARG: $_\n";
}
else {
s/'/\\'/g;
push(@sub, $sub . '(' . join(', ', @args) . ') from ' . $line);
if (wantarray) {
@i = &$sub;
+ --$#sub;
+ $single |= pop(@stack);
+ @i;
}
else {
$i = &$sub;
- @i = $i;
+ --$#sub;
+ $single |= pop(@stack);
+ $i;
}
- --$#sub;
- $single |= pop(@stack);
- @i;
}
$single = 1; # so it stops on first executable statement
-#define PATCHLEVEL 13
+#define PATCHLEVEL 14
-/* $Header: perl.h,v 3.0.1.5 90/02/28 17:52:28 lwall Locked $
+/* $Header: perl.h,v 3.0.1.6 90/03/12 16:40:43 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.6 90/03/12 16:40:43 lwall
+ * patch13: did some ndir straightening up for Xenix
+ *
* Revision 3.0.1.5 90/02/28 17:52:28 lwall
* patch9: Configure now determines whether volatile is supported
* patch9: volatilized some more variables for super-optimizing compilers
#define ntohi ntohl
#endif
-#if defined(I_DIRENT) && !defined(xenix)
+#if defined(I_DIRENT) && !defined(M_XENIX)
# include <dirent.h>
# define DIRENT dirent
#else
-# ifdef I_SYSDIR
-# ifdef hp9000s500
-# include <ndir.h> /* may be wrong in the future */
-# else
-# include <sys/dir.h>
-# endif
+# ifdef I_SYSNDIR
+# include <sys/ndir.h>
# define DIRENT direct
# else
-# ifdef I_SYSNDIR
-# include <sys/ndir.h>
+# ifdef I_SYSDIR
+# ifdef hp9000s500
+# include <ndir.h> /* may be wrong in the future */
+# else
+# include <sys/dir.h>
+# endif
# define DIRENT direct
# endif
# endif
.rn '' }`
-''' $Header: perl.man.1,v 3.0.1.3 90/02/28 17:54:32 lwall Locked $
+''' $Header: perl.man.1,v 3.0.1.4 90/03/12 16:44:33 lwall Locked $
'''
''' $Log: perl.man.1,v $
+''' Revision 3.0.1.4 90/03/12 16:44:33 lwall
+''' patch13: (LIST,) now legal
+''' patch13: improved LIST documentation
+''' patch13: example of if-elsif switch was wrong
+'''
''' Revision 3.0.1.3 90/02/28 17:54:32 lwall
''' patch9: @array in scalar context now returns length of array
''' patch9: in manual, example of open and ?: was backwards
.fi
Array literals are denoted by separating individual values by commas, and
-enclosing the list in parentheses.
+enclosing the list in parentheses:
+.nf
+
+ (LIST)
+
+.fi
In a context not requiring an array value, the value of the array literal
is the value of the final element, as in the C comma operator.
For example,
.fi
assigns the value of variable bar to variable foo.
+Note that the value of an actual array in a scalar context is the length
+of the array; the following assigns to $foo the value 3:
+.nf
+
+.ne 2
+ @foo = (\'cc\', \'\-E\', $bar);
+ $foo = @foo; # $foo gets 3
+
+.fi
+You may have an optional comma before the closing parenthesis of an
+array literal, so that you can say:
+.nf
+
+ @foo = (
+ 1,
+ 2,
+ 3,
+ );
+
+.fi
+When a LIST is evaluated, each element of the list is evaluated in
+an array context, and the resulting array value is interpolated into LIST
+just as if each individual element were a member of LIST. Thus arrays
+lose their identity in a LIST\*(--the list
+
+ (@foo,@bar,&SomeSub)
+
+contains all the elements of @foo followed by all the elements of @bar,
+followed by all the elements returned by the subroutine named SomeSub.
+.PP
+A list value may also be subscripted like a normal array.
+Examples:
+.nf
+
+ $time = (stat($file))[8]; # stat returns array value
+ $digit = ('a','b','c','d','e','f')[$digit-10];
+ return (pop(@foo),pop(@foo))[0];
+
+.fi
+.PP
Array lists may be assigned to if and only if each element of the list
is an lvalue:
.nf
.ne 8
if (/^abc/)
- { $abc = 1; last foo; }
+ { $abc = 1; }
elsif (/^def/)
- { $def = 1; last foo; }
+ { $def = 1; }
elsif (/^xyz/)
- { $xyz = 1; last foo; }
+ { $xyz = 1; }
else
{$nothing = 1;}
''' Beginning of part 2
-''' $Header: perl.man.2,v 3.0.1.3 90/02/28 17:55:58 lwall Locked $
+''' $Header: perl.man.2,v 3.0.1.4 90/03/12 16:46:02 lwall Locked $
'''
''' $Log: perl.man.2,v $
+''' Revision 3.0.1.4 90/03/12 16:46:02 lwall
+''' patch13: documented behavior of @array = /noparens/
+'''
''' Revision 3.0.1.3 90/02/28 17:55:58 lwall
''' patch9: grep now returns number of items matched in scalar context
''' patch9: documented in-place modification capabilites of grep
It does NOT actually set $1, $2, etc. in this case, nor does it set $+, $`, $&
or $'.
If the match fails, a null array is returned.
+If the match succeeds, but there were no parentheses, an array value of (1)
+is returned.
.Sp
Examples:
.nf
''' Beginning of part 3
-''' $Header: perl.man.3,v 3.0.1.4 90/02/28 18:00:09 lwall Locked $
+''' $Header: perl.man.3,v 3.0.1.5 90/03/12 16:52:21 lwall Locked $
'''
''' $Log: perl.man.3,v $
+''' 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)
+'''
''' Revision 3.0.1.4 90/02/28 18:00:09 lwall
''' patch9: added pipe function
''' patch9: documented how to handle arbitrary weird characters in filenames
Returns non-zero if successful.
FILEHANDLE may be a scalar variable name, in which case the variable contains
the name of the filehandle, thus introducing one level of indirection.
+(NOTE: If FILEHANDLE is a variable and the next token is a term, it may be
+misinterpreted as an operator unless you interpose a + or put parens around
+the arguments.)
If FILEHANDLE is omitted, prints by default to standard output (or to the
last selected output channel\*(--see select()).
If LIST is also omitted, prints $_ to
Note that, because print takes a LIST, anything in the LIST is evaluated
in an array context, and any subroutine that you call will have one or more
of its expressions evaluated in an array context.
+Also be careful not to follow the print keyword with a left parenthesis
+unless you want the corresponding right parenthesis to terminate the
+arguments to the print--interpose a + or put parens around all the arguments.
.Ip "printf(FILEHANDLE LIST)" 8 10
.Ip "printf(LIST)" 8
.Ip "printf FILEHANDLE LIST" 8
# prints AbelAxedCainPunishedcatchaseddoggonetoxyz
.fi
+.Ip "splice(ARRAY,OFFSET,LENGTH,LIST)" 8 8
+.Ip "splice(ARRAY,OFFSET,LENGTH)" 8
+.Ip "splice(ARRAY,OFFSET)" 8
+Removes the elements designated by OFFSET and LENGTH from an array, and
+replaces them with the elements of LIST, if any.
+Returns the elements removed from the array.
+The array grows or shrinks as necessary.
+If LENGTH is omitted, removes everything from OFFSET onward.
+The following equivalencies hold (assuming $[ == 0):
+.nf
+
+ push(@a,$x,$y)\h'|3.5i'splice(@a,$#x+1,0,$x,$y)
+ pop(@a)\h'|3.5i'splice(@a,-1)
+ shift(@a)\h'|3.5i'splice(@a,0,1)
+ unshift(@a,$x,$y)\h'|3.5i'splice(@a,0,0,$x,$y)
+ $a[$x] = $y\h'|3.5i'splice(@a,$x,1,$y);
+
+Example, assuming array lengths are passed before arrays:
+
+ sub aeq { # compare two array values
+ local(@a) = splice(@_,0,shift);
+ local(@b) = splice(@_,0,shift);
+ return 0 unless @a == @b; # same len?
+ while (@a) {
+ return 0 if pop(@a) ne pop(@b);
+ }
+ return 1;
+ }
+ if (&aeq($len,@foo[1..$len],0+@bar,@bar)) { ... }
+
+.fi
.Ip "split(/PATTERN/,EXPR,LIMIT)" 8 8
.Ip "split(/PATTERN/,EXPR)" 8 8
.Ip "split(/PATTERN/)" 8
''' Beginning of part 4
-''' $Header: perl.man.4,v 3.0.1.5 90/02/28 18:01:52 lwall Locked $
+''' $Header: perl.man.4,v 3.0.1.6 90/03/12 16:54:04 lwall Locked $
'''
''' $Log: perl.man.4,v $
+''' Revision 3.0.1.6 90/03/12 16:54:04 lwall
+''' patch13: improved documentation of *name
+'''
''' Revision 3.0.1.5 90/02/28 18:01:52 lwall
''' patch9: $0 is now always the command name
'''
In perl you can refer to all the objects of a particular name by prefixing
the name with a star: *foo.
When evaluated, it produces a scalar value that represents all the objects
-of that name.
+of that name, including any filehandle, format or subroutine.
When assigned to within a local() operation, it causes the name mentioned
to refer to whatever * value was assigned to it.
Example:
Since a *name value contains unprintable binary data, if it is used as
an argument in a print, or as a %s argument in a printf or sprintf, it
then has the value '*name', just so it prints out pretty.
+.Sp
+Even if you don't want to modify an array, this mechanism is useful for
+passing multiple arrays in a single LIST, since normally the LIST mechanism
+will merge all the array values so that you can't extract out the
+individual arrays.
.Sh "Regular Expressions"
The patterns used in pattern matching are regular expressions such as
those supplied in the Version 8 regexp routines.
.ne 4
system "echo $foo"; # Insecure
- system "echo", $foo; # Secure (doesn't use sh)
+ system "/bin/echo", $foo; # Secure (doesn't use sh)
system "echo $bar"; # Insecure
system "echo $abc"; # Insecure until PATH set
-/* $Header: perl.y,v 3.0.1.4 90/02/28 18:03:23 lwall Locked $
+/* $Header: perl.y,v 3.0.1.5 90/03/12 16:55:56 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.5 90/03/12 16:55:56 lwall
+ * patch13: added list slice operator (LIST)[LIST]
+ * patch13: (LIST,) now legal
+ *
* Revision 3.0.1.4 90/02/28 18:03:23 lwall
* patch9: line numbers were bogus during certain portions of foreach evaluation
*
{ $$ = l(localize(make_op(O_ASSIGN, 1,
localize(listish(make_list($3))),
Nullarg,Nullarg))); }
+ | '(' expr ',' ')'
+ { $$ = make_list(hide_ary($2)); }
| '(' expr ')'
{ $$ = make_list(hide_ary($2)); }
| '(' ')'
stab2arg(A_STAB,hadd($1)),
jmaybe($3),
Nullarg); }
+ | '(' expr ')' '[' expr ']' %prec '('
+ { $$ = make_op(O_LSLICE, 3,
+ Nullarg,
+ listish(make_list($5)),
+ listish(make_list($2))); }
| ARY '[' expr ']' %prec '('
{ $$ = make_op(O_ASLICE, 2,
stab2arg(A_STAB,aadd($1)),
* blame Henry for some of the lack of readability.
*/
-/* $Header: regcomp.c,v 3.0.1.2 90/02/28 18:08:35 lwall Locked $
+/* $Header: regcomp.c,v 3.0.1.3 90/03/12 16:59:22 lwall Locked $
*
* $Log: regcomp.c,v $
+ * Revision 3.0.1.3 90/03/12 16:59:22 lwall
+ * patch13: pattern matches can now use \0 to mean \000
+ *
* Revision 3.0.1.2 90/02/28 18:08:35 lwall
* patch9: /[\200-\377]/ didn't work on machines with signed chars
*
goto defchar;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
- if (isdigit(regparse[1]))
+ if (isdigit(regparse[1]) || *regparse == '0')
goto defchar;
else {
ret = regnode(REF + *regparse++ - '0');
break;
case '0': case '1': case '2': case '3':case '4':
case '5': case '6': case '7': case '8':case '9':
- if (isdigit(p[1])) {
- foo = *p++ - '0';
- foo <<= 3;
- foo += *p - '0';
+ if (isdigit(p[1]) || *p == '0') {
+ foo = *p - '0';
+ if (isdigit(p[1]))
+ foo = (foo<<3) + *++p - '0';
if (isdigit(p[1]))
foo = (foo<<3) + *++p - '0';
ender = foo;
-/* $Header: stab.c,v 3.0.1.4 90/02/28 18:19:14 lwall Locked $
+/* $Header: stab.c,v 3.0.1.5 90/03/12 17:00: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.5 90/03/12 17:00:11 lwall
+ * patch13: undef $/ didn't work as advertised
+ *
* Revision 3.0.1.4 90/02/28 18:19:14 lwall
* patch9: $0 is now always the command name
* patch9: you may now undef $/ to have no input record separator
multiline = (i != 0);
break;
case '/':
- if (str->str_ptr) {
+ if (str->str_pok) {
record_separator = *str_get(str);
rslen = str->str_cur;
}
-/* $Header: stab.h,v 3.0.1.1 89/12/21 20:19:53 lwall Locked $
+/* $Header: stab.h,v 3.0.1.2 90/03/12 17:00:43 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: stab.h,v $
+ * Revision 3.0.1.2 90/03/12 17:00:43 lwall
+ * patch13: did some ndir straightening up for Xenix
+ *
* Revision 3.0.1.1 89/12/21 20:19:53 lwall
* patch7: in stab.h, added some CRIPPLED_CC support for Microport
*
struct stio {
FILE *ifp; /* ifp and ofp are normally the same */
FILE *ofp; /* but sockets need separate streams */
-#if defined(I_DIRENT) || defined(I_SYSDIR)
+#ifdef READDIR
DIR *dirp; /* for opendir, readdir, etc */
#endif
long lines; /* $. */
-/* $Header: str.c,v 3.0.1.5 90/02/28 18:30:38 lwall Locked $
+/* $Header: str.c,v 3.0.1.6 90/03/12 17:02:14 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.6 90/03/12 17:02:14 lwall
+ * patch13: substr as lvalue didn't invalidate old numeric value
+ *
* Revision 3.0.1.5 90/02/28 18:30:38 lwall
* patch9: you may now undef $/ to have no input record separator
* patch9: nested evals clobbered their longjmp environment
register char *bigend;
register int i;
+ bigstr->str_nok = 0;
+ bigstr->str_pok = SP_VALID; /* disable possible screamer */
+
i = littlelen - len;
if (i > 0) { /* string might grow */
STR_GROW(bigstr, bigstr->str_cur + i + 1);
if (midend > bigend)
fatal("panic: str_insert");
- bigstr->str_pok = SP_VALID; /* disable possible screamer */
-
if (mid - big > bigend - midend) { /* faster to shorten from end */
if (littlelen) {
(void)bcopy(little, mid, littlelen);
#!./perl
-# $Header: op.array,v 3.0 89/10/18 15:26:55 lwall Locked $
+# $Header: op.array,v 3.0.1.1 90/03/12 17:03:03 lwall Locked $
-print "1..30\n";
+print "1..36\n";
@ary = (1,2,3,4,5);
if (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";}
@foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
print join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n";
+
+$foo = join('',('a','b','c','d','e','f')[0..5]);
+print $foo eq 'abcdef' ? "ok 31\n" : "not ok 31\n";
+
+$foo = join('',('a','b','c','d','e','f')[0..1]);
+print $foo eq 'ab' ? "ok 32\n" : "not ok 32\n";
+
+$foo = join('',('a','b','c','d','e','f')[6]);
+print $foo eq '' ? "ok 33\n" : "not ok 33\n";
+
+@foo = ('a','b','c','d','e','f')[0,2,4];
+@bar = ('a','b','c','d','e','f')[1,3,5];
+$foo = join('',(@foo,@bar)[0..5]);
+print $foo eq 'acebdf' ? "ok 34\n" : "not ok 34\n";
+
+$foo = ('a','b','c','d','e','f')[0,2,4];
+print $foo eq 'e' ? "ok 35\n" : "not ok 35\n";
+
+$foo = ('a','b','c','d','e','f')[1];
+print $foo eq 'b' ? "ok 36\n" : "not ok 36\n";
#!./perl
-# $Header: op.mkdir,v 3.0.1.2 90/02/28 18:35:31 lwall Locked $
+# $Header: op.mkdir,v 3.0.1.3 90/03/12 17:03:57 lwall Locked $
print "1..7\n";
`rm -rf blurfl`;
-print (mkdir('blurfl',0666) ? "ok 1\n" : "not ok 1\n");
-print (mkdir('blurfl',0666) ? "not ok 2\n" : "ok 2\n");
+print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n");
+print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n");
print ($! =~ /exists/ ? "ok 3\n" : "not ok 3\n");
print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n");
print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n");
#!./perl
-# $Header: op.push,v 3.0 89/10/18 15:30:48 lwall Locked $
+# $Header: op.push,v 3.0.1.1 90/03/12 17:04:27 lwall Locked $
-print "1..2\n";
+@tests = split(/\n/, <<EOF);
+0 3, 0 1 2, 3 4 5 6 7
+0 0 a b c, , a b c 0 1 2 3 4 5 6 7
+8 0 a b c, , 0 1 2 3 4 5 6 7 a b c
+7 0 6.5, , 0 1 2 3 4 5 6 6.5 7
+1 0 a b c d e f g h i j,, 0 a b c d e f g h i j 1 2 3 4 5 6 7
+0 1 a, 0, a 1 2 3 4 5 6 7
+1 6 x y z, 1 2 3 4 5 6, 0 x y z 7
+0 7 x y z, 0 1 2 3 4 5 6, x y z 7
+1 7 x y z, 1 2 3 4 5 6 7, 0 x y z
+4, 4 5 6 7, 0 1 2 3
+-4, 4 5 6 7, 0 1 2 3
+EOF
+
+print "1..", 2 + @tests, "\n";
+die "blech" unless @tests;
@x = (1,2,3);
push(@x,@x);
if (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
push(x,4);
if (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
+
+$test = 3;
+foreach $line (@tests) {
+ ($list,$get,$leave) = split(/,\t*/,$line);
+ @list = split(' ',$list);
+ @get = split(' ',$get);
+ @leave = split(' ',$leave);
+ @x = (0,1,2,3,4,5,6,7);
+ @got = splice(@x,@list);
+ if (join(':',@got) eq join(':',@get) &&
+ join(':',@x) eq join(':',@leave)) {
+ print "ok ",$test++,"\n";
+ }
+ else {
+ print "not ok ",$test++," got: @got == @get left: @x == @leave\n";
+ }
+}
+
-/* $Header: toke.c,v 3.0.1.5 90/02/28 18:47:06 lwall Locked $
+/* $Header: toke.c,v 3.0.1.6 90/03/12 17:06:36 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.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)
+ *
* Revision 3.0.1.5 90/02/28 18:47:06 lwall
* patch9: return grandfathered to never be function call
* patch9: non-existent perldb.pl now gives reasonable error message
}
oldoldbufptr = oldbufptr = s = str_get(linestr);
str_set(linestr,"");
- RETURN(0);
+ RETURN(';'); /* not infinite loop because rsfp is NULL now */
}
oldoldbufptr = oldbufptr = bufptr = s;
if (perldb) {
TERM(SPLIT);
if (strEQ(d,"sprintf"))
FL(O_SPRINTF);
+ if (strEQ(d,"splice")) {
+ yylval.ival = O_SPLICE;
+ OPERATOR(PUSH);
+ }
break;
case 'q':
if (strEQ(d,"sqrt"))
projects / p5sagit/p5-mst-13.2.git / commitdiff