diff options
| -rw-r--r-- | lib/perldb.pl | 38 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.man.3 | 130 | ||||
| -rw-r--r-- | perl.man.4 | 86 | ||||
| -rw-r--r-- | perly.c | 351 |
5 files changed, 459 insertions, 148 deletions
diff --git a/lib/perldb.pl b/lib/perldb.pl index 84543dfc76..c84b6ac45f 100644 --- a/lib/perldb.pl +++ b/lib/perldb.pl @@ -1,6 +1,6 @@ package DB; -$header = '$Header: perldb.pl,v 3.0.1.2 90/03/12 16:39:39 lwall Locked $'; +$header = '$Header: perldb.pl,v 3.0.1.3 90/08/09 04:00:58 lwall Locked $'; # # This file is automatically included if you do perl -d. # It's probably not useful to include this yourself. @@ -10,6 +10,11 @@ $header = '$Header: perldb.pl,v 3.0.1.2 90/03/12 16:39:39 lwall Locked $'; # have a breakpoint. It also inserts a do 'perldb.pl' before the first line. # # $Log: perldb.pl,v $ +# Revision 3.0.1.3 90/08/09 04:00:58 lwall +# patch19: debugger now allows continuation lines +# patch19: debugger can now dump lists of variables +# patch19: debugger can now add aliases easily from prompt +# # 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 @@ -33,7 +38,7 @@ select(STDOUT); $| = 1; # for real STDOUT $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; -print OUT "\nLoading DB from $header\n\n"; +print OUT "\nLoading custom DB from $header\n\nEnter h for help.\n\n"; sub DB { local($. ,$@, $!, $[, $,, $/, $\); @@ -73,6 +78,11 @@ sub DB { $signal = 0; $cmd eq '' && exit 0; chop($cmd); + $cmd =~ s/\\$// && do { + print OUT " cont: "; + $cmd .= <IN>; + redo; + }; $cmd =~ /^q$/ && exit 0; $cmd =~ /^$/ && ($cmd = $laststep); push(@hist,$cmd) if length($cmd) > 1; @@ -111,7 +121,8 @@ a [line] command Sequence is: check for breakpoint, print line if necessary, do action, prompt user if breakpoint or step, evaluate line. A Delete all actions. -V package List all variables and values in package (default main). +V [pkg [vars]] List some (default all) variables in a package (default main). +X [vars] Same as \"V main [vars]\". < command Define command before prompt. > command Define command after prompt. ! number Redo command (default previous command). @@ -119,6 +130,7 @@ V package List all variables and values in package (default main). H -number Display last number commands (default all). q or ^D Quit. p expr Same as \"package main; print DB'OUT expr\". += [alias value] Define a command alias, or list current aliases. command Execute as a perl statement. "; @@ -137,13 +149,15 @@ command Execute as a perl statement. } } next; }; + $cmd =~ s/^X\b/V main/; $cmd =~ /^V$/ && do { $cmd = 'V main'; }; - $cmd =~ /^V\s*(['A-Za-z_]['\w]*)$/ && do { + $cmd =~ /^V\s*(\S+)\s*(.*)/ && do { $packname = $1; + @vars = split(' ',$2); do 'dumpvar.pl' unless defined &main'dumpvar; if (defined &main'dumpvar) { - &main'dumpvar($packname); + &main'dumpvar($packname,@vars); } else { print DB'OUT "dumpvar.pl not available.\n"; @@ -357,6 +371,20 @@ command Execute as a perl statement. }; next; }; $cmd =~ s/^p( .*)?$/print DB'OUT$1/; + $cmd =~ /^=/ && do { + if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) { + $alias{$k}="s~$k~$v~"; + print OUT "$k = $v\n"; + } elsif ($cmd =~ /^=\s*$/) { + foreach $k (sort keys(%alias)) { + if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) { + print OUT "$k = $v\n"; + } else { + print OUT "$k\t$alias{$k}\n"; + }; + }; + }; + next; }; { package main; eval $DB'cmd; diff --git a/patchlevel.h b/patchlevel.h index 2627e90d71..f198d8a823 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 23 +#define PATCHLEVEL 24 diff --git a/perl.man.3 b/perl.man.3 index e748679844..bfd2b30420 100644 --- a/perl.man.3 +++ b/perl.man.3 @@ -1,7 +1,15 @@ ''' Beginning of part 3 -''' $Header: perl_man.3,v 3.0.1.6 90/03/27 16:17:56 lwall Locked $ +''' $Header: perl_man.3,v 3.0.1.8 90/08/09 04:39:04 lwall Locked $ ''' ''' $Log: perl.man.3,v $ +''' Revision 3.0.1.8 90/08/09 04:39:04 lwall +''' patch19: added require operator +''' patch19: added truncate operator +''' patch19: unpack can do checksumming +''' +''' Revision 3.0.1.7 90/08/03 11:15:42 lwall +''' patch19: Intermediate diffs for Randal +''' ''' Revision 3.0.1.6 90/03/27 16:17:56 lwall ''' patch16: MSDOS support ''' @@ -202,14 +210,14 @@ Typically this is used like the normal piped open when you want to exercise more control over just how the pipe command gets executed, such as when you are running setuid, and don't want to have to scan shell commands for metacharacters. -The following pairs are equivalent: +The following pairs are more or less equivalent: .nf .ne 5 open(FOO, "|tr \'[a\-z]\' \'[A\-Z]\'"); open(FOO, "|\-") || exec \'tr\', \'[a\-z]\', \'[A\-Z]\'; - open(FOO, "cat \-n $file|"); + open(FOO, "cat \-n '$file'|"); open(FOO, "\-|") || exec \'cat\', \'\-n\', $file; .fi @@ -240,6 +248,7 @@ DIRHANDLEs have their own namespace separate from FILEHANDLEs. .Ip "ord EXPR" 8 Returns the numeric ascii value of the first character of EXPR. If EXPR is omitted, uses $_. +''' Comments on f & d by gnb@melba.bby.oz.au 22/11/89 .Ip "pack(TEMPLATE,LIST)" 8 4 Takes an array or list of values and packs it into a binary structure, returning the string containing the structure. @@ -249,7 +258,7 @@ of values, as follows: A An ascii string, will be space padded. a An ascii string, will be null padded. - c A native char value. + c A signed char value. C An unsigned char value. s A signed short value. S An unsigned short value. @@ -259,17 +268,37 @@ of values, as follows: L An unsigned long value. n A short in \*(L"network\*(R" order. N A long in \*(L"network\*(R" order. + f A single-precision float in the native format. + d A double-precision float in the native format. p A pointer to a string. x A null byte. + X Back up a byte. + @ Null fill to absolute position. + u A uuencoded string. .fi Each letter may optionally be followed by a number which gives a repeat count. With all types except "a" and "A" the pack function will gobble up that many values from the LIST. -The "a" and "A" types gobble just one value, but pack it as a string that long, +A * for the repeat count means to use however many items are left. +The "a" and "A" types gobble just one value, but pack it as a string of length +count, padding with nulls or spaces as necessary. (When unpacking, "A" strips trailing spaces and nulls, but "a" does not.) +Real numbers (floats and doubles) are in the nnativeative machine format +only; due to the multiplicity of floating formats around, and the lack +of a standard \*(L"network\*(R" representation, no facility for +interchange has been made. +This means that packed floating point data +written on one machine may not be readable on another - even if both +use IEEE floating point arithmetic (as the endian-ness of the memory +representation is not part of the IEEE spec). +Note that perl uses +doubles internally for all numeric calculation, and converting from +double -> float -> double will loose precision (i.e. unpack("f", +pack("f", $foo)) will not in general equal $foo). +.br Examples: .nf @@ -366,7 +395,7 @@ These are not really functions, but simply syntactic sugar to let you avoid putting too many backslashes into quoted strings. The q operator is a generalized single quote, and the qq operator a generalized double quote. -Any delimiter can be used in place of /, including newline. +Any non-alphanumeric delimiter can be used in place of /, including newline. If the delimiter is an opening bracket or parenthesis, the final delimiter will be the corresponding closing bracket or parenthesis. (Embedded occurrences of the closing bracket need to be backslashed as usual.) @@ -449,6 +478,35 @@ about what was just input: Changes the name of a file. Returns 1 for success, 0 otherwise. Will not work across filesystem boundaries. +.Ip "require(EXPR)" 8 6 +.Ip "require EXPR" 8 +.Ip "require" 8 +Includes the library file specified by EXPR, or by $_ if EXPR is not supplied. +Has semantics similar to the following subroutine: +.nf + + sub require { + local($filename) = @_; + return 1 if $INC{$filename}; + local($realfilename,$result); + ITER: { + foreach $prefix (@INC) { + $realfilename = "$prefix/$filename"; + if (-f $realfilename) { + $result = do $realfilename; + last ITER; + } + } + die "Can't find $filename in \e@INC"; + } + die $@ if $@; + die "$filename did not return true value" unless $result; + $INC{$filename} = $realfilename; + $result; + } + +.fi +Note that the file will not be included twice under the same specified name. .Ip "reset(EXPR)" 8 6 .Ip "reset EXPR" 8 .Ip "reset" 8 @@ -512,7 +570,8 @@ is to be done in a case-insensitive manner. The \*(L"e\*(R" is likewise optional, and if present, indicates that the replacement string is to be evaluated as an expression rather than just as a double-quoted string. -Any delimiter may replace the slashes; if single quotes are used, no +Any non-alphanumeric delimiter may replace the slashes; +if single quotes are used, no interpretation is done on the replacement string (the e modifier overrides this, however); if backquotes are used, the replacement string is a command to execute whose output will be used as the actual replacement text. @@ -632,11 +691,6 @@ Any of the bitmasks can also be undef. The timeout, if specified, is in seconds, which may be fractional. NOTE: not all implementations are capable of returning the $timeleft. If not, they always return $timeleft equal to the supplied $timeout. -.Ip "setpgrp(PID,PGRP)" 8 4 -Sets the current process group for the specified PID, 0 for the current -process. -Will produce a fatal error if used on a machine that doesn't implement -setpgrp(2). .Ip "send(SOCKET,MSG,FLAGS,TO)" 8 4 .Ip "send(SOCKET,MSG,FLAGS)" 8 Sends a message on a socket. @@ -644,6 +698,11 @@ Takes the same flags as the system call of the same name. On unconnected sockets you must specify a destination to send TO. Returns the number of characters sent, or the undefined value if there is an error. +.Ip "setpgrp(PID,PGRP)" 8 4 +Sets the current process group for the specified PID, 0 for the current +process. +Will produce a fatal error if used on a machine that doesn't implement +setpgrp(2). .Ip "setpriority(WHICH,WHO,PRIORITY)" 8 4 Sets the current priority for a process, a process group, or a user. (See setpriority(2).) @@ -778,8 +837,8 @@ If LIMIT is specified, splits into no more than that many fields (though it may split into fewer). If LIMIT is unspecified, trailing null fields are stripped (which potential users of pop() would do well to remember). -A pattern matching the null string (not to be confused with a null pattern, -which is one member of the set of patterns matching a null string) +A pattern matching the null string (not to be confused with a null pattern //, +which is just one member of the set of patterns matching a null string) will split the value of EXPR into separate characters at each point it matches that way. For example: @@ -959,6 +1018,17 @@ If you assign something shorter than LEN, the string will shrink, and if you assign something longer than LEN, the string will grow to accommodate it. To keep the string the same length you may need to pad or chop your value using sprintf(). +.Ip "symlink(OLDFILE,NEWFILE)" 8 2 +Creates a new filename symbolically linked to the old filename. +Returns 1 for success, 0 otherwise. +On systems that don't support symbolic links, produces a fatal error at +run time. +To check for that, use eval: +.nf + + $symlink_exists = (eval \'symlink("","");\', $@ eq \'\'); + +.fi .Ip "syscall(LIST)" 8 6 .Ip "syscall LIST" 8 Calls the system call specified as the first element of the list, passing @@ -974,7 +1044,7 @@ in a numeric context, you may need to add 0 to them to force them to look like numbers. .nf - do 'syscall.h'; # may need to run makelib + require 'syscall.ph'; # may need to run makelib syscall(&SYS_write, fileno(STDOUT), "hi there\en", 9); .fi @@ -988,17 +1058,6 @@ call. To get the actual exit value divide by 256. See also .IR exec . -.Ip "symlink(OLDFILE,NEWFILE)" 8 2 -Creates a new filename symbolically linked to the old filename. -Returns 1 for success, 0 otherwise. -On systems that don't support symbolic links, produces a fatal error at -run time. -To check for that, use eval: -.nf - - $symlink_exists = (eval \'symlink("","");\', $@ eq \'\'); - -.fi .Ip "tell(FILEHANDLE)" 8 6 .Ip "tell FILEHANDLE" 8 6 .Ip "tell" 8 @@ -1049,6 +1108,11 @@ Examples: y/\e001\-@[\-_{\-\e177/ /; \h'|3i'# change non-alphas to space .fi +.Ip "truncate(FILEHANDLE,LENGTH)" 8 4 +.Ip "truncate(EXPR,LENGTH)" 8 +Truncates the file opened on FILEHANDLE, or named by EXPR, to the specified +length. +Produces a fatal error if truncate isn't implemented on your system. .Ip "umask(EXPR)" 8 4 .Ip "umask EXPR" 8 .Ip "umask" 8 @@ -1099,6 +1163,7 @@ Use rmdir instead. Unpack does the reverse of pack: it takes a string representing a structure and expands it out into an array value, returning the array value. +(In a scalar context, it merely returns the first value produced.) The TEMPLATE has the same format as in the pack function. Here's a subroutine that does substring: .nf @@ -1115,6 +1180,19 @@ and then there's sub ord { unpack("c",$_[0]); } .fi +In addition, you may prefix a field with a %<number> to indicate that +you want a <number>-bit checksum of the items instead of the items themselves. +Default is a 16-bit checksum. +For example, the following computes the same number as the System V sum program: +.nf + +.ne 4 + while (<>) { + $checksum += unpack("%16C*", $_); + } + $checksum %= 65536; + +.fi .Ip "unshift(ARRAY,LIST)" 8 4 Does the opposite of a .IR shift . diff --git a/perl.man.4 b/perl.man.4 index 77a8a00597..a1febef438 100644 --- a/perl.man.4 +++ b/perl.man.4 @@ -1,7 +1,14 @@ ''' Beginning of part 4 -''' $Header: perl_man.4,v 3.0.1.8 90/03/27 16:19:31 lwall Locked $ +''' $Header: perl_man.4,v 3.0.1.10 90/08/09 04:47:35 lwall Locked $ ''' ''' $Log: perl.man.4,v $ +''' Revision 3.0.1.10 90/08/09 04:47:35 lwall +''' patch19: added require operator +''' patch19: added numeric interpretation of $] +''' +''' Revision 3.0.1.9 90/08/03 11:15:58 lwall +''' patch19: Intermediate diffs for Randal +''' ''' Revision 3.0.1.8 90/03/27 16:19:31 lwall ''' patch16: MSDOS support ''' @@ -500,7 +507,7 @@ Here is a sample client (untested): $SIG{'INT'} = 'dokill'; sub dokill { kill 9,$child if $child; } - do 'sys/socket.h' || die "Can't do sys/socket.h: $@"; + require 'sys/socket.ph'; $sockaddr = 'S n a4 x8'; chop($hostname = `hostname`); @@ -546,7 +553,7 @@ And here's a server: ($port) = @ARGV; $port = 2345 unless $port; - do 'sys/socket.h' || die "Can't do sys/socket.h: $@"; + require 'sys/socket.ph'; $sockaddr = 'S n a4 x8'; @@ -783,16 +790,21 @@ when subscripting and when evaluating the index() and substr() functions. The string printed out when you say \*(L"perl -v\*(R". It can be used to determine at the beginning of a script whether the perl interpreter executing the script is in the right range of versions. +If used in a numeric context, returns the version + patchlevel / 1000. Example: .nf -.ne 5 +.ne 8 # see if getc is available ($version,$patchlevel) = $] =~ /(\ed+\e.\ed+).*\enPatch level: (\ed+)/; print STDERR "(No filename completion available.)\en" if $version * 1000 + $patchlevel < 2016; +or, used numerically, + + warn "No checksumming!\n" if $] < 3.019; + .fi (Mnemonic: Is this version of perl in the right bracket?) .Ip $; 8 2 @@ -877,6 +889,8 @@ The current set of characters after which a string may be broken to fill continuation fields (starting with ^) in a format. Default is "\ \en-", to break on whitespace or hyphens. (Mnemonic: a \*(L"colon\*(R" in poetry is a part of a line.) +.Ip $ARGV 8 3 +contains the name of the current file when reading from <>. .Ip @ARGV 8 3 The array ARGV contains the command line arguments intended for the script. Note that $#ARGV is the generally number of arguments minus one, since @@ -886,13 +900,21 @@ See $0 for the command name. The array INC contains the list of places to look for .I perl scripts to be -evaluated by the \*(L"do EXPR\*(R" command. +evaluated by the \*(L"do EXPR\*(R" command or the \*(L"require\*(r" command. It initially consists of the arguments to any .B \-I command line switches, followed by the default .I perl -library, probably \*(L"/usr/local/lib/perl\*(R". +library, probably \*(L"/usr/local/lib/perl\*(R", +followed by \*(L".\*(R", to represent the current directory. +.Ip %INC 8 3 +The associative array INC contains entries for each filename that has +been included via \*(L"do\*(R" or \*(L"require\*(R". +The key is the filename you specified, and the value is the location of +the file actually found. +The \*(L"require\*(R" command uses this array to determine whether +a given file has already been included. .Ip $ENV{expr} 8 2 The associative array ENV contains your current environment. Setting a value in ENV changes the environment for child processes. @@ -928,7 +950,7 @@ declaration, you can switch namespaces. The scope of the package declaration is from the declaration itself to the end of the enclosing block (the same scope as the local() operator). Typically it would be the first declaration in a file to be included by -the \*(L"do FILE\*(R" operator. +the \*(L"require\*(R" operator. You can switch into a package in more than one place; it merely influences which symbol table is used by the compiler for the rest of that block. You can refer to variables and filehandles in other packages by prefixing @@ -1099,16 +1121,26 @@ It will halt before the first executable statement and ask you for a command, such as: .Ip "h" 12 4 Prints out a help message. +.Ip "T" 12 4 +Stack trace. .Ip "s" 12 4 Single step. Executes until it reaches the beginning of another statement. +.Ip "n" 12 4 +Next. +Executes over subroutine calls, until it reaches the beginning of the +next statement. +.Ip "f" 12 4 +Finish. +Executes statements until it has finished the current subroutine. .Ip "c" 12 4 Continue. Executes until the next breakpoint is reached. +.Ip "c line" 12 4 +Continue to the specified line. +Inserts a one-time-only breakpoint at the specified line. .Ip "<CR>" 12 4 -Repeat last s or c. -.Ip "n" 12 4 -Single step around subroutine call. +Repeat last n or s. .Ip "l min+incr" 12 4 List incr+1 lines starting at min. If min is omitted, starts where last listing left off. @@ -1118,38 +1150,45 @@ List lines in the indicated range. .Ip "l line" 12 4 List just the indicated line. .Ip "l" 12 4 -List incr+1 more lines after last printed line. +List next window. +.Ip "-" 12 4 +List previous window. +.Ip "w line" 12 4 +List window around line. .Ip "l subname" 12 4 List subroutine. If it's a long subroutine it just lists the beginning. Use \*(L"l\*(R" to list more. +.Ip "/pattern/" 12 4 +Regular expression search forward for pattern; the final / is optional. +.Ip "?pattern?" 12 4 +Regular expression search backward for pattern; the final ? is optional. .Ip "L" 12 4 List lines that have breakpoints or actions. +.Ip "S" 12 4 +Lists the names of all subroutines. .Ip "t" 12 4 Toggle trace mode on or off. -.Ip "b line" 12 4 +.Ip "b line condition" 12 4 Set a breakpoint. -If line is omitted, sets a breakpoint on the current line +If line is omitted, sets a breakpoint on the line that is about to be executed. +If a condition is specified, it is evaluated each time the statement is +reached and a breakpoint is taken only if the condition is true. Breakpoints may only be set on lines that begin an executable statement. -.Ip "b subname" 12 4 +.Ip "b subname condition" 12 4 Set breakpoint at first executable line of subroutine. -.Ip "S" 12 4 -Lists the names of all subroutines. .Ip "d line" 12 4 Delete breakpoint. -If line is omitted, deletes the breakpoint on the current line +If line is omitted, deletes the breakpoint on the line that is about to be executed. .Ip "D" 12 4 Delete all breakpoints. -.Ip "A" 12 4 -Delete all line actions. -.Ip "V package" 12 4 -List all variables in package. -Default is main package. .Ip "a line command" 12 4 Set an action for line. A multi-line command may be entered by backslashing the newlines. +.Ip "A" 12 4 +Delete all line actions. .Ip "< command" 12 4 Set an action to happen before every debugger prompt. A multi-line command may be entered by backslashing the newlines. @@ -1157,6 +1196,9 @@ A multi-line command may be entered by backslashing the newlines. Set an action to happen after the prompt when you've just given a command to return to executing the script. A multi-line command may be entered by backslashing the newlines. +.Ip "V package" 12 4 +List all variables in package. +Default is main package. .Ip "! number" 12 4 Redo a debugging command. If number is omitted, redoes the previous command. @@ -1,4 +1,4 @@ -char rcsid[] = "$Header: perly.c,v 3.0.1.5 90/03/27 16:20:57 lwall Locked $\nPatch level: ###\n"; +char rcsid[] = "$Header: perly.c,v 3.0.1.6 90/08/09 04:55:50 lwall Locked $\nPatch level: ###\n"; /* * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,14 @@ char rcsid[] = "$Header: perly.c,v 3.0.1.5 90/03/27 16:20:57 lwall Locked $\nPat * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perly.c,v $ + * Revision 3.0.1.6 90/08/09 04:55:50 lwall + * patch19: added -x switch to extract script from input trash + * patch19: Added -c switch to do compilation only + * patch19: added numeric interpretation of $] + * patch19: added require operator + * patch19: $0, %ENV, @ARGV were wrong in dumped script + * patch19: . is now explicitly in @INC (and last) + * * Revision 3.0.1.5 90/03/27 16:20:57 lwall * patch16: MSDOS support * patch16: do FILE inside eval blows up @@ -48,6 +56,11 @@ char rcsid[] = "$Header: perly.c,v 3.0.1.5 90/03/27 16:20:57 lwall Locked $\nPat #endif #endif +static char* moreswitches(); +static char* cddir; +extern char **environ; +static bool minus_c; + main(argc,argv,env) register int argc; register char **argv; @@ -85,6 +98,7 @@ setuid perl scripts securely.\n"); (void)fclose(stdprn); #endif if (do_undump) { + origfilename = savestr(argv[0]); do_undump = 0; loop_ptr = -1; /* start label stack again */ goto just_doit; @@ -96,9 +110,9 @@ setuid perl scripts securely.\n"); curstash = defstash = hnew(0); curstname = str_make("main",4); stab_xhash(stabent("_main",TRUE)) = defstash; - incstab = aadd(stabent("INC",TRUE)); + incstab = hadd(aadd(stabent("INC",TRUE))); incstab->str_pok |= SP_MULTI; - for (argc--,argv++; argc; argc--,argv++) { + for (argc--,argv++; argc > 0; argc--,argv++) { if (argv[0][0] != '-' || !argv[0][1]) break; #ifdef DOSUID @@ -111,28 +125,20 @@ setuid perl scripts securely.\n"); reswitch: switch (*s) { case 'a': - minus_a = TRUE; - s++; - goto reswitch; + case 'c': case 'd': -#ifdef TAINT - if (euid != uid || egid != gid) - fatal("No -d allowed in setuid scripts"); -#endif - perldb = TRUE; - s++; - goto reswitch; case 'D': -#ifdef DEBUGGING -#ifdef TAINT - if (euid != uid || egid != gid) - fatal("No -D allowed in setuid scripts"); -#endif - debug = atoi(s+1); -#else - warn("Recompile perl with -DDEBUGGING to use -D switch\n"); -#endif + case 'i': + case 'n': + case 'p': + case 'u': + case 'U': + case 'v': + case 'w': + if (s = moreswitches(s)) + goto reswitch; break; + case 'e': #ifdef TAINT if (euid != uid || egid != gid) @@ -142,15 +148,14 @@ setuid perl scripts securely.\n"); e_tmpname = savestr(TMPPATH); (void)mktemp(e_tmpname); e_fp = fopen(e_tmpname,"w"); + if (!e_fp) + fatal("Cannot open temporary file"); } - if (argv[1]) + if (argv[1]) { fputs(argv[1],e_fp); + argc--,argv++; + } (void)putc('\n', e_fp); - argc--,argv++; - break; - case 'i': - inplace = savestr(s+1); - argvoutstab = stabent("ARGVOUT",TRUE); break; case 'I': #ifdef TAINT @@ -163,21 +168,13 @@ setuid perl scripts securely.\n"); if (*++s) { (void)apush(stab_array(incstab),str_make(s,0)); } - else { + else if (argv[1]) { (void)apush(stab_array(incstab),str_make(argv[1],0)); str_cat(str,argv[1]); argc--,argv++; str_cat(str," "); } break; - case 'n': - minus_n = TRUE; - s++; - goto reswitch; - case 'p': - minus_p = TRUE; - s++; - goto reswitch; case 'P': #ifdef TAINT if (euid != uid || egid != gid) @@ -198,29 +195,12 @@ setuid perl scripts securely.\n"); dosearch = TRUE; s++; goto reswitch; - case 'u': - do_undump = TRUE; - s++; - goto reswitch; - case 'U': - unsafe = TRUE; + case 'x': + doextract = TRUE; s++; - goto reswitch; - case 'v': - fputs(rcsid,stdout); - fputs("\nCopyright (c) 1989, 1990, Larry Wall\n",stdout); -#ifdef MSDOS - fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", - stdout); -#endif - fputs("\n\ -Perl may be copied only under the terms of the GNU General Public License,\n\ -a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); - exit(0); - case 'w': - dowarn = TRUE; - s++; - goto reswitch; + if (*s) + cddir = savestr(s); + break; case '-': argc--,argv++; goto switch_end; @@ -240,6 +220,7 @@ a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); #define PRIVLIB "/usr/local/lib/perl" #endif (void)apush(stab_array(incstab),str_make(PRIVLIB,0)); + (void)apush(stab_array(incstab),str_make(".",1)); str_set(&str_no,No); str_set(&str_yes,Yes); @@ -254,10 +235,19 @@ a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); bufend = s + strlen(s); while (*s) { +#ifndef MSDOS s = cpytill(tokenbuf,s,bufend,':',&len); +#else + for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++); + tokenbuf[len] = '\0'; +#endif if (*s) s++; - if (len) +#ifndef MSDOS + if (len && tokenbuf[len-1] != '/') +#else + if (len && tokenbuf[len-1] != '\\') +#endif (void)strcat(tokenbuf+len,"/"); (void)strcat(tokenbuf+len,argv[0]); #ifdef DEBUGGING @@ -283,15 +273,15 @@ a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); pidstatary = anew(Nullstab); /* for remembering popen pids, status */ - filename = savestr(argv[0]); - origfilename = savestr(filename); + origfilename = savestr(argv[0]); + filename = origfilename; if (strEQ(filename,"-")) argv[0] = ""; if (preprocess) { str_cat(str,"-I"); str_cat(str,PRIVLIB); (void)sprintf(buf, "\ -/bin/sed -e '/^[^#]/b' \ +/bin/sed %s -e '/^[^#]/b' \ -e '/^#[ ]*include[ ]/b' \ -e '/^#[ ]*define[ ]/b' \ -e '/^#[ ]*if[ ]/b' \ @@ -301,7 +291,9 @@ a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); -e '/^#[ ]*endif/b' \ -e 's/^#.*//' \ %s | %s -C %s %s", + (doextract ? "-e '1,/^#/d\n'" : ""), argv[0], CPPSTDIN, str_get(str), CPPMINUS); + doextract = FALSE; #ifdef IAMSUID /* actually, this is caught earlier */ if (euid != uid && !euid) /* if running suidperl */ #ifdef SETEUID @@ -420,7 +412,7 @@ a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); if ((statbuf.st_mode >> 6) & S_IWRITE) fatal("Setuid/gid script is writable by world"); doswitches = FALSE; /* -s is insecure in suid */ - line++; + curcmd->c_line++; if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch || strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */ fatal("No #! line"); @@ -534,6 +526,26 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif /* TAINT */ #endif /* DOSUID */ +#if !defined(IAMSUID) && !defined(TAINT) + + /* skip forward in input to the real script? */ + + while (doextract) { + if ((s = str_gets(linestr, rsfp, 0)) == Nullch) + fatal("No Perl script found in input\n"); + if (*s == '#' && s[1] == '!' && instr(s,"perl")) { + ungetc('\n',rsfp); /* to keep line count right */ + doextract = FALSE; + if (s = instr(s,"perl -")) { + s += 6; + while (s = moreswitches(s)) ; + } + if (cddir && chdir(cddir) < 0) + fatal("Can't chdir to %s",cddir); + } + } +#endif /* !defined(IAMSUID) && !defined(TAINT) */ + defstab = stabent("_",TRUE); if (perldb) { @@ -563,8 +575,14 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); /* now parse the script */ error_count = 0; - if (yyparse() || error_count) - fatal("Execution aborted due to compilation errors.\n"); + if (yyparse() || error_count) { + if (minus_c) + fatal("%s had compilation errors.\n", origfilename); + else { + fatal("Execution of %s aborted due to compilation errors.\n", + origfilename); + } + } New(50,loop_stack,128,struct loop); #ifdef DEBUGGING @@ -589,6 +607,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); } magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':"); + userinit(); /* in case linked C routines want magical variables */ amperstab = stabent("&",allstabs); leftstab = stabent("`",allstabs); @@ -600,16 +619,14 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); /* these aren't necessarily magical */ if (tmpstab = stabent(";",allstabs)) str_set(STAB_STR(tmpstab),"\034"); -#ifdef TAINT - tainted = 1; -#endif - if (tmpstab = stabent("0",allstabs)) - str_set(STAB_STR(tmpstab),origfilename); -#ifdef TAINT - tainted = 0; -#endif - if (tmpstab = stabent("]",allstabs)) - str_set(STAB_STR(tmpstab),rcsid); + if (tmpstab = stabent("]",allstabs)) { + str = STAB_STR(tmpstab); + str_set(str,rcsid); + strncpy(tokenbuf,rcsid+19,3); + sprintf(tokenbuf+3,"%2.2d",PATCHLEVEL); + str->str_u.str_nval = atof(tokenbuf); + str->str_nok = 1; + } str_nset(stab_val(stabent("\"", TRUE)), " ", 1); stdinstab = stabent("STDIN",TRUE); @@ -664,9 +681,12 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #ifdef TAINT tainted = 1; #endif + if (tmpstab = stabent("0",allstabs)) + str_set(STAB_STR(tmpstab),origfilename); if (argvstab = stabent("ARGV",allstabs)) { argvstab->str_pok |= SP_MULTI; (void)aadd(argvstab); + aclear(stab_array(argvstab)); for (; argc > 0; argc--,argv++) { (void)apush(stab_array(argvstab),str_make(argv[0],0)); } @@ -677,6 +697,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); if (envstab = stabent("ENV",allstabs)) { envstab->str_pok |= SP_MULTI; (void)hadd(envstab); + hclear(stab_hash(envstab)); + if (env != environ) + environ[0] = Nullch; for (; *env; env++) { if (!(s = index(*env,'='))) continue; @@ -703,6 +726,11 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); fprintf(stderr,"\nEXECUTING...\n\n"); #endif + if (minus_c) { + fprintf(stderr,"%s syntax OK\n", origfilename); + exit(0); + } + /* do it */ (void) cmd_exec(main_root,G_SCALAR,-1); @@ -716,15 +744,24 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); magicalize(list) register char *list; { - register STAB *stab; char sym[2]; sym[1] = '\0'; - while (*sym = *list++) { - if (stab = stabent(sym,allstabs)) { - stab_flags(stab) = SF_VMAGIC; - str_magic(stab_val(stab), stab, 0, Nullch, 0); - } + while (*sym = *list++) + magicname(sym, Nullch, 0); +} + +int +magicname(sym,name,namlen) +char *sym; +char *name; +int namlen; +{ + register STAB *stab; + + if (stab = stabent(sym,allstabs)) { + stab_flags(stab) = SF_VMAGIC; + str_magic(stab_val(stab), stab, 0, name, namlen); } } @@ -744,14 +781,14 @@ int *arglast; ARRAY *ar; int i; char * VOLATILE oldfile = filename; - VOLATILE line_t oldline = line; + CMD * VOLATILE oldcurcmd = curcmd; VOLATILE int oldtmps_base = tmps_base; VOLATILE int oldsave = savestack->ary_fill; SPAT * VOLATILE oldspat = curspat; static char *last_eval = Nullch; static CMD *last_root = Nullcmd; VOLATILE int sp = arglast[0]; - char *tmps; + char *specfilename; tmps_base = tmps_max; if (curstash != stash) { @@ -759,9 +796,10 @@ int *arglast; curstash = stash; } str_set(stab_val(stabent("@",TRUE)),""); - if (optype != O_DOFILE) { /* normal eval */ + curcmd = &compiling; + if (optype == O_EVAL) { /* normal eval */ filename = "(eval)"; - line = 1; + curcmd->c_line = 1; str_sset(linestr,str); str_cat(linestr,";"); /* be kind to them */ } @@ -771,16 +809,30 @@ int *arglast; cmd_free(last_root); last_root = Nullcmd; } - filename = savestr(str_get(str)); /* can't free this easily */ + specfilename = str_get(str); + filename = savestr(specfilename); /* can't free this easily */ str_set(linestr,""); - rsfp = fopen(filename,"r"); - ar = stab_array(incstab); - if (!rsfp && *filename != '/') { + if (optype == O_REQUIRE && + hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) { + filename = oldfile; + tmps_base = oldtmps_base; + st[++sp] = &str_yes; + return sp; + } + else if (*filename == '/') + rsfp = fopen(filename,"r"); + else { + ar = stab_array(incstab); + Safefree(filename); for (i = 0; i <= ar->ary_fill; i++) { (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename); rsfp = fopen(buf,"r"); if (rsfp) { - filename = savestr(buf); + char *s = buf; + + if (*s == '.' && s[1] == '/') + s += 2; + filename = savestr(s); break; } } @@ -788,11 +840,19 @@ int *arglast; if (!rsfp) { filename = oldfile; tmps_base = oldtmps_base; + if (optype == O_REQUIRE) { + sprintf(tokenbuf,"Can't locate %s in @INC", specfilename); + if (instr(tokenbuf,".h ")) + strcat(tokenbuf," (change .h to .ph maybe?)"); + if (instr(tokenbuf,".ph ")) + strcat(tokenbuf," (did you run makelib?)"); + fatal("%s",tokenbuf); + } if (gimme != G_ARRAY) st[++sp] = &str_undef; return sp; } - line = 0; + curcmd->c_line = 0; } in_eval++; oldoldbufptr = oldbufptr = bufptr = str_get(linestr); @@ -844,6 +904,8 @@ int *arglast; if (rsfp) { fclose(rsfp); rsfp = 0; + if (optype == O_REQUIRE) + fatal("%s", str_get(stab_val(stabent("@",TRUE)))); } } else { @@ -854,21 +916,122 @@ int *arglast; /* if we don't save result, free zaps it */ if (in_eval != 1 && myroot != last_root) cmd_free(myroot); + if (optype != O_EVAL) { + if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) { + (void)hstore(stab_hash(incstab), specfilename, + strlen(specfilename), str_make(filename,0), 0 ); + } + else if (optype == O_REQUIRE) + fatal("%s did not return a true value", specfilename); + } } in_eval--; #ifdef DEBUGGING if (debug & 4) { - tmps = loop_stack[loop_ptr].loop_label; + char *tmps = loop_stack[loop_ptr].loop_label; deb("(Popping label #%d %s)\n",loop_ptr, tmps ? tmps : "" ); } #endif loop_ptr--; filename = oldfile; - line = oldline; + curcmd = oldcurcmd; tmps_base = oldtmps_base; curspat = oldspat; if (savestack->ary_fill > oldsave) /* let them use local() */ restorelist(oldsave); return sp; } + +/* This routine handles any switches that can be given during run */ + +static char * +moreswitches(s) +char *s; +{ + reswitch: + switch (*s) { + case 'a': + minus_a = TRUE; + s++; + return s; + case 'c': + minus_c = TRUE; + s++; + return s; + case 'd': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -d allowed in setuid scripts"); +#endif + perldb = TRUE; + s++; + return s; + case 'D': +#ifdef DEBUGGING +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -D allowed in setuid scripts"); +#endif + debug = atoi(s+1); +#else + warn("Recompile perl with -DDEBUGGING to use -D switch\n"); +#endif + break; + case 'i': + inplace = savestr(s+1); + for (s = inplace; *s && !isspace(*s); s++) ; + *s = '\0'; + argvoutstab = stabent("ARGVOUT",TRUE); + break; + case 'I': +#ifdef TAINT + if (euid != uid || egid != gid) + fatal("No -I allowed in setuid scripts"); +#endif + if (*++s) { + (void)apush(stab_array(incstab),str_make(s,0)); + } + else + fatal("No space allowed after -I"); + break; + case 'n': + minus_n = TRUE; + s++; + return s; + case 'p': + minus_p = TRUE; + s++; + return s; + case 'u': + do_undump = TRUE; + s++; + return s; + case 'U': + unsafe = TRUE; + s++; + return s; + case 'v': + fputs(rcsid,stdout); + fputs("\nCopyright (c) 1989, 1990, Larry Wall\n",stdout); +#ifdef MSDOS + fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", + stdout); +#endif + fputs("\n\ +Perl may be copied only under the terms of the GNU General Public License,\n\ +a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout); + exit(0); + case 'w': + dowarn = TRUE; + s++; + return s; + case ' ': + case '\n': + case '\t': + break; + default: + fatal("Switch meaningless after -x: -%s",s); + } + return Nullch; +} |