require 5.005_64;
+use strict;
+
our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK);
$VERSION = "1.04";
$XS_VERSION = "1.03";
-use strict;
use Carp;
use Exporter ();
use XSLoader ();
-@ISA = qw(Exporter);
BEGIN {
+ @ISA = qw(Exporter);
@EXPORT_OK = qw(
opset ops_to_opset
opset_to_ops opset_to_hex invert_opset
package AnyDBM_File;
use 5.005_64;
+our $VERSION = '1.00';
our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA;
my $mod;
use CGI;
+
+our $VERSION = '1.00';
+
1;
__END__
use CGI;
+
+our $VERSION = '1.00';
+
1;
__END__
package Carp;
+our $VERSION = '1.00';
+
=head1 NAME
carp - warn of errors (from perspective of caller)
+# Carp::Heavy uses some variables in common with Carp.
package Carp;
-our $MaxEvalLen;
-our $MaxLenArg;
-our $Verbose;
+# use strict; # not yet
+
+# On one line so MakeMaker will see it.
+use Carp; our $VERSION = $Carp::VERSION;
+
+our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxLenArg, $Verbose);
sub caller_info {
my $i = shift(@_) + 1;
package DirHandle;
+our $VERSION = '1.00';
+
=head1 NAME
DirHandle - supply object methods for directory handles
use 5.005_64; # for (defined ref) and $#$v and our
package Dumpvalue;
use strict;
+our $VERSION = '1.00';
our(%address, $stab, @stab, %stab, %subs);
# translate control chars to ^X - Randal Schwartz
package English;
+our $VERSION = '1.00';
+
require Exporter;
@ISA = (Exporter);
package Env;
+our $VERSION = '1.00';
+
=head1 NAME
Env - perl module that imports environment variables as scalars or arrays
require 5.001;
-$ExportLevel = 0;
-$Verbose ||= 0;
-$VERSION = '5.562';
+use strict;
+no strict 'refs';
+
+our $Debug = 0;
+our $ExportLevel = 0;
+our $Verbose ||= 0;
+our $VERSION = '5.562';
sub export_to_level {
require Exporter::Heavy;
- goto &heavy_export_to_level;
+ goto &Exporter::Heavy::heavy_export_to_level;
}
sub export {
require Exporter::Heavy;
- goto &heavy_export;
+ goto &Exporter::Heavy::heavy_export;
}
sub export_tags {
require Exporter::Heavy;
- _push_tags((caller)[0], "EXPORT", \@_);
+ Exporter::Heavy::_push_tags((caller)[0], "EXPORT", \@_);
}
sub export_ok_tags {
require Exporter::Heavy;
- _push_tags((caller)[0], "EXPORT_OK", \@_);
+ Exporter::Heavy::_push_tags((caller)[0], "EXPORT_OK", \@_);
}
sub import {
my $pkg = shift;
my $callpkg = caller($ExportLevel);
- *exports = *{"$pkg\::EXPORT"};
+
+ my($exports, $export_cache) = (\@{"$pkg\::EXPORT"},
+ \%{"$pkg\::EXPORT"});
# We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-(
- *fail = *{"$pkg\::EXPORT_FAIL"};
+ my($fail) = \@{"$pkg\::EXPORT_FAIL"};
return export $pkg, $callpkg, @_
- if $Verbose or $Debug or @fail > 1;
- my $args = @_ or @_ = @exports;
+ if $Verbose or $Debug or @$fail > 1;
+ my $args = @_ or @_ = @$exports;
- if ($args and not %exports) {
- foreach my $sym (@exports, @{"$pkg\::EXPORT_OK"}) {
+ if ($args and not %$export_cache) {
+ foreach my $sym (@$exports, @{"$pkg\::EXPORT_OK"}) {
$sym =~ s/^&//;
- $exports{$sym} = 1;
+ $export_cache->{$sym} = 1;
}
}
if ($Verbose or $Debug
- or grep {/\W/ or $args and not exists $exports{$_}
- or @fail and $_ eq $fail[0]
+ or grep {/\W/ or $args and not exists $export_cache->{$_}
+ or @$fail and $_ eq $fail->[0]
or (@{"$pkg\::EXPORT_OK"}
and $_ eq ${"$pkg\::EXPORT_OK"}[0])} @_) {
return export $pkg, $callpkg, ($args ? @_ : ());
}
- #local $SIG{__WARN__} = sub {require Carp; goto &Carp::carp};
local $SIG{__WARN__} =
sub {require Carp; local $Carp::CarpLevel = 1; &Carp::carp};
- foreach $sym (@_) {
+ foreach my $sym (@_) {
# shortcut for the common case of no type character
*{"$callpkg\::$sym"} = \&{"$pkg\::$sym"};
}
}
-1;
-# A simple self test harness. Change 'require Carp' to 'use Carp ()' for testing.
-# package main; eval(join('',<DATA>)) or die $@ unless caller;
-__END__
-package Test;
-$INC{'Exporter.pm'} = 1;
-@ISA = qw(Exporter);
-@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)], T3=>[qw(X3)]);
-@EXPORT_FAIL = qw(B4);
-Exporter::export_ok_tags('T3', 'unknown_tag');
+# Default methods
+
sub export_fail {
- map { "Test::$_" } @_ # edit symbols just as an example
+ my $self = shift;
+ @_;
}
-package main;
-$Exporter::Verbose = 1;
-#import Test;
-#import Test qw(X3); # export ok via export_ok_tags()
-#import Test qw(:T1 !A2 /5/ !/3/ B5);
-import Test qw(:T2 !B4);
-import Test qw(:T2); # should fail
+
+sub require_version {
+ require Exporter::Heavy;
+ goto &Exporter::Heavy::require_version;
+}
+
+
1;
+
=head1 NAME
Exporter - Implements default import method for modules
-package Exporter;
+package Exporter::Heavy;
+
+use strict;
+no strict 'refs';
+
+# On one line so MakeMaker will see it.
+require Exporter; our $VERSION = $Exporter::VERSION;
+
+our $Verbose;
=head1 NAME
my($pkg, $callpkg, @imports) = @_;
my($type, $sym, $oops);
- *exports = *{"${pkg}::EXPORT"};
+ my($exports, $export_cache) = (\@{"${pkg}::EXPORT"},
+ \%{"${pkg}::EXPORT"});
if (@imports) {
- if (!%exports) {
- grep(s/^&//, @exports);
- @exports{@exports} = (1) x @exports;
+ if (!%$export_cache) {
+ s/^&// foreach @$exports;
+ @{$export_cache}{@$exports} = (1) x @$exports;
my $ok = \@{"${pkg}::EXPORT_OK"};
if (@$ok) {
- grep(s/^&//, @$ok);
- @exports{@$ok} = (1) x @$ok;
+ s/^&// foreach @$ok;
+ @{$export_cache}{@$ok} = (1) x @$ok;
}
}
if ($spec =~ s/^://){
if ($spec eq 'DEFAULT'){
- @names = @exports;
+ @names = @$exports;
}
elsif ($tagdata = $tagsref->{$spec}) {
@names = @$tagdata;
}
elsif ($spec =~ m:^/(.*)/$:){
my $patn = $1;
- @allexports = keys %exports unless @allexports; # only do keys once
+ @allexports = keys %$export_cache unless @allexports; # only do keys once
@names = grep(/$patn/, @allexports); # not anchored by default
}
else {
}
foreach $sym (@imports) {
- if (!$exports{$sym}) {
+ if (!$export_cache->{$sym}) {
if ($sym =~ m/^\d/) {
$pkg->require_version($sym);
# If the version number was the only thing specified
# then we should act as if nothing was specified:
if (@imports == 1) {
- @imports = @exports;
+ @imports = @$exports;
last;
}
# We need a way to emulate 'use Foo ()' but still
@imports = ();
last;
}
- } elsif ($sym !~ s/^&// || !$exports{$sym}) {
+ } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) {
require Carp;
Carp::carp(qq["$sym" is not exported by the $pkg module]);
$oops++;
}
}
else {
- @imports = @exports;
+ @imports = @$exports;
}
- *fail = *{"${pkg}::EXPORT_FAIL"};
- if (@fail) {
- if (!%fail) {
+ my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"},
+ \%{"${pkg}::EXPORT_FAIL"});
+
+ if (@$fail) {
+ if (!%$fail_cache) {
# Build cache of symbols. Optimise the lookup by adding
# barewords twice... both with and without a leading &.
- # (Technique could be applied to %exports cache at cost of memory)
- my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail;
+ # (Technique could be applied to $export_cache at cost of memory)
+ my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail;
warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose;
- @fail{@expanded} = (1) x @expanded;
+ @{$fail_cache}{@expanded} = (1) x @expanded;
}
my @failed;
- foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} }
+ foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} }
if (@failed) {
@failed = $pkg->export_fail(@failed);
foreach $sym (@failed) {
sub _push_tags {
my($pkg, $var, $syms) = @_;
- my $nontag;
- *export_tags = \%{"${pkg}::EXPORT_TAGS"};
+ my @nontag = ();
+ my $export_tags = \%{"${pkg}::EXPORT_TAGS"};
push(@{"${pkg}::$var"},
- map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) }
- (@$syms) ? @$syms : keys %export_tags);
- if ($nontag and $^W) {
+ map { $export_tags->{$_} ? @{$export_tags->{$_}}
+ : scalar(push(@nontag,$_),$_) }
+ (@$syms) ? @$syms : keys %$export_tags);
+ if (@nontag and $^W) {
# This may change to a die one day
require Carp;
- Carp::carp("Some names are not tags");
+ Carp::carp(join(", ", @nontag)." are not tags of $pkg");
}
}
-# Default methods
-
-sub export_fail {
- my $self = shift;
- @_;
-}
sub require_version {
my($self, $wanted) = @_;
package ExtUtils::MM_Cygwin;
+use strict;
+
+our $VERSION = '1.00';
+
use Config;
#use Cwd;
#use File::Basename;
require Exporter;
-Exporter::import('ExtUtils::MakeMaker',
- qw( $Verbose &neatvalue));
+require ExtUtils::MakeMaker;
+ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue));
unshift @MM::ISA, 'ExtUtils::MM_Cygwin';
package ExtUtils::MM_OS2;
+use strict;
+
+our $VERSION = '1.00';
+
#use Config;
#use Cwd;
#use File::Basename;
require Exporter;
-Exporter::import('ExtUtils::MakeMaker',
- qw( $Verbose &neatvalue));
+require ExtUtils::MakeMaker;
+ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue));
unshift @MM::ISA, 'ExtUtils::MM_OS2';
package ExtUtils::MM_Unix;
+use strict;
+
use Exporter ();
use Config;
use File::Basename qw(basename dirname fileparse);
use vars qw($VERSION $Is_Mac $Is_OS2 $Is_VMS $Is_Win32 $Is_Dos $Is_PERL_OBJECT
$Verbose %pm %static $Xsubpp_Version);
-$VERSION = substr q$Revision: 1.12603 $, 10;
-# $Id: MM_Unix.pm,v 1.126 1998/06/28 21:32:49 k Exp k $
+our $VERSION = '1.12603';
-Exporter::import('ExtUtils::MakeMaker', qw($Verbose &neatvalue));
+require ExtUtils::MakeMaker;
+ExtUtils::MakeMaker->import(qw($Verbose &neatvalue));
$Is_OS2 = $^O eq 'os2';
$Is_Mac = $^O eq 'MacOS';
package ExtUtils::MM_VMS;
+use strict;
+
use Carp qw( &carp );
use Config;
require Exporter;
use VMS::Filespec;
use File::Basename;
use File::Spec;
-our($Revision, @ISA);
-$Revision = '5.56 (27-Apr-1999)';
+our($Revision, @ISA, $VERSION);
+# All on one line so MakeMaker can see it.
+($VERSION) = ($Revision = '5.56 (27-Apr-1999)') =~ /^([\d.]+)/;
@ISA = qw( File::Spec );
unshift @MM::ISA, 'ExtUtils::MM_VMS';
-Exporter::import('ExtUtils::MakeMaker', '$Verbose', '&neatvalue');
+require ExtUtils::MakeMaker;
+ExtUtils::MakeMaker->import('$Verbose', '&neatvalue');
=head1 NAME
package ExtUtils::MM_Win32;
+our $VERSION = '1.00';
+
=head1 NAME
ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker
use File::Basename;
require Exporter;
-Exporter::import('ExtUtils::MakeMaker',
- qw( $Verbose &neatvalue));
+require ExtUtils::MakeMaker;
+ExtUtils::MakeMaker->import(qw( $Verbose &neatvalue));
$ENV{EMXSHELL} = 'sh'; # to run `commands`
unshift @MM::ISA, 'ExtUtils::MM_Win32';
package File::CheckTree;
+
+our $VERSION = '4.1';
+
require 5.000;
require Exporter;
=cut
-@ISA = qw(Exporter);
-@EXPORT = qw(validate);
-
-# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $
-
-# The validate routine takes a single multiline string consisting of
-# lines containing a filename plus a file test to try on it. (The
-# file test may also be a 'cd', causing subsequent relative filenames
-# to be interpreted relative to that directory.) After the file test
-# you may put '|| die' to make it a fatal error if the file test fails.
-# The default is '|| warn'. The file test may optionally have a ! prepended
-# to test for the opposite condition. If you do a cd and then list some
-# relative filenames, you may want to indent them slightly for readability.
-# If you supply your own "die" or "warn" message, you can use $file to
-# interpolate the filename.
-
-# Filetests may be bunched: -rwx tests for all of -r, -w and -x.
-# Only the first failed test of the bunch will produce a warning.
-
-# The routine returns the number of warnings issued.
-
-# Usage:
-# use File::CheckTree;
-# $warnings += validate('
-# /vmunix -e || die
-# /boot -e || die
-# /bin cd
-# csh -ex
-# csh !-ug
-# sh -ex
-# sh !-ug
-# /usr -d || warn "What happened to $file?\n"
-# ');
+our @ISA = qw(Exporter);
+our @EXPORT = qw(validate);
sub validate {
local($file,$test,$warnings,$oldwarnings);
$this =~ s/(-\w\b)/$1 \$file/g;
$this =~ s/-Z/-$one/;
$this .= ' || warn' unless $this =~ /\|\|/;
- $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || valmess('$2','$1')/;
+ $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 ||
+ valmess('$2','$1')/;
$this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
eval $this;
last if $warnings > $oldwarnings;
$warnings;
}
+our %Val_Switch = (
+ 'r' => sub { "$_[0] is not readable by uid $>." },
+ 'w' => sub { "$_[0] is not writable by uid $>." },
+ 'x' => sub { "$_[0] is not executable by uid $>." },
+ 'o' => sub { "$_[0] is not owned by uid $>." },
+ 'R' => sub { "$_[0] is not readable by you." },
+ 'W' => sub { "$_[0] is not writable by you." },
+ 'X' => sub { "$_[0] is not executable by you." },
+ 'O' => sub { "$_[0] is not owned by you." },
+ 'e' => sub { "$_[0] does not exist." },
+ 'z' => sub { "$_[0] does not have zero size." },
+ 's' => sub { "$_[0] does not have non-zero size." },
+ 'f' => sub { "$_[0] is not a plain file." },
+ 'd' => sub { "$_[0] is not a directory." },
+ 'l' => sub { "$_[0] is not a symbolic link." },
+ 'p' => sub { "$_[0] is not a named pipe (FIFO)." },
+ 'S' => sub { "$_[0] is not a socket." },
+ 'b' => sub { "$_[0] is not a block special file." },
+ 'c' => sub { "$_[0] is not a character special file." },
+ 'u' => sub { "$_[0] does not have the setuid bit set." },
+ 'g' => sub { "$_[0] does not have the setgid bit set." },
+ 'k' => sub { "$_[0] does not have the sticky bit set." },
+ 'T' => sub { "$_[0] is not a text file." },
+ 'B' => sub { "$_[0] is not a binary file." },
+);
+
sub valmess {
- local($disposition,$this) = @_;
- $file = $cwd . '/' . $file unless $file =~ m|^/|s;
+ my($disposition,$this) = @_;
+ my $file = $cwd . '/' . $file unless $file =~ m|^/|s;
+
+ my $ferror;
if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
- $neg = $1;
- $tmp = $2;
- $tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
- $tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
- $tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
- $tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
- $tmp eq 'R' && ($mess = "$file is not readable by you.");
- $tmp eq 'W' && ($mess = "$file is not writable by you.");
- $tmp eq 'X' && ($mess = "$file is not executable by you.");
- $tmp eq 'O' && ($mess = "$file is not owned by you.");
- $tmp eq 'e' && ($mess = "$file does not exist.");
- $tmp eq 'z' && ($mess = "$file does not have zero size.");
- $tmp eq 's' && ($mess = "$file does not have non-zero size.");
- $tmp eq 'f' && ($mess = "$file is not a plain file.");
- $tmp eq 'd' && ($mess = "$file is not a directory.");
- $tmp eq 'l' && ($mess = "$file is not a symbolic link.");
- $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
- $tmp eq 'S' && ($mess = "$file is not a socket.");
- $tmp eq 'b' && ($mess = "$file is not a block special file.");
- $tmp eq 'c' && ($mess = "$file is not a character special file.");
- $tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
- $tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
- $tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
- $tmp eq 'T' && ($mess = "$file is not a text file.");
- $tmp eq 'B' && ($mess = "$file is not a binary file.");
+ my($neg,$ftype) = ($1,$2);
+
+ $ferror = $Val_Switch{$tmp}->($file);
+
if ($neg eq '!') {
- $mess =~ s/ is not / should not be / ||
- $mess =~ s/ does not / should not / ||
- $mess =~ s/ not / /;
+ $ferror =~ s/ is not / should not be / ||
+ $ferror =~ s/ does not / should not / ||
+ $ferror =~ s/ not / /;
}
}
else {
$this =~ s/\$file/'$file'/g;
- $mess = "Can't do $this.\n";
+ $ferror = "Can't do $this.\n";
}
- die "$mess\n" if $disposition eq 'die';
- warn "$mess\n";
+ die "$ferror\n" if $disposition eq 'die';
+ warn "$ferror\n";
++$warnings;
}
package File::DosGlob;
+our $VERSION = '1.00';
+use strict;
+
sub doglob {
my $cond = shift;
my @retval = ();
#print "doglob: ", join('|', @_), "\n";
OUTER:
- for my $arg (@_) {
- local $_ = $arg;
+ for my $pat (@_) {
my @matched = ();
my @globdirs = ();
my $head = '.';
my $sepchr = '/';
- next OUTER unless defined $_ and $_ ne '';
+ my $tail;
+ next OUTER unless defined $pat and $pat ne '';
# if arg is within quotes strip em and do no globbing
- if (/^"(.*)"\z/s) {
- $_ = $1;
- if ($cond eq 'd') { push(@retval, $_) if -d $_ }
- else { push(@retval, $_) if -e $_ }
+ if ($pat =~ /^"(.*)"\z/s) {
+ $pat = $1;
+ if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
+ else { push(@retval, $pat) if -e $pat }
next OUTER;
}
# wildcards with a drive prefix such as h:*.pm must be changed
# to h:./*.pm to expand correctly
- if (m|^([A-Za-z]:)[^/\\]|s) {
+ if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
substr($_,0,2) = $1 . "./";
}
- if (m|^(.*)([\\/])([^\\/]*)\z|s) {
- my $tail;
+ if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
($head, $sepchr, $tail) = ($1,$2,$3);
#print "div: |$head|$sepchr|$tail|\n";
- push (@retval, $_), next OUTER if $tail eq '';
+ push (@retval, $pat), next OUTER if $tail eq '';
if ($head =~ /[*?]/) {
@globdirs = doglob('d', $head);
push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
next OUTER if @globdirs;
}
$head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
- $_ = $tail;
+ $pat = $tail;
}
#
# If file component has no wildcards, we can avoid opendir
- unless (/[*?]/) {
+ unless ($pat =~ /[*?]/) {
$head = '' if $head eq '.';
$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
- $head .= $_;
+ $head .= $pat;
if ($cond eq 'd') { push(@retval,$head) if -d $head }
else { push(@retval,$head) if -e $head }
next OUTER;
$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
# escape regex metachars but not glob chars
- s:([].+^\-\${}[|]):\\$1:g;
+ $pat =~ s:([].+^\-\${}[|]):\\$1:g;
# and convert DOS-style wildcards to regex
- s/\*/.*/g;
- s/\?/.?/g;
+ $pat =~ s/\*/.*/g;
+ $pat =~ s/\?/.?/g;
- #print "regex: '$_', head: '$head'\n";
- my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }';
- warn($@), next OUTER if $@;
+ #print "regex: '$pat', head: '$head'\n";
+ my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
INNER:
for my $e (@leaves) {
next INNER if $e eq '.' or $e eq '..';
# has a dot *and* name is shorter than 9 chars.
#
if (index($e,'.') == -1 and length($e) < 9
- and index($_,'\\.') != -1) {
+ and index($pat,'\\.') != -1) {
push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
}
}
my %entries;
sub glob {
- my $pat = shift;
- my $cxix = shift;
+ my($pat,$cxix) = @_;
my @pat;
# glob without args defaults to $_
}
}
-sub import {
+{
+ no strict 'refs';
+
+ sub import {
my $pkg = shift;
return unless @_;
my $sym = shift;
my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
*{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
+ }
}
-
1;
__END__
package File::Find;
+use strict;
use 5.005_64;
+our $VERSION = '1.00';
require Exporter;
require Cwd;
=cut
-@ISA = qw(Exporter);
-@EXPORT = qw(find finddepth);
+our @ISA = qw(Exporter);
+our @EXPORT = qw(find finddepth);
use strict;
use 5.005_64;
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+our $VERSION = '1.00';
+
BEGIN {
use Exporter ();
@EXPORT = qw(stat lstat);
package FileCache;
+our $VERSION = '1.00';
+
=head1 NAME
FileCache - keep more files open than the system permits
package I18N::Collate;
+use strict;
+our $VERSION = '1.00';
+
=head1 NAME
I18N::Collate - compare 8-bit scalar data according to the current locale
require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(collate_xfrm setlocale LC_COLLATE);
-@EXPORT_OK = qw();
+our @ISA = qw(Exporter);
+our @EXPORT = qw(collate_xfrm setlocale LC_COLLATE);
+our @EXPORT_OK = qw();
use overload qw(
fallback 1
cmp collate_cmp
);
+our($LOCALE, $C);
+
+our $please_use_I18N_Collate_even_if_deprecated = 0;
sub new {
my $new = $_[1];
use strict;
use 5.005_64;
+our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
use strict;
use 5.005_64;
+our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
use strict;
use 5.005_64;
+our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
use strict;
use 5.005_64;
+our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
#:vi:set ts=20
+our $VERSION = '1.00';
+
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
-%Type_Description = (
+our(%Kinds, %Type, %Flavor);
+
+our %Type_Description = (
'ARRAY' => 'Functions for real @ARRAYs',
'Binary' => 'Functions for fixed length data or records',
'File' => 'Functions for filehandles, files, or directories',
'Namespace' => 'Keywords altering or affecting scoping of identifiers',
);
-@Type_Order = qw{
+our @Type_Order = qw{
String
Regexp
Math
chomp;
s/#.*//;
next unless $_;
- ($name, $type, $text) = split " ", $_, 3;
+ my($name, $type, $text) = split " ", $_, 3;
$Type{$name} = $type;
$Flavor{$name} = $text;
- for $type ( split /[,\s]+/, $type ) {
- push @{$Kinds{$type}}, $name;
+ for my $t ( split /[,\s]+/, $type ) {
+ push @{$Kinds{$t}}, $name;
}
}
close DATA;
unless (caller) {
- foreach $type ( @Type_Order ) {
- $list = join(", ", sort @{$Kinds{$type}});
- $typedesc = $Type_Description{$type} . ":";
+ foreach my $type ( @Type_Order ) {
+ my $list = join(", ", sort @{$Kinds{$type}});
+ my $typedesc = $Type_Description{$type} . ":";
write;
}
}
use Cwd;
use File::Spec::Unix;
use Getopt::Long;
-use Pod::Functions;
use locale; # make \w work right in non-ASCII lands
require 5.000;
require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(look);
+use strict;
+
+our $VERSION = '1.00';
+our @ISA = qw(Exporter);
+our @EXPORT = qw(look);
=head1 NAME
=cut
sub look {
- local(*FH,$key,$dict,$fold) = @_;
+ my($fh,$key,$dict,$fold) = @_;
local($_);
- my(@stat) = stat(FH)
+ my(@stat) = stat($fh)
or return -1;
my($size, $blksize) = @stat[7,11];
$blksize ||= 8192;
my($min, $max, $mid) = (0, int($size / $blksize));
while ($max - $min > 1) {
$mid = int(($max + $min) / 2);
- seek(FH, $mid * $blksize, 0)
+ seek($fh, $mid * $blksize, 0)
or return -1;
- <FH> if $mid; # probably a partial line
- $_ = <FH>;
+ <$fh> if $mid; # probably a partial line
+ $_ = <$fh>;
chop;
s/[^\w\s]//g if $dict;
$_ = lc $_ if $fold;
}
}
$min *= $blksize;
- seek(FH,$min,0)
+ seek($fh,$min,0)
or return -1;
- <FH> if $min;
+ <$fh> if $min;
for (;;) {
- $min = tell(FH);
- defined($_ = <FH>)
+ $min = tell($fh);
+ defined($_ = <$fh>)
or last;
chop;
s/[^\w\s]//g if $dict;
$_ = lc $_ if $fold;
last if $_ ge $key;
}
- seek(FH,$min,0);
+ seek($fh,$min,0);
$min;
}
package SelectSaver;
+our $VERSION = '1.00';
+
=head1 NAME
SelectSaver - save and restore selected file handle
package Term::Cap;
use Carp;
-# Last updated: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com
+our $VERSION = '1.00';
+
+# Last updated: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com
# TODO:
# support Berkeley DB termcaps
require 5.000;
require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(Complete);
+use strict;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(Complete);
+our $VERSION = '1.2';
# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91
=cut
+our($complete, $kill, $erase1, $erase2);
CONFIG: {
$complete = "\004";
$kill = "\025";
}
sub Complete {
- my($prompt, @cmp_list, $cmp, $test, $l, @match);
+ my($prompt, @cmp_lst, $cmp, $test, $l, @match);
my ($return, $r) = ("", 0);
$return = "";
=cut
+use strict;
+
package Term::ReadLine::Stub;
-@ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
+our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap';
$DB::emacs = $DB::emacs; # To peacify -w
+our @rl_term_set;
*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set;
sub ReadLine {'Term::ReadLine::Stub'}
}
}
- $consoleOUT = $console;
+ my $consoleOUT = $console;
$console = "&STDIN" unless defined $console;
if (!defined $consoleOUT) {
$consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT";
#local (*FIN, *FOUT);
my ($FIN, $FOUT, $ret);
if (@_==2) {
- ($console, $consoleOUT) = findConsole;
+ my($console, $consoleOUT) = findConsole;
open(FIN, "<$console");
open(FOUT,">$consoleOUT");
#OUT->autoflush(1); # Conflicts with debugger?
- $sel = select(FOUT);
+ my $sel = select(FOUT);
$| = 1; # for DB::OUT
select($sel);
$ret = bless [\*FIN, \*FOUT];
} else { # Filehandles supplied
$FIN = $_[2]; $FOUT = $_[3];
#OUT->autoflush(1); # Conflicts with debugger?
- $sel = select($FOUT);
+ my $sel = select($FOUT);
$| = 1; # for DB::OUT
select($sel);
$ret = bless [$FIN, $FOUT];
package Term::ReadLine; # So late to allow the above code be defined?
+our $VERSION = '1.00';
+
my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef;
if ($which) {
if ($which =~ /\bgnu\b/i){
# To make possible switch off RL in debugger: (Not needed, work done
# in debugger).
-
+our @ISA;
if (defined &Term::ReadLine::Gnu::readline) {
@ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub);
} elsif (defined &Term::ReadLine::Perl::readline) {
# Prompt-start, prompt-end, command-line-start, command-line-end
# -- zero-width beautifies to emit around prompt and the command line.
-@rl_term_set = ("","","","");
+our @rl_term_set = ("","","","");
# string encoded:
-$rl_term_set = ',,,';
+our $rl_term_set = ',,,';
+our $terminal;
sub LoadTermCap {
return if defined $terminal;
package Term::ReadLine::Tk;
+our($count_handle, $count_DoOne, $count_loop);
$count_handle = $count_DoOne = $count_loop = 0;
+our($giveup);
sub handle {$giveup = 1; $count_handle++}
sub Tk_loop {
require 5.005; # Probably works on earlier versions too.
require Exporter;
+our $VERSION = '1.00';
+
=head1 NAME
abbrev - create an abbreviation table from a list
package Tie::Hash;
+our $VERSION = '1.00';
+
=head1 NAME
Tie::Hash, Tie::StdHash - base class definitions for tied hashes
package Tie::RefHash;
+our $VERSION = '1.21';
+
=head1 NAME
Tie::RefHash - use references as hash keys
package Tie::Scalar;
+our $VERSION = '1.00';
+
=head1 NAME
Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
package Tie::SubstrHash;
+our $VERSION = '1.00';
+
=head1 NAME
Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
require 5.000;
require Exporter;
use Carp;
+use strict;
-@ISA = qw( Exporter );
-@EXPORT = qw( timegm timelocal );
-@EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
+our $VERSION = '1.00';
+our @ISA = qw( Exporter );
+our @EXPORT = qw( timegm timelocal );
+our @EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
# Set up constants
- $SEC = 1;
- $MIN = 60 * $SEC;
- $HR = 60 * $MIN;
- $DAY = 24 * $HR;
+our $SEC = 1;
+our $MIN = 60 * $SEC;
+our $HR = 60 * $MIN;
+our $DAY = 24 * $HR;
# Determine breakpoint for rolling century
- my $thisYear = (localtime())[5];
- $nextCentury = int($thisYear / 100) * 100;
- $breakpoint = ($thisYear + 50) % 100;
- $nextCentury += 100 if $breakpoint < 50;
+ my $ThisYear = (localtime())[5];
+ my $NextCentury = int($ThisYear / 100) * 100;
+ my $Breakpoint = ($ThisYear + 50) % 100;
+ $NextCentury += 100 if $Breakpoint < 50;
-my %options;
+our(%Options, %Cheat);
sub timegm {
my (@date) = @_;
$date[5] -= 1900;
}
elsif ($date[5] >= 0 && $date[5] < 100) {
- $date[5] -= 100 if $date[5] > $breakpoint;
- $date[5] += $nextCentury;
+ $date[5] -= 100 if $date[5] > $Breakpoint;
+ $date[5] += $NextCentury;
}
- $ym = pack(C2, @date[5,4]);
- $cheat = $cheat{$ym} || &cheat(@date);
+ my $ym = pack('C2', @date[5,4]);
+ my $cheat = $Cheat{$ym} || &cheat($ym, @date);
$cheat
+ $date[0] * $SEC
+ $date[1] * $MIN
}
sub timegm_nocheck {
- local $options{no_range_check} = 1;
+ local $Options{no_range_check} = 1;
&timegm;
}
$tzsec += $HR if($lt[8]);
- $time = $t + $tzsec;
- @test = localtime($time + ($tt - $t));
+ my $time = $t + $tzsec;
+ my @test = localtime($time + ($tt - $t));
$time -= $HR if $test[2] != $_[2];
$time;
}
sub timelocal_nocheck {
- local $options{no_range_check} = 1;
+ local $Options{no_range_check} = 1;
&timelocal;
}
sub cheat {
- $year = $_[5];
- $month = $_[4];
- unless ($options{no_range_check}) {
+ my($ym, @date) = @_;
+ my($sec, $min, $hour, $day, $month, $year) = @date;
+ unless ($Options{no_range_check}) {
croak "Month '$month' out of range 0..11" if $month > 11 || $month < 0;
- croak "Day '$_[3]' out of range 1..31" if $_[3] > 31 || $_[3] < 1;
- croak "Hour '$_[2]' out of range 0..23" if $_[2] > 23 || $_[2] < 0;
- croak "Minute '$_[1]' out of range 0..59" if $_[1] > 59 || $_[1] < 0;
- croak "Second '$_[0]' out of range 0..59" if $_[0] > 59 || $_[0] < 0;
+ croak "Day '$day' out of range 1..31" if $day > 31 || $day < 1;
+ croak "Hour '$hour' out of range 0..23" if $hour > 23 || $hour < 0;
+ croak "Minute '$min' out of range 0..59" if $min > 59 || $min < 0;
+ croak "Second '$sec' out of range 0..59" if $sec > 59 || $sec < 0;
}
- $guess = $^T;
- @g = gmtime($guess);
- $lastguess = "";
- $counter = 0;
- while ($diff = $year - $g[5]) {
- croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255;
+ my $guess = $^T;
+ my @g = gmtime($guess);
+ my $lastguess = "";
+ my $counter = 0;
+ while (my $diff = $year - $g[5]) {
+ my $thisguess;
+ croak "Can't handle date (".join(", ",@date).")" if ++$counter > 255;
$guess += $diff * (363 * $DAY);
@g = gmtime($guess);
if (($thisguess = "@g") eq $lastguess){
- croak "Can't handle date (".join(", ",@_).")";
+ croak "Can't handle date (".join(", ",@date).")";
#date beyond this machine's integer limit
}
$lastguess = $thisguess;
}
- while ($diff = $month - $g[4]) {
- croak "Can't handle date (".join(", ",@_).")" if ++$counter > 255;
+ while (my $diff = $month - $g[4]) {
+ my $thisguess;
+ croak "Can't handle date (".join(", ",@date).")" if ++$counter > 255;
$guess += $diff * (27 * $DAY);
@g = gmtime($guess);
if (($thisguess = "@g") eq $lastguess){
- croak "Can't handle date (".join(", ",@_).")";
+ croak "Can't handle date (".join(", ",@date).")";
#date beyond this machine's integer limit
}
$lastguess = $thisguess;
}
- @gfake = gmtime($guess-1); #still being sceptic
+ my @gfake = gmtime($guess-1); #still being sceptic
if ("@gfake" eq $lastguess){
- croak "Can't handle date (".join(", ",@_).")";
+ croak "Can't handle date (".join(", ",@date).")";
#date beyond this machine's integer limit
}
$g[3]--;
$guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAY;
- $cheat{$ym} = $guess;
+ $Cheat{$ym} = $guess;
}
1;
package Time::tm;
use strict;
+our $VERSION = '1.00';
+
use Class::Struct qw(struct);
struct('Time::tm' => [
map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst }
package UNIVERSAL;
+our $VERSION = '1.00';
+
# UNIVERSAL should not contain any extra subs/methods beyond those
# that it exists to define. The use of Exporter below is a historical
# accident that should be fixed sometime.
use strict;
use 5.005_64;
+our $VERSION = '1.00';
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
BEGIN {
use Exporter ();
package User::pwent;
use 5.006;
+our $VERSION = '1.00';
use strict;
use warnings;
package bytes;
+our $VERSION = '1.00';
+
$bytes::hint_bits = 0x00000008;
sub import {
package charnames;
+
+our $VERSION = '1.00';
+
use bytes (); # for $bytes::hint_bits
use warnings();
$charnames::hint_bits = 0x20000;
use 5.005_64;
use Carp;
-our $VERSION = v1.0;
+our $VERSION = 1.0;
our $DEBUG;
our $VERBOSE;
our $PRETTY;
package filetest;
+our $VERSION = '1.00';
+
=head1 NAME
filetest - Perl pragma to control the filetest permission operators
package integer;
+our $VERSION = '1.00';
+
=head1 NAME
integer - Perl pragma to compute arithmetic in integer instead of double
package less;
+our $VERSION = '0.01';
+
=head1 NAME
less - perl pragma to request less of something from the compiler
package locale;
+our $VERSION = '1.00';
+
=head1 NAME
locale - Perl pragma to use and avoid POSIX locales for built-in operations
# Populate hash in non-PerlIO case
%layers = (crlf => 1, raw => 0) unless (@layers);
+our $VERSION = '1.00';
+
sub import {
shift;
die "`use open' needs explicit list of disciplines" unless @_;
package overload;
+our $VERSION = '1.00';
+
$overload::hint_bits = 0x20000;
sub nil {}
package subs;
+our $VERSION = '1.00';
+
=head1 NAME
subs - Perl pragma to predeclare sub names
$utf8::hint_bits = 0x00800000;
+our $VERSION = '1.00';
+
sub import {
$^H |= $utf8::hint_bits;
$enc{caller()} = $_[1] if $_[1];
require 5.002;
+our $VERSION = '1.00';
+
# The following require can't be removed during maintenance
# releases, sadly, because of the risk of buggy code that does
# require Carp; Carp::croak "..."; without brackets dying
package warnings::register ;
+our $VERSION = '1.00';
+
=pod
=head1 NAME
}
}
+use warnings;
+no warnings qw(deprecated); # else attrs cries.
+
sub NTESTS () ;
-my $test, $ntests;
+my ($test, $ntests);
BEGIN {$ntests=0}
$test=0;
my $failed = 0;
{
my $w = "" ;
- local $SIG{__WARN__} = sub {$w = @_[0]} ;
+ local $SIG{__WARN__} = sub {$w = shift} ;
eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }';
(print "not "), $failed=1 if $@;
print "ok ",++$test,"\n";
use Sys::Syslog qw(:DEFAULT setlogsock);
+# Test this to 1 if your syslog accepts udp connections.
+# Most don't (or at least shouldn't)
+my $Test_Syslog_INET = 0;
+
print "1..6\n";
if (Sys::Syslog::_PATH_LOG()) {
for (1..3) { print "ok $_ # skipping, _PATH_LOG unavailable\n" }
}
-print defined(eval { setlogsock('inet') }) ? "ok 4\n" : "not ok 4\n";
-print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n" : "not ok 5\n";
-print defined(eval { syslog('info', 'test') }) ? "ok 6\n" : "not ok 6\n";
+if( $Test_Syslog_INET ) {
+ print defined(eval { setlogsock('inet') }) ? "ok 4\n"
+ : "not ok 4\n";
+ print defined(eval { openlog('perl', 'ndelay', 'local0') }) ? "ok 5\n"
+ : "not ok 5\n";
+ print defined(eval { syslog('info', 'test') }) ? "ok 6\n"
+ : "not ok 6\n";
+}
+else {
+ print "ok $_ # skipped(assuming syslog doesn't accept inet connections)\n"
+ foreach (4..6);
+}
#!/usr/bin/perl
+our $VERSION = '1.00';
+
BEGIN {
push @INC, './lib';
}
package warnings;
+our $VERSION = '1.00';
+
=head1 NAME
warnings - Perl pragma to control optional warnings
projects / p5sagit/p5-mst-13.2.git / commitdiff