summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/AutoSplit.pm4
-rw-r--r--lib/Cwd.pm2
-rw-r--r--lib/Devel/SelfStubber.pm1
-rw-r--r--lib/Env.pm7
-rw-r--r--lib/Exporter.pm11
-rw-r--r--lib/ExtUtils/Liblist.pm1
-rw-r--r--lib/ExtUtils/MakeMaker.pm79
-rw-r--r--lib/ExtUtils/Manifest.pm36
-rw-r--r--lib/ExtUtils/Mkbootstrap.pm30
-rw-r--r--lib/FileHandle.pm69
-rw-r--r--lib/IPC/Open2.pm10
-rw-r--r--lib/IPC/Open3.pm13
-rw-r--r--lib/SelfLoader.pm1
-rw-r--r--lib/Sys/Hostname.pm31
-rw-r--r--lib/Sys/Syslog.pm46
-rw-r--r--lib/Term/Cap.pm427
-rw-r--r--lib/Term/Complete.pm79
-rw-r--r--lib/Test/Harness.pm62
-rw-r--r--lib/Text/Soundex.pm84
-rw-r--r--lib/Text/Tabs.pm29
-rw-r--r--lib/Text/Wrap.pm25
-rw-r--r--lib/TieHash.pm99
-rw-r--r--lib/Time/Local.pm57
-rw-r--r--lib/less.pm6
-rw-r--r--lib/overload.pm2
-rw-r--r--lib/strict.pm12
-rw-r--r--lib/syslog.pl18
27 files changed, 898 insertions, 343 deletions
diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm
index 46cf68985a..fd537bb979 100644
--- a/lib/AutoSplit.pm
+++ b/lib/AutoSplit.pm
@@ -14,6 +14,10 @@ use Carp;
AutoSplit - split a package for autoloading
+=head1 SYNOPSIS
+
+ perl -e 'use AutoSplit; autosplit_modules(@ARGV)' ...
+
=head1 DESCRIPTION
This function will split up your program into files that the AutoLoader
diff --git a/lib/Cwd.pm b/lib/Cwd.pm
index 2636fd2e4f..a627354f1b 100644
--- a/lib/Cwd.pm
+++ b/lib/Cwd.pm
@@ -31,7 +31,7 @@ getcwd - get pathname of current working directory
The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
in Perl.
-The fastgetcwd() function looks the same as getcwd(), but runs faster.
+The fastcwd() function looks the same as getcwd(), but runs faster.
It's also more dangerous because you might conceivably chdir() out of a
directory that you can't chdir() back into.
diff --git a/lib/Devel/SelfStubber.pm b/lib/Devel/SelfStubber.pm
index 1b5e575b8f..0a8caadad0 100644
--- a/lib/Devel/SelfStubber.pm
+++ b/lib/Devel/SelfStubber.pm
@@ -60,6 +60,7 @@ sub stub {
1;
__END__
+
=head1 NAME
Devel::SelfStubber - generate stubs for a SelfLoading module
diff --git a/lib/Env.pm b/lib/Env.pm
index 21870903b4..0e790754a8 100644
--- a/lib/Env.pm
+++ b/lib/Env.pm
@@ -2,7 +2,12 @@ package Env;
=head1 NAME
-Env - Perl module that imports environment variables
+Env - perl module that imports environment variables
+
+=head1 SYNOPSIS
+
+ use Env;
+ use Env qw(PATH HOME TERM);
=head1 DESCRIPTION
diff --git a/lib/Exporter.pm b/lib/Exporter.pm
index 8c4368c0ef..382ee859f4 100644
--- a/lib/Exporter.pm
+++ b/lib/Exporter.pm
@@ -1,6 +1,15 @@
package Exporter;
-=head1 Comments
+=head1 NAME
+
+Exporter - provide inport/export controls for Perl modules
+
+=head1 SYNOPSIS
+
+use Module;
+use Module qw(name1 name2 :tag /pattern/ !name);
+
+=head1 DESCRIPTION
If the first entry in an import list begins with !, : or / then the
list is treated as a series of specifications which either add to or
diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm
index 53eb0322d0..ebb2536382 100644
--- a/lib/ExtUtils/Liblist.pm
+++ b/lib/ExtUtils/Liblist.pm
@@ -171,6 +171,7 @@ sub lsdir { #yes, duplicate code seems less hassle than having an
1;
__END__
+
=head1 NAME
ExtUtils::Liblist - determine libraries to use and how to use them
diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm
index 5de54c6231..6aae816d4a 100644
--- a/lib/ExtUtils/MakeMaker.pm
+++ b/lib/ExtUtils/MakeMaker.pm
@@ -56,10 +56,10 @@ sub warndirectuse {
package ExtUtils::MakeMaker;
-# Last edited $Date: 1995/12/05 18:20:28 $ by Andreas Koenig
-# $Id: MakeMaker.pm,v 1.115 1995/12/05 18:20:28 k Exp $
+# Last edited $Date: 1995/12/10 23:38:09 $ by Andreas Koenig
+# $Id: MakeMaker.pm,v 1.116 1995/12/10 23:38:09 k Exp $
-$Version = $VERSION = "5.11";
+$Version = $VERSION = "5.12";
$ExtUtils::MakeMaker::Version_OK = 4.13; # Makefiles older than $Version_OK will die
# (Will be checked from MakeMaker version 4.13 onwards)
@@ -993,7 +993,7 @@ EOM
# version compatibility between the *.pm file and the
# corresponding *.xs file. The bottomline was, that we need an
# XS_VERSION macro that defaults to VERSION:
- $self->{XS_VERSION} ||= $self->{VERSION};
+ # $self->{XS_VERSION} ||= $self->{VERSION};
# --- Initialize Perl Binary Locations
@@ -1132,25 +1132,27 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
$self->{MAN1PODS} = {};
} else {
my %manifypods = ();
- foreach $name (@{$self->{EXE_FILES}}) {
- local(*TESTPOD);
- my($ispod)=0;
- if (open(TESTPOD,"<$name")) {
- my $testpodline;
- while ($testpodline = <TESTPOD>) {
- if($testpodline =~ /^=head/) {
- $ispod=1;
- last;
+ if( exists $self->{EXE_FILES} ){
+ foreach $name (@{$self->{EXE_FILES}}) {
+ local(*TESTPOD);
+ my($ispod)=0;
+ if (open(TESTPOD,"<$name")) {
+ my $testpodline;
+ while ($testpodline = <TESTPOD>) {
+ if($testpodline =~ /^=head/) {
+ $ispod=1;
+ last;
+ }
+ }
+ close(TESTPOD);
+ } else {
+ # If it doesn't exist yet, we assume, it has pods in it
+ $ispod = 1;
+ }
+ if( $ispod ) {
+ $manifypods{$name} = $self->catdir('$(INST_MAN1DIR)',basename($name).'.$(MAN1EXT)');
}
}
- close(TESTPOD);
- } else {
- # If it doesn't exist yet, we assume, it has pods in it
- $ispod = 1;
- }
- if( $ispod ) {
- $manifypods{$name} = $self->catdir('$(INST_MAN1DIR)',basename($name).'.$(MAN1EXT)');
- }
}
$self->{MAN1PODS} = \%manifypods;
@@ -1241,7 +1243,10 @@ sub init_others { # --- Initialize Other Attributes
# Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS}
# Lets look at $self->{LIBS} carefully: It may be an anon array, a string or
# undefined. In any case we turn it into an anon array:
- $self->{LIBS}=[] unless $self->{LIBS};
+
+ # May check $Config{libs} too, thus not empty.
+ $self->{LIBS}=[''] unless $self->{LIBS};
+
$self->{LIBS}=[$self->{LIBS}] if ref \$self->{LIBS} eq SCALAR;
$self->{LD_RUN_PATH} = "";
my($libs);
@@ -1288,7 +1293,7 @@ sub init_others { # --- Initialize Other Attributes
$self->{UMASK_NULL} = "umask 0";
}
-sub find_perl{
+sub find_perl {
my($self, $ver, $names, $dirs, $trace) = @_;
unless (ref $self){
ExtUtils::MakeMaker::TieAtt::warndirectuse((caller(0))[3]);
@@ -1306,10 +1311,10 @@ in these dirs:
next unless defined $dir; # $self->{PERL_SRC} may be undefined
foreach $name (@$names){
my $abs;
- if ($name =~ m|^/|) {
+ if ($self->file_name_is_absolute($name)) {
$abs = $name;
- } elsif ($name =~ m|/|) {
- $abs = $self->catfile(".", $name); # not absolute
+ } elsif ($name =~ m|/|) { # file_name_contains_path
+ $abs = $self->catfile(".", $name);
} else {
$abs = $self->catfile($dir, $name);
}
@@ -1366,6 +1371,12 @@ sub maybe_command {
return;
}
+sub perl_script {
+ my($self,$file) = @_;
+ return 1 if -r $file && ! -d $file;
+ return;
+}
+
# Ilya's suggestion, not yet used
sub file_name_is_absolute {
my($self,$file) = @_;
@@ -1421,9 +1432,9 @@ VERSION = $self->{VERSION}
VERSION_SYM = $self->{VERSION_SYM}
VERSION_MACRO = VERSION
DEFINE_VERSION = -D\$(VERSION_MACRO)=\\\"\$(VERSION)\\\"
-XS_VERSION = $self->{XS_VERSION}
-XS_VERSION_MACRO = XS_VERSION
-XS_DEFINE_VERSION = -D\$(XS_VERSION_MACRO)=\\\"\$(XS_VERSION)\\\"
+# XS_VERSION = $self->{XS_VERSION}
+# XS_VERSION_MACRO = XS_VERSION
+# XS_DEFINE_VERSION = -D\$(XS_VERSION_MACRO)=\\\"\$(XS_VERSION)\\\"
# In which directory should we put this extension during 'make'?
# This is typically ./blib.
@@ -2286,7 +2297,7 @@ sub manifypods {
} else {
$pod2man_exe = "$Config{bin}/pod2man";
}
- unless ($self->maybe_command($pod2man_exe)) {
+ unless ($self->perl_script($pod2man_exe)) {
# No pod2man but some MAN3PODS to be installed
print <<END;
@@ -2338,6 +2349,7 @@ $self->{PL_FILES}->{$plfile} :: $plfile
sub installbin {
my($self) = shift;
return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
+ return "" unless @{$self->{EXE_FILES}};
my(@m, $from, $to, %fromto, @to);
push @m, $self->dir_target(qw[$(INST_EXE)]);
for $from (@{$self->{EXE_FILES}}) {
@@ -2615,7 +2627,7 @@ doc_install ::
@ echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod
@ $(PERL) -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \\
-e "use ExtUtils::MakeMaker; MY->new({})->writedoc('Module', '$(NAME)', \\
- 'LINKTYPE=$(LINKTYPE)', 'VERSION=$(VERSION)', 'XS_VERSION=$(XS_VERSION)', \\
+ 'LINKTYPE=$(LINKTYPE)', 'VERSION=$(VERSION)', \\
'EXE_FILES=$(EXE_FILES)')" >> $(INSTALLARCHLIB)/perllocal.pod
};
@@ -3921,11 +3933,6 @@ May be set to an empty string, which is identical to C<-prototypes>, or
C<-noprototypes>. See the xsubpp documentation for details. MakeMaker
defaults to the empty string.
-=item XS_VERSION
-
-Your version number for the XS part of your extension. This defaults
-to S(VERSION).
-
=back
=head2 Additional lowercase attributes
diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm
index 1c54c77ee9..4d18cbe5fd 100644
--- a/lib/ExtUtils/Manifest.pm
+++ b/lib/ExtUtils/Manifest.pm
@@ -27,7 +27,8 @@ C<ExtUtils::Manifest::manicopy($read,$target,$how);>
=head1 DESCRIPTION
Mkmanifest() writes all files in and below the current directory to a
-file named C<MANIFEST> in the current directory. It works similar to
+file named in the global variable $ExtUtils::Manifest::MANIFEST (which
+defaults to C<MANIFEST>) in the current directory. It works similar to
find . -print
@@ -89,6 +90,17 @@ expressions should appear one on each line. A typical example:
C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>,
C<&maniread>, and C<&manicopy> are exportable.
+=head1 GLOBAL VARIABLES
+
+C<$ExtUtils::Manifest::MANIFEST> defaults to C<MANIFEST>. Changing it
+results in both a different C<MANIFEST> and a different
+C<MANIFEST.SKIP> file. This is useful if you want to maintain
+different distributions for different audiences (say a user version
+and a developer version including RCS).
+
+<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value,
+all functions act silently.
+
=head1 DIAGNOSTICS
All diagnostic output is sent to C<STDERR>.
@@ -117,6 +129,10 @@ to MANIFEST. $Verbose is set to 1 by default.
=back
+=head1 SEE ALSO
+
+L<ExtUtils::MakeMaker> which has handy targets for most of the functionality.
+
=head1 AUTHOR
Andreas Koenig F<E<lt>koenig@franz.ww.TU-Berlin.DEE<gt>>
@@ -136,10 +152,12 @@ $Debug = 0;
$Verbose = 1;
$Is_VMS = $Config{'osname'} eq 'VMS';
-$VERSION = $VERSION = substr(q$Revision: 1.17 $,10,4);
+$VERSION = $VERSION = substr(q$Revision: 1.18 $,10,4);
$Quiet = 0;
+$MANIFEST = 'MANIFEST';
+
# Really cool fix from Ilya :)
unless (defined $Config{d_link}) {
*ln = \&cp;
@@ -150,8 +168,8 @@ sub mkmanifest {
my $read = maniread() or $manimiss++;
$read = {} if $manimiss;
local *M;
- rename "MANIFEST", "MANIFEST.bak" unless $manimiss;
- open M, ">MANIFEST" or die "Could not open MANIFEST: $!";
+ rename $MANIFEST, "$MANIFEST.bak" unless $manimiss;
+ open M, ">$MANIFEST" or die "Could not open $MANIFEST: $!";
my $matches = _maniskip();
my $found = manifind();
my($key,$val,$file,%all);
@@ -159,7 +177,7 @@ sub mkmanifest {
foreach $file (sort keys %all) {
next if &$matches($file);
if ($Verbose){
- warn "Added to MANIFEST: $file\n" unless exists $read->{$file};
+ warn "Added to $MANIFEST: $file\n" unless exists $read->{$file};
}
my $text = $all{$file};
($file,$text) = split(/\s+/,$text,2) if $Is_VMS;
@@ -205,7 +223,7 @@ sub _manicheck {
if ($arg & 1){
my $found = manifind();
foreach $file (sort keys %$read){
- warn "Debug: manicheck checking from MANIFEST $file\n" if $Debug;
+ warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug;
unless ( exists $found->{$file} ) {
warn "No such file: $file\n" unless $Quiet;
push @missfile, $file;
@@ -224,7 +242,7 @@ sub _manicheck {
}
warn "Debug: manicheck checking from disk $file\n" if $Debug;
unless ( exists $read->{$file} ) {
- warn "Not in MANIFEST: $file\n" unless $Quiet;
+ warn "Not in $MANIFEST: $file\n" unless $Quiet;
push @missentry, $file;
}
}
@@ -234,7 +252,7 @@ sub _manicheck {
sub maniread {
my ($mfile) = @_;
- $mfile = "MANIFEST" unless defined $mfile;
+ $mfile = $MANIFEST unless defined $mfile;
my $read = {};
local *M;
unless (open M, $mfile){
@@ -255,7 +273,7 @@ sub _maniskip {
my ($mfile) = @_;
my $matches = sub {0};
my @skip ;
- my $mfile = "MANIFEST.SKIP" unless defined $mfile;
+ my $mfile = "$MANIFEST.SKIP" unless defined $mfile;
local *M;
return $matches unless -f $mfile;
open M, $mfile or return $matches;
diff --git a/lib/ExtUtils/Mkbootstrap.pm b/lib/ExtUtils/Mkbootstrap.pm
index a074bb1dd2..571098552f 100644
--- a/lib/ExtUtils/Mkbootstrap.pm
+++ b/lib/ExtUtils/Mkbootstrap.pm
@@ -7,12 +7,17 @@ $Version=2.0; # just to start somewhere
sub Mkbootstrap {
-=head1 USEFUL SUBROUTINES
+=head1 NAME
-=head2 Mkbootstrap()
+Mkbootstrap - make a bootstrap file for use by DynaLoader
-Make a bootstrap file for use by this system's DynaLoader. It
-typically gets called from an extension Makefile.
+=head1 SYNOPSIS
+
+C<mkbootstrap>
+
+=head1 DESCRIPTION
+
+Mkbootstrap typically gets called from an extension Makefile.
There is no C<*.bs> file supplied with the extension. Instead a
C<*_BS> file which has code for the special cases, like posix for
@@ -20,15 +25,14 @@ berkeley db on the NeXT.
This file will get parsed, and produce a maybe empty
C<@DynaLoader::dl_resolve_using> array for the current architecture.
-That will be extended by $BSLOADLIBS, which was computed by Andy's
-extliblist script. If this array still is empty, we do nothing, else
-we write a .bs file with an C<@DynaLoader::dl_resolve_using> array, but
-without any C<if>s, because there is no longer a need to deal with
-special cases.
-
-The C<*_BS> file can put some code into the generated C<*.bs> file by placing
-it in C<$bscode>. This is a handy 'escape' mechanism that may prove
-useful in complex situations.
+That will be extended by $BSLOADLIBS, which was computed by
+ExtUtils::Liblist::ext(). If this array still is empty, we do nothing,
+else we write a .bs file with an C<@DynaLoader::dl_resolve_using>
+array.
+
+The C<*_BS> file can put some code into the generated C<*.bs> file by
+placing it in C<$bscode>. This is a handy 'escape' mechanism that may
+prove useful in complex situations.
If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then
Mkbootstrap will automatically add a dl_findfile() call to the
diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm
index 9408717a7c..cbc6efbc6c 100644
--- a/lib/FileHandle.pm
+++ b/lib/FileHandle.pm
@@ -2,7 +2,7 @@ package FileHandle;
# Note that some additional FileHandle methods are defined in POSIX.pm.
-=head1 NAME
+=head1 NAME
FileHandle - supply object methods for filehandles
@@ -21,7 +21,6 @@ cacheout - keep more files open than the system permits
See L<perlvar> for complete descriptions of each of the following supported C<FileHandle>
methods:
- print
autoflush
output_field_separator
output_record_separator
@@ -35,15 +34,55 @@ methods:
format_line_break_characters
format_formfeed
+Furthermore, for doing normal I/O you might need these:
+
+=over
+
+=item $fh->print
+
+See L<perlfunc/print>.
+
+=item $fh->printf
+
+See L<perlfunc/printf>.
+
+=item $fh->getline
+
+This works like <$fh> described in L<perlop/"I/O Operators"> except that it's more readable
+and can be safely called in an array context but still
+returns just one line.
+
+=item $fh->getlines
+
+This works like <$fh> when called in an array context to
+read all the remaining lines in a file, except that it's more readable.
+It will also croak() if accidentally called in a scalar context.
+
+=back
+
+=head2 The cacheout() Library
+
The cacheout() function will make sure that there's a filehandle
open for writing available as the pathname you give it. It automatically
closes and re-opens files if you exceed your system file descriptor maximum.
+=head1 SEE ALSO
+
+L<perlfunc>,
+L<perlop/"I/O Operators">,
+L<POSIX/"FileHandle">
+
=head1 BUGS
F<sys/param.h> lies with its C<NOFILE> define on some systems,
so you may have to set $cacheout::maxopen yourself.
+Some of the methods that set variables (like format_name()) don't
+seem to work.
+
+The POSIX functions that create FileHandle methods should be
+in this module instead.
+
Due to backwards compatibility, all filehandles resemble objects
of class C<FileHandle>, or actually classes derived from that class.
They actually aren't. Which means you can't derive your own
@@ -53,11 +92,11 @@ class from C<FileHandle> and inherit those methods.
require 5.000;
use English;
+use Carp;
use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(
- print
autoflush
output_field_separator
output_record_separator
@@ -70,6 +109,12 @@ use Exporter;
format_top_name
format_line_break_characters
format_formfeed
+
+ print
+ printf
+ getline
+ getlines
+
cacheout
);
@@ -78,6 +123,24 @@ sub print {
print $this @_;
}
+sub printf {
+ local($this) = shift;
+ printf $this @_;
+}
+
+sub getline {
+ local($this) = shift;
+ croak "usage: FileHandle::getline()" if @_;
+ return scalar <$this>;
+}
+
+sub getlines {
+ local($this) = shift;
+ croak "usage: FileHandle::getline()" if @_;
+ croak "can't call FileHandle::getlines in a scalar context" if wantarray;
+ return <$this>;
+}
+
sub autoflush {
local($old) = select($_[0]);
local($prev) = $OUTPUT_AUTOFLUSH;
diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm
index 71f89f35c2..1ac963ab6b 100644
--- a/lib/IPC/Open2.pm
+++ b/lib/IPC/Open2.pm
@@ -10,9 +10,9 @@ IPC::Open2, open2 - open a process for both reading and writing
=head1 SYNOPSIS
use IPC::Open2;
- $pid = open2('rdr', 'wtr', 'some cmd and args');
+ $pid = open2(\*RDR, \*WTR, 'some cmd and args');
# or
- $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+ $pid = open2(\*RDR, \*WTR, 'some', 'cmd', 'and', 'args');
=head1 DESCRIPTION
@@ -39,7 +39,7 @@ however, are quite apt to cause deadlock.
The big problem with this approach is that if you don't have control
over source code being run in the the child process, you can't control what it does
-with pipe buffering. Thus you can't just open a pipe to "cat -v" and continually
+with pipe buffering. Thus you can't just open a pipe to C<cat -v> and continually
read and write a line from it.
=head1 SEE ALSO
@@ -80,8 +80,8 @@ sub open2 {
# force unqualified filehandles into callers' package
local($package) = caller;
- $dad_rdr =~ s/^[^']+$/$package'$&/;
- $dad_wtr =~ s/^[^']+$/$package'$&/;
+ $dad_rdr =~ s/^[^']+$/$package'$&/ unless ref $dad_rdr;
+ $dad_wtr =~ s/^[^']+$/$package'$&/ unless ref $dad_wtr;
local($kid_rdr) = ++$fh;
local($kid_wtr) = ++$fh;
diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm
index db8652ee78..5bc757c344 100644
--- a/lib/IPC/Open3.pm
+++ b/lib/IPC/Open3.pm
@@ -9,7 +9,7 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling
=head1 SYNOPSIS
- $pid = open3('WTRFH', 'RDRFH', 'ERRFH'
+ $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH
'some cmd and args', 'optarg', ...);
=head1 DESCRIPTION
@@ -24,6 +24,11 @@ the child will read from it directly. If RDRFH or ERRFH begins with
">&", then the child will send output directly to that file handle. In both
cases, there will be a dup(2) instead of a pipe(2) made.
+If you try to read from the child's stdout writer and their stderr
+writer, you'll have problems with blocking, which means you'll
+want to use select(), which means you'll have to use sysread() instead
+of normal stuff.
+
All caveats from open2() continue to apply. See L<open2> for details.
=cut
@@ -78,9 +83,9 @@ sub open3 {
# force unqualified filehandles into callers' package
my($package) = caller;
- $dad_wtr =~ s/^[^:]+$/$package\:\:$&/;
- $dad_rdr =~ s/^[^:]+$/$package\:\:$&/;
- $dad_err =~ s/^[^:]+$/$package\:\:$&/;
+ $dad_wtr =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_wtr;
+ $dad_rdr =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_rdr;
+ $dad_err =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_err;
my($kid_rdr) = ++$fh;
my($kid_wtr) = ++$fh;
diff --git a/lib/SelfLoader.pm b/lib/SelfLoader.pm
index 017d20437b..e3da9ebadb 100644
--- a/lib/SelfLoader.pm
+++ b/lib/SelfLoader.pm
@@ -100,6 +100,7 @@ sub _package_defined {}
1;
__END__
+
=head1 NAME
SelfLoader - load functions only on demand
diff --git a/lib/Sys/Hostname.pm b/lib/Sys/Hostname.pm
index 4dd4fe2bdc..91c62b6db6 100644
--- a/lib/Sys/Hostname.pm
+++ b/lib/Sys/Hostname.pm
@@ -1,6 +1,3 @@
-# by David Sundstrom sunds@asictest.sc.ti.com
-# Texas Instruments
-
package Sys::Hostname;
use Carp;
@@ -8,9 +5,31 @@ require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(hostname);
-#
-# Try every conceivable way to get hostname.
-#
+=head1 NAME
+
+Sys::Hostname - Try every conceivable way to get hostname
+
+=head1 SYNOPSIS
+
+ use Sys::Hostname;
+ $host = hostname;
+
+=head1 DESCRIPTION
+
+Attempts several methods of getting the system hostname and
+then caches the result. It tries C<syscall(SYS_gethostname)>,
+C<`hostname`>, C<`uname -n`>, and the file F</com/host>.
+If all that fails it C<croak>s.
+
+All nulls, returns, and newlines are removed from the result.
+
+=head1 AUTHOR
+
+David Sundstrom <sunds@asictest.sc.ti.com>
+
+Texas Instruments
+
+=cut
sub hostname {
diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm
index 671da9f996..bd8f07cc79 100644
--- a/lib/Sys/Syslog.pm
+++ b/lib/Sys/Syslog.pm
@@ -125,7 +125,7 @@ sub syslog {
if ($lo_cons) {
if ($pid = fork) {
unless ($lo_nowait) {
- do {$died = wait;} until $died == $pid || $died < 0;
+ $died = waitpid($pid, 0);
}
}
else {
@@ -147,44 +147,12 @@ sub xlate {
}
sub connect {
- $pat = 'S n C4 x8';
-
- $af_unix = AF_UNIX();
- $af_inet = AF_INET();
-
- $stream = SOCK_STREAM();
- $datagram = SOCK_DGRAM();
-
- ($name,$aliases,$proto) = getprotobyname('udp');
- $udp = $proto;
-
- ($name,$aliase,$port,$proto) = getservbyname('syslog','udp');
- $syslog = $port;
-
- if ($myname = hostname()) {
- ($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($myname);
- croak "Can't lookup $myname" 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);
- croak "Can't lookup $host" unless $name;
- @bytes = unpack("C4",$addrs[0]);
- }
- $that = pack($pat,$af_inet,$syslog,@bytes);
-
- socket(SYSLOG,$af_inet,$datagram,$udp) || croak "socket: $!";
- bind(SYSLOG,$this) || croak "bind: $!";
- connect(SYSLOG,$that) || croak "connect: $!";
-
+ my $udp = getprotobyname('udp');
+ my $syslog = getservbyname('syslog','udp');
+ my $this = sockaddr_in($syslog, INADDR_ANY);
+ my $that = sockaddr_in($syslog, inet_aton($host) || croak "Can't lookup $host");
+ socket(SYSLOG,AF_INET,SOCK_DGRAM,$udp) || croak "socket: $!";
+ connect(SYSLOG,$that) || croak "connect: $!";
local($old) = select(SYSLOG); $| = 1; select($old);
$connected = 1;
}
diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm
index 061ca704b7..5e900c3f23 100644
--- a/lib/Term/Cap.pm
+++ b/lib/Term/Cap.pm
@@ -1,138 +1,250 @@
-# Term::Cap.pm -- Termcap interface routines
package Term::Cap;
+use Carp;
-# Converted to package on 25 Feb 1994 <sanders@bsdi.com>
-#
-# Usage:
-# require 'ioctl.pl';
-# 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.
-#
+# Last updated: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
-# 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;
+# TODO:
+# support Berkeley DB termcaps
+# should probably be a .xs module
+# force $FH into callers package?
+# keep $FH in object at Tgetent time?
+
+=head1 NAME
+
+Term::Cap - Perl termcap interface
+
+=head1 SYNOPSIS
+
+ require Term::Cap;
+ $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+ $terminal->Trequire(qw/ce ku kd/);
+ $terminal->Tgoto('cm', $col, $row, $FH);
+ $terminal->Tputs('dl', $count, $FH);
+ $terminal->Tpad($string, $count, $FH);
+
+=head1 DESCRIPTION
+
+These are low-level functions to extract and use capabilities from
+a terminal capability (termcap) database.
+
+The B<Tgetent> function extracts the entry of the specified terminal
+type I<TERM> (defaults to the environment variable I<TERM>) from the
+database.
+
+It will look in the environment for a I<TERMCAP> variable. If
+found, and the value does not begin with a slash, and the terminal
+type name is the same as the environment string I<TERM>, the
+I<TERMCAP> string is used instead of reading a termcap file. If
+it does begin with a slash, the string is used as a path name of
+the termcap file to search. If I<TERMCAP> does not begin with a
+slash and name is different from I<TERM>, B<Tgetent> searches the
+files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>,
+in that order, unless the environment variable I<TERMPATH> exists,
+in which case it specifies a list of file pathnames (separated by
+spaces or colons) to be searched B<instead>. Whenever multiple
+files are searched and a tc field occurs in the requested entry,
+the entry it names must be found in the same file or one of the
+succeeding files. If there is a C<:tc=...:> in the I<TERMCAP>
+environment variable string it will continue the search in the
+files as above.
+
+I<OSPEED> is the terminal output bit rate (often mistakenly called
+the baud rate). I<OSPEED> can be specified as either a POSIX
+termios/SYSV termio speeds (where 9600 equals 9600) or an old
+BSD-style speeds (where 13 equals 9600).
+
+B<Tgetent> returns a blessed object reference which the user can
+then use to send the control strings to the terminal using B<Tputs>
+and B<Tgoto>. It calls C<croak> on failure.
+
+B<Tgoto> decodes a cursor addressing string with the given parameters.
+
+The output strings for B<Tputs> are cached for counts of 1 for performance.
+B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap
+data and C<$self-E<gt>{xx}> is the cached version.
+
+ print $terminal->Tpad($self->{_xx}, 1);
+
+B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also
+output the string to $FH if specified.
+
+The extracted termcap entry is available in the object
+as C<$self-E<gt>{TERMCAP}>.
+
+=head1 EXAMPLES
+
+ # Get terminal output speed
+ require POSIX;
+ my $termios = new POSIX::Termios;
+ $termios->getattr;
+ my $ospeed = $termios->getospeed;
+
+ # Old-style ioctl code to get ospeed:
+ # require 'ioctl.pl';
+ # ioctl(TTY,$TIOCGETP,$sgtty);
+ # ($ispeed,$ospeed) = unpack('cc',$sgtty);
+
+ # allocate and initialize a terminal structure
+ $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
+
+ # require certain capabilities to be available
+ $terminal->Trequire(qw/ce ku kd/);
+
+ # Output Routines, if $FH is undefined these just return the string
+
+ # Tgoto does the % expansion stuff with the given args
+ $terminal->Tgoto('cm', $col, $row, $FH);
+
+ # Tputs doesn't do any % expansion.
+ $terminal->Tputs('dl', $count = 1, $FH);
+
+=cut
+
+# Returns a list of termcap files to check.
+sub termcap_path { ## private
+ my @termcap_path;
+ # $TERMCAP, if it's a filespec
+ push(@termcap_path, $ENV{TERMCAP}) if $ENV{TERMCAP} =~ /^\//;
+ if ($ENV{TERMPATH}) {
+ # Add the users $TERMPATH
+ push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
+ }
+ else {
+ # Defaults
+ push(@termcap_path,
+ $ENV{'HOME'} . '/.termcap',
+ '/etc/termcap',
+ '/usr/share/misc/termcap',
+ );
}
- # we always search TERMCAP first
- $v = getenv(TERMCAP);
- unshift(@termcap_path, $v) if $v =~ /^\//;
+ # return the list of those termcaps that exist
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
+sub Tgetent { ## public -- static method
+ my $class = shift;
+ my $self = bless shift, $class;
+ my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP);
+ local($termpat,$state,$first,$entry); # used inside eval
+ local $_;
+
+ # Compute PADDING factor from OSPEED (to be used by Tpad)
+ if (! $self->{OSPEED}) {
+ carp "OSPEED was not set, defaulting to 9600";
+ $self->{OSPEED} = 9600;
+ }
+ if ($self->{OSPEED} < 16) {
+ # delays for old style speeds
+ my @pad = (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);
+ $self->{PADDING} = $pad[$self->{OSPEED}];
+ }
+ else {
+ $self->{PADDING} = 10000 / $self->{OSPEED};
+ }
+
+ $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set");
+ $term = $self->{TERM}; # $term is the term type we are looking for
+
+ # $tmp_term is always the next term (possibly :tc=...:) we are looking for
+ $tmp_term = $self->{TERM};
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
+
+ my $foo = $ENV{TERMCAP};
+
+ # $entry is the extracted termcap entry
+ if (($foo !~ m:^/:) && ($foo =~ m/(^|\|)${termpat}[:|]/)) {
+ $entry = $foo;
+ }
+
+ my @termcap_path = termcap_path;
+ croak "Can't find a valid termcap file" unless @termcap_path || $entry;
+
+ $state = 1; # 0 == finished
+ # 1 == next file
+ # 2 == search again
+
+ $first = 0; # first entry (keeps term name)
+
+ $max = 32; # max :tc=...:'s
+
+ if ($entry) {
+ # ok, we're starting with $TERMCAP
+ $first++; # we're the first entry
+ # do we need to continue?
+ if ($entry =~ s/:tc=([^:]+):/:/) {
+ $tmp_term = $1;
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
+ }
+ else {
+ $state = 0; # we're already finished
+ }
+ }
+
+ # This is eval'ed inside the while loop for each file
+ $search = q{
+ while ($_ = <TERMCAP>) {
+ next if /^\\t/ || /^#/;
+ if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
+ chomp;
+ s/^[^:]*:// if $first++;
+ $state = 0;
+ while ($_ =~ s/\\\\$//) { $_ .= <TERMCAP>; chomp; }
+ last;
}
+ }
+ $entry .= $_;
+ };
- open(TERMCAP,"< $TERMCAP\0") || die "Tgetent: $TERMCAP: $!\n";
- # print STDERR "Trying... $TERMCAP\n";
- $loop = "
- while (<TERMCAP>) {
- next if /^\t/;
- next if /^#/;
- if (/(^|\\|)${TERM}[:\\|]/) {
- chop;
- s/^[^:]*:// unless \$first++;
- \$state = 0;
- while (chop eq '\\\\') {
- \$_ .= <TERMCAP>;
- chop;
- }
- \$_ .= ':';
- last;
- }
- }
- \$entry .= \$_;
- ";
- eval $loop;
- 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;
+ while ($state != 0) {
+ if ($state == 1) {
+ # get the next TERMCAP
+ $TERMCAP = shift @termcap_path
+ || croak "failed termcap lookup on $tmp_term";
+ }
+ else {
+ # do the same file again
+ # prevent endless recursion
+ $max-- || croak "failed termcap loop at $tmp_term";
+ $state = 1; # ok, maybe do a new file next time
+ }
+
+ open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!";
+ eval $search;
+ die $@ if $@;
+ close TERMCAP;
+
+ # If :tc=...: found then search this file again
+ $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2);
+ # protect any pattern metacharacters in $tmp_term
+ $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g;
}
- die "Tgetent: Can't find $term\n" unless $entry ne '';
- $entry =~ s/:\s+:/:/g;
- $this->{TERMCAP} = $entry;
- #print STDERR $entry, "\n"; # DEBUG
+
+ croak "Can't find $term" if $entry eq '';
+ $entry =~ s/:+\s*:+/:/g; # cleanup $entry
+ $entry =~ s/:+/:/g; # cleanup $entry
+ $self->{TERMCAP} = $entry; # save it
+ # print STDERR "DEBUG: $entry = ", $entry, "\n";
# Precompile $entry into the object
+ $entry =~ s/^[^:]*://;
foreach $field (split(/:[\s:\\]*/,$entry)) {
- if ($field =~ /^\w\w$/) {
- $this->{'_' . $field} = 1 unless defined $this->{'_' . $1};
+ if ($field =~ /^(\w\w)$/) {
+ $self->{'_' . $field} = 1 unless defined $self->{'_' . $1};
+ # print STDERR "DEBUG: flag $1\n";
}
elsif ($field =~ /^(\w\w)\@/) {
- $this->{'_' . $1} = "";
+ $self->{'_' . $1} = "";
+ # print STDERR "DEBUG: unset $1\n";
}
elsif ($field =~ /^(\w\w)#(.*)/) {
- $this->{'_' . $1} = $2 unless defined $this->{'_' . $1};
+ $self->{'_' . $1} = $2 unless defined $self->{'_' . $1};
+ # print STDERR "DEBUG: numeric $1 = $2\n";
}
elsif ($field =~ /^(\w\w)=(.*)/) {
- next if defined $this->{'_' . ($cap = $1)};
+ # print STDERR "DEBUG: string $1 = $2\n";
+ next if defined $self->{'_' . ($cap = $1)};
$_ = $2;
s/\\E/\033/g;
s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
@@ -146,47 +258,47 @@ sub Tgetent {
s/\^(.)/pack('c',ord($1) & 31)/eg;
s/\\(.)/$1/g;
s/\377/^/g;
- $this->{'_' . $cap} = $_;
+ $self->{'_' . $cap} = $_;
}
- # else { warn "Tgetent: junk in $term: $field\n"; }
+ # else { carp "junk in $term ignored: $field"; }
}
- $this->{'_pc'} = "\0" unless defined $this->{'_pc'};
- $this->{'_bc'} = "\b" unless defined $this->{'_bc'};
- $this;
+ $self->{'_pc'} = "\0" unless defined $self->{'_pc'};
+ $self->{'_bc'} = "\b" unless defined $self->{'_bc'};
+ $self;
}
-# 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);
+# $terminal->Tpad($string, $cnt, $FH);
+sub Tpad { ## public
+ my $self = shift;
+ my($string, $cnt, $FH) = @_;
+ my($decr, $ms);
if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
$ms = $1;
$ms *= $cnt if $2;
$string = $3;
- $decr = $this->{OSPEED} < 50 ? $Tpad[$this->{OSPEED}] : $this->{DECR};
+ $decr = $self->{PADDING};
if ($decr > .1) {
$ms += $decr / 2;
- $string .= $this->{'_pc'} x ($ms / $decr);
+ $string .= $self->{'_pc'} x ($ms / $decr);
}
}
print $FH $string if $FH;
$string;
}
-# $term->Tputs($cap, $cnt, $FH);
-sub Tputs {
- local($this, $cap, $cnt, $FH) = @_;
- local $string;
+# $terminal->Tputs($cap, $cnt, $FH);
+sub Tputs { ## public
+ my $self = shift;
+ my($cap, $cnt, $FH) = @_;
+ my $string;
if ($cnt > 1) {
- $string = Tpad($this, $this->{'_' . $cap}, $cnt);
+ $string = Tpad($self, $self->{'_' . $cap}, $cnt);
} else {
- $string = defined $this->{$cap} ? $this->{$cap} :
- ($this->{$cap} = Tpad($this, $this->{'_' . $cap}, 1));
+ # cache result because Tpad can be slow
+ $string = defined $self->{$cap} ? $self->{$cap} :
+ ($self->{$cap} = Tpad($self, $self->{'_' . $cap}, 1));
}
print $FH $string if $FH;
$string;
@@ -207,15 +319,16 @@ sub Tputs {
# %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($this, $cap, $code, $tmp, $FH) = @_;
- local $string = $this->{'_' . $cap};
- local $result = '';
- local $after = '';
- local $online = 0;
- local @tmp = ($tmp,$code);
- local $cnt = $code;
+# $terminal->Tgoto($cap, $col, $row, $FH);
+sub Tgoto { ## public
+ my $self = shift;
+ my($cap, $code, $tmp, $FH) = @_;
+ my $string = $self->{'_' . $cap};
+ my $result = '';
+ my $after = '';
+ my $online = 0;
+ my @tmp = ($tmp,$code);
+ my $cnt = $code;
while ($string =~ /^([^%]*)%(.)(.*)/) {
$result .= $1;
@@ -228,10 +341,10 @@ sub Tgoto {
$tmp = shift(@tmp);
if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
if ($online) {
- ++$tmp, $after .= $this->{'_up'} if $this->{'_up'};
+ ++$tmp, $after .= $self->{'_up'} if $self->{'_up'};
}
else {
- ++$tmp, $after .= $this->{'_bc'};
+ ++$tmp, $after .= $self->{'_bc'};
}
}
$result .= sprintf("%c",$tmp);
@@ -269,19 +382,21 @@ sub Tgoto {
return "OOPS";
}
}
- $string = Tpad($this, $result . $string . $after, $cnt);
+ $string = Tpad($self, $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->{'_' . $_};
+# $terminal->Trequire(qw/ce ku kd/);
+sub Trequire { ## public
+ my $self = shift;
+ my($cap,@undefined);
+ foreach $cap (@_) {
+ push(@undefined, $cap)
+ unless defined $self->{'_' . $cap} && $self->{'_' . $cap};
}
+ croak "Terminal does not support: (@undefined)" if @undefined;
}
1;
+
diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm
index 97c71fe43f..6faef2296e 100644
--- a/lib/Term/Complete.pm
+++ b/lib/Term/Complete.pm
@@ -5,30 +5,63 @@ require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(Complete);
-#
# @(#)complete.pl,v1.1 (me@anywhere.EBay.Sun.COM) 09/23/91
-#
-# Author: Wayne Thompson
-#
-# Description:
-# This routine provides word completion.
-# (TAB) attempts word completion.
-# (^D) prints completion list.
-# (These may be changed by setting $Complete::complete, etc.)
-#
-# Diagnostics:
-# Bell when word completion fails.
-#
-# Dependencies:
-# The tty driver is put into raw mode.
-#
-# Bugs:
-#
-# Usage:
-# $input = complete('prompt_string', \@completion_list);
-# or
-# $input = complete('prompt_string', @completion_list);
-#
+
+=head1 NAME
+
+Term::Complete - Perl word completion module
+
+=head1 SYNOPSIS
+
+ $input = complete('prompt_string', \@completion_list);
+ $input = complete('prompt_string', @completion_list);
+
+=head1 DESCRIPTION
+
+This routine provides word completion on the list of words in
+the array (or array ref).
+
+The tty driver is put into raw mode using the system command
+C<stty raw -echo> and restored using C<stty -raw echo>.
+
+The following command characters are defined:
+
+=over 4
+
+=item <tab>
+Attempts word completion.
+Cannot be changed.
+
+=item ^D
+
+Prints completion list.
+Defined by I<$Term::Complete::complete>.
+
+=item ^U
+
+Erases the current input.
+Defined by I<$Term::Complete::kill>.
+
+=item <del>, <bs>
+
+Erases one character.
+Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
+
+=back
+
+=head1 DIAGNOSTICS
+
+Bell sounds when word completion fails.
+
+=head1 BUGS
+
+The completion charater <tab> cannot be changed.
+
+=head1 AUTHOR
+
+Wayne Thompson
+
+=cut
CONFIG: {
$complete = "\004";
diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm
index 635febdca5..99e06f7381 100644
--- a/lib/Test/Harness.pm
+++ b/lib/Test/Harness.pm
@@ -10,7 +10,7 @@ $ENV{EMXSHELL} = 'sh' if $Is_OS2; # to run commands
$path_s = $Is_OS2 ? ';' : ':' ;
@ISA=(Exporter);
-@EXPORT= qw(&runtests &test_lib);
+@EXPORT= qw(&runtests);
@EXPORT_OK= qw($verbose $switches);
$verbose = 0;
@@ -85,3 +85,63 @@ sub runtests {
}
1;
+__END__
+
+=head1 NAME
+
+Test::Harness - run perl standard test scripts with statistics
+
+=head1 SYNOPSIS
+
+use Test::Harness;
+
+runtests(@tests);
+
+=head1 DESCRIPTION
+
+Perl test scripts print to standard output C<"ok N"> for each single
+test, where C<N> is an increasing sequence of integers. The first line
+output by a standard test scxript is C<"1..M"> with C<M> being the
+number of tests that should be run within the test
+script. Test::Harness::runscripts(@tests) runs all the testscripts
+named as arguments and checks standard output for the expected
+C<"ok N"> strings.
+
+After all tests have been performed, runscripts() prints some
+performance statistics that are computed by the Benchmark module.
+
+=head1 EXPORT
+
+C<&runscripts> is exported by Test::Harness per default.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item C<All tests successful.\nFiles=%d, Tests=%d, %s>
+
+If all tests are successful some statistics about the performance are
+printed.
+
+=item C<Failed 1 test, $pct% okay.>
+
+=item C<Failed %d/%d tests, %.2f%% okay.>
+
+If not all tests were successful, the script dies with one of the
+above messages.
+
+=back
+
+=head1 SEE ALSO
+
+See L<Benchmerk> for the underlying timing routines.
+
+=head1 BUGS
+
+Test::Harness uses $^X to determine the perl binary to run the tests
+with. Test scripts running via the shebang (C<#!>) line may not be portable
+because $^X is not consistent for shebang scripts across
+platforms. This is no problem when Test::Harness is run with an
+absolute path to the perl binary.
+
+=cut
diff --git a/lib/Text/Soundex.pm b/lib/Text/Soundex.pm
index 655152347c..a334404667 100644
--- a/lib/Text/Soundex.pm
+++ b/lib/Text/Soundex.pm
@@ -40,19 +40,12 @@ require Exporter;
$soundex_nocode = undef;
-# soundex
-#
-# usage:
-#
-# @codes = &soundex (@wordList);
-# $code = &soundex ($word);
-#
-# This strenuously avoids 0
-
sub soundex
{
local (@s, $f, $fc, $_) = @_;
+ push @s, '' unless @s; # handle no args as a single empty string
+
foreach (@s)
{
tr/a-z/A-Z/;
@@ -80,3 +73,76 @@ sub soundex
1;
+__END__
+
+=head1 NAME
+
+Text::Soundex - Implementation of the Soundex Algorithm as Described by Knuth
+
+=head1 SYNOPSIS
+
+ use Text::Soundex;
+
+ $code = soundex $string; # get soundex code for a string
+ @codes = soundex @list; # get list of codes for list of strings
+
+ # set value to be returned for strings without soundex code
+
+ $soundex_nocode = 'Z000';
+
+=head1 DESCRIPTION
+
+This module implements the soundex algorithm as described by Donald Knuth
+in Volume 3 of B<The Art of Computer Programming>. The algorithm is
+intended to hash words (in particular surnames) into a small space using a
+simple model which approximates the sound of the word when spoken by an English
+speaker. Each word is reduced to a four character string, the first
+character being an upper case letter and the remaining three being digits.
+
+If there is no soundex code representation for a string then the value of
+C<$soundex_nocode> is returned. This is initially set to C<undef>, but
+many people seem to prefer an I<unlikely> value like C<Z000>
+(how unlikely this is depends on the data set being dealt with.) Any value
+can be assigned to C<$soundex_nocode>.
+
+In scalar context C<soundex> returns the soundex code of its first
+argument, and in array context a list is returned in which each element is the
+soundex code for the corresponding argument passed to C<soundex> e.g.
+
+ @codes = soundex qw(Mike Stok);
+
+leaves C<@codes> containing C<('M200', 'S320')>.
+
+=head1 EXAMPLES
+
+Knuth's examples of various names and the soundex codes they map to
+are listed below:
+
+ Euler, Ellery -> E460
+ Gauss, Ghosh -> G200
+ Hilbert, Heilbronn -> H416
+ Knuth, Kant -> K530
+ Lloyd, Ladd -> L300
+ Lukasiewicz, Lissajous -> L222
+
+so:
+
+ $code = soundex 'Knuth'; # $code contains 'K530'
+ @list = soundex qw(Lloyd Gauss); # @list contains 'L300', 'G200'
+
+=head1 LIMITATIONS
+
+As the soundex algorithm was originally used a B<long> time ago in the US
+it considers only the English alphabet and pronunciation.
+
+As it is mapping a large space (arbitrary length strings) onto a small
+space (single letter plus 3 digits) no inference can be made about the
+similarity of two strings which end up with the same soundex code. For
+example, both C<Hilbert> and C<Heilbronn> end up with a soundex code
+of C<H416>.
+
+=head1 AUTHOR
+
+This code was implemented by Mike Stok (C<stok@cybercom.net>) from the
+description given by Knuth. Ian Phillips (C<ian@pipex.net>) and Rich Pinder
+(C<rpinder@hsc.usc.edu>) supplied ideas and spotted mistakes.
diff --git a/lib/Text/Tabs.pm b/lib/Text/Tabs.pm
index 7cfb478b75..2481d81ec6 100644
--- a/lib/Text/Tabs.pm
+++ b/lib/Text/Tabs.pm
@@ -10,6 +10,35 @@
# Version: 9/21/95
#
+=head1 NAME
+
+Text::Tabs -- expand and unexpand tabs
+
+=head1 SYNOPSIS
+
+ use Text::Tabs;
+
+ #$tabstop = 8; # Defaults
+ print expand("Hello\tworld");
+ print unexpand("Hello, world");
+ $tabstop = 4;
+ print join("\n",expand(split(/\n/,
+ "Hello\tworld,\nit's a nice day.\n"
+ )));
+
+=head1 DESCRIPTION
+
+This module expands and unexpands tabs into spaces, as per the unix expand
+and unexpand programs. Either function should be passed an array of strings
+(newlines may I<not> be included, and should be used to split an incoming
+string into separate elements.) which will be processed and returned.
+
+=head1 AUTHOR
+
+David Muir Sharnoff <muir@idiom.com>
+
+=cut
+
package Text::Tabs;
require Exporter;
diff --git a/lib/Text/Wrap.pm b/lib/Text/Wrap.pm
index 9b1d054704..b665752f94 100644
--- a/lib/Text/Wrap.pm
+++ b/lib/Text/Wrap.pm
@@ -30,6 +30,31 @@ package Text::Wrap;
# Version: 9/21/95
#
+=head1 NAME
+
+Text::Wrap -- wrap text into a paragraph
+
+=head1 SYNOPSIS
+
+ use Text::Wrap;
+
+ $Text::Wrap::columns = 20; # Default
+ print wrap("\t","",Hello, world, it's a nice day, isn't it?");
+
+=head1 DESCRIPTION
+
+This module is a simple paragraph formatter that wraps text into a paragraph
+and indents each line. The single exported function, wrap(), takes three
+arguments. The first is included before the first output line, and the
+second argument is included before each subsequest output line. The third
+argument is the text to be wrapped.
+
+=head1 AUTHOR
+
+David Muir Sharnoff <muir@idiom.com>
+
+=cut
+
require Exporter;
@ISA = (Exporter);
diff --git a/lib/TieHash.pm b/lib/TieHash.pm
index 446cbcb25b..161771a0ea 100644
--- a/lib/TieHash.pm
+++ b/lib/TieHash.pm
@@ -1,4 +1,103 @@
package TieHash;
+
+=head1 NAME
+
+TieHash, TieHash::Std - base class definitions for tied hashes
+
+=head1 SYNOPSIS
+
+ package NewHash;
+ require TieHash;
+
+ @ISA = (TieHash);
+
+ sub DELETE { ... } # Provides needed method
+ sub CLEAR { ... } # Overrides inherited method
+
+
+ package NewStdHash;
+ require TieHash;
+
+ @ISA = (TieHash::Std);
+
+ # All methods provided by default, define only those needing overrides
+ sub DELETE { ... }
+
+
+ package main;
+
+ tie %new_hash, NewHash;
+ tie %new_std_hash, NewStdHash;
+
+=head1 DESCRIPTION
+
+This module provides some skeletal methods for hash-tying classes. See
+L<perlfunc/tie> for a list of the functions required in order to tie a hash
+to a package. The basic B<TieHash> package provides a C<new> method, as well
+as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<TieHash::Std> package
+provides most methods required for hashes in L<perlfunc/tie>. It inherits from
+B<TieHash>, and causes tied hashes to behave exactly like standard hashes,
+allowing for selective overloading of methods. The B<new> method is provided
+as grandfathering in the case a class forgets to include a B<TIEHASH> method.
+
+For developers wishing to write their own tied hashes, the required methods
+are:
+
+=item TIEHASH classname, LIST
+
+The method invoked by the command C<tie %hash, class>. Associates a new
+hash instance with the specified class. C<LIST> would represent additional
+arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
+complete the association.
+
+=item STORE this, key, value
+
+Store datum I<value> into I<key> for the tied hash I<this>.
+
+=item FETCH this, key
+
+Retrieve the datum in I<key> for the tied hash I<this>.
+
+=item FIRSTKEY this
+
+Return the (key, value) pair for the first key in the hash.
+
+=item NEXTKEY this, lastkey
+
+Return the next (key, value) pair for the hash.
+
+=item EXISTS this, key
+
+Verify that I<key> exists with the tied hash I<this>.
+
+=item DELETE this, key
+
+Delete the key I<key> from the tied hash I<this>.
+
+=item CLEAR this
+
+Clear all values from the tied hash I<this>.
+
+=back
+
+=head1 CAVEATS
+
+The L<perlfunc/tie> documentation includes a method called C<DESTROY> as
+a necessary method for tied hashes. Neither B<TieHash> nor B<TieHash::Std>
+define a default for this method.
+
+The C<CLEAR> method provided by these two packages is not listed in the
+L<perlfunc/tie> section.
+
+=head1 MORE INFORMATION
+
+The packages relating to various DBM-related implemetations (F<DB_File>,
+F<NDBM_File>, etc.) show examples of general tied hashes, as does the
+L<Config> module. While these do not utilize B<TieHash>, they serve as
+good working examples.
+
+=cut
+
use Carp;
sub new {
diff --git a/lib/Time/Local.pm b/lib/Time/Local.pm
index 64e62405f7..451c7fa20c 100644
--- a/lib/Time/Local.pm
+++ b/lib/Time/Local.pm
@@ -6,31 +6,38 @@ use Carp;
@ISA = qw(Exporter);
@EXPORT = qw(timegm timelocal);
-# timelocal.pl
-#
-# Usage:
-# $time = timelocal($sec,$min,$hours,$mday,$mon,$year);
-# $time = timegm($sec,$min,$hours,$mday,$mon,$year);
-
-# These routines are quite efficient and yet are always guaranteed to agree
-# with localtime() and gmtime(). We manage this by caching the start times
-# of any months we've seen before. If we know the start time of the month,
-# we can always calculate any time within the month. The start times
-# themselves are guessed by successive approximation starting at the
-# current time, since most dates seen in practice are close to the
-# current date. Unlike algorithms that do a binary search (calling gmtime
-# once for each bit of the time value, resulting in 32 calls), this algorithm
-# calls it at most 6 times, and usually only once or twice. If you hit
-# the month cache, of course, it doesn't call it at all.
-
-# timelocal is implemented using the same cache. We just assume that we're
-# translating a GMT time, and then fudge it when we're done for the timezone
-# and daylight savings arguments. The timezone is determined by examining
-# the result of localtime(0) when the package is initialized. The daylight
-# savings offset is currently assumed to be one hour.
-
-# Both routines return -1 if the integer limit is hit. I.e. for dates
-# after the 1st of January, 2038 on most machines.
+=head1 NAME
+
+Time::Local - efficiently compute tome from local and GMT time
+
+=head1 SYNOPSIS
+
+ $time = timelocal($sec,$min,$hours,$mday,$mon,$year);
+ $time = timegm($sec,$min,$hours,$mday,$mon,$year);
+
+=head1 DESCRIPTION
+
+These routines are quite efficient and yet are always guaranteed to agree
+with localtime() and gmtime(). We manage this by caching the start times
+of any months we've seen before. If we know the start time of the month,
+we can always calculate any time within the month. The start times
+themselves are guessed by successive approximation starting at the
+current time, since most dates seen in practice are close to the
+current date. Unlike algorithms that do a binary search (calling gmtime
+once for each bit of the time value, resulting in 32 calls), this algorithm
+calls it at most 6 times, and usually only once or twice. If you hit
+the month cache, of course, it doesn't call it at all.
+
+timelocal is implemented using the same cache. We just assume that we're
+translating a GMT time, and then fudge it when we're done for the timezone
+and daylight savings arguments. The timezone is determined by examining
+the result of localtime(0) when the package is initialized. The daylight
+savings offset is currently assumed to be one hour.
+
+Both routines return -1 if the integer limit is hit. I.e. for dates
+after the 1st of January, 2038 on most machines.
+
+=cut
@epoch = localtime(0);
$tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT
diff --git a/lib/less.pm b/lib/less.pm
index 5e055f3920..b3afef0fcd 100644
--- a/lib/less.pm
+++ b/lib/less.pm
@@ -2,7 +2,11 @@ package less;
=head1 NAME
-less - Perl pragma to request less of something from the compiler
+less - perl pragma to request less of something from the compiler
+
+=head1 SYNOPSIS
+
+ use less; # unimplemented
=head1 DESCRIPTION
diff --git a/lib/overload.pm b/lib/overload.pm
index 3c9562aca5..54d2cbb441 100644
--- a/lib/overload.pm
+++ b/lib/overload.pm
@@ -62,7 +62,7 @@ __END__
=head1 NAME
-C<overload.pm> - Package for overloading perl operations
+overload - Package for overloading perl operations
=head1 SYNOPSIS
diff --git a/lib/strict.pm b/lib/strict.pm
index d35c6c105c..6f6028cad4 100644
--- a/lib/strict.pm
+++ b/lib/strict.pm
@@ -53,13 +53,17 @@ name without fully qualifying it.
=item C<strict subs>
-This disables the poetry optimization,
-generating a compile-time error if you
-try to use a bareword identifier that's not a subroutine.
+This disables the poetry optimization, generating a compile-time error if
+you try to use a bareword identifier that's not a subroutine, unless it
+appears in curly braces or on the left hand side of the "=>" symbol.
+
use strict 'subs';
$SIG{PIPE} = Plumber; # blows up
- $SIG{"PIPE"} = "Plumber"; # just fine
+ $SIG{PIPE} = "Plumber"; # just fine: bareword in curlies always ok
+ $SIG{PIPE} = \&Plumber; # preferred form
+
+
=back
diff --git a/lib/syslog.pl b/lib/syslog.pl
index a3b9edf8da..2034e0aa48 100644
--- a/lib/syslog.pl
+++ b/lib/syslog.pl
@@ -31,8 +31,16 @@ package syslog;
$host = 'localhost' unless $host; # set $syslog'host to change
+if ($] >= 5) {
+ warn "You should 'use Sys::Socket' instead; continuing" # if $^W
+}
+
require 'syslog.ph';
+ eval 'require Socket' ||
+eval { require "socket.ph" } ||
+ require "sys/socket.ph";
+
$maskpri = &LOG_UPTO(&LOG_DEBUG);
sub main'openlog {
@@ -141,16 +149,16 @@ sub xlate {
sub connect {
$pat = 'S n C4 x8';
- $af_unix = 1;
- $af_inet = 2;
+ $af_unix = &AF_UNIX;
+ $af_inet = &AF_INET;
- $stream = 1;
- $datagram = 2;
+ $stream = &SOCK_STREAM;
+ $datagram = &SOCK_DGRAM;
($name,$aliases,$proto) = getprotobyname('udp');
$udp = $proto;
- ($name,$aliase,$port,$proto) = getservbyname('syslog','udp');
+ ($name,$aliases,$port,$proto) = getservbyname('syslog','udp');
$syslog = $port;
if (chop($myname = `hostname`)) {
View Lorry Controller Status