diff options
author | Todd C. Miller <millert@cvs.openbsd.org> | 2010-09-24 14:49:07 +0000 |
---|---|---|
committer | Todd C. Miller <millert@cvs.openbsd.org> | 2010-09-24 14:49:07 +0000 |
commit | f71c95b5031c3088ae3cd9d5dd30e7ec656a90a7 (patch) | |
tree | 8dce35ffcd4a360c13e9f9899f2901cfac9021ea /gnu/usr.bin/perl/dist | |
parent | 2b8edcc678d4399ef602e199f35685717f277627 (diff) |
Perl 5.12.2 from CPAN
Diffstat (limited to 'gnu/usr.bin/perl/dist')
19 files changed, 353 insertions, 988 deletions
diff --git a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm index 9bac7077e70..0bdc65fed1e 100644 --- a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm +++ b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags.pm @@ -19,7 +19,7 @@ require Exporter; ); %EXPORT_TAGS = ('ALL' => \@EXPORT_OK); -$VERSION = "0.40"; +$VERSION = "0.35"; sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function @@ -579,16 +579,16 @@ tag ("ar") exists. Examples: - alternate_language_tags('no-bok') is ('nb') - alternate_language_tags('nb') is ('no-bok') - alternate_language_tags('he') is ('iw') - alternate_language_tags('iw') is ('he') - alternate_language_tags('i-hakka') is ('zh-hakka', 'x-hakka') - alternate_language_tags('zh-hakka') is ('i-hakka', 'x-hakka') - alternate_language_tags('en') is () - alternate_language_tags('x-mingo-tom') is ('i-mingo-tom') - alternate_language_tags('x-klikitat') is ('i-klikitat') - alternate_language_tags('i-klikitat') is ('x-klikitat') + alternate_language_tags('no-bok') is ('nb') + alternate_language_tags('nb') is ('no-bok') + alternate_language_tags('he') is ('iw') + alternate_language_tags('iw') is ('he') + alternate_language_tags('i-hakka') is ('zh-hakka', 'x-hakka') + alternate_language_tags('zh-hakka') is ('i-hakka', 'x-hakka') + alternate_language_tags('en') is () + alternate_language_tags('x-mingo-tom') is ('i-mingo-tom') + alternate_language_tags('x-klikitat') is ('i-klikitat') + alternate_language_tags('i-klikitat') is ('x-klikitat') This function returns empty-list if given anything other than a formally valid language tag. @@ -678,7 +678,7 @@ sub alternate_language_tags { # My guesses at Slavic intelligibility: ([qw(ru be uk)]) x 2, # Russian, Belarusian, Ukranian - ([qw(sr hr bs)]) x 2, # Serbian, Croatian, Bosnian + 'sr' => 'hr', 'hr' => 'sr', # Serb + Croat 'cs' => 'sk', 'sk' => 'cs', # Czech + Slovak 'ms' => 'id', 'id' => 'ms', # Malay + Indonesian @@ -844,17 +844,17 @@ language tags with their ASCII characters shifted into Plane 14. * L<I18N::LangTags::List|I18N::LangTags::List> -* RFC 3066, C<http://www.ietf.org/rfc/rfc3066.txt>, "Tags for the +* RFC 3066, C<ftp://ftp.isi.edu/in-notes/rfc3066.txt>, "Tags for the Identification of Languages". (Obsoletes RFC 1766) -* RFC 2277, C<http://www.ietf.org/rfc/rfc2277.txt>, "IETF Policy on +* RFC 2277, C<ftp://ftp.isi.edu/in-notes/rfc2277.txt>, "IETF Policy on Character Sets and Languages". -* RFC 2231, C<http://www.ietf.org/rfc/rfc2231.txt>, "MIME Parameter +* RFC 2231, C<ftp://ftp.isi.edu/in-notes/rfc2231.txt>, "MIME Parameter Value and Encoded Word Extensions: Character Sets, Languages, and Continuations". -* RFC 2482, C<http://www.ietf.org/rfc/rfc2482.txt>, +* RFC 2482, C<ftp://ftp.isi.edu/in-notes/rfc2482.txt>, "Language Tagging in Unicode Plain Text". * Locale::Codes, in @@ -862,7 +862,7 @@ C<http://www.perl.com/CPAN/modules/by-module/Locale/> * ISO 639-2, "Codes for the representation of names of languages", including two-letter and three-letter codes, -C<http://www.loc.gov/standards/iso639-2/php/code_list.php> +C<http://www.loc.gov/standards/iso639-2/langcodes.html> * The IANA list of registered languages (hopefully up-to-date), C<http://www.iana.org/assignments/language-tags> diff --git a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm index f13d5460b32..87280b7b511 100644 --- a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm +++ b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/Detect.pm @@ -11,7 +11,7 @@ use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } } # define the constant 'DEBUG' at compile-time -$VERSION = "1.05"; +$VERSION = "1.04"; @ISA = (); use I18N::LangTags qw(alternate_language_tags locale2language_tag); @@ -136,7 +136,6 @@ sub _try_use { # Basically a wrapper around "require Modulename" my $module = $_[0]; # ASSUME sane module name! { no strict 'refs'; - no warnings 'once'; return($tried{$module} = 1) if %{$module . "::Lexicon"} or @{$module . "::ISA"}; # weird case: we never use'd it, but there it is! diff --git a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm index 786d7b89bb8..5494bea21ed 100644 --- a/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm +++ b/gnu/usr.bin/perl/dist/I18N-LangTags/lib/I18N/LangTags/List.pm @@ -4,7 +4,7 @@ package I18N::LangTags::List; # Time-stamp: "2004-10-06 23:26:21 ADT" use strict; use vars qw(%Name %Is_Disrec $Debug $VERSION); -$VERSION = '0.39'; +$VERSION = '0.35'; # POD at the end. #---------------------------------------------------------------------- diff --git a/gnu/usr.bin/perl/dist/IO/IO.pm b/gnu/usr.bin/perl/dist/IO/IO.pm index ba89f0c8e6c..61e957c2fcc 100644 --- a/gnu/usr.bin/perl/dist/IO/IO.pm +++ b/gnu/usr.bin/perl/dist/IO/IO.pm @@ -7,7 +7,7 @@ use Carp; use strict; use warnings; -our $VERSION = "1.31"; +our $VERSION = "1.25_02"; XSLoader::load 'IO', $VERSION; sub import { @@ -32,8 +32,8 @@ IO - load various IO modules =head1 SYNOPSIS - use IO qw(Handle File); # loads IO modules, here IO::Handle, IO::File - use IO; # DEPRECATED + use IO qw(Handle File); # loads IO modules, here IO::Handle, IO::File + use IO; # DEPRECATED =head1 DESCRIPTION diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm index 7326d7823d4..cce392c2ce3 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Dir.pm @@ -19,14 +19,14 @@ use File::stat; use File::Spec; @ISA = qw(Tie::Hash Exporter); -$VERSION = "1.10"; +$VERSION = "1.07"; $VERSION = eval $VERSION; @EXPORT_OK = qw(DIR_UNLINK); sub DIR_UNLINK () { 1 } sub new { - @_ >= 1 && @_ <= 2 or croak 'usage: IO::Dir->new([DIRNAME])'; + @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]'; my $class = shift; my $dh = gensym; if (@_) { @@ -186,7 +186,7 @@ argument which, if given, C<new> will pass to C<open> =back The following methods are wrappers for the directory related functions built -into perl (the trailing 'dir' has been removed from the names). See L<perlfunc> +into perl (the trailing `dir' has been removed from the names). See L<perlfunc> for details of these functions. =over 4 @@ -237,7 +237,7 @@ L<File::stat> =head1 AUTHOR Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perlbug@perl.org>. +bugs to <perl5-porters@perl.org>. =head1 COPYRIGHT diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm index 8b29bac2210..d33d090d0b2 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/File.pm @@ -10,25 +10,25 @@ IO::File - supply object methods for filehandles use IO::File; - $fh = IO::File->new(); + $fh = new IO::File; if ($fh->open("< file")) { print <$fh>; $fh->close; } - $fh = IO::File->new("> file"); + $fh = new IO::File "> file"; if (defined $fh) { print $fh "bar\n"; $fh->close; } - $fh = IO::File->new("file", "r"); + $fh = new IO::File "file", "r"; if (defined $fh) { print <$fh>; undef $fh; # automatically closes the file } - $fh = IO::File->new("file", O_WRONLY|O_APPEND); + $fh = new IO::File "file", O_WRONLY|O_APPEND; if (defined $fh) { print $fh "corge\n"; @@ -131,12 +131,13 @@ use Carp; use Symbol; use SelectSaver; use IO::Seekable; +use File::Spec; require Exporter; @ISA = qw(IO::Handle IO::Seekable Exporter); -$VERSION = "1.16"; +$VERSION = "1.14"; @EXPORT = @IO::Seekable::EXPORT; @@ -156,7 +157,7 @@ sub new { my $type = shift; my $class = ref($type) || $type || "IO::File"; @_ >= 0 && @_ <= 3 - or croak "usage: $class->new([FILENAME [,MODE [,PERMS]]])"; + or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]"; my $fh = $class->SUPER::new(); if (@_) { $fh->open(@_) diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm index aebf74e4c02..2f1f1b423bc 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Handle.pm @@ -8,13 +8,13 @@ IO::Handle - supply object methods for I/O handles use IO::Handle; - $io = IO::Handle->new(); + $io = new IO::Handle; if ($io->fdopen(fileno(STDIN),"r")) { print $io->getline; $io->close; } - $io = IO::Handle->new(); + $io = new IO::Handle; if ($io->fdopen(fileno(STDOUT),"w")) { $io->print("Some text\n"); } @@ -139,12 +139,9 @@ guaranteed. =item $io->write ( BUF, LEN [, OFFSET ] ) -This C<write> is somewhat like C<write> found in C, in that it is the +This C<write> is like C<write> found in C, that is it is the opposite of read. The wrapper for the perl C<write> function is -called C<format_write>. However, whilst the C C<write> function returns -the number of bytes written, this C<write> function simply returns true -if successful (like C<print>). A more C-like C<write> is C<syswrite> -(see above). +called C<format_write>. =item $io->error @@ -271,7 +268,7 @@ use IO (); # Load the XS module require Exporter; @ISA = qw(Exporter); -$VERSION = "1.35"; +$VERSION = "1.28"; $VERSION = eval $VERSION; @EXPORT_OK = qw( @@ -312,25 +309,14 @@ $VERSION = eval $VERSION; sub new { my $class = ref($_[0]) || $_[0] || "IO::Handle"; - if (@_ != 1) { - # Since perl will automatically require IO::File if needed, but - # also initialises IO::File's @ISA as part of the core we must - # ensure IO::File is loaded if IO::Handle is. This avoids effect- - # ively "half-loading" IO::File. - if ($] > 5.013 && $class eq 'IO::File' && !$INC{"IO/File.pm"}) { - require IO::File; - shift; - return IO::File::->new(@_); - } - croak "usage: $class->new()"; - } + @_ == 1 or croak "usage: new $class"; my $io = gensym; bless $io, $class; } sub new_from_fd { my $class = ref($_[0]) || $_[0] || "IO::Handle"; - @_ == 3 or croak "usage: $class->new_from_fd(FD, MODE)"; + @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; my $io = gensym; shift; IO::Handle::fdopen($io, @_) @@ -433,14 +419,14 @@ sub say { print $this @_; } -# Special XS wrapper to make them inherit lexical hints from the caller. -_create_getline_subs( <<'END' ) or die $@; sub getline { @_ == 1 or croak 'usage: $io->getline()'; my $this = shift; return scalar <$this>; } +*gets = \&getline; # deprecated + sub getlines { @_ == 1 or croak 'usage: $io->getlines()'; wantarray or @@ -448,10 +434,6 @@ sub getlines { my $this = shift; return <$this>; } -1; # return true for error checking -END - -*gets = \&getline; # deprecated sub truncate { @_ == 2 or croak 'usage: $io->truncate(LEN)'; @@ -621,11 +603,11 @@ sub ioctl { return ioctl($io, $op, $_[2]); } -# this sub is for compatibility with older releases of IO that used -# a sub called constant to determine if a constant existed -- GMB +# this sub is for compatability with older releases of IO that used +# a sub called constant to detemine if a constant existed -- GMB # # The SEEK_* and _IO?BF constants were the only constants at that time -# any new code should just check defined(&CONSTANT_NAME) +# any new code should just chech defined(&CONSTANT_NAME) sub constant { no strict 'refs'; diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm index 684069f4b7e..827cc48bfcd 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Pipe.pm @@ -14,12 +14,12 @@ our($VERSION); use Carp; use Symbol; -$VERSION = "1.15"; +$VERSION = "1.13"; sub new { my $type = shift; my $class = ref($type) || $type || "IO::Pipe"; - @_ == 0 || @_ == 2 or croak "usage: $class->([READFH, WRITEFH])"; + @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; my $me = bless gensym(), $class; @@ -166,7 +166,7 @@ IO::Pipe - supply object methods for pipes use IO::Pipe; - $pipe = IO::Pipe->new(); + $pipe = new IO::Pipe; if($pid = fork()) { # Parent $pipe->reader(); @@ -184,7 +184,7 @@ IO::Pipe - supply object methods for pipes or - $pipe = IO::Pipe->new(); + $pipe = new IO::Pipe; $pipe->reader(qw(ls -l)); @@ -246,7 +246,7 @@ L<IO::Handle> =head1 AUTHOR Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perlbug@perl.org>. +bugs to <perl5-porters@perl.org>. =head1 COPYRIGHT diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm index 47f1a135595..e7fb0135069 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Poll.pm @@ -13,7 +13,7 @@ use Exporter (); our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); @ISA = qw(Exporter); -$VERSION = "0.09"; +$VERSION = "0.07"; @EXPORT = qw( POLLIN POLLOUT @@ -140,7 +140,7 @@ IO::Poll - Object interface to system poll call use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP); - $poll = IO::Poll->new(); + $poll = new IO::Poll; $poll->mask($input_handle => POLLIN); $poll->mask($output_handle => POLLOUT); @@ -198,7 +198,7 @@ L<poll(2)>, L<IO::Handle>, L<IO::Select> =head1 AUTHOR Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perlbug@perl.org>. +bugs to <perl5-porters@perl.org>. =head1 COPYRIGHT diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm index 994f8966ab6..fc05fe70e9c 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Select.pm @@ -11,7 +11,7 @@ use warnings::register; use vars qw($VERSION @ISA); require Exporter; -$VERSION = "1.22"; +$VERSION = "1.17"; @ISA = qw(Exporter); # This is only so we can do version checking @@ -74,9 +74,9 @@ sub _update foreach $f (@_) { my $fn = $vec->_fileno($f); + next unless defined $fn; + my $i = $fn + FIRST_FD; if ($add) { - next unless defined $fn; - my $i = $fn + FIRST_FD; if (defined $vec->[$i]) { $vec->[$i] = $f; # if array rest might be different, so we update next; @@ -85,25 +85,10 @@ sub _update vec($bits, $fn, 1) = 1; $vec->[$i] = $f; } else { # remove - if ( ! defined $fn ) { # remove if fileno undef'd - $fn = 0; - for my $fe (@{$vec}[FIRST_FD .. $#$vec]) { - if (defined($fe) && $fe == $f) { - $vec->[FD_COUNT]--; - $fe = undef; - vec($bits, $fn, 1) = 0; - last; - } - ++$fn; - } - } - else { - my $i = $fn + FIRST_FD; - next unless defined $vec->[$i]; - $vec->[FD_COUNT]--; - vec($bits, $fn, 1) = 0; - $vec->[$i] = undef; - } + next unless defined $vec->[$i]; + $vec->[FD_COUNT]--; + vec($bits, $fn, 1) = 0; + $vec->[$i] = undef; } $count++; } @@ -361,8 +346,8 @@ listening for more connections on a listen socket use IO::Select; use IO::Socket; - $lsn = IO::Socket::INET->new(Listen => 1, LocalPort => 8080); - $sel = IO::Select->new( $lsn ); + $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080); + $sel = new IO::Select( $lsn ); while(@ready = $sel->can_read) { foreach $fh (@ready) { @@ -384,7 +369,7 @@ listening for more connections on a listen socket =head1 AUTHOR Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perlbug@perl.org>. +bugs to <perl5-porters@perl.org>. =head1 COPYRIGHT diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm index c78aeecc1a0..6d4f6ab6123 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket.pm @@ -1,4 +1,3 @@ - # IO::Socket.pm # # Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. @@ -24,7 +23,7 @@ require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian'); @ISA = qw(IO::Handle); -$VERSION = "1.38"; +$VERSION = "1.31"; @EXPORT_OK = qw(sockatmark); @@ -119,29 +118,16 @@ sub connect { my $sel = new IO::Select $sock; undef $!; - my($r,$w,$e) = IO::Select::select(undef,$sel,$sel,$timeout); - if(@$e[0]) { - # Windows return from select after the timeout in case of - # WSAECONNREFUSED(10061) if exception set is not used. - # This behavior is different from Linux. - # Using the exception - # set we now emulate the behavior in Linux - # - Karthik Rajagopalan - $err = $sock->getsockopt(SOL_SOCKET,SO_ERROR); - $@ = "connect: $err"; - } - elsif(!@$w[0]) { + if (!$sel->can_write($timeout)) { $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); $@ = "connect: timeout"; } elsif (!connect($sock,$addr) && - not ($!{EISCONN} || ($^O eq 'MSWin32' && - ($! == (($] < 5.019004) ? 10022 : Errno::EINVAL)))) + not ($!{EISCONN} || ($! == 10022 && $^O eq 'MSWin32')) ) { # Some systems refuse to re-connect() to # an already open socket and set errno to EISCONN. - # Windows sets errno to WSAEINVAL (10022) (pre-5.19.4) or - # EINVAL (22) (5.19.4 onwards). + # Windows sets errno to WSAEINVAL (10022) $err = $!; $@ = "connect: $!"; } @@ -169,7 +155,7 @@ sub blocking { my $sock = shift; return $sock->SUPER::blocking(@_) - if $^O ne 'MSWin32' && $^O ne 'VMS'; + if $^O ne 'MSWin32'; # Windows handles blocking differently # @@ -251,8 +237,6 @@ sub accept { $peer = accept($new,$sock) or return; - ${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto ); - return wantarray ? ($new, $peer) : $new; } @@ -353,27 +337,18 @@ sub timeout { sub sockdomain { @_ == 1 or croak 'usage: $sock->sockdomain()'; my $sock = shift; - if (!defined(${*$sock}{'io_socket_domain'})) { - my $addr = $sock->sockname(); - ${*$sock}{'io_socket_domain'} = sockaddr_family($addr) - if (defined($addr)); - } ${*$sock}{'io_socket_domain'}; } sub socktype { @_ == 1 or croak 'usage: $sock->socktype()'; my $sock = shift; - ${*$sock}{'io_socket_type'} = $sock->sockopt(Socket::SO_TYPE) - if (!defined(${*$sock}{'io_socket_type'}) && defined(eval{Socket::SO_TYPE})); ${*$sock}{'io_socket_type'} } sub protocol { @_ == 1 or croak 'usage: $sock->protocol()'; my($sock) = @_; - ${*$sock}{'io_socket_proto'} = $sock->sockopt(Socket::SO_PROTOCOL) - if (!defined(${*$sock}{'io_socket_proto'}) && defined(eval{Socket::SO_PROTOCOL})); ${*$sock}{'io_socket_proto'}; } @@ -499,23 +474,8 @@ C<use> declaration will fail at compile time. =item connected -If the socket is in a connected state, the peer address is returned. If the -socket is not in a connected state, undef is returned. - -Note that connected() considers a half-open TCP socket to be "in a connected -state". Specifically, connected() does not distinguish between the -B<ESTABLISHED> and B<CLOSE-WAIT> TCP states; it returns the peer address, -rather than undef, in either case. Thus, in general, connected() cannot -be used to reliably learn whether the peer has initiated a graceful shutdown -because in most cases (see below) the local TCP state machine remains in -B<CLOSE-WAIT> until the local application calls shutdown() or close(); -only at that point does connected() return undef. - -The "in most cases" hedge is because local TCP state machine behavior may -depend on the peer's socket options. In particular, if the peer socket has -SO_LINGER enabled with a zero timeout, then the peer's close() will generate -a RST segment, upon receipt of which the local TCP transitions immediately to -B<CLOSED>, and in that state, connected() I<will> return undef. +If the socket is in a connected state the peer address is returned. +If the socket is not in a connected state then undef will be returned. =item protocol @@ -557,12 +517,6 @@ value returned. =back -=head1 LIMITATIONS - -On some systems, for an IO::Socket object created with new_from_fd(), -or created with accept() from such an object, the protocol(), -sockdomain() and socktype() methods may return undef. - =head1 SEE ALSO L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> @@ -570,7 +524,7 @@ L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> =head1 AUTHOR Graham Barr. atmark() by Lincoln Stein. Currently maintained by the -Perl Porters. Please report all bugs to <perlbug@perl.org>. +Perl Porters. Please report all bugs to <perl5-porters@perl.org>. =head1 COPYRIGHT diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm index 7a1694733b5..2f0e5d1d7a6 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/INET.pm @@ -15,7 +15,7 @@ use Exporter; use Errno; @ISA = qw(IO::Socket); -$VERSION = "1.35"; +$VERSION = "1.31"; my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1; @@ -50,7 +50,7 @@ sub _get_proto_number { return undef unless defined $name; return $proto_number{$name} if exists $proto_number{$name}; - my @proto = eval { getprotobyname($name) }; + my @proto = getprotobyname($name); return undef unless @proto; _cache_proto(@proto); @@ -62,7 +62,7 @@ sub _get_proto_name { return undef unless defined $num; return $proto_name{$num} if exists $proto_name{$num}; - my @proto = eval { getprotobynumber($num) }; + my @proto = getprotobynumber($num); return undef unless @proto; _cache_proto(@proto); @@ -338,28 +338,26 @@ In addition to the key-value pairs accepted by L<IO::Socket>, C<IO::Socket::INET> provides. - PeerAddr Remote host address <hostname>[:<port>] - PeerHost Synonym for PeerAddr - PeerPort Remote port or service <service>[(<no>)] | <no> - LocalAddr Local host bind address hostname[:port] - LocalHost Synonym for LocalAddr - LocalPort Local host bind port <service>[(<no>)] | <no> - Proto Protocol name (or number) "tcp" | "udp" | ... - Type Socket type SOCK_STREAM | SOCK_DGRAM | ... - Listen Queue size for listen - ReuseAddr Set SO_REUSEADDR before binding - Reuse Set SO_REUSEADDR before binding (deprecated, - prefer ReuseAddr) - ReusePort Set SO_REUSEPORT before binding - Broadcast Set SO_BROADCAST before binding - Timeout Timeout value for various operations - MultiHomed Try all addresses for multi-homed hosts - Blocking Determine if connection will be blocking mode + PeerAddr Remote host address <hostname>[:<port>] + PeerHost Synonym for PeerAddr + PeerPort Remote port or service <service>[(<no>)] | <no> + LocalAddr Local host bind address hostname[:port] + LocalHost Synonym for LocalAddr + LocalPort Local host bind port <service>[(<no>)] | <no> + Proto Protocol name (or number) "tcp" | "udp" | ... + Type Socket type SOCK_STREAM | SOCK_DGRAM | ... + Listen Queue size for listen + ReuseAddr Set SO_REUSEADDR before binding + Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr) + ReusePort Set SO_REUSEPORT before binding + Broadcast Set SO_BROADCAST before binding + Timeout Timeout value for various operations + MultiHomed Try all addresses for multi-homed hosts + Blocking Determine if connection will be blocking mode If C<Listen> is defined then a listen socket is created, else if the socket type, which is derived from the protocol, is SOCK_STREAM then -connect() is called. If the C<Listen> argument is given, but false, -the queue size will be set to 5. +connect() is called. Although it is not illegal, the use of C<MultiHomed> on a socket which is in non-blocking mode is of little use. This is because the @@ -399,13 +397,12 @@ Examples: $sock = IO::Socket::INET->new('127.0.0.1:25'); - $sock = IO::Socket::INET->new( - PeerPort => 9999, - PeerAddr => inet_ntoa(INADDR_BROADCAST), - Proto => udp, - LocalAddr => 'localhost', - Broadcast => 1 ) - or die "Can't bind : $@\n"; + $sock = IO::Socket::INET->new(PeerPort => 9999, + PeerAddr => inet_ntoa(INADDR_BROADCAST), + Proto => udp, + LocalAddr => 'localhost', + Broadcast => 1 ) + or die "Can't bind : $@\n"; NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE @@ -456,7 +453,7 @@ L<Socket>, L<IO::Socket> =head1 AUTHOR Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perlbug@perl.org>. +bugs to <perl5-porters@perl.org>. =head1 COPYRIGHT diff --git a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm index 30b8f74eb05..baa092ba1fb 100644 --- a/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm +++ b/gnu/usr.bin/perl/dist/IO/lib/IO/Socket/UNIX.pm @@ -12,7 +12,7 @@ use IO::Socket; use Carp; @ISA = qw(IO::Socket); -$VERSION = "1.26"; +$VERSION = "1.23"; $VERSION = eval $VERSION; IO::Socket::UNIX->register_domain( AF_UNIX ); @@ -74,28 +74,6 @@ IO::Socket::UNIX - Object interface for AF_UNIX domain sockets use IO::Socket::UNIX; - my $SOCK_PATH = "$ENV{HOME}/unix-domain-socket-test.sock"; - - # Server: - my $server = IO::Socket::UNIX->new( - Type => SOCK_STREAM(), - Local => $SOCK_PATH, - Listen => 1, - ); - - my $count = 1; - while (my $conn = $server->accept()) { - $conn->print("Hello " . ($count++) . "\n"); - } - - # Client: - my $client = IO::Socket::UNIX->new( - Type => SOCK_STREAM(), - Peer => $SOCK_PATH, - ); - - # Now read and write from $client - =head1 DESCRIPTION C<IO::Socket::UNIX> provides an object interface to creating and using sockets @@ -118,12 +96,18 @@ C<IO::Socket::UNIX> provides. Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM) Local Path to local fifo Peer Path to peer fifo - Listen Queue size for listen + Listen Create a listen socket If the constructor is only passed a single argument, it is assumed to be a C<Peer> specification. -If the C<Listen> argument is given, but false, the queue size will be set to 5. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE =back @@ -148,7 +132,7 @@ L<Socket>, L<IO::Socket> =head1 AUTHOR Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perlbug@perl.org>. +bugs to <perl5-porters@perl.org>. =head1 COPYRIGHT diff --git a/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm b/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm index c2bd723e91b..1bfbbc9bba4 100644 --- a/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm +++ b/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext.pm @@ -1,33 +1,16 @@ - package Locale::Maketext; use strict; use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS $USE_LITERALS $MATCH_SUPERS_TIGHTLY); use Carp (); -use I18N::LangTags (); -use I18N::LangTags::Detect (); +use I18N::LangTags 0.30 (); #-------------------------------------------------------------------------- BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } } # define the constant 'DEBUG' at compile-time -# turn on utf8 if we have it (this is what GutsLoader.pm used to do essentially ) -# use if (exists $INC{'utf8.pm'} || eval 'use utf8'), 'utf8'; -BEGIN { - - # if we have it || we can load it - if ( exists $INC{'utf8.pm'} || eval { local $SIG{'__DIE__'};require utf8; } ) { - utf8->import(); - DEBUG and warn " utf8 on for _compile()\n"; - } - else { - DEBUG and warn " utf8 not available for _compile() ($INC{'utf8.pm'})\n$@\n"; - } -} - - -$VERSION = '1.25'; +$VERSION = '1.14'; @ISA = (); $MATCH_SUPERS = 1; @@ -148,7 +131,8 @@ sub failure_handler_auto { $handle->{'failure_lex'} ||= {}; my $lex = $handle->{'failure_lex'}; - my $value ||= ($lex->{$phrase} ||= $handle->_compile($phrase)); + my $value; + $lex->{$phrase} ||= ($value = $handle->_compile($phrase)); # Dumbly copied from sub maketext: return ${$value} if ref($value) eq 'SCALAR'; @@ -160,11 +144,12 @@ sub failure_handler_auto { # If we make it here, there was an exception thrown in the # call to $value, and so scream: if($@) { + my $err = $@; # pretty up the error message - $@ =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?} + $err =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?} {\n in bracket code [compiled line $1],}s; #$err =~ s/\n?$/\n/s; - Carp::croak "Error in maketexting \"$phrase\":\n$@ as used"; + Carp::croak "Error in maketexting \"$phrase\":\n$err as used"; # Rather unexpected, but suppose that the sub tried calling # a method that didn't exist. } @@ -194,54 +179,34 @@ sub maketext { my($handle, $phrase) = splice(@_,0,2); Carp::confess('No handle/phrase') unless (defined($handle) && defined($phrase)); - # backup $@ in case it's still being used in the calling code. - # If no failures, we'll re-set it back to what it was later. - my $at = $@; - # Copy @_ case one of its elements is $@. - @_ = @_; + # Don't interefere with $@ in case that's being interpolated into the msg. + local $@; # Look up the value: my $value; - if (exists $handle->{'_external_lex_cache'}{$phrase}) { - DEBUG and warn "* Using external lex cache version of \"$phrase\"\n"; - $value = $handle->{'_external_lex_cache'}{$phrase}; - } - else { - foreach my $h_r ( - @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs } - ) { - DEBUG and warn "* Looking up \"$phrase\" in $h_r\n"; - if(exists $h_r->{$phrase}) { - DEBUG and warn " Found \"$phrase\" in $h_r\n"; - unless(ref($value = $h_r->{$phrase})) { - # Nonref means it's not yet compiled. Compile and replace. - if ($handle->{'use_external_lex_cache'}) { - $value = $handle->{'_external_lex_cache'}{$phrase} = $handle->_compile($value); - } - else { - $value = $h_r->{$phrase} = $handle->_compile($value); - } - } - last; - } - # extending packages need to be able to localize _AUTO and if readonly can't "local $h_r->{'_AUTO'} = 1;" - # but they can "local $handle->{'_external_lex_cache'}{'_AUTO'} = 1;" - elsif($phrase !~ m/^_/s and ($handle->{'use_external_lex_cache'} ? ( exists $handle->{'_external_lex_cache'}{'_AUTO'} ? $handle->{'_external_lex_cache'}{'_AUTO'} : $h_r->{'_AUTO'} ) : $h_r->{'_AUTO'})) { - # it's an auto lex, and this is an autoable key! - DEBUG and warn " Automaking \"$phrase\" into $h_r\n"; - if ($handle->{'use_external_lex_cache'}) { - $value = $handle->{'_external_lex_cache'}{$phrase} = $handle->_compile($phrase); - } - else { - $value = $h_r->{$phrase} = $handle->_compile($phrase); - } - last; + foreach my $h_r ( + @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs } + ) { + DEBUG and warn "* Looking up \"$phrase\" in $h_r\n"; + if(exists $h_r->{$phrase}) { + DEBUG and warn " Found \"$phrase\" in $h_r\n"; + unless(ref($value = $h_r->{$phrase})) { + # Nonref means it's not yet compiled. Compile and replace. + $value = $h_r->{$phrase} = $handle->_compile($value); } - DEBUG>1 and print " Not found in $h_r, nor automakable\n"; - # else keep looking + last; + } + elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) { + # it's an auto lex, and this is an autoable key! + DEBUG and warn " Automaking \"$phrase\" into $h_r\n"; + + $value = $h_r->{$phrase} = $handle->_compile($phrase); + last; } + DEBUG>1 and print " Not found in $h_r, nor automakable\n"; + # else keep looking } unless(defined($value)) { @@ -250,12 +215,10 @@ sub maketext { DEBUG and warn "WARNING0: maketext fails looking for <$phrase>\n"; my $fail; if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference - $@ = $at; # Put $@ back in case we altered it along the way. return &{$fail}($handle, $phrase, @_); # If it ever returns, it should return a good value. } else { # It's a method name - $@ = $at; # Put $@ back in case we altered it along the way. return $handle->$fail($phrase, @_); # If it ever returns, it should return a good value. } @@ -266,14 +229,8 @@ sub maketext { } } - if(ref($value) eq 'SCALAR'){ - $@ = $at; # Put $@ back in case we altered it along the way. - return $$value ; - } - if(ref($value) ne 'CODE'){ - $@ = $at; # Put $@ back in case we altered it along the way. - return $value ; - } + return $$value if ref($value) eq 'SCALAR'; + return $value unless ref($value) eq 'CODE'; { local $SIG{'__DIE__'}; @@ -282,19 +239,18 @@ sub maketext { # If we make it here, there was an exception thrown in the # call to $value, and so scream: if ($@) { + my $err = $@; # pretty up the error message - $@ =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?} + $err =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?} {\n in bracket code [compiled line $1],}s; #$err =~ s/\n?$/\n/s; - Carp::croak "Error in maketexting \"$phrase\":\n$@ as used"; + Carp::croak "Error in maketexting \"$phrase\":\n$err as used"; # Rather unexpected, but suppose that the sub tried calling # a method that didn't exist. } else { - $@ = $at; # Put $@ back in case we altered it along the way. return $value; } - $@ = $at; # Put $@ back in case we altered it along the way. } ########################################################################### @@ -344,7 +300,7 @@ sub _langtag_munging { my($base_class, @languages) = @_; # We have all these DEBUG statements because otherwise it's hard as hell - # to diagnose if/when something goes wrong. + # to diagnose ifwhen something goes wrong. DEBUG and warn 'Lgs1: ', map("<$_>", @languages), "\n"; @@ -391,6 +347,7 @@ sub _langtag_munging { ########################################################################### sub _ambient_langprefs { + require I18N::LangTags::Detect; return I18N::LangTags::Detect::detect(); } @@ -430,6 +387,10 @@ sub _add_supers { # ########################################################################### +use Locale::Maketext::GutsLoader; + +########################################################################### + my %tried = (); # memoization of whether we've used this module, or found it unusable. @@ -439,18 +400,16 @@ sub _try_use { # Basically a wrapper around "require Modulename" my $module = $_[0]; # ASSUME sane module name! { no strict 'refs'; - no warnings 'once'; return($tried{$module} = 1) if %{$module . '::Lexicon'} or @{$module . '::ISA'}; # weird case: we never use'd it, but there it is! } DEBUG and warn " About to use $module ...\n"; - - local $SIG{'__DIE__'}; - local $@; - eval "require $module"; # used to be "use $module", but no point in that. - + { + local $SIG{'__DIE__'}; + eval "require $module"; # used to be "use $module", but no point in that. + } if($@) { DEBUG and warn "Error using $module \: $@\n"; return $tried{$module} = 0; @@ -494,312 +453,4 @@ sub _lex_refs { # report the lexicon references for this handle's class sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity! -#-------------------------------------------------------------------------- - -sub _compile { - # This big scary routine compiles an entry. - # It returns either a coderef if there's brackety bits in this, or - # otherwise a ref to a scalar. - - my $string_to_compile = $_[1]; # There are taint issues using regex on @_ - perlbug 60378,27344 - - # The while() regex is more expensive than this check on strings that don't need a compile. - # this op causes a ~2% speed hit for strings that need compile and a 250% speed improvement - # on strings that don't need compiling. - return \"$string_to_compile" if($string_to_compile !~ m/[\[~\]]/ms); # return a string ref if chars [~] are not in the string - - my $target = ref($_[0]) || $_[0]; - - my(@code); - my(@c) = (''); # "chunks" -- scratch. - my $call_count = 0; - my $big_pile = ''; - { - my $in_group = 0; # start out outside a group - my($m, @params); # scratch - - while($string_to_compile =~ # Iterate over chunks. - m/( - [^\~\[\]]+ # non-~[] stuff (Capture everything else here) - | - ~. # ~[, ~], ~~, ~other - | - \[ # [ presumably opening a group - | - \] # ] presumably closing a group - | - ~ # terminal ~ ? - | - $ - )/xgs - ) { - DEBUG>2 and warn qq{ "$1"\n}; - - if($1 eq '[' or $1 eq '') { # "[" or end - # Whether this is "[" or end, force processing of any - # preceding literal. - if($in_group) { - if($1 eq '') { - $target->_die_pointing($string_to_compile, 'Unterminated bracket group'); - } - else { - $target->_die_pointing($string_to_compile, 'You can\'t nest bracket groups'); - } - } - else { - if ($1 eq '') { - DEBUG>2 and warn " [end-string]\n"; - } - else { - $in_group = 1; - } - die "How come \@c is empty?? in <$string_to_compile>" unless @c; # sanity - if(length $c[-1]) { - # Now actually processing the preceding literal - $big_pile .= $c[-1]; - if($USE_LITERALS and ( - (ord('A') == 65) - ? $c[-1] !~ m/[^\x20-\x7E]/s - # ASCII very safe chars - : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s - # EBCDIC very safe chars - )) { - # normal case -- all very safe chars - $c[-1] =~ s/'/\\'/g; - push @code, q{ '} . $c[-1] . "',\n"; - $c[-1] = ''; # reuse this slot - } - else { - $c[-1] =~ s/\\\\/\\/g; - push @code, ' $c[' . $#c . "],\n"; - push @c, ''; # new chunk - } - } - # else just ignore the empty string. - } - - } - elsif($1 eq ']') { # "]" - # close group -- go back in-band - if($in_group) { - $in_group = 0; - - DEBUG>2 and warn " --Closing group [$c[-1]]\n"; - - # And now process the group... - - if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) { - DEBUG>2 and warn " -- (Ignoring)\n"; - $c[-1] = ''; # reset out chink - next; - } - - #$c[-1] =~ s/^\s+//s; - #$c[-1] =~ s/\s+$//s; - ($m,@params) = split(/,/, $c[-1], -1); # was /\s*,\s*/ - - # A bit of a hack -- we've turned "~,"'s into DELs, so turn - # 'em into real commas here. - if (ord('A') == 65) { # ASCII, etc - foreach($m, @params) { tr/\x7F/,/ } - } - else { # EBCDIC (1047, 0037, POSIX-BC) - # Thanks to Peter Prymmer for the EBCDIC handling - foreach($m, @params) { tr/\x07/,/ } - } - - # Special-case handling of some method names: - if($m eq '_*' or $m =~ m/^_(-?\d+)$/s) { - # Treat [_1,...] as [,_1,...], etc. - unshift @params, $m; - $m = ''; - } - elsif($m eq '*') { - $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars" - } - elsif($m eq '#') { - $m = 'numf'; # "#" for "number": [#,_1] for "the number _1" - } - - # Most common case: a simple, legal-looking method name - if($m eq '') { - # 0-length method name means to just interpolate: - push @code, ' ('; - } - elsif($m =~ /^\w+$/s - # exclude anything fancy, especially fully-qualified module names - ) { - push @code, ' $_[0]->' . $m . '('; - } - else { - # TODO: implement something? or just too icky to consider? - $target->_die_pointing( - $string_to_compile, - "Can't use \"$m\" as a method name in bracket group", - 2 + length($c[-1]) - ); - } - - pop @c; # we don't need that chunk anymore - ++$call_count; - - foreach my $p (@params) { - if($p eq '_*') { - # Meaning: all parameters except $_[0] - $code[-1] .= ' @_[1 .. $#_], '; - # and yes, that does the right thing for all @_ < 3 - } - elsif($p =~ m/^_(-?\d+)$/s) { - # _3 meaning $_[3] - $code[-1] .= '$_[' . (0 + $1) . '], '; - } - elsif($USE_LITERALS and ( - (ord('A') == 65) - ? $p !~ m/[^\x20-\x7E]/s - # ASCII very safe chars - : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s - # EBCDIC very safe chars - )) { - # Normal case: a literal containing only safe characters - $p =~ s/'/\\'/g; - $code[-1] .= q{'} . $p . q{', }; - } - else { - # Stow it on the chunk-stack, and just refer to that. - push @c, $p; - push @code, ' $c[' . $#c . '], '; - } - } - $code[-1] .= "),\n"; - - push @c, ''; - } - else { - $target->_die_pointing($string_to_compile, q{Unbalanced ']'}); - } - - } - elsif(substr($1,0,1) ne '~') { - # it's stuff not containing "~" or "[" or "]" - # i.e., a literal blob - my $text = $1; - $text =~ s/\\/\\\\/g; - $c[-1] .= $text; - - } - elsif($1 eq '~~') { # "~~" - $c[-1] .= '~'; - - } - elsif($1 eq '~[') { # "~[" - $c[-1] .= '['; - - } - elsif($1 eq '~]') { # "~]" - $c[-1] .= ']'; - - } - elsif($1 eq '~,') { # "~," - if($in_group) { - # This is a hack, based on the assumption that no-one will actually - # want a DEL inside a bracket group. Let's hope that's it's true. - if (ord('A') == 65) { # ASCII etc - $c[-1] .= "\x7F"; - } - else { # EBCDIC (cp 1047, 0037, POSIX-BC) - $c[-1] .= "\x07"; - } - } - else { - $c[-1] .= '~,'; - } - - } - elsif($1 eq '~') { # possible only at string-end, it seems. - $c[-1] .= '~'; - - } - else { - # It's a "~X" where X is not a special character. - # Consider it a literal ~ and X. - my $text = $1; - $text =~ s/\\/\\\\/g; - $c[-1] .= $text; - } - } - } - - if($call_count) { - undef $big_pile; # Well, nevermind that. - } - else { - # It's all literals! Ahwell, that can happen. - # So don't bother with the eval. Return a SCALAR reference. - return \$big_pile; - } - - die q{Last chunk isn't null??} if @c and length $c[-1]; # sanity - DEBUG and warn scalar(@c), " chunks under closure\n"; - if(@code == 0) { # not possible? - DEBUG and warn "Empty code\n"; - return \''; - } - elsif(@code > 1) { # most cases, presumably! - unshift @code, "join '',\n"; - } - unshift @code, "use strict; sub {\n"; - push @code, "}\n"; - - DEBUG and warn @code; - my $sub = eval(join '', @code); - die "$@ while evalling" . join('', @code) if $@; # Should be impossible. - return $sub; -} - -#-------------------------------------------------------------------------- - -sub _die_pointing { - # This is used by _compile to throw a fatal error - my $target = shift; # class name - # ...leaving $_[0] the error-causing text, and $_[1] the error message - - my $i = index($_[0], "\n"); - - my $pointy; - my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1; - if($pos < 1) { - $pointy = "^=== near there\n"; - } - else { # we need to space over - my $first_tab = index($_[0], "\t"); - if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) { - # No tabs, or the first tab is harmlessly after where we will point to, - # AND we're far enough from the margin that we can draw a proper arrow. - $pointy = ('=' x $pos) . "^ near there\n"; - } - else { - # tabs screw everything up! - $pointy = substr($_[0],0,$pos); - $pointy =~ tr/\t //cd; - # make everything into whitespace, but preserving tabs - $pointy .= "^=== near there\n"; - } - } - - my $errmsg = "$_[1], in\:\n$_[0]"; - - if($i == -1) { - # No newline. - $errmsg .= "\n" . $pointy; - } - elsif($i == (length($_[0]) - 1) ) { - # Already has a newline at end. - $errmsg .= $pointy; - } - else { - # don't bother with the pointy bit, I guess. - } - Carp::croak( "$errmsg via $target, as used" ); -} - 1; diff --git a/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext/GutsLoader.pm b/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext/GutsLoader.pm index 35a71ab5094..daa9840260a 100644 --- a/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext/GutsLoader.pm +++ b/gnu/usr.bin/perl/dist/Locale-Maketext/lib/Locale/Maketext/GutsLoader.pm @@ -1,26 +1,49 @@ package Locale::Maketext::GutsLoader; -use Locale::Maketext; - -our $VERSION = '1.20'; +$VERSION = '1.13'; +use strict; sub zorp { return scalar @_ } -=head1 NAME - -Locale::Maketext::GutsLoader - Deprecated module to load Locale::Maketext utf8 code - -=head1 SYNOPSIS - - # Do this instead please - use Locale::Maketext - -=head1 DESCRIPTION - -Previously Locale::Maketext::Guts performed some magic to load -Locale::Maketext when utf8 was unavailable. The subs this module provided -were merged back into Locale::Maketext. - -=cut +BEGIN { + $Locale::Maketext::GutsLoader::GUTSPATH = __FILE__; + *Locale::Maketext::DEBUG = sub () {0} + unless defined &Locale::Maketext::DEBUG; +} + +# +# This whole drama is so that we can load the utf8'd code +# in Locale::Maketext::Guts, but if that fails, snip the +# utf8 and then try THAT. +# + +$Locale::Maketext::GUTSPATH = ''; +Locale::Maketext::DEBUG and warn "Requiring Locale::Maketext::Guts...\n"; +eval 'require Locale::Maketext::Guts'; + +if ($@) { + my $path = $Locale::Maketext::GUTSPATH; + + die "Can't load Locale::Maketext::Guts\nAborting" unless $path; + + die "No readable file $Locale::Maketext::GutsLoader::GUTSPATH\nAborting" + unless -e $path and -f _ and -r _; + + open(IN, $path) or die "Can't read-open $path\nAborting"; + + my $source; + { local $/; $source = <IN>; } + close(IN); + unless( $source =~ s/\b(use utf8)/# $1/ ) { + Locale::Maketext::DEBUG and + print "I didn't see 'use utf8' in $path\n"; + } + eval $source; + die "Can't compile $path\n...The error I got was:\n$@\nAborting" if $@; + Locale::Maketext::DEBUG and warn "Non-utf8'd Locale::Maketext::Guts fine\n"; +} +else { + Locale::Maketext::DEBUG and warn "Loaded Locale::Maketext::Guts fine\n"; +} 1; diff --git a/gnu/usr.bin/perl/dist/Module-CoreList/corelist b/gnu/usr.bin/perl/dist/Module-CoreList/corelist index aa4a94571a3..08f198f4ac8 100644 --- a/gnu/usr.bin/perl/dist/Module-CoreList/corelist +++ b/gnu/usr.bin/perl/dist/Module-CoreList/corelist @@ -10,13 +10,9 @@ See L<Module::CoreList> for one. =head1 SYNOPSIS - corelist -v - corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ... - corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ... - corelist [-r <PerlVersion>] ... - corelist --feature <FeatureName> [<FeatureName>] ... - corelist --diff PerlVersion PerlVersion - corelist --upstream <ModuleName> + corelist -v + corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ... + corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ... =head1 OPTIONS @@ -27,67 +23,32 @@ See L<Module::CoreList> for one. lists all versions of the given module (or the matching modules, in case you used a module regexp) in the perls Module::CoreList knows about. - corelist -a Unicode - - Unicode was first released with perl v5.6.2 - v5.6.2 3.0.1 - v5.8.0 3.2.0 - v5.8.1 4.0.0 - v5.8.2 4.0.0 - v5.8.3 4.0.0 - v5.8.4 4.0.1 - v5.8.5 4.0.1 - v5.8.6 4.0.1 - v5.8.7 4.1.0 - v5.8.8 4.1.0 - v5.8.9 5.1.0 - v5.9.0 4.0.0 - v5.9.1 4.0.0 - v5.9.2 4.0.1 - v5.9.3 4.1.0 - v5.9.4 4.1.0 - v5.9.5 5.0.0 - v5.10.0 5.0.0 - v5.10.1 5.1.0 - v5.11.0 5.1.0 - v5.11.1 5.1.0 - v5.11.2 5.1.0 - v5.11.3 5.2.0 - v5.11.4 5.2.0 - v5.11.5 5.2.0 - v5.12.0 5.2.0 - v5.12.1 5.2.0 - v5.12.2 5.2.0 - v5.12.3 5.2.0 - v5.12.4 5.2.0 - v5.13.0 5.2.0 - v5.13.1 5.2.0 - v5.13.2 5.2.0 - v5.13.3 5.2.0 - v5.13.4 5.2.0 - v5.13.5 5.2.0 - v5.13.6 5.2.0 - v5.13.7 6.0.0 - v5.13.8 6.0.0 - v5.13.9 6.0.0 - v5.13.10 6.0.0 - v5.13.11 6.0.0 - v5.14.0 6.0.0 - v5.14.1 6.0.0 - v5.15.0 6.0.0 + corelist -a utf8 + + utf8 was first released with perl 5.006 + 5.006 undef + 5.006001 undef + 5.006002 undef + 5.007003 1.00 + 5.008 1.00 + 5.008001 1.02 + 5.008002 1.02 + 5.008003 1.02 + 5.008004 1.03 + 5.008005 1.04 + 5.008006 1.04 + 5.008007 1.05 + 5.008008 1.06 + 5.009 1.02 + 5.009001 1.02 + 5.009002 1.04 + 5.009003 1.06 =item -d finds the first perl version where a module has been released by date, and not by version number (as is the default). -=item --diff - -Given two versions of perl, this prints a human-readable table of all module -changes between the two. The output format may change in the future, and is -meant for I<humans>, not programs. For programs, use the L<Module::CoreList> -API. - =item -? or -help help! help! help! to see more help, try --man. @@ -107,21 +68,6 @@ like C<5.8.8>.) In module filtering context, it can be used as Perl version filter. -=item -r - -lists all of the perl releases and when they were released - -If you pass a perl version you get the release date for that version only. - -=item --feature, -f - -lists the first version bundle of each named feature given - -=item --upstream, -u - -Shows if the given module is primarily maintained in perl core or on CPAN -and bug tracker URL. - =back As a special case, if you specify the module name C<Unicode>, you'll get @@ -131,50 +77,22 @@ requested perl versions. =cut use Module::CoreList; -use Getopt::Long qw(:config no_ignore_case); +use Getopt::Long; use Pod::Usage; use strict; use warnings; -use List::Util qw/maxstr/; my %Opts; -GetOptions( - \%Opts, - qw[ help|?! man! r|release:s v|version:s a! d diff|D feature|f u|upstream ] -); +GetOptions(\%Opts, qw[ help|?! man! v|version:s a! d ] ); pod2usage(1) if $Opts{help}; pod2usage(-verbose=>2) if $Opts{man}; -if(exists $Opts{r} ){ - if ( !$Opts{r} ) { - print "\nModule::CoreList has release info for the following perl versions:\n"; - my $versions = { }; - my $max_ver_len = max_mod_len(\%Module::CoreList::released); - for my $ver ( grep !/0[01]0$/, sort keys %Module::CoreList::released ) { - printf "%-${max_ver_len}s %s\n", format_perl_version($ver), $Module::CoreList::released{$ver}; - } - print "\n"; - exit 0; - } - - my $num_r = numify_version( $Opts{r} ); - my $version_hash = Module::CoreList->find_version($num_r); - - if( !$version_hash ) { - print "\nModule::CoreList has no info on perl $Opts{r}\n\n"; - exit 1; - } - - printf "Perl %s was released on %s\n\n", format_perl_version($num_r), $Module::CoreList::released{$num_r}; - exit 0; -} - if(exists $Opts{v} ){ if( !$Opts{v} ) { print "\nModule::CoreList has info on the following perl versions:\n"; - print format_perl_version($_)."\n" for grep !/0[01]0$/, sort keys %Module::CoreList::version; + print format_perl_version($_)."\n" for sort keys %Module::CoreList::version; print "\n"; exit 0; } @@ -198,78 +116,6 @@ if(exists $Opts{v} ){ } } -if ($Opts{diff}) { - if(@ARGV != 2) { - die "\nprovide exactly two perl core versions to diff with --diff\n"; - } - - my ($old_ver, $new_ver) = @ARGV; - - my $old = numify_version($old_ver); - my $new = numify_version($new_ver); - - my %diff = Module::CoreList::changes_between($old, $new); - - for my $lib (sort keys %diff) { - my $diff = $diff{$lib}; - - my $was = ! exists $diff->{left} ? '(absent)' - : ! defined $diff->{left} ? '(undef)' - : $diff->{left}; - - my $now = ! exists $diff->{right} ? '(absent)' - : ! defined $diff->{right} ? '(undef)' - : $diff->{right}; - - printf "%-35s %10s %10s\n", $lib, $was, $now; - } - exit(0); -} - -if ($Opts{feature}) { - die "\n--feature is only available with perl v5.16.0 or greater\n" - if $] < 5.016; - - die "\nprovide at least one feature name to --feature\n" - unless @ARGV; - - no warnings 'once'; - require feature; - - my %feature2version; - my @bundles = map { $_->[0] } - sort { $b->[1] <=> $a->[1] } - map { [$_, numify_version($_)] } - grep { not /[^0-9.]/ } - keys %feature::feature_bundle; - - for my $version (@bundles) { - $feature2version{$_} = $version =~ /^\d\.\d+$/ ? "$version.0" : $version - for @{ $feature::feature_bundle{$version} }; - } - - # allow internal feature names, just in case someone gives us __SUB__ - # instead of current_sub. - while (my ($name, $internal) = each %feature::feature) { - $internal =~ s/^feature_//; - $feature2version{$internal} = $feature2version{$name} - if $feature2version{$name}; - } - - my $when = maxstr(values %Module::CoreList::released); - print "\n","Data for $when\n"; - - for my $feature (@ARGV) { - print "feature \"$feature\" ", - exists $feature2version{$feature} - ? "was first released with the perl " - . format_perl_version(numify_version($feature2version{$feature})) - . " feature bundle\n" - : "doesn't exist (or so I think)\n"; - } - exit(0); -} - if ( !@ARGV ) { pod2usage(0); } @@ -331,32 +177,16 @@ sub module_version { ? Module::CoreList->removed_from_by_date($mod) : Module::CoreList->removed_from($mod); - my $when = maxstr(values %Module::CoreList::released); - print "\n","Data for $when\n"; - if( defined $ret ) { - my $deprecated = Module::CoreList->deprecated_in($mod); $msg .= " was "; $msg .= "first " unless $ver; $msg .= "released with perl " . format_perl_version($ret); - $msg .= ( $rem ? ',' : ' and' ) . " deprecated (will be CPAN-only) in " . format_perl_version($deprecated) if $deprecated; $msg .= " and removed from " . format_perl_version($rem) if $rem; } else { $msg .= " was not in CORE (or so I think)"; } - print $msg,"\n"; - - if( defined $ret and exists $Opts{u} ) { - my $upsream = $Module::CoreList::upstream{$mod}; - $upsream = 'undef' unless $upsream; - print "upstream: $upsream\n"; - if ( $upsream ne 'blead' ) { - my $bugtracker = $Module::CoreList::bug_tracker{$mod}; - $bugtracker = 'unknown' unless $bugtracker; - print "bug tracker: $bugtracker\n"; - } - } + print "\n",$msg,"\n"; if(defined $ret and exists $Opts{a} and $Opts{a}){ display_a($mod); @@ -383,7 +213,7 @@ sub max { sub display_a { my $mod = shift; - for my $v (grep !/0[01]0$/, sort keys %Module::CoreList::version ) { + for my $v (grep !/000$/, sort keys %Module::CoreList::version ) { next unless exists $Module::CoreList::version{$v}{$mod}; my $mod_v = $Module::CoreList::version{$v}{$mod} || 'undef'; diff --git a/gnu/usr.bin/perl/dist/Storable/Storable.pm b/gnu/usr.bin/perl/dist/Storable/Storable.pm index 7d8a01198d5..7627943b55d 100644 --- a/gnu/usr.bin/perl/dist/Storable/Storable.pm +++ b/gnu/usr.bin/perl/dist/Storable/Storable.pm @@ -1,14 +1,13 @@ # -# Copyright (c) 1995-2001, Raphael Manfredi -# Copyright (c) 2002-2013 by the Perl 5 Porters +# Copyright (c) 1995-2000, Raphael Manfredi # # You may redistribute only under the same terms as Perl 5, as specified # in the README file that comes with the distribution. # -require XSLoader; +require DynaLoader; require Exporter; -package Storable; @ISA = qw(Exporter); +package Storable; @ISA = qw(Exporter DynaLoader); @EXPORT = qw(store retrieve); @EXPORT_OK = qw( @@ -20,32 +19,24 @@ package Storable; @ISA = qw(Exporter); file_magic read_magic ); +use AutoLoader; +use FileHandle; use vars qw($canonical $forgive_me $VERSION); -$VERSION = '2.49_01'; +$VERSION = '2.22'; +*AUTOLOAD = \&AutoLoader::AUTOLOAD; # Grrr... -BEGIN { - if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) { - Log::Agent->import; - } - # - # Use of Log::Agent is optional. If it hasn't imported these subs then - # provide a fallback implementation. - # - unless ($Storable::{logcroak} && *{$Storable::{logcroak}}{CODE}) { - require Carp; - *logcroak = sub { - Carp::croak(@_); - }; - } - unless ($Storable::{logcarp} && *{$Storable::{logcarp}}{CODE}) { - require Carp; - *logcarp = sub { - Carp::carp(@_); - }; - } +# +# Use of Log::Agent is optional +# + +{ + local $SIG{__DIE__}; + eval "use Log::Agent"; } +require Carp; + # # They might miss :flock in Fcntl # @@ -66,12 +57,28 @@ sub CLONE { Storable::init_perinterp(); } +# Can't Autoload cleanly as this clashes 8.3 with &retrieve +sub retrieve_fd { &fd_retrieve } # Backward compatibility + # By default restricted hashes are downgraded on earlier perls. $Storable::downgrade_restricted = 1; $Storable::accept_future_minor = 1; +bootstrap Storable; +1; +__END__ +# +# Use of Log::Agent is optional. If it hasn't imported these subs then +# Autoloader will kindly supply our fallback implementation. +# + +sub logcroak { + Carp::croak(@_); +} -XSLoader::load('Storable', $Storable::VERSION); +sub logcarp { + Carp::carp(@_); +} # # Determine whether locking is possible, but only when needed. @@ -109,10 +116,8 @@ EOM } sub file_magic { - require IO::File; - my $file = shift; - my $fh = IO::File->new; + my $fh = new FileHandle; open($fh, "<". $file) || die "Can't open '$file': $!"; binmode($fh); defined(sysread($fh, my $buf, 32)) || die "Can't read from '$file': $!"; @@ -146,14 +151,14 @@ sub read_magic { $net_order = 0; } else { - $buf =~ s/(.)//s; - my $major = (ord $1) >> 1; + $net_order = ord(substr($buf, 0, 1, "")); + my $major = $net_order >> 1; return undef if $major > 4; # sanity (assuming we never go that high) $info{major} = $major; - $net_order = (ord $1) & 0x01; + $net_order &= 0x01; if ($major > 1) { - return undef unless $buf =~ s/(.)//s; - my $minor = ord $1; + return undef unless length($buf); + my $minor = ord(substr($buf, 0, 1, "")); $info{minor} = $minor; $info{version} = "$major.$minor"; $info{version_nv} = sprintf "%d.%03d", $major, $minor; @@ -166,16 +171,17 @@ sub read_magic { $info{netorder} = $net_order; unless ($net_order) { - return undef unless $buf =~ s/(.)//s; - my $len = ord $1; + return undef unless length($buf); + my $len = ord(substr($buf, 0, 1, "")); return undef unless length($buf) >= $len; return undef unless $len == 4 || $len == 8; # sanity - @info{qw(byteorder intsize longsize ptrsize)} - = unpack "a${len}CCC", $buf; - (substr $buf, 0, $len + 3) = ''; + $info{byteorder} = substr($buf, 0, $len, ""); + $info{intsize} = ord(substr($buf, 0, 1, "")); + $info{longsize} = ord(substr($buf, 0, 1, "")); + $info{ptrsize} = ord(substr($buf, 0, 1, "")); if ($info{version_nv} >= 2.002) { - return undef unless $buf =~ s/(.)//s; - $info{nvsize} = ord $1; + return undef unless length($buf); + $info{nvsize} = ord(substr($buf, 0, 1, "")); } } $info{hdrsize} = $buflen - length($buf); @@ -256,18 +262,11 @@ sub _store { my $ret; # Call C routine nstore or pstore, depending on network order eval { $ret = &$xsptr(*FILE, $self) }; - # close will return true on success, so the or short-circuits, the () - # expression is true, and for that case the block will only be entered - # if $@ is true (ie eval failed) - # if close fails, it returns false, $ret is altered, *that* is (also) - # false, so the () expression is false, !() is true, and the block is - # entered. - if (!(close(FILE) or undef $ret) || $@) { - unlink($file) or warn "Can't unlink $file: $!\n"; - } + close(FILE) or $ret = undef; + unlink($file) or warn "Can't unlink $file: $!\n" if $@ || !defined $ret; logcroak $@ if $@ =~ s/\.?\n$/,/; $@ = $da; - return $ret; + return $ret ? $ret : undef; } # @@ -306,13 +305,13 @@ sub _store_fd { logcroak $@ if $@ =~ s/\.?\n$/,/; local $\; print $file ''; # Autoflush the file if wanted $@ = $da; - return $ret; + return $ret ? $ret : undef; } # # freeze # -# Store object and its hierarchy in memory and return a scalar +# Store oject and its hierarchy in memory and return a scalar # containing the result. # sub freeze { @@ -402,8 +401,6 @@ sub fd_retrieve { return $self; } -sub retrieve_fd { &fd_retrieve } # Backward compatibility - # # thaw # @@ -906,12 +903,12 @@ This returns the file format version as number. It is a string like "2.007". This value is suitable for numeric comparisons. The constant function C<Storable::BIN_VERSION_NV> returns a comparable -number that represents the highest file version number that this -version of Storable fully supports (but see discussion of +number that represent the highest file version number that this +version of Storable fully support (but see discussion of C<$Storable::accept_future_minor> above). The constant C<Storable::BIN_WRITE_VERSION_NV> function returns what file version is written and might be less than C<Storable::BIN_VERSION_NV> in some -configurations. +configuations. =item C<major>, C<minor> @@ -1020,38 +1017,6 @@ compartment: =for example_testing is( $code->(), 42 ); -=head1 SECURITY WARNING - -B<Do not accept Storable documents from untrusted sources!> - -Some features of Storable can lead to security vulnerabilities if you -accept Storable documents from untrusted sources. Most obviously, the -optional (off by default) CODE reference serialization feature allows -transfer of code to the deserializing process. Furthermore, any -serialized object will cause Storable to helpfully load the module -corresponding to the class of the object in the deserializing module. -For manipulated module names, this can load almost arbitrary code. -Finally, the deserialized object's destructors will be invoked when -the objects get destroyed in the deserializing process. Maliciously -crafted Storable documents may put such objects in the value of -a hash key that is overridden by another key/value pair in the -same hash, thus causing immediate destructor execution. - -In a future version of Storable, we intend to provide options to disable -loading modules for classes and to disable deserializing objects -altogether. I<Nonetheless, Storable deserializing documents from -untrusted sources is expected to have other, yet undiscovered, -security concerns such as allowing an attacker to cause the deserializer -to crash hard.> - -B<Therefore, let me repeat: Do not accept Storable documents from -untrusted sources!> - -If your application requires accepting data from untrusted sources, you -are best off with a less powerful and more-likely safe serialization format -and implementation. If your data is sufficiently simple, JSON is a good -choice and offers maximum interoperability. - =head1 WARNING If you're using references as keys within your hash tables, you're bound @@ -1086,8 +1051,8 @@ deal with them. The store functions will C<croak> if they run into such references unless you set C<$Storable::forgive_me> to some C<TRUE> value. In that -case, the fatal message is converted to a warning and some meaningless -string is stored instead. +case, the fatal message is turned in a warning and some +meaningless string is stored instead. Setting C<$Storable::canonical> may not yield frozen strings that compare equal due to possible stringification of numbers. When the @@ -1163,7 +1128,7 @@ correct behaviour. What this means is that if you have data written by Storable 1.x running on perl 5.6.0 or 5.6.1 configured with 64 bit integers on Unix or Linux then by default this Storable will refuse to read it, giving the error -I<Byte order is not compatible>. If you have such data then you +I<Byte order is not compatible>. If you have such data then you you should set C<$Storable::interwork_56_64bit> to a true value to make this Storable read and write files with the old header. You should also migrate your data, or any older perl you are communicating with, to this @@ -1182,7 +1147,7 @@ Thank you to (in chronological order): Jarkko Hietaniemi <jhi@iki.fi> Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de> - Benjamin A. Holzman <bholzman@earthlink.net> + Benjamin A. Holzman <bah@ecnvantage.com> Andrew Ford <A.Ford@ford-mason.co.uk> Gisle Aas <gisle@aas.no> Jeff Gresham <gresham_jeffrey@jpmorgan.com> @@ -1193,8 +1158,6 @@ Thank you to (in chronological order): Salvador Ortiz Garcia <sog@msg.com.mx> Dominic Dunlop <domo@computer.org> Erik Haugan <erik@solbors.no> - Benjamin A. Holzman <ben.holzman@grantstreet.com> - Reini Urban <rurban@cpanel.net> for their bug reports, suggestions and contributions. @@ -1206,9 +1169,7 @@ simply counting the objects instead of tagging them (leading to a binary incompatibility for the Storable image starting at version 0.6--older images are, of course, still properly understood). Murray Nesbitt made Storable thread-safe. Marc Lehmann added overloading -and references to tied items support. Benjamin Holzman added a performance -improvement for overloaded classes; thanks to Grant Street Group for footing -the bill. +and references to tied items support. =head1 AUTHOR diff --git a/gnu/usr.bin/perl/dist/base/lib/base.pm b/gnu/usr.bin/perl/dist/base/lib/base.pm index 5d1378786de..2f6a19e4b9a 100644 --- a/gnu/usr.bin/perl/dist/base/lib/base.pm +++ b/gnu/usr.bin/perl/dist/base/lib/base.pm @@ -2,7 +2,7 @@ package base; use strict 'vars'; use vars qw($VERSION); -$VERSION = '2.22'; +$VERSION = '2.15'; $VERSION = eval $VERSION; # constant.pm is slow @@ -22,6 +22,12 @@ sub has_fields { return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 ); } +sub has_version { + my($base) = shift; + my $vglob = ${$base.'::'}{VERSION}; + return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 ); +} + sub has_attr { my($proto) = shift; my($class) = ref $proto || $proto; @@ -55,23 +61,6 @@ else { } } -if ($] < 5.008) { - *_module_to_filename = sub { - (my $fn = $_[0]) =~ s!::!/!g; - $fn .= '.pm'; - return $fn; - } -} -else { - *_module_to_filename = sub { - (my $fn = $_[0]) =~ s!::!/!g; - $fn .= '.pm'; - utf8::encode($fn); - return $fn; - } -} - - sub import { my $class = shift; @@ -81,6 +70,7 @@ sub import { my $fields_base; my $inheritor = caller(0); + my @isa_classes; my @bases; foreach my $base (@_) { @@ -90,23 +80,18 @@ sub import { next if grep $_->isa($base), ($inheritor, @bases); - # Following blocks help isolate $SIG{__DIE__} changes - { + if (has_version($base)) { + ${$base.'::VERSION'} = '-1, set by base.pm' + unless defined ${$base.'::VERSION'}; + } + else { my $sigdie; { local $SIG{__DIE__}; - my $fn = _module_to_filename($base); - eval { require $fn }; + eval "require $base"; # Only ignore "Can't locate" errors from our eval require. # Other fatal errors (syntax etc) must be reported. - # - # changing the check here is fragile - if the check - # here isn't catching every error you want, you should - # probably be using parent.pm, which doesn't try to - # guess whether require is needed or failed, - # see [perl #118561] - die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s - || $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/; + die if $@ && $@ !~ /^Can't locate .*? at \(eval /; unless (%{"$base\::"}) { require Carp; local $" = " "; @@ -120,6 +105,8 @@ ERROR } # Make sure a global $SIG{__DIE__} makes it out of the localization. $SIG{__DIE__} = $sigdie if defined $sigdie; + ${$base.'::VERSION'} = "-1, set by base.pm" + unless defined ${$base.'::VERSION'}; } push @bases, $base; @@ -134,6 +121,8 @@ ERROR } } # Save this until the end so it's all or nothing if the above loop croaks. + push @{"$inheritor\::ISA"}, @isa_classes; + push @{"$inheritor\::ISA"}, @bases; if( defined $fields_base ) { @@ -217,26 +206,26 @@ those modules at the same time. Roughly similar in effect to push @ISA, qw(Foo Bar); } -When C<base> tries to C<require> a module, it will not die if it cannot find -the module's file, but will die on any other error. After all this, should -your base class be empty, containing no symbols, C<base> will die. This is -useful for inheriting from classes in the same file as yourself but where -the filename does not match the base module name, like so: +C<base> employs some heuristics to determine if a module has already been +loaded, if it has it doesn't try again. If C<base> tries to C<require> the +module it will not die if it cannot find the module's file, but will die on any +other error. After all this, should your base class be empty, containing no +symbols, it will die. This is useful for inheriting from classes in the same +file as yourself, like so: - # in Bar.pm package Foo; sub exclaim { "I can have such a thing?!" } - + package Bar; use base "Foo"; -There is no F<Foo.pm>, but because C<Foo> defines a symbol (the C<exclaim> -subroutine), C<base> will not die when the C<require> fails to load F<Foo.pm>. +If $VERSION is not detected even after loading it, <base> will define $VERSION +in the base package, setting it to the string C<-1, set by base.pm>. C<base> will also initialize the fields if one of the base classes has it. Multiple inheritance of fields is B<NOT> supported, if two or more base classes -each have inheritable fields the 'base' pragma will croak. See L<fields> -for a description of this feature. +each have inheritable fields the 'base' pragma will croak. See L<fields>, +L<public> and L<protected> for a description of this feature. The base class' C<import> method is B<not> called. @@ -254,7 +243,7 @@ found in your path. Attempting to inherit from yourself generates a warning. - package Foo; + use Foo; use base 'Foo'; =back diff --git a/gnu/usr.bin/perl/dist/base/lib/fields.pm b/gnu/usr.bin/perl/dist/base/lib/fields.pm index ad1a5cfa412..de6f379d9fe 100644 --- a/gnu/usr.bin/perl/dist/base/lib/fields.pm +++ b/gnu/usr.bin/perl/dist/base/lib/fields.pm @@ -11,7 +11,7 @@ unless( eval q{require warnings::register; warnings::register->import; 1} ) { } use vars qw(%attr $VERSION); -$VERSION = '2.17'; +$VERSION = '2.15'; # constant.pm is slow sub PUBLIC () { 2**0 } @@ -200,13 +200,9 @@ fields - compile-time class fields my $var = Foo->new; $var->{foo} = 42; - # this will generate a run-time error + # this will generate an error $var->{zap} = 42; - # this will generate a compile-time error - my Foo $foo = Foo->new; - $foo->{zap} = 24; - # subclassing { package Bar; @@ -224,34 +220,38 @@ fields - compile-time class fields =head1 DESCRIPTION -The C<fields> pragma enables compile-time and run-time verified class -fields. +The C<fields> pragma enables compile-time verified class fields. NOTE: The current implementation keeps the declared fields in the %FIELDS hash of the calling package, but this may change in future versions. Do B<not> update the %FIELDS hash directly, because it must be created at compile-time for it to be fully useful, as is done by this pragma. -If a typed lexical variable (C<my Class -$var>) holding a reference is used to access a +B<Only valid for perl before 5.9.0:> + +If a typed lexical variable holding a reference is used to access a hash element and a package with the same name as the type has -declared class fields using this pragma, then the hash key is -verified at compile time. If the variables are not typed, access is -only checked at run time. +declared class fields using this pragma, then the operation is +turned into an array access at compile time. + The related C<base> pragma will combine fields from base classes and any fields declared using the C<fields> pragma. This enables field -inheritance to work properly. Inherited fields can be overridden but -will generate a warning if warnings are enabled. +inheritance to work properly. + +Field names that start with an underscore character are made private to +the class and are not visible to subclasses. Inherited fields can be +overridden but will generate a warning if used together with the C<-w> +switch. + +B<Only valid for perls before 5.9.0:> -B<Only valid for Perl 5.8.x and earlier:> Field names that start with an -underscore character are made private to the class and are not visible -to subclasses. +The effect of all this is that you can have objects with named +fields which are as compact and as fast arrays to access. This only +works as long as the objects are accessed through properly typed +variables. If the objects are not typed, access is only checked at +run time. -Also, B<in Perl 5.8.x and earlier>, this pragma uses pseudo-hashes, the -effect being that you can have objects with named fields which are as -compact and as fast arrays to access, as long as the objects are -accessed through properly typed variables. The following functions are supported: @@ -259,8 +259,15 @@ The following functions are supported: =item new -fields::new() creates and blesses a hash comprised of the fields declared -using the C<fields> pragma into the specified class. It is the +B< perl before 5.9.0: > fields::new() creates and blesses a +pseudo-hash comprised of the fields declared using the C<fields> +pragma into the specified class. + +B< perl 5.9.0 and higher: > fields::new() creates and blesses a +restricted-hash comprised of the fields declared using the C<fields> +pragma into the specified class. + +This function is usable with or without pseudo-hashes. It is the recommended way to construct a fields-based object. This makes it possible to write a constructor like this: @@ -271,18 +278,14 @@ This makes it possible to write a constructor like this: sub new { my $self = shift; $self = fields::new($self) unless ref $self; - $self->{cat} = 'meow'; # scalar element - @$self{'dog','bird'} = ('bark','tweet'); # slice + $self->{cat} = 'meow'; # scalar element + @$self{'dog','bird'} = ('bark','tweet'); # slice return $self; } =item phash -B<This function only works in Perl 5.8.x and earlier.> Pseudo-hashes -were removed from Perl as of 5.10. Consider using restricted hashes or -fields::new() instead (which itself uses restricted hashes under 5.10+). -See L<Hash::Util>. Using fields::phash() under 5.10 or higher will -cause an error. +B< before perl 5.9.0: > fields::phash() can be used to create and initialize a plain (unblessed) pseudo-hash. This function should always be used instead of creating @@ -309,10 +312,16 @@ be used to construct the pseudo hash. Examples: my $pseudohash = fields::phash(%args); +B< perl 5.9.0 and higher: > + +Pseudo-hashes have been removed from Perl as of 5.10. Consider using +restricted hashes or fields::new() instead. Using fields::phash() +will cause an error. + =back =head1 SEE ALSO -L<base>, L<Hash::Util> +L<base> =cut |