summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/AutoLoader.pm3
-rw-r--r--lib/Carp.pm21
-rw-r--r--lib/Cwd.pm17
-rw-r--r--lib/English.pm206
-rw-r--r--lib/Exporter.pm123
-rw-r--r--lib/ExtUtils/MakeMaker.pm16
-rwxr-xr-xlib/ExtUtils/xsubpp27
-rw-r--r--lib/File/Basename.pm24
-rw-r--r--lib/File/CheckTree.pm4
-rw-r--r--lib/File/Find.pm31
-rw-r--r--lib/File/Path.pm33
-rw-r--r--lib/Math/BigInt.pm24
-rw-r--r--lib/SubstrHash.pm140
-rw-r--r--lib/Sys/Syslog.pm2
-rw-r--r--lib/Term/Cap.pm251
-rw-r--r--lib/TieHash.pm16
-rw-r--r--lib/assert.pl15
-rw-r--r--lib/bigrat.pl1
-rw-r--r--lib/perl5db.pl17
-rw-r--r--lib/pwd.pl1
20 files changed, 712 insertions, 260 deletions
diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm
index 3f5eef2375..92109a3681 100644
--- a/lib/AutoLoader.pm
+++ b/lib/AutoLoader.pm
@@ -14,6 +14,9 @@ AUTOLOAD {
if ($name =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
eval {require $name};
}
+ elsif ($AUTOLOAD =~ /::DESTROY$/) {
+ eval "sub $AUTOLOAD {}";
+ }
if ($@){
$@ =~ s/ at .*\n//;
croak $@;
diff --git a/lib/Carp.pm b/lib/Carp.pm
index 5daba5c289..c847b77b36 100644
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -3,6 +3,8 @@ package Carp;
# This package implements handy routines for modules that wish to throw
# exceptions outside of the current package.
+$CarpLevel = 0; # How many extra package levels to skip on carp.
+
require Exporter;
@ISA = Exporter;
@EXPORT = qw(confess croak carp);
@@ -10,7 +12,7 @@ require Exporter;
sub longmess {
my $error = shift;
my $mess = "";
- my $i = 2;
+ my $i = 1 + $CarpLevel;
my ($pack,$file,$line,$sub);
while (($pack,$file,$line,$sub) = caller($i++)) {
$mess .= "\t$sub " if $error eq "called";
@@ -20,18 +22,27 @@ sub longmess {
$mess || $error;
}
-sub shortmess {
- my $error = shift;
+sub shortmess { # Short-circuit &longmess if called via multiple packages
+ my $error = $_[0]; # Instead of "shift"
my ($curpack) = caller(1);
+ my $extra = $CarpLevel;
my $i = 2;
my ($pack,$file,$line,$sub);
while (($pack,$file,$line,$sub) = caller($i++)) {
- return "$error at $file line $line\n" if $pack ne $curpack;
+ if ($pack ne $curpack) {
+ if ($extra-- > 0) {
+ $curpack = $pack;
+ }
+ else {
+ return "$error at $file line $line\n";
+ }
+ }
}
- longmess $error;
+ goto &longmess;
}
sub confess { die longmess @_; }
sub croak { die shortmess @_; }
sub carp { warn shortmess @_; }
+1;
diff --git a/lib/Cwd.pm b/lib/Cwd.pm
index b27e088847..20b175c81d 100644
--- a/lib/Cwd.pm
+++ b/lib/Cwd.pm
@@ -1,18 +1,30 @@
package Cwd;
require 5.000;
require Exporter;
+use Config;
@ISA = qw(Exporter);
@EXPORT = qw(getcwd fastcwd);
@EXPORT_OK = qw(chdir);
+# VMS: $ENV{'DEFAULT'} points to default directory at all times
+# 08-Dec-1994 Charles Bailey bailey@genetics.upenn.edu
+# Note: Use of Cwd::getcwd() or Cwd::chdir() (but not Cwd::fastcwd())
+# causes the logical name PWD to be defined in the process
+# logical name table as the default device and directory
+# seen by Perl. This may not be the same as the default device
+# and directory seen by DCL after Perl exits, since the effects
+# the CRTL chdir() function persist only until Perl exits.
+
# By Brandon S. Allbery
#
# Usage: $cwd = getcwd();
sub getcwd
{
+ if($Config{'osname'} eq 'VMS') { return $ENV{'PWD'} = $ENV{'DEFAULT'} }
+
my($dotdots, $cwd, @pst, @cst, $dir, @tst);
unless (@cst = stat('.'))
@@ -79,6 +91,8 @@ sub getcwd
# you might chdir out of a directory that you can't chdir back into.
sub fastcwd {
+ if($Config{'osname'} eq 'VMS') { return $ENV{'DEFAULT'} }
+
my($odev, $oino, $cdev, $cino, $tdev, $tino);
my(@path, $path);
local(*DIR);
@@ -143,8 +157,11 @@ sub chdir_init{
sub chdir {
my($newdir) = shift;
+ $newdir =~ s|/{2,}|/|g;
chdir_init() unless $chdir_init;
return 0 unless (CORE::chdir $newdir);
+ if ($Config{'osname'} eq 'VMS') { return $ENV{PWD} = $ENV{DEFAULT} }
+
if ($newdir =~ m#^/#) {
$ENV{'PWD'} = $newdir;
}else{
diff --git a/lib/English.pm b/lib/English.pm
index b203721a52..d40d28af7d 100644
--- a/lib/English.pm
+++ b/lib/English.pm
@@ -3,59 +3,65 @@ package English;
require Exporter;
@ISA = (Exporter);
-local($^W) = 0;
+local $^W = 0;
+
+# Grandfather $NAME import
+sub import {
+ my $this = shift;
+ my @list = @_;
+ local $Exporter::ExportLevel = 1;
+ Exporter::import($this,grep {s/^\$/*/} @list);
+}
@EXPORT = qw(
*ARG
- $MATCH
- $PREMATCH
- $POSTMATCH
- $LAST_PAREN_MATCH
- $INPUT_LINE_NUMBER
- $NR
- $INPUT_RECORD_SEPARATOR
- $RS
- $OUTPUT_AUTOFLUSH
- $OUTPUT_FIELD_SEPARATOR
- $OFS
- $OUTPUT_RECORD_SEPARATOR
- $ORS
- $LIST_SEPARATOR
- $SUBSCRIPT_SEPARATOR
- $SUBSEP
- $FORMAT_PAGE_NUMBER
- $FORMAT_LINES_PER_PAGE
- $FORMAT_LINES_LEFT
- $FORMAT_NAME
- $FORMAT_TOP_NAME
- $FORMAT_LINE_BREAK_CHARACTERS
- $FORMAT_FORMFEED
- $CHILD_ERROR
- $OS_ERROR
- $ERRNO
- $EVAL_ERROR
- $PROCESS_ID
- $PID
- $REAL_USER_ID
- $UID
- $EFFECTIVE_USER_ID
- $EUID
- $REAL_GROUP_ID
- $GID
- $EFFECTIVE_GROUP_ID
- $EGID
- $PROGRAM_NAME
- $PERL_VERSION
- $DEBUGGING
- $SYSTEM_FD_MAX
- $INPLACE_EDIT
- $PERLDB
- $BASETIME
- $WARNING
- $EXECUTABLE_NAME
- $ARRAY_BASE
- $OFMT
- $MULTILINE_MATCHING
+ *MATCH
+ *PREMATCH
+ *POSTMATCH
+ *LAST_PAREN_MATCH
+ *INPUT_LINE_NUMBER
+ *NR
+ *INPUT_RECORD_SEPARATOR
+ *RS
+ *OUTPUT_AUTOFLUSH
+ *OUTPUT_FIELD_SEPARATOR
+ *OFS
+ *OUTPUT_RECORD_SEPARATOR
+ *ORS
+ *LIST_SEPARATOR
+ *SUBSCRIPT_SEPARATOR
+ *SUBSEP
+ *FORMAT_PAGE_NUMBER
+ *FORMAT_LINES_PER_PAGE
+ *FORMAT_LINES_LEFT
+ *FORMAT_NAME
+ *FORMAT_TOP_NAME
+ *FORMAT_LINE_BREAK_CHARACTERS
+ *FORMAT_FORMFEED
+ *CHILD_ERROR
+ *OS_ERROR
+ *ERRNO
+ *EVAL_ERROR
+ *PROCESS_ID
+ *PID
+ *REAL_USER_ID
+ *UID
+ *EFFECTIVE_USER_ID
+ *EUID
+ *REAL_GROUP_ID
+ *GID
+ *EFFECTIVE_GROUP_ID
+ *EGID
+ *PROGRAM_NAME
+ *PERL_VERSION
+ *ACCUMULATOR
+ *DEBUGGING
+ *SYSTEM_FD_MAX
+ *INPLACE_EDIT
+ *PERLDB
+ *BASETIME
+ *WARNING
+ *EXECUTABLE_NAME
);
# The ground of all being.
@@ -64,79 +70,79 @@ local($^W) = 0;
# Matching.
- *MATCH = \$& ;
- *PREMATCH = \$` ;
- *POSTMATCH = \$' ;
- *LAST_PAREN_MATCH = \$+ ;
+ *MATCH = *& ;
+ *PREMATCH = *` ;
+ *POSTMATCH = *' ;
+ *LAST_PAREN_MATCH = *+ ;
# Input.
- *INPUT_LINE_NUMBER = \$. ;
- *NR = \$. ;
- *INPUT_RECORD_SEPARATOR = \$/ ;
- *RS = \$/ ;
+ *INPUT_LINE_NUMBER = *. ;
+ *NR = *. ;
+ *INPUT_RECORD_SEPARATOR = */ ;
+ *RS = */ ;
# Output.
- *OUTPUT_AUTOFLUSH = \$| ;
- *OUTPUT_FIELD_SEPARATOR = \$, ;
- *OFS = \$, ;
- *OUTPUT_RECORD_SEPARATOR = \$\ ;
- *ORS = \$\ ;
+ *OUTPUT_AUTOFLUSH = *| ;
+ *OUTPUT_FIELD_SEPARATOR = *, ;
+ *OFS = *, ;
+ *OUTPUT_RECORD_SEPARATOR = *\ ;
+ *ORS = *\ ;
# Interpolation "constants".
- *LIST_SEPARATOR = \$" ;
- *SUBSCRIPT_SEPARATOR = \$; ;
- *SUBSEP = \$; ;
+ *LIST_SEPARATOR = *" ;
+ *SUBSCRIPT_SEPARATOR = *; ;
+ *SUBSEP = *; ;
# Formats
- *FORMAT_PAGE_NUMBER = \$% ;
- *FORMAT_LINES_PER_PAGE = \$= ;
- *FORMAT_LINES_LEFT = \$- ;
- *FORMAT_NAME = \$~ ;
- *FORMAT_TOP_NAME = \$^ ;
- *FORMAT_LINE_BREAK_CHARACTERS = \$: ;
- *FORMAT_FORMFEED = \$^L ;
+ *FORMAT_PAGE_NUMBER = *% ;
+ *FORMAT_LINES_PER_PAGE = *= ;
+ *FORMAT_LINES_LEFT = *- ;
+ *FORMAT_NAME = *~ ;
+ *FORMAT_TOP_NAME = *^ ;
+ *FORMAT_LINE_BREAK_CHARACTERS = *: ;
+ *FORMAT_FORMFEED = *^L ;
# Error status.
- *CHILD_ERROR = \$? ;
- *OS_ERROR = \$! ;
- *ERRNO = \$! ;
- *EVAL_ERROR = \$@ ;
+ *CHILD_ERROR = *? ;
+ *OS_ERROR = *! ;
+ *ERRNO = *! ;
+ *EVAL_ERROR = *@ ;
# Process info.
- *PROCESS_ID = \$$ ;
- *PID = \$$ ;
- *REAL_USER_ID = \$< ;
- *UID = \$< ;
- *EFFECTIVE_USER_ID = \$> ;
- *EUID = \$> ;
- *REAL_GROUP_ID = \$( ;
- *GID = \$( ;
- *EFFECTIVE_GROUP_ID = \$) ;
- *EGID = \$) ;
- *PROGRAM_NAME = \$0 ;
+ *PROCESS_ID = *$ ;
+ *PID = *$ ;
+ *REAL_USER_ID = *< ;
+ *UID = *< ;
+ *EFFECTIVE_USER_ID = *> ;
+ *EUID = *> ;
+ *REAL_GROUP_ID = *( ;
+ *GID = *( ;
+ *EFFECTIVE_GROUP_ID = *) ;
+ *EGID = *) ;
+ *PROGRAM_NAME = *0 ;
# Internals.
- *PERL_VERSION = \$] ;
- *ACCUMULATOR = \$^A ;
- *DEBUGGING = \$^D ;
- *SYSTEM_FD_MAX = \$^F ;
- *INPLACE_EDIT = \$^I ;
- *PERLDB = \$^P ;
- *BASETIME = \$^T ;
- *WARNING = \$^W ;
- *EXECUTABLE_NAME = \$^X ;
+ *PERL_VERSION = *] ;
+ *ACCUMULATOR = *^A ;
+ *DEBUGGING = *^D ;
+ *SYSTEM_FD_MAX = *^F ;
+ *INPLACE_EDIT = *^I ;
+ *PERLDB = *^P ;
+ *BASETIME = *^T ;
+ *WARNING = *^W ;
+ *EXECUTABLE_NAME = *^X ;
# Deprecated.
-# *ARRAY_BASE = \$[ ;
-# *OFMT = \$# ;
-# *MULTILINE_MATCHING = \$* ;
+# *ARRAY_BASE = *[ ;
+# *OFMT = *# ;
+# *MULTILINE_MATCHING = ** ;
1;
diff --git a/lib/Exporter.pm b/lib/Exporter.pm
index dce6909b18..add5657fac 100644
--- a/lib/Exporter.pm
+++ b/lib/Exporter.pm
@@ -1,29 +1,109 @@
package Exporter;
-require 5.000;
+=head1 Comments
+
+If the first entry in an import list begins with /, ! or : then
+treat the list as a series of specifications which either add to
+or delete from the list of names to import. They are processed
+left to right. Specifications are in the form:
+
+ [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
+ [!]name This name only
+ [!]:tag All names in $EXPORT_TAGS{":tag"}
+ [!]:DEFAULT All names in @EXPORT
+
+e.g., Foo.pm defines:
+
+ @EXPORT = qw(A1 A2 A3 A4 A5);
+ @EXPORT_OK = qw(B1 B2 B3 B4 B5);
+ %EXPORT_TAGS = (':T1' => [qw(A1 A2 B1 B2)], ':T2' => [qw(A1 A2 B3 B4)]);
+
+ Note that you cannot use tags in @EXPORT or @EXPORT_OK.
+ Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK.
+
+Application says:
+
+ use Module qw(:T2 !B3 A3);
+ use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET);
+ use POSIX qw(/^S_/ acos asin atan /^E/ !/^EXIT/);
+
+=cut
+
+require 5.001;
$ExportLevel = 0;
+$Verbose = 0;
+
+require Carp;
sub export {
- my $pack = shift;
- my $callpack = shift;
+
+ # First make import warnings look like they're coming from the "use".
+ local $SIG{__WARN__} = sub {
+ my $text = shift;
+ $text =~ s/ at \S*Exporter.pm line \d+.\n//;
+ local $Carp::CarpLevel = 1; # ignore package calling us too.
+ Carp::carp($text);
+ };
+
+ my $pkg = shift;
+ my $callpkg = shift;
my @imports = @_;
- *exports = \@{"${pack}::EXPORT"};
+ my($type, $sym);
+ *exports = \@{"${pkg}::EXPORT"};
if (@imports) {
my $oops;
- my $type;
- *exports = \%{"${pack}::EXPORT"};
+ *exports = \%{"${pkg}::EXPORT"};
if (!%exports) {
grep(s/^&//, @exports);
@exports{@exports} = (1) x @exports;
- foreach $extra (@{"${pack}::EXPORT_OK"}) {
+ foreach $extra (@{"${pkg}::EXPORT_OK"}) {
$exports{$extra} = 1;
}
}
+
+ if ($imports[0] =~ m#^[/!:]#){
+ my(@allexports) = keys %exports;
+ my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
+ my $tagdata;
+ my %imports;
+ # negated first item implies starting with default set:
+ unshift(@imports, ':DEFAULT') if $imports[0] =~ m/^!/;
+ foreach (@imports){
+ my(@names);
+ my($mode,$spec) = m/^(!)?(.*)/;
+ $mode = '+' unless defined $mode;
+
+ @names = ($spec); # default, maybe overridden below
+
+ if ($spec =~ m:^/(.*)/$:){
+ my $patn = $1;
+ @names = grep(/$patn/, @allexports); # XXX anchor by default?
+ }
+ elsif ($spec =~ m#^:(.*)# and $tagsref){
+ if ($1 eq 'DEFAULT'){
+ @names = @exports;
+ }
+ elsif ($tagsref and $tagdata = $tagsref->{$1}) {
+ @names = @$tagdata;
+ }
+ }
+
+ warn "Import Mode $mode, Spec $spec, Names @names\n" if $Verbose;
+ if ($mode eq '!') {
+ map {delete $imports{$_}} @names; # delete @imports{@names} would be handy :-)
+ }
+ else {
+ @imports{@names} = (1) x @names;
+ }
+ }
+ @imports = keys %imports;
+ }
+
foreach $sym (@imports) {
if (!$exports{$sym}) {
if ($sym !~ s/^&// || !$exports{$sym}) {
- warn qq["$sym" is not exported by the $pack module ],
+ warn qq["$sym" is not exported by the $pkg module ],
"at $callfile line $callline\n";
$oops++;
next;
@@ -35,23 +115,32 @@ sub export {
else {
@imports = @exports;
}
+ warn "Importing from $pkg into $callpkg: ",
+ join(", ",@imports),"\n" if ($Verbose && @imports);
foreach $sym (@imports) {
$type = '&';
$type = $1 if $sym =~ s/^(\W)//;
- *{"${callpack}::$sym"} =
- $type eq '&' ? \&{"${pack}::$sym"} :
- $type eq '$' ? \${"${pack}::$sym"} :
- $type eq '@' ? \@{"${pack}::$sym"} :
- $type eq '%' ? \%{"${pack}::$sym"} :
- $type eq '*' ? *{"${pack}::$sym"} :
+ *{"${callpkg}::$sym"} =
+ $type eq '&' ? \&{"${pkg}::$sym"} :
+ $type eq '$' ? \${"${pkg}::$sym"} :
+ $type eq '@' ? \@{"${pkg}::$sym"} :
+ $type eq '%' ? \%{"${pkg}::$sym"} :
+ $type eq '*' ? *{"${pkg}::$sym"} :
warn "Can't export symbol: $type$sym\n";
}
};
sub import {
- local ($callpack, $callfile, $callline) = caller($ExportLevel);
- my $pack = shift;
- export $pack, $callpack, @_;
+ local ($callpkg, $callfile, $callline) = caller($ExportLevel);
+ my $pkg = shift;
+ export $pkg, $callpkg, @_;
+}
+
+sub export_tags {
+ my ($pkg) = caller;
+ *tags = \%{"${pkg}::EXPORT_TAGS"};
+ push(@{"${pkg}::EXPORT"},
+ map {$tags{$_} ? @{$tags{$_}} : $_} @_ ? @_ : keys %tags);
}
1;
diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm
index f619108341..e09b438e75 100644
--- a/lib/ExtUtils/MakeMaker.pm
+++ b/lib/ExtUtils/MakeMaker.pm
@@ -304,7 +304,10 @@ sub check_hints {
$hint=(reverse sort @goodhints)[0];
# execute the hintsfile:
- eval `cat hints/$hint.pl`;
+ open HINTS, "hints/$hint.pl";
+ @goodhints = <HINTS>;
+ close HINTS;
+ eval join('',@goodhints);
}
# Setup dummy package:
@@ -672,8 +675,8 @@ Exporter::import('ExtUtils::MakeMaker',
@Other_Att_Keys{qw(EXTRALIBS BSLOADLIBS LDLOADLIBS)} = (1) x 3;
if ($Is_VMS = $Config{'osname'} eq 'VMS') {
- require File::VMSspec;
- import File::VMSspec 'vmsify';
+ require VMS::Filespec;
+ import VMS::Filespec 'vmsify';
}
@@ -752,7 +755,8 @@ sub init_main {
}
$att{INST_EXE} = "./blib" unless $att{INST_EXE};
$att{MAP_TARGET} = "perl" unless $att{MAP_TARGET};
- $att{LIBPERL_A} = 'libperl.a' unless $att{LIBPERL_A};
+ $att{LIBPERL_A} = $Is_VMS ? 'libperl.olb' : 'libperl.a'
+ unless $att{LIBPERL_A};
}
# make a few simple checks
@@ -981,7 +985,7 @@ sub find_perl{
foreach $dir (@$dirs){
next unless defined $dir; # $att{PERL_SRC} may be undefined
foreach $name (@$names){
- print "checking $dir/$name" if ($trace >= 2);
+ print "Checking $dir/$name " if ($trace >= 2);
if ($Is_VMS) {
$name .= ".exe" unless -x "$dir/$name";
}
@@ -1986,7 +1990,7 @@ sub extliblist{
if (@fullname=<${thispth}/lib${thislib}.${so}.[0-9]*>){
$fullname=$fullname[-1]; #ATTN: 10 looses against 9!
} elsif (-f ($fullname="$thispth/lib$thislib.$so")
- && (($Config{'dlsrc'} ne "dl_dld") || ($thislib eq "m"))){
+ && (($Config{'dlsrc'} ne "dl_dld.xs") || ($thislib eq "m"))){
} elsif (-f ($fullname="$thispth/lib${thislib}_s.a")
&& ($thislib .= "_s") ){ # we must explicitly ask for _s version
} elsif (-f ($fullname="$thispth/lib$thislib.a")){
diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index bc0852303f..21bbc4edee 100755
--- a/lib/ExtUtils/xsubpp
+++ b/lib/ExtUtils/xsubpp
@@ -68,6 +68,8 @@ SWITCH: while ($ARGV[0] =~ s/^-//) {
}
@ARGV == 1 or die $usage;
chop($pwd = `pwd`);
+# Check for error message from VMS
+if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
or ($dir, $filename) = ('.', $ARGV[0]);
@@ -77,7 +79,9 @@ $typemap = shift @ARGV;
foreach $typemap (@tm) {
die "Can't find $typemap in $pwd\n" unless -r $typemap;
}
-unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap);
+unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
+ ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
+ ../typemap typemap);
foreach $typemap (@tm) {
open(TYPEMAP, $typemap) || next;
$mode = Typemap;
@@ -321,11 +325,17 @@ EOF
$_ = shift(@line);
last if /^\s*NOT_IMPLEMENTED_YET/;
last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
- # Catch common error. Much more error checking required here.
- blurt("Error: no tab in $pname argument declaration '$_'\n")
- unless (m/\S+\s*\t\s*\S+/);
($var_type, $var_name, $var_init) =
/\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
+ # Catch common errors. More error checking required here.
+ blurt("Error: no tab in $pname argument declaration '$_'\n")
+ unless (m/\S+\s*\t\s*\S+/);
+ # catch C style argument declaration (this could be made alowable syntax)
+ warn("Warning: ignored semicolon in $pname argument declaration '$_'\n")
+ if ($var_name =~ s/;//g); # eg SV *<tab>name;
+ # catch many errors similar to: SV<tab>* name
+ blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
+ unless ($var_name =~ m/^&?\w+$/);
if ($var_name =~ /^&/) {
$var_name =~ s/^&//;
$var_addr{$var_name} = 1;
@@ -523,7 +533,7 @@ sub generate_init {
local($ntype);
local($tk);
- blurt("$type not in typemap"), return unless defined($type_kind{$type});
+ blurt("'$type' not in typemap"), return unless defined($type_kind{$type});
($ntype = $type) =~ s/\s*\*/Ptr/g;
$subtype = $ntype;
$subtype =~ s/Ptr$//;
@@ -563,7 +573,7 @@ sub generate_output {
if ($type =~ /^array\(([^,]*),(.*)\)/) {
print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
} else {
- blurt("$type not in typemap"), return
+ blurt("'$type' not in typemap"), return
unless defined($type_kind{$type});
($ntype = $type) =~ s/\s*\*/Ptr/g;
$ntype =~ s/\(\)//g;
@@ -613,4 +623,7 @@ sub map_type {
}
}
-exit $errors;
+# If this is VMS, the exit status has meaning to the shell, so we
+# use a predictable value (SS$_Abort) rather than an arbitrary
+# number.
+exit $Is_VMS ? 44 : $errors;
diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm
index 9e2e25e889..5e09ae4977 100644
--- a/lib/File/Basename.pm
+++ b/lib/File/Basename.pm
@@ -4,7 +4,7 @@ require 5.000;
use Config;
require Exporter;
@ISA = qw(Exporter);
-@EXPORT = qw(fileparse set_fileparse_fstype basename dirname);
+@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
# fileparse_set_fstype() - specify OS-based rules used in future
# calls to routines in this package
@@ -13,7 +13,9 @@ require Exporter;
# Any other name uses Unix-style rules
sub fileparse_set_fstype {
- $Fileparse_fstype = $_[0];
+ my($old) = $Fileparse_fstype;
+ $Fileparse_fstype = $_[0] if $_[0];
+ $old;
}
# fileparse() - parse file specification
@@ -46,7 +48,7 @@ sub fileparse_set_fstype {
# ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
# '\.book\d+');
# would yield $base == 'draft',
-# $path == '/virgil/aeneid', and
+# $path == '/virgil/aeneid/' (note trailing slash)
# $tail == '.book7'.
# Similarly, on a system running VMS,
# ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*');
@@ -66,7 +68,7 @@ sub fileparse {
if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation
else {
($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
- $dirpath = $ENV{'PATH'} unless $dirpath;
+ $dirpath = $ENV{'DEFAULT'} unless $dirpath;
}
}
if ($fstype =~ /^MSDOS/i) {
@@ -76,7 +78,7 @@ sub fileparse {
elsif ($fstype =~ /^MAC/i) {
($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
}
- else { # default to Unix
+ elsif ($fstype !~ /^VMS/i) { # default to Unix
($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#);
$dirpath = '.' unless $dirpath;
}
@@ -90,7 +92,7 @@ sub fileparse {
}
}
- ($basename,$dirpath,$tail);
+ wantarray ? ($basename,$dirpath,$tail) : $basename;
}
@@ -98,13 +100,15 @@ sub fileparse {
# basename() - returns first element of list returned by fileparse()
sub basename {
- (fileparse(@_))[0];
+ my($name) = shift;
+ (fileparse($name, map("\Q$_\E",@_)))[0];
}
# dirname() - returns device and directory portion of file specification
# Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS
-# filespecs. This differs from the second element of the list returned
+# filespecs except for names ending with a separator, e.g., "/xx/yy/".
+# This differs from the second element of the list returned
# by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and
# the last directory name if the filespec ends in a '/' or '\'), is lost.
@@ -113,14 +117,14 @@ sub dirname {
my($fstype) = $Fileparse_fstype;
if ($fstype =~ /VMS/i) {
- if (m#/#) { $fstype = '' }
+ if ($_[0] =~ m#/#) { $fstype = '' }
else { return $dirname }
}
if ($fstype =~ /MacOS/i) { return $dirname }
elsif ($fstype =~ /MSDOS/i) {
if ( $dirname =~ /:\\$/) { return $dirname }
chop $dirname;
- $dirname =~ s:[^/]+$:: unless $basename;
+ $dirname =~ s:[^\\]+$:: unless $basename;
$dirname = '.' unless $dirname;
}
else {
diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm
index d3dfa70084..a440bda71e 100644
--- a/lib/File/CheckTree.pm
+++ b/lib/File/CheckTree.pm
@@ -98,11 +98,11 @@ sub valmess {
$mess =~ s/ does not / should not / ||
$mess =~ s/ not / /;
}
- print stderr $mess,"\n";
+ print STDERR $mess,"\n";
}
else {
$this =~ s/\$file/'$file'/g;
- print stderr "Can't do $this.\n";
+ print STDERR "Can't do $this.\n";
}
if ($disposition eq 'die') { exit 1; }
++$warnings;
diff --git a/lib/File/Find.pm b/lib/File/Find.pm
index 612f14525a..c7b0051ce2 100644
--- a/lib/File/Find.pm
+++ b/lib/File/Find.pm
@@ -1,9 +1,12 @@
package File::Find;
require 5.000;
require Exporter;
+use Config;
+use Cwd;
+use File::Basename;
@ISA = qw(Exporter);
-@EXPORT = qw(find finddepth);
+@EXPORT = qw(find finddepth $name $dir);
# Usage:
# use File::Find;
@@ -38,7 +41,7 @@ require Exporter;
sub find {
my $wanted = shift;
- chop($cwd = `pwd`);
+ my $cwd = fastcwd();
foreach $topdir (@_) {
(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
|| (warn("Can't stat $topdir: $!\n"), next);
@@ -48,6 +51,7 @@ sub find {
$name = $topdir;
&$wanted;
($fixtopdir = $topdir) =~ s,/$,, ;
+ $fixtopdir =~ s/\.dir$// if $Is_VMS; ;
&finddir($wanted,$fixtopdir,$topnlink);
}
else {
@@ -55,7 +59,7 @@ sub find {
}
}
else {
- unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ unless (($dir,$_) = fileparse($topdir)) {
($dir,$_) = ('.', $topdir);
}
$name = $topdir;
@@ -97,13 +101,15 @@ sub finddir {
# Get link count and check for directoriness.
- ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+ ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_))
+ unless ($nlink || $dont_use_nlink);
if (-d _) {
# It really is a directory, so do it recursively.
if (!$prune && chdir $_) {
+ $name =~ s/\.dir$// if $Is_VMS;
&finddir($wanted,$name,$nlink);
chdir '..';
}
@@ -145,13 +151,14 @@ sub finddir {
sub finddepth {
my $wanted = shift;
- chop($cwd = `pwd`);
+ $cwd = fastcwd();;
foreach $topdir (@_) {
(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
|| (warn("Can't stat $topdir: $!\n"), next);
if (-d _) {
if (chdir($topdir)) {
($fixtopdir = $topdir) =~ s,/$,, ;
+ $fixtopdir =~ s/\.dir$// if $Is_VMS;
&finddepthdir($wanted,$fixtopdir,$topnlink);
($dir,$_) = ($fixtopdir,'.');
$name = $fixtopdir;
@@ -162,7 +169,7 @@ sub finddepth {
}
}
else {
- unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
+ unless (($dir,$_) = fileparse($topdir)) {
($dir,$_) = ('.', $topdir);
}
chdir $dir && &$wanted;
@@ -182,7 +189,7 @@ sub finddepthdir {
my(@filenames) = readdir(DIR);
closedir(DIR);
- if ($nlink == 2) { # This dir has no subdirectories.
+ if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories.
for (@filenames) {
next if $_ eq '.';
next if $_ eq '..';
@@ -198,17 +205,18 @@ sub finddepthdir {
next if $_ eq '..';
$nlink = $prune = 0;
$name = "$dir/$_";
- if ($subcount > 0) { # Seen all the subdirs?
+ if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs?
# Get link count and check for directoriness.
- ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
+ ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_));
if (-d _) {
# It really is a directory, so do it recursively.
if (!$prune && chdir $_) {
+ $name =~ s/\.dir$// if $Is_VMS;
&finddepthdir($wanted,$name,$nlink);
chdir '..';
}
@@ -220,5 +228,10 @@ sub finddepthdir {
}
}
+if ($Config{'osname'} eq 'VMS') {
+ $Is_VMS = 1;
+ $dont_use_nlink = 1;
+}
+
1;
diff --git a/lib/File/Path.pm b/lib/File/Path.pm
index 30f550d7f4..ec117b8de9 100644
--- a/lib/File/Path.pm
+++ b/lib/File/Path.pm
@@ -58,17 +58,19 @@ Unix file specification syntax.
=item *
a boolean value, which if TRUE will cause C<rmtree> to
-print a message each time it tries to delete a file,
-giving the name of the file, and indicating whether
-it's using C<rmdir> or C<unlink> to remove it.
+print a message each time it examines a file, giving the
+name of the file, and indicating whether it's using C<rmdir>
+or C<unlink> to remove it, or that it's skipping it.
(defaults to FALSE)
=item *
a boolean value, which if TRUE will cause C<rmtree> to
-skip any files to which you do not have write access.
-This will change in the future when a criterion for
-'delete permission' is settled. (defaults to FALSE)
+skip any files to which you do not have delete access
+(if running under VMS) or write access (if running
+under another OS). This will change in the future when
+a criterion for 'delete permission' under OSs other
+than VMS is settled. (defaults to FALSE)
=back
@@ -81,7 +83,7 @@ Charles Bailey <bailey@genetics.upenn.edu>
=head1 REVISION
-This document was last revised 29-Jan-1995, for perl 5.001
+This document was last revised 08-Mar-1995, for perl 5.001
=cut
@@ -92,6 +94,8 @@ require Exporter;
@ISA = qw( Exporter );
@EXPORT = qw( mkpath rmtree );
+$Is_VMS = $Config{'osname'} eq 'VMS';
+
sub mkpath{
my($paths, $verbose, $mode) = @_;
# $paths -- either a path string or ref to list of paths
@@ -102,7 +106,7 @@ sub mkpath{
$paths = [$paths] unless ref $paths;
my(@created);
foreach $path (@$paths){
- next if -d $path;
+ next if -d $path;
my(@p);
foreach(split(/\//, $path)){
push(@p, $_);
@@ -124,15 +128,24 @@ sub rmtree {
$root =~ s#/$##;
if (-d $root) {
opendir(D,$root);
+ $root =~ s#\.dir$## if $Is_VMS;
@files = map("$root/$_", grep $_!~/^\.{1,2}$/, readdir(D));
closedir(D);
$count += rmtree(\@files,$verbose,$safe);
- next if ($safe && !(-w $root));
+ if ($safe &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+ print "skipped $root\n" if $verbose;
+ next;
+ }
print "rmdir $root\n" if $verbose;
(rmdir $root && ++$count) or carp "Can't remove directory $root: $!";
}
else {
- next if ($safe && !(-w $root));
+ if ($safe &&
+ ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+ print "skipped $root\n" if $verbose;
+ next;
+ }
print "unlink $root\n" if $verbose;
(unlink($root) && ++$count) or carp "Can't unlink file $root: $!";
}
diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm
index 3e0fc17ff6..8c0ca4e6d4 100644
--- a/lib/Math/BigInt.pm
+++ b/lib/Math/BigInt.pm
@@ -2,32 +2,34 @@ package Math::BigInt;
%OVERLOAD = (
# Anonymous subroutines:
-'+' => sub {new BigInt &badd},
-'-' => sub {new BigInt
+'+' => sub {new Math::BigInt &badd},
+'-' => sub {new Math::BigInt
$_[2]? bsub($_[1],${$_[0]}) : bsub(${$_[0]},$_[1])},
-'<=>' => sub {new BigInt
+'<=>' => sub {new Math::BigInt
$_[2]? bcmp($_[1],${$_[0]}) : bcmp(${$_[0]},$_[1])},
-'cmp' => sub {new BigInt
+'cmp' => sub {new Math::BigInt
$_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])},
-'*' => sub {new BigInt &bmul},
-'/' => sub {new BigInt
+'*' => sub {new Math::BigInt &bmul},
+'/' => sub {new Math::BigInt
$_[2]? scalar bdiv($_[1],${$_[0]}) :
scalar bdiv(${$_[0]},$_[1])},
-'%' => sub {new BigInt
+'%' => sub {new Math::BigInt
$_[2]? bmod($_[1],${$_[0]}) : bmod(${$_[0]},$_[1])},
-'**' => sub {new BigInt
+'**' => sub {new Math::BigInt
$_[2]? bpow($_[1],${$_[0]}) : bpow(${$_[0]},$_[1])},
-'neg' => sub {new BigInt &bneg},
-'abs' => sub {new BigInt &babs},
+'neg' => sub {new Math::BigInt &bneg},
+'abs' => sub {new Math::BigInt &babs},
qw(
"" stringify
0+ numify) # Order of arguments unsignificant
);
+$NaNOK=1;
+
sub new {
my $foo = bnorm($_[1]);
- die "Not a number initialized to BigInt" if $foo eq "NaN";
+ die "Not a number initialized to Math::BigInt" if !$NaNOK && $foo eq "NaN";
bless \$foo;
}
sub stringify { "${$_[0]}" }
diff --git a/lib/SubstrHash.pm b/lib/SubstrHash.pm
new file mode 100644
index 0000000000..6250e73848
--- /dev/null
+++ b/lib/SubstrHash.pm
@@ -0,0 +1,140 @@
+package SubstrHash;
+use Carp;
+
+sub TIEHASH {
+ my $pack = shift;
+ my ($klen, $vlen, $tsize) = @_;
+ my $rlen = 1 + $klen + $vlen;
+ $tsize = findprime($tsize * 1.1); # Allow 10% empty.
+ $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
+ $$self[0] x= $rlen * $tsize;
+ $self;
+}
+
+sub FETCH {
+ local($self,$key) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ return undef;
+ }
+ elsif (ord($record) == 1) {
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ return substr($record, 1+$klen, $vlen);
+ }
+ &rehash;
+ }
+}
+
+sub STORE {
+ local($self,$key,$val) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ croak("Table is full") if $self[5] == $tsize;
+ croak(qq/Value "$val" is not $vlen characters long./)
+ if length($val) != $vlen;
+ my $writeoffset;
+
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ $record = "\2". $key . $val;
+ die "panic" unless length($record) == $rlen;
+ $writeoffset = $offset unless defined $writeoffset;
+ substr($$self[0], $writeoffset, $rlen) = $record;
+ ++$$self[5];
+ return;
+ }
+ elsif (ord($record) == 1) {
+ $writeoffset = $offset unless defined $writeoffset;
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ $record = "\2". $key . $val;
+ die "panic" unless length($record) == $rlen;
+ substr($$self[0], $offset, $rlen) = $record;
+ return;
+ }
+ &rehash;
+ }
+}
+
+sub DELETE {
+ local($self,$key) = @_;
+ local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
+ &hashkey;
+ for (;;) {
+ $offset = $hash * $rlen;
+ $record = substr($$self[0], $offset, $rlen);
+ if (ord($record) == 0) {
+ return undef;
+ }
+ elsif (ord($record) == 1) {
+ }
+ elsif (substr($record, 1, $klen) eq $key) {
+ substr($$self[0], $offset, 1) = "\1";
+ return substr($record, 1+$klen, $vlen);
+ --$$self[5];
+ }
+ &rehash;
+ }
+}
+
+sub FIRSTKEY {
+ local($self) = @_;
+ $$self[6] = -1;
+ &NEXTKEY;
+}
+
+sub NEXTKEY {
+ local($self) = @_;
+ local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
+ for (++$iterix; $iterix < $tsize; ++$iterix) {
+ next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
+ $$self[6] = $iterix;
+ return substr($$self[0], $iterix * $rlen + 1, $klen);
+ }
+ $$self[6] = -1;
+ undef;
+}
+
+sub hashkey {
+ croak(qq/Key "$key" is not $klen characters long.\n/)
+ if length($key) != $klen;
+ $hash = 2;
+ for (unpack('C*', $key)) {
+ $hash = $hash * 33 + $_;
+ }
+ $hash = $hash - int($hash / $tsize) * $tsize
+ if $hash >= $tsize;
+ $hash = 1 unless $hash;
+ $hashbase = $hash;
+}
+
+sub rehash {
+ $hash += $hashbase;
+ $hash -= $tsize if $hash >= $tsize;
+}
+
+sub findprime {
+ use integer;
+
+ my $num = shift;
+ $num++ unless $num % 2;
+
+ $max = int sqrt $num;
+
+ NUM:
+ for (;; $num += 2) {
+ for ($i = 3; $i <= $max; $i += 2) {
+ next NUM unless $num % $i;
+ }
+ return $num;
+ }
+}
+
+1;
diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm
index 0f7859e226..0a0d25eb9b 100644
--- a/lib/Sys/Syslog.pm
+++ b/lib/Sys/Syslog.pm
@@ -139,7 +139,7 @@ sub xlate {
local($name) = @_;
$name =~ y/a-z/A-Z/;
$name = "LOG_$name" unless $name =~ /^LOG_/;
- $name = "syslog'$name";
+ $name = "Sys::Syslog::$name";
eval(&$name) || -1;
}
diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm
index e1476a3411..061ca704b7 100644
--- a/lib/Term/Cap.pm
+++ b/lib/Term/Cap.pm
@@ -1,74 +1,138 @@
+# Term::Cap.pm -- Termcap interface routines
package Term::Cap;
-require 5.000;
-require Exporter;
-use Carp;
-@ISA = qw(Exporter);
-@EXPORT = qw(&Tgetent &Tputs &Tgoto $ispeed $ospeed %TC);
-
-# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
+# Converted to package on 25 Feb 1994 <sanders@bsdi.com>
#
# Usage:
# require 'ioctl.pl';
-# ioctl(TTY,$TIOCGETP,$foo);
-# ($ispeed,$ospeed) = unpack('cc',$foo);
-# use Termcap;
-# &Tgetent('vt100'); # sets $TC{'cm'}, etc.
-# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
-# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
+# ioctl(TTY,$TIOCGETP,$sgtty);
+# ($ispeed,$ospeed) = unpack('cc',$sgtty);
+#
+# require Term::Cap;
+#
+# $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+# sets $term->{'_cm'}, etc.
+# $this->Trequire(qw/ce ku kd/);
+# die unless entries are defined for the terminal
+# $term->Tgoto('cm', $col, $row, $FH);
+# $term->Tputs('dl', $cnt = 1, $FH);
+# $this->Tpad($string, $cnt = 1, $FH);
+# processes a termcap string and adds padding if needed
+# if $FH is undefined these just return the string
+#
+# CHANGES:
+# Converted to package
+# Allows :tc=...: in $ENV{'TERMCAP'} (flows to default termcap file)
+# Now die's properly if it can't open $TERMCAP or if the eval $loop fails
+# Tputs() results are cached (use Tgoto or Tpad to avoid)
+# Tgoto() will do output if $FH is passed (like Tputs without caching)
+# Supports POSIX termios speeds and old style speeds
+# Searches termcaps properly (TERMPATH, etc)
+# The output routines are optimized for cached Tputs().
+# $this->{_xx} is the raw termcap data and $this->{xx} is a
+# cached and padded string for count == 1.
#
-sub Tgetent {
- local($TERM) = @_;
- local($TERMCAP,$_,$entry,$loop,$field);
- warn "Tgetent: no ospeed set" unless $ospeed;
- foreach $key (keys(%TC)) {
- delete $TC{$key};
+# internal routines
+sub getenv { defined $ENV{$_[0]} ? $ENV{$_[0]} : ''; }
+sub termcap_path {
+ local @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
+ local $v;
+ if ($v = getenv(TERMPATH)) {
+ # user specified path
+ @termcap_path = split(':', $v);
+ } else {
+ # default path
+ @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
+ $v = getenv(HOME);
+ unshift(@termcap_path, $v . '/.termcap') if $v;
}
- $TERM = $ENV{'TERM'} unless $TERM;
- $TERM =~ s/(\W)/\\$1/g;
- $TERMCAP = $ENV{'TERMCAP'};
- $TERMCAP = '/etc/termcap' unless $TERMCAP;
- if ($TERMCAP !~ m:^/:) {
- if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
- $TERMCAP = '/etc/termcap';
- }
- }
- if ($TERMCAP =~ m:^/:) {
- $entry = '';
+ # we always search TERMCAP first
+ $v = getenv(TERMCAP);
+ unshift(@termcap_path, $v) if $v =~ /^\//;
+ grep(-f, @termcap_path);
+}
+
+sub Tgetent {
+ local($type) = shift;
+ local($this) = @_;
+ local($TERM,$TERMCAP,$term,$entry,$cap,$loop,$field,$entry,$_);
+
+ warn "Tgetent: no ospeed set\n" unless $this->{OSPEED} > 0;
+ $this->{DECR} = 10000 / $this->{OSPEED} if $this->{OSPEED} > 50;
+ $term = $TERM = $this->{TERM} =
+ $this->{TERM} || getenv(TERM) || die "Tgetent: TERM not set\n";
+
+ $TERMCAP = getenv(TERMCAP);
+ $TERMCAP = '' if $TERMCAP =~ m:^/: || $TERMCAP !~ /(^|\|)$TERM[:\|]/;
+ local @termcap_path = &termcap_path;
+ die "Tgetent: Can't find a valid termcap file\n"
+ unless @termcap_path || $TERMCAP;
+
+ # handle environment TERMCAP, setup for continuation if needed
+ $entry = $TERMCAP;
+ $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1);
+ if ($TERMCAP eq '' || $1) { # the search goes on
+ local $first = $TERMCAP eq '' ? 1 : 0; # make it pretty
+ local $max = 32; # max :tc=...:'s
+ local $state = 1; # 0 == finished
+ # 1 == next file
+ # 2 == search again
do {
+ if ($state == 1) {
+ $TERMCAP = shift @termcap_path
+ || die "Tgetent: failed lookup on $TERM\n";
+ } else {
+ $max-- || die "Tgetent: termcap loop at $TERM\n";
+ $state = 1; # back to default state
+ }
+
+ open(TERMCAP,"< $TERMCAP\0") || die "Tgetent: $TERMCAP: $!\n";
+ # print STDERR "Trying... $TERMCAP\n";
$loop = "
- open(TERMCAP,'<$TERMCAP') || croak \"Can't open $TERMCAP\";
- while (<TERMCAP>) {
- next if /^#/;
- next if /^\t/;
- if (/(^|\\|)${TERM}[:\\|]/) {
- chop;
- while (chop eq '\\\\') {
- \$_ .= <TERMCAP>;
+ while (<TERMCAP>) {
+ next if /^\t/;
+ next if /^#/;
+ if (/(^|\\|)${TERM}[:\\|]/) {
chop;
+ s/^[^:]*:// unless \$first++;
+ \$state = 0;
+ while (chop eq '\\\\') {
+ \$_ .= <TERMCAP>;
+ chop;
+ }
+ \$_ .= ':';
+ last;
}
- \$_ .= ':';
- last;
}
- }
- close TERMCAP;
- \$entry .= \$_;
+ \$entry .= \$_;
";
eval $loop;
- } while s/:tc=([^:]+):/:/ && ($TERM = $1);
- $TERMCAP = $entry;
+ die $@ if $@;
+ #print STDERR "$TERM: $_\n--------\n"; # DEBUG
+ close TERMCAP;
+ # If :tc=...: found then search this file again
+ $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1, $state = 2);
+ } while $state != 0;
}
+ die "Tgetent: Can't find $term\n" unless $entry ne '';
+ $entry =~ s/:\s+:/:/g;
+ $this->{TERMCAP} = $entry;
+ #print STDERR $entry, "\n"; # DEBUG
- foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
+ # Precompile $entry into the object
+ foreach $field (split(/:[\s:\\]*/,$entry)) {
if ($field =~ /^\w\w$/) {
- $TC{$field} = 1;
+ $this->{'_' . $field} = 1 unless defined $this->{'_' . $1};
+ }
+ elsif ($field =~ /^(\w\w)\@/) {
+ $this->{'_' . $1} = "";
}
elsif ($field =~ /^(\w\w)#(.*)/) {
- $TC{$1} = $2 unless defined $TC{$1};
+ $this->{'_' . $1} = $2 unless defined $this->{'_' . $1};
}
elsif ($field =~ /^(\w\w)=(.*)/) {
- $entry = $1;
+ next if defined $this->{'_' . ($cap = $1)};
$_ = $2;
s/\\E/\033/g;
s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
@@ -82,40 +146,77 @@ sub Tgetent {
s/\^(.)/pack('c',ord($1) & 31)/eg;
s/\\(.)/$1/g;
s/\377/^/g;
- $TC{$entry} = $_ unless defined $TC{$entry};
+ $this->{'_' . $cap} = $_;
}
+ # else { warn "Tgetent: junk in $term: $field\n"; }
}
- $TC{'pc'} = "\0" unless defined $TC{'pc'};
- $TC{'bc'} = "\b" unless defined $TC{'bc'};
+ $this->{'_pc'} = "\0" unless defined $this->{'_pc'};
+ $this->{'_bc'} = "\b" unless defined $this->{'_bc'};
+ $this;
}
-@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);
+# delays for old style speeds
+@Tpad = (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);
+
+# $term->Tpad($string, $cnt, $FH);
+sub Tpad {
+ local($this, $string, $cnt, $FH) = @_;
+ local($decr, $ms);
-sub Tputs {
- local($string,$affcnt,$FH) = @_;
- local($ms);
if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
$ms = $1;
- $ms *= $affcnt if $2;
+ $ms *= $cnt if $2;
$string = $3;
- $decr = $Tputs[$ospeed];
+ $decr = $this->{OSPEED} < 50 ? $Tpad[$this->{OSPEED}] : $this->{DECR};
if ($decr > .1) {
$ms += $decr / 2;
- $string .= $TC{'pc'} x ($ms / $decr);
+ $string .= $this->{'_pc'} x ($ms / $decr);
}
}
print $FH $string if $FH;
$string;
}
+# $term->Tputs($cap, $cnt, $FH);
+sub Tputs {
+ local($this, $cap, $cnt, $FH) = @_;
+ local $string;
+
+ if ($cnt > 1) {
+ $string = Tpad($this, $this->{'_' . $cap}, $cnt);
+ } else {
+ $string = defined $this->{$cap} ? $this->{$cap} :
+ ($this->{$cap} = Tpad($this, $this->{'_' . $cap}, 1));
+ }
+ print $FH $string if $FH;
+ $string;
+}
+
+# %% output `%'
+# %d output value as in printf %d
+# %2 output value as in printf %2d
+# %3 output value as in printf %3d
+# %. output value as in printf %c
+# %+x add x to value, then do %.
+#
+# %>xy if value > x then add y, no output
+# %r reverse order of two parameters, no output
+# %i increment by one, no output
+# %B BCD (16*(value/10)) + (value%10), no output
+#
+# %n exclusive-or all parameters with 0140 (Datamedia 2500)
+# %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
+#
+# $term->Tgoto($cap, $col, $row, $FH);
sub Tgoto {
- local($string) = shift(@_);
- local($result) = '';
- local($after) = '';
- local($code,$tmp) = @_;
- local(@tmp);
- @tmp = ($tmp,$code);
- local($online) = 0;
+ local($this, $cap, $code, $tmp, $FH) = @_;
+ local $string = $this->{'_' . $cap};
+ local $result = '';
+ local $after = '';
+ local $online = 0;
+ local @tmp = ($tmp,$code);
+ local $cnt = $code;
+
while ($string =~ /^([^%]*)%(.)(.*)/) {
$result .= $1;
$code = $2;
@@ -127,10 +228,10 @@ sub Tgoto {
$tmp = shift(@tmp);
if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
if ($online) {
- ++$tmp, $after .= $TC{'up'} if $TC{'up'};
+ ++$tmp, $after .= $this->{'_up'} if $this->{'_up'};
}
else {
- ++$tmp, $after .= $TC{'bc'};
+ ++$tmp, $after .= $this->{'_bc'};
}
}
$result .= sprintf("%c",$tmp);
@@ -168,7 +269,19 @@ sub Tgoto {
return "OOPS";
}
}
- $result . $string . $after;
+ $string = Tpad($this, $result . $string . $after, $cnt);
+ print $FH $string if $FH;
+ $string;
+}
+
+# $this->Trequire($cap1, $cap2, ...);
+sub Trequire {
+ local $this = shift;
+ local $_;
+ foreach (@_) {
+ die "Trequire: Terminal does not support: $_\n"
+ unless defined $this->{'_' . $_} && $this->{'_' . $_};
+ }
}
1;
diff --git a/lib/TieHash.pm b/lib/TieHash.pm
index 0cb4afa20d..2d5c2f41f0 100644
--- a/lib/TieHash.pm
+++ b/lib/TieHash.pm
@@ -39,4 +39,20 @@ sub CLEAR {
}
}
+# The TieHash::Std package implements standard perl hash behaviour.
+# It exists to act as a base class for classes which only wish to
+# alter some parts of their behaviour.
+
+package TieHash::Std;
+@ISA = qw(TieHash);
+
+sub TIEHASH { bless {}, $_[0] }
+sub STORE { $_[0]->{$_[1]} = $_[2] }
+sub FETCH { $_[0]->{$_[1]} }
+sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
+sub NEXTKEY { each %{$_[0]} }
+sub EXISTS { exists $_[0]->{$_[1]} }
+sub DELETE { delete $_[0]->{$_[1]} }
+sub CLEAR { %{$_[0]} = () }
+
1;
diff --git a/lib/assert.pl b/lib/assert.pl
index 0661d70af5..4c9ebf20a0 100644
--- a/lib/assert.pl
+++ b/lib/assert.pl
@@ -16,6 +16,8 @@ sub assert {
}
sub panic {
+ package DB;
+
select(STDERR);
print "\npanic: @_\n";
@@ -24,10 +26,11 @@ sub panic {
# stack traceback gratefully borrowed from perl debugger
- local($i,$_);
- local($p,$f,$l,$s,$h,$a,@a,@sub);
+ local $_;
+ my $i;
+ my ($p,$f,$l,$s,$h,$a,@a,@frames);
for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
- @a = @DB'args;
+ @a = @args;
for (@a) {
if (/^StB\000/ && length($_) == length($_main{'_main'})) {
$_ = sprintf("%s",$_);
@@ -41,10 +44,10 @@ sub panic {
}
$w = $w ? '@ = ' : '$ = ';
$a = $h ? '(' . join(', ', @a) . ')' : '';
- push(@sub, "$w&$s$a from file $f line $l\n");
+ push(@frames, "$w&$s$a from file $f line $l\n");
}
- for ($i=0; $i <= $#sub; $i++) {
- print $sub[$i];
+ for ($i=0; $i <= $#frames; $i++) {
+ print $frames[$i];
}
exit 1;
}
diff --git a/lib/bigrat.pl b/lib/bigrat.pl
index 5bd127a9ae..fb436ce570 100644
--- a/lib/bigrat.pl
+++ b/lib/bigrat.pl
@@ -55,6 +55,7 @@ sub norm { #(bint, bint) return rat_num
'NaN';
} else {
local($gcd) = &'bgcd($num,$dom);
+ $gcd =~ s/^-/+/;
if ($gcd ne '+1') {
$num = &'bdiv($num,$gcd);
$dom = &'bdiv($dom,$gcd);
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index ac03c098fe..358b548a3c 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -50,11 +50,13 @@ print OUT ("Emacs support ",
".\n");
print OUT "\nEnter h for help.\n\n";
+@ARGS;
+
sub DB {
&save;
- ($package, $filename, $line) = caller;
+ ($pkg, $filename, $line) = caller;
$usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
- "package $package;"; # this won't let them modify, alas
+ "package $pkg;"; # this won't let them modify, alas
local(*dbline) = "::_<$filename";
$max = $#dbline;
if (($stop,$action) = split(/\0/,$dbline{$line})) {
@@ -70,7 +72,7 @@ sub DB {
if ($emacs) {
print OUT "\032\032$filename:$line:0\n";
} else {
- $prefix = $sub =~ /'|::/ ? "" : "${package}::";
+ $prefix = $sub =~ /'|::/ ? "" : "${pkg}::";
$prefix .= "$sub($filename:";
if (length($prefix) > 30) {
print OUT "$prefix$line):\n$line:\t",$dbline[$line];
@@ -167,9 +169,9 @@ command Execute as a perl statement in current package.
print OUT $subname,"\n";
}
next CMD; };
- $cmd =~ s/^X\b/V $package/;
+ $cmd =~ s/^X\b/V $pkg/;
$cmd =~ /^V$/ && do {
- $cmd = "V $package"; };
+ $cmd = "V $pkg"; };
$cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
local ($savout) = select(OUT);
$packname = $1;
@@ -288,7 +290,7 @@ command Execute as a perl statement in current package.
$cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
$subname = $1;
$cond = $2 || '1';
- $subname = "${package}::" . $subname
+ $subname = "${pkg}::" . $subname
unless $subname =~ /'|::/;
$subname = "main" . $subname if substr($subname,0,1) eq "'";
$subname = "main" . $subname if substr($subname,0,2) eq "::";
@@ -492,7 +494,8 @@ command Execute as a perl statement in current package.
$evalarg = $post; &eval;
}
}
- ($@, $!, $,, $/, $\) = @saved;
+ ($@, $!, $,, $/, $\, $^W) = @saved;
+ ();
}
sub save {
diff --git a/lib/pwd.pl b/lib/pwd.pl
index 0cc3d4e96e..beb591679e 100644
--- a/lib/pwd.pl
+++ b/lib/pwd.pl
@@ -34,6 +34,7 @@ sub main'initpwd {
sub main'chdir {
local($newdir) = shift;
+ $newdir =~ s|/{2,}|/|g;
if (chdir $newdir) {
if ($newdir =~ m#^/#) {
$ENV{'PWD'} = $newdir;
View Lorry Controller Status