diff options
| -rw-r--r-- | h2pl/mksizes | 42 | ||||
| -rw-r--r-- | h2pl/mkvars | 31 | ||||
| -rw-r--r-- | lib/nsyslog.pl | 209 | ||||
| -rw-r--r-- | os2/eg/os2.pl | 70 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.h | 35 | ||||
| -rw-r--r-- | perl.man.1 | 95 | ||||
| -rw-r--r-- | perl.man.2 | 57 | ||||
| -rw-r--r-- | perl.y | 65 | ||||
| -rw-r--r-- | t/op.pack | 8 | ||||
| -rw-r--r-- | usub/mus | 129 | ||||
| -rw-r--r-- | usub/pager | 209 |
12 files changed, 899 insertions, 53 deletions
diff --git a/h2pl/mksizes b/h2pl/mksizes new file mode 100644 index 0000000000..cb4b8ab86e --- /dev/null +++ b/h2pl/mksizes @@ -0,0 +1,42 @@ +#!/usr/local/bin/perl + +($iam = $0) =~ s%.*/%%; +$tmp = "$iam.$$"; +open (CODE,">$tmp.c") || die "$iam: cannot create $tmp.c: $!\n"; + +$mask = q/printf ("$sizeof{'%s'} = %d;\n"/; + +# write C program +select(CODE); + +print <<EO_C_PROGRAM; +#include <sys/param.h> +#include <sys/types.h> +#include <sys/socket.h> +#include <net/if_arp.h> +#include <net/if.h> +#include <net/route.h> +#include <sys/ioctl.h> + +main() { +EO_C_PROGRAM + +while ( <> ) { + chop; + printf "\t%s, \n\t\t\"%s\", sizeof(%s));\n", $mask, $_,$_; +} + +print "\n}\n"; + +close CODE; + +# compile C program + +select(STDOUT); + +system "cc $tmp.c -o $tmp"; +die "couldn't compile $tmp.c" if $?; +system "./$tmp"; +die "couldn't run $tmp" if $?; + +unlink "$tmp.c", $tmp; diff --git a/h2pl/mkvars b/h2pl/mkvars new file mode 100644 index 0000000000..c6b5ad14da --- /dev/null +++ b/h2pl/mkvars @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +require 'sizeof.ph'; + +$LIB = '/usr/local/lib/perl'; + +foreach $include (@ARGV) { + printf STDERR "including %s\n", $include; + do $include; + warn "sourcing $include: $@\n" if ($@); + if (!open (INCLUDE,"$LIB/$include")) { + warn "can't open $LIB/$include: $!\n"; + next; + } + while (<INCLUDE>) { + chop; + if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) { + $var = $1; + $val = eval "&$var;"; + if ($@) { + warn "$@: $_"; + print <<EOT +warn "\$$var isn't correctly set" if defined \$_main{'$var'}; +EOT + next; + } + ( $nval = sprintf ("%x",$val ) ) =~ tr/a-z/A-Z/; + printf "\$%s = 0x%s;\n", $var, $nval; + } + } +} diff --git a/lib/nsyslog.pl b/lib/nsyslog.pl new file mode 100644 index 0000000000..37f4fe1454 --- /dev/null +++ b/lib/nsyslog.pl @@ -0,0 +1,209 @@ +# +# syslog.pl +# +# $Log: nsyslog.pl,v $ +# Revision 3.0.1.1 90/08/09 03:57:17 lwall +# patch19: Initial revision +# +# Revision 1.2 90/06/11 18:45:30 18:45:30 root () +# - Changed 'warn' to 'mail|warning' in test call (to give example of +# facility specification, and because 'warn' didn't work on HP-UX). +# - Fixed typo in &openlog ("ncons" should be "cons"). +# - Added (package-global) $maskpri, and &setlogmask. +# - In &syslog: +# - put argument test ahead of &connect (why waste cycles?), +# - allowed facility to be specified in &syslog's first arg (temporarily +# overrides any $facility set in &openlog), just as in syslog(3C), +# - do a return 0 when bit for $numpri not set in log mask (see syslog(3C)), +# - changed $whoami code to use getlogin, getpwuid($<) and 'syslog' +# (in that order) when $ident is null, +# - made PID logging consistent with syslog(3C) and subject to $lo_pid only, +# - fixed typo in "print CONS" statement ($<facility should be <$facility). +# - changed \n to \r in print CONS (\r is useful, $message already has a \n). +# - Changed &xlate to return -1 for an unknown name, instead of croaking. +# +# +# tom christiansen <tchrist@convex.com> +# modified to use sockets by Larry Wall <lwall@jpl-devvax.jpl.nasa.gov> +# NOTE: openlog now takes three arguments, just like openlog(3) +# +# call syslog() with a string priority and a list of printf() args +# like syslog(3) +# +# usage: require 'syslog.pl'; +# +# then (put these all in a script to test function) +# +# +# do openlog($program,'cons,pid','user'); +# do syslog('info','this is another test'); +# do syslog('mail|warning','this is a better test: %d', time); +# do closelog(); +# +# do syslog('debug','this is the last test'); +# do openlog("$program $$",'ndelay','user'); +# do syslog('notice','fooprogram: this is really done'); +# +# $! = 55; +# do syslog('info','problem was %m'); # %m == $! in syslog(3) + +package syslog; + +$host = 'localhost' unless $host; # set $syslog'host to change + +require '/usr/local/lib/perl/syslog.ph'; + +$maskpri = &LOG_UPTO(&LOG_DEBUG); + +sub main'openlog { + ($ident, $logopt, $facility) = @_; # package vars + $lo_pid = $logopt =~ /\bpid\b/; + $lo_ndelay = $logopt =~ /\bndelay\b/; + $lo_cons = $logopt =~ /\bcons\b/; + $lo_nowait = $logopt =~ /\bnowait\b/; + &connect if $lo_ndelay; +} + +sub main'closelog { + $facility = $ident = ''; + &disconnect; +} + +sub main'setlogmask { + local($oldmask) = $maskpri; + $maskpri = shift; + $oldmask; +} + +sub main'syslog { + local($priority) = shift; + local($mask) = shift; + local($message, $whoami); + local(@words, $num, $numpri, $numfac, $sum); + local($facility) = $facility; # may need to change temporarily. + + die "syslog: expected both priority and mask" unless $mask && $priority; + + @words = split(/\W+/, $priority, 2);# Allow "level" or "level|facility". + undef $numpri; + undef $numfac; + foreach (@words) { + $num = &xlate($_); # Translate word to number. + if (/^kern$/ || $num < 0) { + die "syslog: invalid level/facility: $_\n"; + } + elsif ($num <= &LOG_PRIMASK) { + die "syslog: too many levels given: $_\n" if defined($numpri); + $numpri = $num; + return 0 unless &LOG_MASK($numpri) & $maskpri; + } + else { + die "syslog: too many facilities given: $_\n" if defined($numfac); + $facility = $_; + $numfac = $num; + } + } + + die "syslog: level must be given\n" unless defined($numpri); + + if (!defined($numfac)) { # Facility not specified in this call. + $facility = 'user' unless $facility; + $numfac = &xlate($facility); + } + + &connect unless $connected; + + $whoami = $ident; + + if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) { + $whoami = $1; + $mask = $2; + } + + unless ($whoami) { + ($whoami = getlogin) || + ($whoami = getpwuid($<)) || + ($whoami = 'syslog'); + } + + $whoami .= "[$$]" if $lo_pid; + + $mask =~ s/%m/$!/g; + $mask .= "\n" unless $mask =~ /\n$/; + $message = sprintf ($mask, @_); + + $sum = $numpri + $numfac; + unless (send(SYSLOG,"<$sum>$whoami: $message",0)) { + if ($lo_cons) { + if ($pid = fork) { + unless ($lo_nowait) { + do {$died = wait;} until $died == $pid || $died < 0; + } + } + else { + open(CONS,">/dev/console"); + print CONS "<$facility.$priority>$whoami: $message\r"; + exit if defined $pid; # if fork failed, we're parent + close CONS; + } + } + } +} + +sub xlate { + local($name) = @_; + $name =~ y/a-z/A-Z/; + $name = "LOG_$name" unless $name =~ /^LOG_/; + $name = "syslog'$name"; + eval &$name || -1; +} + +sub connect { + $pat = 'S n C4 x8'; + + $af_unix = 1; + $af_inet = 2; + + $stream = 1; + $datagram = 2; + + ($name,$aliases,$proto) = getprotobyname('udp'); + $udp = $proto; + + ($name,$aliase,$port,$proto) = getservbyname('syslog','udp'); + $syslog = $port; + + if (chop($myname = `hostname`)) { + ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname); + die "Can't lookup $myname\n" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + else { + @bytes = (0,0,0,0); + } + $this = pack($pat, $af_inet, 0, @bytes); + + if ($host =~ /^\d+\./) { + @bytes = split(/\./,$host); + } + else { + ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($host); + die "Can't lookup $host\n" unless $name; + @bytes = unpack("C4",$addrs[0]); + } + $that = pack($pat,$af_inet,$syslog,@bytes); + + socket(SYSLOG,$af_inet,$datagram,$udp) || die "socket: $!\n"; + bind(SYSLOG,$this) || die "bind: $!\n"; + connect(SYSLOG,$that) || die "connect: $!\n"; + + local($old) = select(SYSLOG); $| = 1; select($old); + $connected = 1; +} + +sub disconnect { + close SYSLOG; + $connected = 0; +} + +1; diff --git a/os2/eg/os2.pl b/os2/eg/os2.pl new file mode 100644 index 0000000000..224b9b386c --- /dev/null +++ b/os2/eg/os2.pl @@ -0,0 +1,70 @@ +extproc C:\binp\misc\perl.exe -S + +# os2.pl: Demonstrates the OS/2 system calls and shows off some of the +# features in common with the UNIX version. + +do "syscalls.pl" || die "Cannot load syscalls.pl ($!)"; + +# OS/2 version number. + + $version = " "; syscall($OS2_GetVersion,$version); + ($minor, $major) = unpack("CC", $version); + print "You are using OS/2 version ", int($major/10), + ".", int($minor/10), "\n\n"; + +# Process ID. + print "This process ID is $$ and its parent's ID is ", + getppid(), "\n\n"; + +# Priority. + + printf "Current priority is %x\n", getpriority(0,0); + print "Changing priority by +5\n"; + print "Failed!\n" unless setpriority(0,0,+5); + printf "Priority is now %x\n\n", getpriority(0,0); + +# Beep. + print "Here is an A440.\n\n"; + syscall($OS2_Beep,440,50); + +# Pipes. Unlike MS-DOS, OS/2 supports true asynchronous pipes. + open(ROT13, '|perl -pe y/a-zA-Z/n-za-mN-ZA-M/') || die; + select(ROT13); $|=1; select(STDOUT); + print "Type two lines of stuff, and I'll ROT13 it while you wait.\n". + "If you type fast, you might be able to type both of your\n". + "lines before I get a chance to translate the first line.\n"; + $_ = <STDIN>; print ROT13 $_; + $_ = <STDIN>; print ROT13 $_; + close(ROT13); + print "Thanks.\n\n"; + +# Inspecting the disks. + print "Let's look at the disks you have installed...\n\n"; + + $x = "\0\0"; + syscall($OS2_Config, $x, 2); + print "You have ", unpack("S", $x), " floppy disks,\n"; + + $x = " "; + syscall($OS2_PhysicalDisk, 1, $x, 2, 0, 0); + ($numdisks) = unpack("S", $x); + + print "and $numdisks partitionable disks.\n\n"; + for ($i = 1; $i <= $numdisks; $i++) { + $disk = $i . ":"; + $handle = " "; + syscall($OS2_PhysicalDisk, 2, $handle, 2, $disk, 3); + ($numhandle) = unpack("S", $handle); + $zero = pack("C", 0); + $parmblock = " " x 16; + syscall($OS2_IOCtl, $parmblock, $zero, 0x63, 9, $numhandle); + ($x, $cylinders, $heads, $sect) = unpack("SSSS", $parmblock); + print "Hard drive #$i:\n"; + print " cylinders: $cylinders\n"; + print " heads: $heads\n"; + print " sect/trk: $sect\n"; + syscall($OS2_PhysicalDisk, 3, 0, 0, $handle, 2); + } + +# I won't bother with the other stuff. You get the idea. + diff --git a/patchlevel.h b/patchlevel.h index 7c3da2cb8a..2627e90d71 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1 +1 @@ -#define PATCHLEVEL 22 +#define PATCHLEVEL 23 @@ -1,4 +1,4 @@ -/* $Header: perl.h,v 3.0.1.7 90/03/27 16:12:52 lwall Locked $ +/* $Header: perl.h,v 3.0.1.8 90/08/09 04:10:53 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,11 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.h,v $ + * 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 + * patch19: added -x switch to extract script from input trash + * * Revision 3.0.1.7 90/03/27 16:12:52 lwall * patch16: MSDOS support * patch16: support for machines that can't cast negative floats to unsigned ints @@ -134,11 +139,12 @@ #ifdef MEMCPY #ifndef memcpy -#ifdef __STDC__ +#if defined(__STDC__ ) || defined(MSDOS) extern void *memcpy(), *memset(); #else extern char *memcpy(), *memset(); #endif +extern int memcmp(); #endif #define bcopy(s1,s2,l) memcpy(s2,s1,l) #define bzero(s,l) memset(s,0,l) @@ -268,6 +274,8 @@ EXT int dbmlen; # endif #endif +typedef unsigned int STRLEN; + typedef struct arg ARG; typedef struct cmd CMD; typedef struct formcmd FCMD; @@ -293,7 +301,7 @@ typedef struct stab STAB; #include "array.h" #include "hash.h" -#if defined(iAPX286) || defined(M_I286) || defined(I80286) || defined(M_I86) +#if defined(iAPX286) || defined(M_I286) || defined(I80286) # define I286 #endif @@ -361,7 +369,15 @@ EXT STR *Str; #define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len) +#ifndef MSDOS #define STR_GROW(str,len) if ((str)->str_len < (len)) str_grow(str,len) +#define Str_Grow str_grow +#else +/* extra parentheses intentionally NOT placed around "len"! */ +#define STR_GROW(str,len) if ((str)->str_len < (unsigned long)len) \ + str_grow(str,(unsigned long)len) +#define Str_Grow(str,len) str_grow(str,(unsigned long)(len)) +#endif /* MSDOS */ #ifndef BYTEORDER #define BYTEORDER 0x1234 @@ -504,7 +520,6 @@ ARRAY *saveary(); EXT char **origargv; EXT int origargc; -EXT line_t line INIT(0); EXT line_t subline INIT(0); EXT STR *subname INIT(Nullstr); EXT int arybase INIT(0); @@ -547,6 +562,7 @@ EXT STR *DBsingle INIT(Nullstr); EXT int lastspbase; EXT int lastsize; +EXT char *curpack; EXT char *filename; EXT char *origfilename; EXT FILE * VOLATILE rsfp; @@ -574,6 +590,7 @@ EXT bool minus_p INIT(FALSE); EXT bool minus_a INIT(FALSE); EXT bool doswitches INIT(FALSE); EXT bool dowarn INIT(FALSE); +EXT bool doextract INIT(FALSE); EXT bool allstabs INIT(FALSE); /* init all customary symbols in symbol table?*/ EXT bool sawampersand INIT(FALSE); /* must save all match strings */ EXT bool sawstudy INIT(FALSE); /* do fbminstr on all strings */ @@ -590,7 +607,11 @@ int cshlen INIT(0); EXT bool tainted INIT(FALSE); /* using variables controlled by $< */ #endif +#ifndef MSDOS #define TMPPATH "/tmp/perl-eXXXXXX" +#else +#define TMPPATH "/tmp/plXXXXXX" +#endif /* MSDOS */ EXT char *e_tmpname; EXT FILE *e_fp INIT(Nullfp); @@ -658,6 +679,12 @@ EXT jmp_buf top_env; EXT char * VOLATILE goto_targ INIT(Nullch); /* cmd_exec gets strange when set */ +struct ufuncs { + int (*uf_val)(); + int (*uf_set)(); + int uf_index; +}; + EXT ARRAY *stack; /* THE STACK */ EXT ARRAY * VOLATILE savestack; /* to save non-local values on */ diff --git a/perl.man.1 b/perl.man.1 index 69f373ffe4..ac2fee713e 100644 --- a/perl.man.1 +++ b/perl.man.1 @@ -1,7 +1,18 @@ .rn '' }` -''' $Header: perl_man.1,v 3.0.1.5 90/03/27 16:14:37 lwall Locked $ +''' $Header: perl_man.1,v 3.0.1.7 90/08/09 04:24:03 lwall Locked $ ''' ''' $Log: perl.man.1,v $ +''' Revision 3.0.1.7 90/08/09 04:24:03 lwall +''' patch19: added -x switch to extract script from input trash +''' patch19: Added -c switch to do compilation only +''' patch19: bare identifiers are now strings if no other interpretation possible +''' patch19: -s now returns size of file +''' patch19: Added __LINE__ and __FILE__ tokens +''' patch19: Added __END__ token +''' +''' Revision 3.0.1.6 90/08/03 11:14:44 lwall +''' patch19: Intermediate diffs for Randal +''' ''' Revision 3.0.1.5 90/03/27 16:14:37 lwall ''' patch16: .. now works using magical string increment ''' @@ -182,6 +193,11 @@ is equivalent to .fi .TP 5 +.B \-c +causes +.I perl +to check the syntax of the script and then exit without executing it. +.TP 5 .BI \-d runs the script under the perl debugger. See the section on Debugging. @@ -372,6 +388,16 @@ by csh. In order to start up sh rather than csh, some systems may have to replace the #! line with a line containing just a colon, which will be politely ignored by perl. +Other systems can't control that, and need a totally devious construct that +will work under any of csh, sh or perl, such as the following: +.nf + +.ne 3 + eval '(exit $?0)' && eval 'exec /usr/bin/perl -S $0 ${1+"$@"}' + & eval 'exec /usr/bin/perl -S $0 $argv:q' + if 0; + +.fi .TP 5 .B \-u causes @@ -386,6 +412,8 @@ If you are going to run your executable as a set-id program then you should probably compile it using taintperl rather than normal perl. If you want to execute a portion of your script before dumping, use the dump operator instead. +Note: availability of undump is platform specific and may not be available +for a specific port of perl. .TP 5 .B \-U allows @@ -407,6 +435,23 @@ filehandles or filehandles opened readonly that you are attempting to write on. Also warns you if you use == on values that don't look like numbers, and if your subroutines recurse more than 100 deep. +.TP 5 +.BI \-x directory +tells +.I perl +that the script is embedded in a message. +Leading garbage will be discarded until the first line that starts +with #! and contains the string "perl". +Any meaningful switches on that line will be applied (but only one +group of switches, as with normal #! processing). +If a directory name is specified, Perl will switch to that directory +before running the script. +The +.B \-x +switch only controls the the disposal of leading garbage. +The script must be terminated with __END__ if there is trailing garbage +to be ignored (the script can process any or all of the trailing garbage +via standard input if desired). .Sh "Data Types and Objects" .PP .I Perl @@ -571,6 +616,27 @@ Also note that a single quoted string must be separated from a preceding word by a space, since single quote is a valid character in an identifier (see Packages). .PP +Two special literals are __LINE__ and __FILE__, which represent the current +line number and filename at that point in your program. +They may only be used as separate tokens; they will not be interpolated +into strings. +In addition, the token __END__ may be used to indicate the logical end of the +script before the actual end of file. +Any following text is ignored (but if the script is being read from +the standard input, then the rest of the input is available by reading +from filehandle STDIN). +The two control characters ^D and ^Z are synonyms for __END__. +.PP +A word that doesn't have any other interpretation in the grammar will be +treated as if it had single quotes around it. +For this purpose, a word consists only of alphanumeric characters and underline, +and must start with an alphabetic character. +As with filehandles and labels, a bare word that consists entirely of +lowercase letters risks conflict with future reserved words, and if you +use the +.B \-w +switch, Perl will warn you about any such words. +.PP Array values are interpolated into double-quoted strings by joining all the elements of the array with the delimiter specified in the $" variable, space by default. @@ -739,6 +805,11 @@ If a string is enclosed by backticks (grave accents), it first undergoes variable substitution just like a double quoted string. It is then interpreted as a command, and the output of that command is the value of the pseudo-literal, like in a shell. +In a scalar context, a single string consisting of all the output is +returned. +In an array context, an array of values is returned, one for each line +of output. +(You can set $/ to use a different line terminator.) The command is executed each time the pseudo-literal is evaluated. The status value of the command is returned in $? (see Predefined Names for the interpretation of $?). @@ -1046,6 +1117,8 @@ is the same as .PP The foreach loop iterates over a normal array value and sets the variable VAR to be each element of the array in turn. +The variable is implicitly local to the loop, and regains its former value +upon exiting the loop. The \*(L"foreach\*(R" keyword is actually identical to the \*(L"for\*(R" keyword, so you can use \*(L"foreach\*(R" for readability or \*(L"for\*(R" for brevity. If VAR is omitted, $_ is set to each value. @@ -1070,7 +1143,7 @@ Examples: for (1..15) { print "Merry Christmas\en"; } .ne 3 - foreach $item (split(/:[\e\e\en:]*/, $ENV{\'TERMCAP\'}) { + foreach $item (split(/:[\e\e\en:]*/, $ENV{\'TERMCAP\'})) { print "Item: $item\en"; } @@ -1112,9 +1185,9 @@ or .ne 6 foo: { - /^abc/ && do { $abc = 1; last foo; } - /^def/ && do { $def = 1; last foo; } - /^xyz/ && do { $xyz = 1; last foo; } + /^abc/ && do { $abc = 1; last foo; }; + /^def/ && do { $def = 1; last foo; }; + /^xyz/ && do { $xyz = 1; last foo; }; $nothing = 1; } @@ -1336,7 +1409,7 @@ The operator may be any of: \-O File is owned by real uid. \-e File exists. \-z File has zero size. - \-s File has non-zero size. + \-s File has non-zero size (returns size). \-f File is a plain file. \-d File is a directory. \-l File is a symbolic link. @@ -1472,3 +1545,13 @@ to get dates with leading zeros. (If the final value specified is not in the sequence that the magical increment would produce, the sequence goes until the next value would be longer than the final value specified.) +.PP +The || and && operators differ from C's in that, rather than returning 0 or 1, +they return the last value evaluated. +Thus, a portable way to find out the home directory might be: +.nf + + $home = $ENV{'HOME'} || $ENV{'LOGDIR'} || + (getpwuid($<))[7] || die "You're homeless!\en"; + +.fi diff --git a/perl.man.2 b/perl.man.2 index 4f637f1db0..1289103688 100644 --- a/perl.man.2 +++ b/perl.man.2 @@ -1,7 +1,13 @@ ''' Beginning of part 2 -''' $Header: perl_man.2,v 3.0.1.5 90/03/27 16:15:17 lwall Locked $ +''' $Header: perl_man.2,v 3.0.1.7 90/08/09 04:27:04 lwall Locked $ ''' ''' $Log: perl.man.2,v $ +''' Revision 3.0.1.7 90/08/09 04:27:04 lwall +''' patch19: added require operator +''' +''' Revision 3.0.1.6 90/08/03 11:15:29 lwall +''' patch19: Intermediate diffs for Randal +''' ''' Revision 3.0.1.5 90/03/27 16:15:17 lwall ''' patch16: MSDOS support ''' @@ -65,6 +71,11 @@ See example in section on Interprocess Communication. Returns the arctangent of X/Y in the range .if t \-\(*p to \(*p. .if n \-PI to PI. +.Ip "bind(SOCKET,NAME)" 8 2 +Does the same thing that the bind system call does. +Returns true if it succeeded, false otherwise. +NAME should be a packed address of the proper type for the socket. +See example in section on Interprocess Communication. .Ip "binmode(FILEHANDLE)" 8 4 .Ip "binmode FILEHANDLE" 8 4 Arranges for the file to be read in \*(L"binary\*(R" mode in operating systems @@ -74,11 +85,6 @@ to LF on input and LF translated to CR LF on output. Binmode has no effect under Unix. If FILEHANDLE is an expression, the value is taken as the name of the filehandle. -.Ip "bind(SOCKET,NAME)" 8 2 -Does the same thing that the bind system call does. -Returns true if it succeeded, false otherwise. -NAME should be a packed address of the proper type for the socket. -See example in section on Interprocess Communication. .Ip "chdir(EXPR)" 8 2 .Ip "chdir EXPR" 8 2 Changes the working directory to EXPR, if possible. @@ -414,6 +420,8 @@ Note that the following are NOT equivalent: do $foo(); # call a subroutine .fi +Note that inclusion of library routines is better done with +the \*(L"require\*(R" operator. .Ip "dump LABEL" 8 6 This causes an immediate core dump. Primarily this is so that you can use the undump program to turn your @@ -433,8 +441,8 @@ Example: .ne 16 #!/usr/bin/perl - do 'getopt.pl'; - do 'stat.pl'; + require 'getopt.pl'; + require 'stat.pl'; %days = ( 'Sun',1, 'Mon',2, @@ -479,6 +487,8 @@ See also keys() and values(). Returns 1 if the next read on FILEHANDLE will return end of file, or if FILEHANDLE is not open. FILEHANDLE may be an expression whose value gives the real filehandle name. +(Note that this function actually reads a character and then ungetc's it, +so it is not very useful in an interactive context.) An eof without an argument returns the eof status for the last file read. Empty parentheses () may be used to indicate the pseudo file formed of the files listed on the command line, i.e. eof() is reasonable to use inside @@ -584,7 +594,7 @@ Implements the fcntl(2) function. You'll probably have to say .nf - do "fcntl.h"; # probably /usr/local/lib/perl/fcntl.h + require "fcntl.ph"; # probably /usr/local/lib/perl/fcntl.ph .fi first to get the correct function definitions. @@ -627,7 +637,7 @@ Here's a mailbox appender for BSD systems. flock(MBOX,$LOCK_UN); } - open(MBOX, ">>/usr/spool/mail/$USER") + open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}") || die "Can't open mailbox: $!"; do lock(); @@ -650,7 +660,7 @@ If FILEHANDLE is omitted, reads from STDIN. Returns the current login from /etc/utmp, if any. If null, use getpwuid. - ($login = getlogin) || (($login) = getpwuid($<)); + $login = getlogin || (getpwuid($<))[0] || "Somebody"; .Ip "getpeername(SOCKET)" 8 3 Returns the packed sockaddr address of other end of the SOCKET connection. @@ -805,18 +815,26 @@ In a scalar context, returns the number of times the expression was true. Note that, since $_ is a reference into the array value, it can be used to modify the elements of the array. While this is useful and supported, it can cause bizarre results if -the LIST contains literal values. +the LIST is not a named array. .Ip "hex(EXPR)" 8 4 .Ip "hex EXPR" 8 Returns the decimal value of EXPR interpreted as an hex string. (To interpret strings that might start with 0 or 0x see oct().) If EXPR is omitted, uses $_. +.Ip "index(STR,SUBSTR)" 8 4 +Returns the position of the first occurrence of SUBSTR in STR, based at 0, or whatever you've +set the $[ variable to. +If the substring is not found, returns one less than the base, ordinarily \-1. +.Ip "int(EXPR)" 8 4 +.Ip "int EXPR" 8 +Returns the integer portion of EXPR. +If EXPR is omitted, uses $_. .Ip "ioctl(FILEHANDLE,FUNCTION,SCALAR)" 8 4 Implements the ioctl(2) function. You'll probably have to say .nf - do "ioctl.h"; # probably /usr/local/lib/perl/ioctl.h + require "ioctl.ph"; # probably /usr/local/lib/perl/ioctl.ph .fi first to get the correct function definitions. @@ -837,7 +855,7 @@ The following example sets the erase character to DEL. .nf .ne 9 - do 'ioctl.h'; + require 'ioctl.ph'; $sgttyb_t = "ccccs"; # 4 chars and a short if (ioctl(STDIN,$TIOCGETP,$sgttyb)) { @ary = unpack($sgttyb_t,$sgttyb); @@ -865,14 +883,6 @@ easily determine the actual value returned by the operating system: ($retval = ioctl(...)) || ($retval = -1); printf "System returned %d\en", $retval; .fi -.Ip "index(STR,SUBSTR)" 8 4 -Returns the position of the first occurrence of SUBSTR in STR, based at 0, or whatever you've -set the $[ variable to. -If the substring is not found, returns one less than the base, ordinarily \-1. -.Ip "int(EXPR)" 8 4 -.Ip "int EXPR" 8 -Returns the integer portion of EXPR. -If EXPR is omitted, uses $_. .Ip "join(EXPR,LIST)" 8 8 .Ip "join(EXPR,ARRAY)" 8 Joins the separate strings of LIST or ARRAY into a single string with fields @@ -1057,7 +1067,8 @@ the $_ string is searched. See also the section on regular expressions. .Sp If / is the delimiter then the initial \*(L'm\*(R' is optional. -With the \*(L'm\*(R' you can use any pair of characters as delimiters. +With the \*(L'm\*(R' you can use any pair of non-alphanumeric characters +as delimiters. This is particularly useful for matching Unix path names that contain \*(L'/\*(R'. If the final delimiter is followed by the optional letter \*(L'i\*(R', the matching is done in a case-insensitive manner. @@ -1,4 +1,4 @@ -/* $Header: perl.y,v 3.0.1.6 90/03/27 16:13:45 lwall Locked $ +/* $Header: perl.y,v 3.0.1.7 90/08/09 04:17:44 lwall Locked $ * * Copyright (c) 1989, Larry Wall * @@ -6,6 +6,13 @@ * as specified in the README file that comes with the perl 3.0 kit. * * $Log: perl.y,v $ + * Revision 3.0.1.7 90/08/09 04:17:44 lwall + * patch19: did preliminary work toward debugging packages and evals + * patch19: added require operator + * patch19: bare identifiers are now strings if no other interpretation possible + * patch19: null-label lines threw off line number of next statement + * patch19: split; didn't pass correct bufend to scanpat + * * Revision 3.0.1.6 90/03/27 16:13:45 lwall * patch16: formats didn't work inside eval * @@ -57,7 +64,7 @@ ARG *arg5; } %token <cval> WORD -%token <ival> APPEND OPEN SELECT LOOPEX +%token <ival> APPEND OPEN SSELECT LOOPEX %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 @@ -72,7 +79,7 @@ ARG *arg5; %type <ival> prog decl format remember %type <cmdval> block lineseq line loop cond sideff nexpr else %type <arg> expr sexpr cexpr csexpr term handle aryword hshword -%type <arg> texpr listop +%type <arg> texpr listop bareword %type <cval> label %type <compval> compblock @@ -153,8 +160,11 @@ line : decl { if ($1 != Nullch) { $$ = add_label($1, make_acmd(C_EXPR, Nullstab, Nullarg, Nullarg) ); - } else - $$ = Nullcmd; } + } + else { + $$ = Nullcmd; + cmdline = NOLINE; + } } | label sideff ';' { $$ = add_label($1,$2); } ; @@ -228,7 +238,7 @@ loop : label WHILE '(' texpr ')' compblock l(make_op(O_ASSIGN,2, listish(make_op(O_ARRAY, 1, stab2arg(A_STAB,scrstab), - Nullarg,Nullarg, 1)), + Nullarg,Nullarg )), listish(make_list($5)), Nullarg)), Nullarg), @@ -255,7 +265,7 @@ loop : label WHILE '(' texpr ')' compblock l(make_op(O_ASSIGN,2, listish(make_op(O_ARRAY, 1, stab2arg(A_STAB,scrstab), - Nullarg,Nullarg, 1 )), + Nullarg,Nullarg )), listish(make_list($4)), Nullarg)), Nullarg), @@ -325,12 +335,15 @@ subrout : SUB WORD block package : PACKAGE WORD ';' { char tmpbuf[256]; + STAB *tmpstab; savehptr(&curstash); saveitem(curstname); str_set(curstname,$2); sprintf(tmpbuf,"'_%s",$2); - curstash = stab_xhash(hadd(stabent(tmpbuf,TRUE))); + tmpstab = hadd(stabent(tmpbuf,TRUE)); + curstash = stab_xhash(tmpstab); + curpack = stab_name(tmpstab); curstash->tbl_coeffsize = 0; Safefree($2); } @@ -569,17 +582,17 @@ term : '-' term %prec UMINUS Nullarg,Nullarg); } | UNIOP { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); - if ($1 == O_EVAL || $1 == O_RESET) + if ($1 == O_EVAL || $1 == O_RESET || $1 == O_REQUIRE) $$ = fixeval($$); } | UNIOP sexpr { $$ = make_op($1,1,$2,Nullarg,Nullarg); - if ($1 == O_EVAL || $1 == O_RESET) + if ($1 == O_EVAL || $1 == O_RESET || $1 == O_REQUIRE) $$ = fixeval($$); } - | SELECT + | SSELECT { $$ = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);} - | SELECT '(' handle ')' + | SSELECT '(' handle ')' { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg); } - | SELECT '(' sexpr csexpr csexpr csexpr ')' + | SSELECT '(' sexpr csexpr csexpr csexpr ')' { arg4 = $6; $$ = make_op(O_SSELECT, 4, $3, $4, $5); } | OPEN WORD %prec '(' @@ -646,7 +659,7 @@ term : '-' term %prec UMINUS aadd(stabent(subline ? "_" : "ARGV", TRUE))), Nullarg, Nullarg); } | SPLIT %prec '(' - { (void)scanpat("/\\s+/"); +{static char p[]="/\\s+/";char*o=bufend;bufend=p+5;(void)scanpat(p);bufend=o; $$ = make_split(defstab,yylval.arg,Nullarg); } | SPLIT '(' sexpr csexpr csexpr ')' { $$ = mod_match(O_MATCH, $4, @@ -681,11 +694,11 @@ term : '-' term %prec UMINUS { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); } | FUNC1 '(' ')' { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); - if ($1 == O_EVAL || $1 == O_RESET) + if ($1 == O_EVAL || $1 == O_RESET || $1 == O_REQUIRE) $$ = fixeval($$); } | FUNC1 '(' expr ')' { $$ = make_op($1, 1, $3, Nullarg, Nullarg); - if ($1 == O_EVAL || $1 == O_RESET) + if ($1 == O_EVAL || $1 == O_RESET || $1 == O_REQUIRE) $$ = fixeval($$); } | FUNC2 '(' sexpr cexpr ')' { $$ = make_op($1, 2, $3, $4, Nullarg); @@ -707,6 +720,7 @@ term : '-' term %prec UMINUS Nullarg); } | HSHFUN3 '(' hshword csexpr cexpr ')' { $$ = make_op($1, 3, $3, $4, $5); } + | bareword | listop ; @@ -756,4 +770,23 @@ hshword : WORD { $$ = stab2arg(A_STAB,$1); } ; +/* + * NOTE: The following entry must stay at the end of the file so that + * reduce/reduce conflicts resolve to it only if it's the only option. + */ + +bareword: WORD + { char *s = $1; + $$ = op_new(1); + $$->arg_type = O_ITEM; + $$[1].arg_type = A_SINGLE; + $$[1].arg_ptr.arg_str = str_make($1,0); + while (*s) { + if (!islower(*s)) + break; + } + if (dowarn && !*s) + warn("\"%s\" may clash with future reserved word", $1); + } + %% /* PROGRAM */ @@ -1,11 +1,13 @@ #!./perl -# $Header: op.pack,v 3.0 89/10/18 15:30:39 lwall Locked $ +# $Header: op.pack,v 3.0.1.1 90/08/09 05:27:04 lwall Locked $ print "1..3\n"; -$format = "c2x5CCxsila6"; -@ary = (1,-100,127,128,32767,12345,123456,"abcdef"); +$format = "c2x5CCxsdila6"; +# Need the expression in here to force ary[5] to be numeric. This avoids +# test2 failing because ary2 goes str->numeric->str and ary doesn't. +@ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef"); $foo = pack($format,@ary); @ary2 = unpack($format,$foo); diff --git a/usub/mus b/usub/mus new file mode 100644 index 0000000000..490f0082a7 --- /dev/null +++ b/usub/mus @@ -0,0 +1,129 @@ +#!/usr/bin/perl + +while (<>) { + if (s/^CASE\s+//) { + @fields = split; + $funcname = pop(@fields); + $rettype = "@fields"; + @modes = (); + @types = (); + @names = (); + @outies = (); + @callnames = (); + $pre = "\n"; + $post = ''; + + while (<>) { + last unless /^[IO]+\s/; + @fields = split(' '); + push(@modes, shift(@fields)); + push(@names, pop(@fields)); + push(@types, "@fields"); + } + while (s/^<\s//) { + $pre .= "\t $_"; + $_ = <>; + } + while (s/^>\s//) { + $post .= "\t $_"; + $_ = <>; + } + $items = @names; + $namelist = '$' . join(', $', @names); + $namelist = '' if $namelist eq '$'; + print <<EOF; + case US_$funcname: + if (items != $items) + fatal("Usage: &$funcname($namelist)"); + else { +EOF + if ($rettype eq 'void') { + print <<EOF; + int retval = 1; +EOF + } + else { + print <<EOF; + $rettype retval; +EOF + } + foreach $i (1..@names) { + $mode = $modes[$i-1]; + $type = $types[$i-1]; + $name = $names[$i-1]; + if ($type =~ /^[A-Z]+\*$/) { + $cast = "*($type*)"; + } + else { + $cast = "($type)"; + } + $what = ($type =~ /^(struct\s+\w+|char|[A-Z]+)\s*\*$/ ? "get" : "gnum"); + $type .= "\t" if length($type) < 4; + $cast .= "\t" if length($cast) < 8; + $x = "\t" x (length($name) < 6); + if ($mode =~ /O/) { + if ($what eq 'gnum') { + push(@outies, "\t str_numset(st[$i], (double) $name);\n"); + } + else { + push(@outies, "\t str_set(st[$i], (char*) $name);\n"); + } + push(@callnames, "&$name"); + } + else { + push(@callnames, $name); + } + if ($mode =~ /I/) { + print <<EOF; + $type $name =$x $cast str_$what(st[$i]); +EOF + } + else { + print <<EOF; + $type $name; +EOF + } + } + $callnames = join(', ', @callnames); + $outies = join("\n",@outies); + if ($rettype eq 'void') { + print <<EOF; +$pre (void)$funcname($callnames); +EOF + } + else { + print <<EOF; +$pre retval = $funcname($callnames); +EOF + } + if ($rettype =~ /^(struct\s+\w+|char)\s*\*$/) { + print <<EOF; + str_set(st[0], (char*) retval); +EOF + } + elsif ($rettype =~ /^[A-Z]+\s*\*$/) { + print <<EOF; + str_set(st[0], (char*) &retval, sizeof retval); +EOF + } + else { + print <<EOF; + str_numset(st[0], (double) retval); +EOF + } + print $outies if $outies; + print $post if $post; + if (/^END/) { + print "\t}\n\treturn sp;\n"; + } + else { + redo; + } + } + elsif (/^END/) { + print "\t}\n\treturn sp;\n"; + } + else { + print; + } +} diff --git a/usub/pager b/usub/pager new file mode 100644 index 0000000000..79e70b92f1 --- /dev/null +++ b/usub/pager @@ -0,0 +1,209 @@ +#!./curseperl + +eval <<'EndOfMain'; $evaloffset = 3; # line number of this line + + $| = 1; # command buffering on stdout + &initterm; + &inithelp; + &slurpfile && &pagearray; + +EndOfMain + +&endwin; + +if ($@) { + print ""; # force flush of stdout + $@ =~ s/\(eval\)/$0/ && $@ =~ s/line (\d+)/'line ' . ($1 + $evaloffset)/e; + die $@; +} + +exit; + +################################################################################ + +sub initterm { + + &initscr; &cbreak; &noecho; &scrollok($stdscr, 1); + &defbell unless defined &bell; + + $lines = $LINES; $lines1 = $lines - 1; $lines2 = $lines - 2; + $cols = $COLS; $cols1 = $cols - 1; $cols2 = $cols - 2;; + + $dl = &getcap('dl'); + $al = &getcap('al'); + $ho = &getcap('ho'); + $ce = &getcap('ce'); +} + +sub slurpfile { + while (<>) { + s/^(\t+)/' ' x length($1)/e; + &expand($_) if /\t/; + if (length($_) < $cols) { + push(@lines, $_); + } + else { + while ($_ && $_ ne "\n") { + push(@lines, substr($_,0,$cols)); + substr($_,0,$cols) = ''; + } + } + } + 1; +} + +sub drawscreen { + &move(0,0); + for ($line .. $line + $lines2) { + &addstr($lines[$_]); + } + &clrtobot; + &percent; + &refresh; +} + +sub expand { + while (($off = index($_[0],"\t")) >= 0) { + substr($_[0], $off, 1) = ' ' x (8 - $off % 8); + } +} + +sub pagearray { + $line = 0; + + $| = 1; + + for (&drawscreen;;&drawscreen) { + + $ch = &getch; + $ch = "j" if $ch eq "\n"; + + if ($ch eq ' ') { + last if $percent >= 100; + &move(0,0); + $line += $lines1; + } + elsif ($ch eq 'b') { + $line -= $lines1; + &move(0,0); + $line = 0 if $line < 0; + } + elsif ($ch eq "j") { + $line += 1; + if ($dl) { + print $ho, $dl; + &mvcur(0,0,$lines2,0); + print $ce,$lines[$line+$lines2],$ce; + &wmove($curscr,0,0); + &wdeleteln($curscr); + &wmove($curscr,$lines2,0); + &waddstr($curscr,$lines[$line+$lines2]); + } + &wmove($stdscr,0,0); + &wdeleteln($stdscr); + &wmove($stdscr,$lines2,0); + &waddstr($stdscr,$lines[$line+$lines2]); + &percent; + &refresh; + redo; + } + elsif ($ch eq "k") { + next if $line <= 0; + $line -= 1; + if ($al) { + print $ho, $al, $ce, $lines[$line]; + &wmove($curscr,0,0); + &winsertln($curscr); + &waddstr($curscr,$lines[$line]); + } + &wmove($stdscr,0,0); + &winsertln($stdscr); + &waddstr($stdscr,$lines[$line]); + &percent; + &refresh; + redo; + } + elsif ($ch eq "\f") { + &clear; + } + elsif ($ch eq "q") { + last; + } + elsif ($ch eq "h") { + &clear; + &help; + &clear; + } + else { + &bell; + } + } +} + +sub defbell { + eval q# + sub bell { + print "\007"; + } + #; +} + +sub help { + local(*lines) = *helplines; + local($line); + &pagearray; +} + +sub inithelp { + @helplines = split(/\n/,<<'EOT'); + + Commands marked with * may be preceeded by a number, N. + + h Display this help. + q Exit. + + f, SPACE * Forward N lines, default one screen. + b * Backward N lines, default one screen. + e, j, CR * Forward N lines, default 1 line. + y, k * Backward N lines, default 1 line. + d * Forward N lines, default 10 or last N to d or u command. + u * Backward N lines, default 10 or last N to d or u command. + r Repaint screen. + R Repaint screen, discarding buffered input. + + /pattern * Search forward for N-th line containing the pattern. + ?pattern * Search backward for N-th line containing the pattern. + n * Repeat previous search (for N-th occurence). + + g * Go to line N, default 1. + G * Like g, but default is last line in file. + p, % * Position to N percent into the file. + m<letter> Mark the current position with <letter>. + '<letter> Return to a previously marked position. + '' Return to previous position. + + E [file] Examine a new file. + N * Examine the next file (from the command line). + P * Examine the previous file (from the command line). + = Print current file name. + V Print version number of "less". + + -<flag> Toggle a command line flag. + +cmd Execute the less cmd each time a new file is examined. + + !command Passes the command to a shell to be executed. + v Edit the current file with $EDITOR. +EOT + for (@helplines) { + s/$/\n/; + } +} + +sub percent { + &standout; + $percent = int(($line + $lines1) * 100 / @lines); + &move($lines1,0); + &addstr("($percent%)"); + &standend; + &clrtoeol; +} |