diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/abbrev.pl | 32 | ||||
| -rw-r--r-- | lib/complete.pl | 84 | ||||
| -rw-r--r-- | lib/dumpvar.pl | 28 | ||||
| -rw-r--r-- | lib/getopt.pl | 12 | ||||
| -rw-r--r-- | lib/getopts.pl | 45 | ||||
| -rw-r--r-- | lib/importenv.pl | 4 | ||||
| -rw-r--r-- | lib/look.pl | 44 | ||||
| -rw-r--r-- | lib/perldb.pl | 434 | ||||
| -rw-r--r-- | lib/stat.pl | 4 | ||||
| -rw-r--r-- | lib/termcap.pl | 164 | ||||
| -rw-r--r-- | lib/validate.pl | 103 |
11 files changed, 947 insertions, 7 deletions
diff --git a/lib/abbrev.pl b/lib/abbrev.pl new file mode 100644 index 0000000000..5859a7be48 --- /dev/null +++ b/lib/abbrev.pl @@ -0,0 +1,32 @@ +;# Usage: +;# %foo = (); +;# &abbrev(*foo,LIST); +;# ... +;# $long = $foo{$short}; + +package abbrev; + +sub main'abbrev { + local(*domain) = @_; + shift(@_); + @cmp = @_; + foreach $name (@_) { + @extra = split(//,$name); + $abbrev = shift(@extra); + $len = 1; + foreach $cmp (@cmp) { + next if $cmp eq $name; + while (substr($cmp,0,$len) eq $abbrev) { + $abbrev .= shift(@extra); + ++$len; + } + } + $domain{$abbrev} = $name; + while ($#extra >= 0) { + $abbrev .= shift(@extra); + $domain{$abbrev} = $name; + } + } +} + +1; diff --git a/lib/complete.pl b/lib/complete.pl new file mode 100644 index 0000000000..fd50674086 --- /dev/null +++ b/lib/complete.pl @@ -0,0 +1,84 @@ +;# +;# @(#)complete.pl 1.0 (sun!waynet) 11/11/88 +;# +;# Author: Wayne Thompson +;# +;# Description: +;# This routine provides word completion. +;# (TAB) attempts word completion. +;# (^D) prints completion list. +;# +;# Diagnostics: +;# Bell when word completion fails. +;# +;# Dependencies: +;# The tty driver is put into raw mode. +;# +;# Bugs: +;# The erase and kill characters are hard coded. +;# +;# Usage: +;# $input = do Complete('prompt_string', @completion_list); +;# + +sub Complete { + local ($prompt) = shift (@_); + local ($c, $cmp, $l, $r, $ret, $return, $test); + @_ = sort @_; + system 'stty raw -echo'; + loop: { + print $prompt, $return; + while (($c = getc(stdin)) ne "\r") { + if ($c eq "\t") { # (TAB) attempt completion + @_match = (); + foreach $cmp (@_) { + push (@_match, $cmp) if $cmp =~ /^$return/; + } + $test = $_match[0]; + $l = length ($test); + unless ($#_match == 0) { + shift (@_match); + foreach $cmp (@_match) { + until (substr ($cmp, 0, $l) eq substr ($test, 0, $l)) { + $l--; + } + } + print "\007"; + } + print $test = substr ($test, $r, $l - $r); + $r = length ($return .= $test); + } + elsif ($c eq "\004") { # (^D) completion list + print "\r\n"; + foreach $cmp (@_) { + print "$cmp\r\n" if $cmp =~ /^$return/; + } + redo loop; + } + elsif ($c eq "\025" && $r) { # (^U) kill + $return = ''; + $r = 0; + print "\r\n"; + redo loop; + } + # (DEL) || (BS) erase + elsif ($c eq "\177" || $c eq "\010") { + if($r) { + print "\b \b"; + chop ($return); + $r--; + } + } + elsif ($c =~ /\S/) { # printable char + $return .= $c; + $r++; + print $c; + } + } + } + system 'stty -raw echo'; + print "\n"; + $return; +} + +1; diff --git a/lib/dumpvar.pl b/lib/dumpvar.pl new file mode 100644 index 0000000000..8a49ec09e7 --- /dev/null +++ b/lib/dumpvar.pl @@ -0,0 +1,28 @@ +package dumpvar; + +sub main'dumpvar { + ($package) = @_; + local(*stab) = eval("*_$package"); + while (($key,$val) = each(%stab)) { + { + local(*entry) = $val; + if (defined $entry) { + print "\$$key = '$entry'\n"; + } + if (defined @entry) { + print "\@$key = (\n"; + foreach $num ($[ .. $#entry) { + print " $num\t'",$entry[$num],"'\n"; + } + print ")\n"; + } + if ($key ne "_$package" && defined %entry) { + print "\%$key = (\n"; + foreach $key (sort keys(%entry)) { + print " $key\t'",$entry{$key},"'\n"; + } + print ")\n"; + } + } + } +} diff --git a/lib/getopt.pl b/lib/getopt.pl index 4832233ed2..b85b643e22 100644 --- a/lib/getopt.pl +++ b/lib/getopt.pl @@ -1,4 +1,4 @@ -;# $Header: getopt.pl,v 2.0 88/06/05 00:16:22 root Exp $ +;# $Header: getopt.pl,v 3.0 89/10/18 15:19:26 lwall Locked $ ;# Process single-character switches with switch clustering. Pass one argument ;# which is a string containing all switches that take an argument. For each @@ -17,11 +17,11 @@ sub Getopt { ($first,$rest) = ($1,$2); if (index($argumentative,$first) >= $[) { if ($rest ne '') { - shift; + shift(@ARGV); } else { - shift; - $rest = shift; + shift(@ARGV); + $rest = shift(@ARGV); } eval "\$opt_$first = \$rest;"; } @@ -31,8 +31,10 @@ sub Getopt { $ARGV[0] = "-$rest"; } else { - shift; + shift(@ARGV); } } } } + +1; diff --git a/lib/getopts.pl b/lib/getopts.pl new file mode 100644 index 0000000000..926988516e --- /dev/null +++ b/lib/getopts.pl @@ -0,0 +1,45 @@ +;# getopts.pl - a better getopt.pl + +;# Usage: +;# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a +;# # side effect. + +sub Getopts { + local($argumentative) = @_; + local(@args,$_,$first,$rest); + + @args = split( / */, $argumentative ); + while(($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + $pos = index($argumentative,$first); + if($pos >= $[) { + if($args[$pos+1] eq ':') { + shift; + if($rest eq '') { + $rest = shift; + } + eval "\$opt_$first = \$rest;"; + } + else { + eval "\$opt_$first = 1"; + if($rest eq '') { + shift; + } + else { + $ARGV[0] = "-$rest"; + } + } + } + else { + print stderr "Unknown option: $first\n"; + if($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift; + } + } + } +} + +1; diff --git a/lib/importenv.pl b/lib/importenv.pl index c0c2be088e..c321a20219 100644 --- a/lib/importenv.pl +++ b/lib/importenv.pl @@ -1,4 +1,4 @@ -;# $Header: importenv.pl,v 2.0 88/06/05 00:16:17 root Exp $ +;# $Header: importenv.pl,v 3.0 89/10/18 15:19:39 lwall Locked $ ;# This file, when interpreted, pulls the environment into normal variables. ;# Usage: @@ -12,3 +12,5 @@ foreach $key (keys(ENV)) { $tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/; } eval $tmp; + +1; diff --git a/lib/look.pl b/lib/look.pl new file mode 100644 index 0000000000..ebbaa73a3d --- /dev/null +++ b/lib/look.pl @@ -0,0 +1,44 @@ +;# Usage: &look(*FILEHANDLE,$key,$dict,$fold) + +;# Sets file position in FILEHANDLE to be first line greater than or equal +;# (stringwise) to $key. Pass flags for dictionary order and case folding. + +sub look { + local(*FH,$key,$fold) = @_; + local($max,$min,$mid,$_); + local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(FH); + $blksize = 8192 unless $blksize; + $key =~ s/[^\w\s]//g if $dict; + $key =~ y/A-Z/a-z/ if $fold; + $max = $size + $blksize - 1; + $max -= $size % $blksize; + while ($max - $min > $blksize) { + $mid = ($max + $min) / 2; + die "look: internal error" if $mid % $blksize; + seek(FH,$mid,0); + $_ = <FH>; # probably a partial line + $_ = <FH>; + chop; + s/[^\w\s]//g if $dict; + y/A-Z/a-z/ if $fold; + if ($_ lt $key) { + $min = $mid; + } + else { + $max = $mid; + } + } + seek(FH,$min,0); + while (<FH>) { + chop; + s/[^\w\s]//g if $dict; + y/A-Z/a-z/ if $fold; + last if $_ ge $key; + $min = tell(FH); + } + seek(FH,$min,0); + $min; +} + +1; diff --git a/lib/perldb.pl b/lib/perldb.pl new file mode 100644 index 0000000000..51f6c24e11 --- /dev/null +++ b/lib/perldb.pl @@ -0,0 +1,434 @@ +package DB; + +$header = '$Header: perldb.pl,v 3.0 89/10/18 15:19:46 lwall Locked $'; +# +# This file is automatically included if you do perl -d. +# It's probably not useful to include this yourself. +# +# Perl supplies the values for @line and %sub. It effectively inserts +# a do DB'DB(<linenum>); in front of every place that can +# have a breakpoint. It also inserts a do 'perldb.pl' before the first line. +# +# $Log: perldb.pl,v $ +# Revision 3.0 89/10/18 15:19:46 lwall +# 3.0 baseline +# +# Revision 2.0 88/06/05 00:09:45 root +# Baseline version 2.0. +# +# + +open(IN,"/dev/tty"); # so we don't dingle stdin +open(OUT,">/dev/tty"); # so we don't dongle stdout +select(OUT); +$| = 1; # for DB'OUT +select(STDOUT); +$| = 1; # for real STDOUT + +$header =~ s/\$Header: perldb.pl,v 3.0 89/10/18 15:19:46 lwall Locked $/$1$2/; +print OUT "\nLoading DB from $header\n\n"; + +sub DB { + local($. ,$@, $!, $[, $,, $/, $\); + $[ = 0; $, = ""; $/ = "\n"; $\ = ""; + ($line) = @_; + if ($stop[$line]) { + if ($stop eq '1') { + $signal |= 1; + } + else { + package main; + $DB'signal |= eval $DB'stop[$DB'line]; print DB'OUT $@; + $DB'stop[$DB'line] =~ s/;9$//; + } + } + if ($single || $trace || $signal) { + print OUT "$sub($line):\t",$line[$line]; + for ($i = $line + 1; $i <= $max && $line[$i] == 0; ++$i) { + last if $line[$i] =~ /^\s*(}|#|\n)/; + print OUT "$sub($i):\t",$line[$i]; + } + } + if ($action[$line]) { + package main; + eval $DB'action[$DB'line]; print DB'OUT $@; + } + if ($single || $signal) { + if ($pre) { + package main; + eval $DB'pre; print DB'OUT $@; + } + print OUT $#stack . " levels deep in subroutine calls!\n" + if $single & 4; + $start = $line; + while ((print OUT " DB<", $#hist+1, "> "), $cmd=<IN>) { + $single = 0; + $signal = 0; + $cmd eq '' && exit 0; + chop($cmd); + $cmd =~ /^q$/ && exit 0; + $cmd =~ /^$/ && ($cmd = $laststep); + push(@hist,$cmd) if length($cmd) > 1; + ($i) = split(/\s+/,$cmd); + eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i}; + $cmd =~ /^h$/ && do { + print OUT " +T Stack trace. +s Single step. +n Next, steps over subroutine calls. +f Finish current subroutine. +c [line] Continue; optionally inserts a one-time-only breakpoint + at the specified line. +<CR> Repeat last n or s. +l min+incr List incr+1 lines starting at min. +l min-max List lines. +l line List line; +l List next window. +- List previous window. +w line List window around line. +l subname List subroutine. +/pattern/ Search forwards for pattern; final / is optional. +?pattern? Search backwards for pattern. +L List breakpoints and actions. +S List subroutine names. +t Toggle trace mode. +b [line] [condition] + Set breakpoint; line defaults to the current execution line; + condition breaks if it evaluates to true, defaults to \'1\'. +b subname [condition] + Set breakpoint at first line of subroutine. +d [line] Delete breakpoint. +D Delete all breakpoints. +a [line] command + Set an action to be done before the line is executed. + 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). +< command Define command before prompt. +> command Define command after prompt. +! number Redo command (default previous command). +! -number Redo number\'th to last command. +H -number Display last number commands (default all). +q or ^D Quit. +p expr Same as \"package main; print DB'OUT expr\". +command Execute as a perl statement. + +"; + next; }; + $cmd =~ /^t$/ && do { + $trace = !$trace; + print OUT "Trace = ".($trace?"on":"off")."\n"; + next; }; + $cmd =~ /^S$/ && do { + foreach $subname (sort(keys %sub)) { + if ($subname =~ /^main'(.*)/) { + print OUT $1,"\n"; + } + else { + print OUT $subname,"\n"; + } + } + next; }; + $cmd =~ /^V$/ && do { + $cmd = 'V main'; }; + $cmd =~ /^V\s*(['A-Za-z_]['\w]*)$/ && do { + $packname = $1; + do 'dumpvar.pl' unless defined &main'dumpvar; + if (defined &main'dumpvar) { + &main'dumpvar($packname); + } + else { + print DB'OUT "dumpvar.pl not available.\n"; + } + next; }; + $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do { + $subname = $1; + $subname = "main'" . $subname unless $subname =~ /'/; + $subrange = $sub{$subname}; + if ($subrange) { + if (eval($subrange) < -$window) { + $subrange =~ s/-.*/+/; + } + $cmd = "l $subrange"; + } else { + print OUT "Subroutine $1 not found.\n"; + next; + } }; + $cmd =~ /^w\s*(\d*)$/ && do { + $incr = $window - 1; + $start = $1 if $1; + $start -= $preview; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^-$/ && do { + $incr = $window - 1; + $cmd = 'l ' . ($start-$window*2) . '+'; }; + $cmd =~ /^l$/ && do { + $incr = $window - 1; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do { + $start = $1 if $1; + $incr = $2; + $incr = $window - 1 unless $incr; + $cmd = 'l ' . $start . '-' . ($start + $incr); }; + $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do { + $end = (!$2) ? $max : ($4 ? $4 : $2); + $end = $max if $end > $max; + $i = $2; + $i = $line if $i eq '.'; + $i = 1 if $i < 1; + for (; $i <= $end; $i++) { + print OUT "$i:\t", $line[$i]; + last if $signal; + } + $start = $i; # remember in case they want more + $start = $max if $start > $max; + next; }; + $cmd =~ /^D$/ && do { + print OUT "Deleting all breakpoints...\n"; + for ($i = 1; $i <= $max ; $i++) { + $stop[$i] = 0; + } + next; }; + $cmd =~ /^L$/ && do { + for ($i = 1; $i <= $max; $i++) { + if ($stop[$i] || $action[$i]) { + print OUT "$i:\t", $line[$i]; + print OUT " break if (", $stop[$i], ")\n" + if $stop[$i]; + print OUT " action: ", $action[$i], "\n" + if $action[$i]; + last if $signal; + } + } + next; }; + $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do { + $subname = $1; + $subname = "main'" . $subname unless $subname =~ /'/; + ($i) = split(/-/, $sub{$subname}); + if ($i) { + ++$i while $line[$i] == 0 && $i < $#line; + $stop[$i] = $2 ? $2 : 1; + } else { + print OUT "Subroutine $1 not found.\n"; + } + next; }; + $cmd =~ /^b\s*(\d*)\s*(.*)/ && do { + $i = ($1?$1:$line); + if ($line[$i] == 0) { + print OUT "Line $i not breakable.\n"; + } else { + $stop[$i] = $2 ? $2 : 1; + } + next; }; + $cmd =~ /^d\s*(\d+)?/ && do { + $i = ($1?$1:$line); + $stop[$i] = ''; + next; }; + $cmd =~ /^A$/ && do { + for ($i = 1; $i <= $max ; $i++) { + $action[$i] = ''; + } + next; }; + $cmd =~ /^<\s*(.*)/ && do { + $pre = do action($1); + next; }; + $cmd =~ /^>\s*(.*)/ && do { + $post = do action($1); + next; }; + $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do { + $i = $1; + if ($line[$i] == 0) { + print OUT "Line $i may not have an action.\n"; + } else { + $action[$i] = do action($3); + } + next; }; + $cmd =~ /^n$/ && do { + $single = 2; + $laststep = $cmd; + last; }; + $cmd =~ /^s$/ && do { + $single = 1; + $laststep = $cmd; + last; }; + $cmd =~ /^c\s*(\d*)\s*$/ && do { + $i = $1; + if ($i) { + if ($line[$i] == 0) { + print OUT "Line $i not breakable.\n"; + next; + } + $stop[$i] .= ";9"; # add one-time-only b.p. + } + for ($i=0; $i <= $#stack; ) { + $stack[$i++] &= ~1; + } + last; }; + $cmd =~ /^f$/ && do { + $stack[$#stack] |= 2; + last; }; + $cmd =~ /^T$/ && do { + for ($i=0; $i <= $#sub; ) { + print OUT $sub[$i++], "\n"; + last if $signal; + } + next; }; + $cmd =~ /^\/(.*)$/ && do { + $inpat = $1; + $inpat =~ s:([^\\])/$:$1:; + if ($inpat ne "") { + eval '$inpat =~ m'."\n$inpat\n"; + if ($@ ne "") { + print OUT "$@"; + next; + } + $pat = $inpat; + } + $end = $start; + eval ' + for (;;) { + ++$start; + $start = 1 if ($start > $max); + last if ($start == $end); + if ($line[$start] =~ m'."\n$pat\n".'i) { + print OUT "$start:\t", $line[$start], "\n"; + last; + } + } '; + print OUT "/$pat/: not found\n" if ($start == $end); + next; }; + $cmd =~ /^\?(.*)$/ && do { + $inpat = $1; + $inpat =~ s:([^\\])\?$:$1:; + if ($inpat ne "") { + eval '$inpat =~ m'."\n$inpat\n"; + if ($@ ne "") { + print OUT "$@"; + next; + } + $pat = $inpat; + } + $end = $start; + eval ' + for (;;) { + --$start; + $start = $max if ($start <= 0); + last if ($start == $end); + if ($line[$start] =~ m'."\n$pat\n".'i) { + print OUT "$start:\t", $line[$start], "\n"; + last; + } + } '; + print OUT "?$pat?: not found\n" if ($start == $end); + next; }; + $cmd =~ /^!+\s*(-)?(\d+)?$/ && do { + pop(@hist) if length($cmd) > 1; + $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist)); + $cmd = $hist[$i] . "\n"; + print OUT $cmd; + redo; }; + $cmd =~ /^!(.+)$/ && do { + $pat = "^$1"; + pop(@hist) if length($cmd) > 1; + for ($i = $#hist; $i; --$i) { + last if $hist[$i] =~ $pat; + } + if (!$i) { + print OUT "No such command!\n\n"; + next; + } + $cmd = $hist[$i] . "\n"; + print OUT $cmd; + redo; }; + $cmd =~ /^H\s*(-(\d+))?/ && do { + $end = $2?($#hist-$2):0; + $hist = 0 if $hist < 0; + for ($i=$#hist; $i>$end; $i--) { + print OUT "$i: ",$hist[$i],"\n" + unless $hist[$i] =~ /^.?$/; + }; + next; }; + $cmd =~ s/^p( .*)?$/print DB'OUT$1/; + { + package main; + eval $DB'cmd; + } + print OUT $@,"\n"; + } + if ($post) { + package main; + eval $DB'post; print DB'OUT $@; + } + } +} + +sub action { + local($action) = @_; + while ($action =~ s/\\$//) { + print OUT "+ "; + $action .= <IN>; + } + $action; +} + +sub catch { + $signal = 1; +} + +sub sub { + push(@stack, $single); + $single &= 1; + $single |= 4 if $#stack == $deep; + local(@args) = @_; + for (@args) { + if (/^Stab/ && length($_) == length($_main{'_main'})) { + $_ = sprintf("%s",$_); + print "ARG: $_\n"; + } + else { + s/'/\\'/g; + s/(.*)/'$1'/ unless /^-?[\d.]+$/; + } + } + push(@sub, $sub . '(' . join(', ', @args) . ') from ' . $line); + if (wantarray) { + @i = &$sub; + } + else { + $i = &$sub; + @i = $i; + } + --$#sub; + $single |= pop(@stack); + @i; +} + +$single = 1; # so it stops on first executable statement +$max = $#line; +@hist = ('?'); +$SIG{'INT'} = "DB'catch"; +$deep = 100; # warning if stack gets this deep +$window = 10; +$preview = 3; + +@stack = (0); +@args = @ARGV; +for (@args) { + s/'/\\'/g; + s/(.*)/'$1'/ unless /^-?[\d.]+$/; +} +push(@sub, 'main(' . join(', ', @args) . ")" ); +$sub = 'main'; + +if (-f '.perldb') { + do './.perldb'; +} +elsif (-f "$ENV{'LOGDIR'}/.perldb") { + do "$ENV{'LOGDIR'}/.perldb"; +} +elsif (-f "$ENV{'HOME'}/.perldb") { + do "$ENV{'HOME'}/.perldb"; +} + +1; diff --git a/lib/stat.pl b/lib/stat.pl index 1895c58c19..8cf0bde193 100644 --- a/lib/stat.pl +++ b/lib/stat.pl @@ -1,4 +1,4 @@ -;# $Header: stat.pl,v 2.0 88/06/05 00:16:29 root Exp $ +;# $Header: stat.pl,v 3.0 89/10/18 15:19:53 lwall Locked $ ;# Usage: ;# @ary = stat(foo); @@ -25,3 +25,5 @@ sub Stat { ($st_dev,$st_ino,$st_mode,$st_nlink,$st_uid,$st_gid,$st_rdev,$st_size, $st_atime,$st_mtime,$st_ctime,$st_blksize,$st_blocks) = stat(shift(@_)); } + +1; diff --git a/lib/termcap.pl b/lib/termcap.pl new file mode 100644 index 0000000000..ab693f28d7 --- /dev/null +++ b/lib/termcap.pl @@ -0,0 +1,164 @@ +;# $Header: termcap.pl,v 3.0 89/10/18 15:19:58 lwall Locked $ +;# +;# Usage: +;# do 'ioctl.pl'; +;# ioctl(TTY,$TIOCGETP,$foo); +;# ($ispeed,$ospeed) = unpack('cc',$foo); +;# do 'termcap.pl'; +;# do Tgetent('vt100'); # sets $TC{'cm'}, etc. +;# do Tgoto($TC{'cm'},$row,$col); +;# do Tputs($TC{'dl'},$affcnt,'FILEHANDLE'); +;# +sub Tgetent { + local($TERM) = @_; + local($TERMCAP,$_,$entry,$loop,$field); + + warn "Tgetent: no ospeed set" unless $ospeed; + foreach $key (keys(TC)) { + delete $TC{$key}; + } + $TERM = $ENV{'TERM'} unless $TERM; + $TERMCAP = $ENV{'TERMCAP'}; + $TERMCAP = '/etc/termcap' unless $TERMCAP; + if ($TERMCAP !~ m:^/:) { + if (index($TERMCAP,"|$TERM|") < $[) { + $TERMCAP = '/etc/termcap'; + } + } + if ($TERMCAP =~ m:^/:) { + $entry = ''; + do { + $loop = " + open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\"; + while (<TERMCAP>) { + next if /^#/; + next if /^\t/; + if (/\\|$TERM[:\\|]/) { + chop; + while (chop eq '\\\\') { + \$_ .= <TERMCAP>; + chop; + } + \$_ .= ':'; + last; + } + } + close TERMCAP; + \$entry .= \$_; + "; + eval $loop; + } while s/:tc=([^:]+):/:/, $TERM = $1; + $TERMCAP = $entry; + } + + foreach $field (split(/:[\s:\\]*/,$TERMCAP)) { + if ($field =~ /^\w\w$/) { + $TC{$field} = 1; + } + elsif ($field =~ /^(\w\w)#(.*)/) { + $TC{$1} = $2 if $TC{$1} eq ''; + } + elsif ($field =~ /^(\w\w)=(.*)/) { + $entry = $1; + $_ = $2; + s/\\E/\033/g; + s/\\(\d\d\d)/pack('c',$1 & 0177)/eg; + s/\\n/\n/g; + s/\\r/\r/g; + s/\\t/\t/g; + s/\\b/\b/g; + s/\\f/\f/g; + s/\\\^/\377/g; + s/\^\?/\177/g; + s/\^(.)/pack('c',$1 & 031)/eg; + s/\\(.)/$1/g; + s/\377/^/g; + $TC{$entry} = $_ if $TC{$entry} eq ''; + } + } + $TC{'pc'} = "\0" if $TC{'pc'} eq ''; + $TC{'bc'} = "\b" if $TC{'bc'} eq ''; +} + +@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); + +sub Tputs { + local($string,$affcnt,$FH) = @_; + local($ms); + if ($string =~ /(^[\d.]+)(\*?)(.*)$/) { + $ms = $1; + $ms *= $affcnt if $2; + $string = $3; + $decr = $Tputs[$ospeed]; + if ($decr > .1) { + $ms += $decr / 2; + $string .= $TC{'pc'} x ($ms / $decr); + } + } + print $FH $string if $FH; + $string; +} + +sub Tgoto { + local($string) = shift(@_); + local($result) = ''; + local($after) = ''; + local($code,$tmp) = @_; + @_ = ($tmp,$code); + local($online) = 0; + while ($string =~ /^([^%]*)%(.)(.*)/) { + $result .= $1; + $code = $2; + $string = $3; + if ($code eq 'd') { + $result .= sprintf("%d",shift(@_)); + } + elsif ($code eq '.') { + $tmp = shift(@_); + if ($tmp == 0 || $tmp == 4 || $tmp == 10) { + if ($online) { + ++$tmp, $after .= $TC{'up'} if $TC{'up'}; + } + else { + ++$tmp, $after .= $TC{'bc'}; + } + } + $result .= sprintf("%c",$tmp); + $online = !$online; + } + elsif ($code eq '+') { + $result .= sprintf("%c",shift(@_)+ord($string)); + $string = substr($string,1,99); + $online = !$online; + } + elsif ($code eq 'r') { + ($code,$tmp) = @_; + @_ = ($tmp,$code); + $online = !$online; + } + elsif ($code eq '>') { + ($code,$tmp,$string) = unpack("CCa99",$string); + if ($_[$[] > $code) { + $_[$[] += $tmp; + } + } + elsif ($code eq '2') { + $result .= sprintf("%02d",shift(@_)); + $online = !$online; + } + elsif ($code eq '3') { + $result .= sprintf("%03d",shift(@_)); + $online = !$online; + } + elsif ($code eq 'i') { + ($code,$tmp) = @_; + @_ = ($code+1,$tmp+1); + } + else { + return "OOPS"; + } + } + $result . $string . $after; +} + +1; diff --git a/lib/validate.pl b/lib/validate.pl new file mode 100644 index 0000000000..bee7bbaddf --- /dev/null +++ b/lib/validate.pl @@ -0,0 +1,103 @@ +;# $Header: validate.pl,v 3.0 89/10/18 15:20:04 lwall Locked $ + +;# The validate routine takes a single multiline string consisting of +;# lines containing a filename plus a file test to try on it. (The +;# file test may also be a 'cd', causing subsequent relative filenames +;# to be interpreted relative to that directory.) After the file test +;# you may put '|| die' to make it a fatal error if the file test fails. +;# The default is '|| warn'. The file test may optionally have a ! prepended +;# to test for the opposite condition. If you do a cd and then list some +;# relative filenames, you may want to indent them slightly for readability. +;# If you supply your own "die" or "warn" message, you can use $file to +;# interpolate the filename. + +;# Filetests may be bunched: -rwx tests for all of -r, -w and -x. +;# Only the first failed test of the bunch will produce a warning. + +;# The routine returns the number of warnings issued. + +;# Usage: +;# $warnings += do validate(' +;# /vmunix -e || die +;# /boot -e || die +;# /bin cd +;# csh -ex +;# csh !-ug +;# sh -ex +;# sh !-ug +;# /usr -d || warn "What happened to $file?\n" +;# '); + +sub validate { + local($file,$test,$warnings,$oldwarnings); + foreach $check (split(/\n/,$_[0])) { + next if $check =~ /^#/; + next if $check =~ /^$/; + ($file,$test) = split(' ',$check,2); + if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) { + $testlist = $2; + @testlist = split(//,$testlist); + } + else { + @testlist = ('Z'); + } + $oldwarnings = $warnings; + foreach $one (@testlist) { + $this = $test; + $this =~ s/(-\w\b)/$1 \$file/g; + $this =~ s/-Z/-$one/; + $this .= ' || warn' unless $this =~ /\|\|/; + $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || do valmess('$2','$1')/; + $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g; + eval $this; + last if $warnings > $oldwarnings; + } + } + $warnings; +} + +sub valmess { + local($disposition,$this) = @_; + $file = $cwd . '/' . $file unless $file =~ m|^/|; + if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { + $neg = $1; + $tmp = $2; + $tmp eq 'r' && ($mess = "$file is not readable by uid $>."); + $tmp eq 'w' && ($mess = "$file is not writable by uid $>."); + $tmp eq 'x' && ($mess = "$file is not executable by uid $>."); + $tmp eq 'o' && ($mess = "$file is not owned by uid $>."); + $tmp eq 'R' && ($mess = "$file is not readable by you."); + $tmp eq 'W' && ($mess = "$file is not writable by you."); + $tmp eq 'X' && ($mess = "$file is not executable by you."); + $tmp eq 'O' && ($mess = "$file is not owned by you."); + $tmp eq 'e' && ($mess = "$file does not exist."); + $tmp eq 'z' && ($mess = "$file does not have zero size."); + $tmp eq 's' && ($mess = "$file does not have non-zero size."); + $tmp eq 'f' && ($mess = "$file is not a plain file."); + $tmp eq 'd' && ($mess = "$file is not a directory."); + $tmp eq 'l' && ($mess = "$file is not a symbolic link."); + $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO)."); + $tmp eq 'S' && ($mess = "$file is not a socket."); + $tmp eq 'b' && ($mess = "$file is not a block special file."); + $tmp eq 'c' && ($mess = "$file is not a character special file."); + $tmp eq 'u' && ($mess = "$file does not have the setuid bit set."); + $tmp eq 'g' && ($mess = "$file does not have the setgid bit set."); + $tmp eq 'k' && ($mess = "$file does not have the sticky bit set."); + $tmp eq 'T' && ($mess = "$file is not a text file."); + $tmp eq 'B' && ($mess = "$file is not a binary file."); + if ($neg eq '!') { + $mess =~ s/ is not / should not be / || + $mess =~ s/ does not / should not / || + $mess =~ s/ not / /; + } + print stderr $mess,"\n"; + } + else { + $this =~ s/\$file/'$file'/g; + print stderr "Can't do $this.\n"; + } + if ($disposition eq 'die') { exit 1; } + ++$warnings; +} + +1; |