See patch #19.
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.
# 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
$| = 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($. ,$@, $!, $[, $,, $/, $\);
$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;
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).
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.
";
}
}
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";
};
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;
-#define PATCHLEVEL 23
+#define PATCHLEVEL 24
''' 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
'''
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
.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.
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.
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
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.)
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
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.
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.
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).)
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:
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
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
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
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
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
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 .
''' 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
'''
$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`);
($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';
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
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
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.
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
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.
.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.
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.
-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
*
* 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
#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;
(void)fclose(stdprn);
#endif
if (do_undump) {
+ origfilename = savestr(argv[0]);
do_undump = 0;
loop_ptr = -1; /* start label stack again */
goto just_doit;
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
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)
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
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)
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;
#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);
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
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' \
-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
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");
#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) {
/* 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
}
magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':");
+ userinit(); /* in case linked C routines want magical variables */
amperstab = stabent("&",allstabs);
leftstab = stabent("`",allstabs);
/* 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);
#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));
}
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;
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);
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);
}
}
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) {
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 */
}
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;
}
}
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);
if (rsfp) {
fclose(rsfp);
rsfp = 0;
+ if (optype == O_REQUIRE)
+ fatal("%s", str_get(stab_val(stabent("@",TRUE))));
}
}
else {
/* 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;
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff