diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/IO')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/IO/Dir.pm | 246 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/IO/File.pm | 208 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/IO/Handle.pm | 625 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/IO/Pipe.pm | 257 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/IO/Poll.pm | 209 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/IO/Seekable.pm | 128 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/IO/Select.pm | 381 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/IO/Socket.pm | 476 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/IO/Socket/INET.pm | 431 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm | 144 | ||||
| -rwxr-xr-x | Master/tlpkg/tlperl/lib/IO/String.pm | 551 |
11 files changed, 0 insertions, 3656 deletions
diff --git a/Master/tlpkg/tlperl/lib/IO/Dir.pm b/Master/tlpkg/tlperl/lib/IO/Dir.pm deleted file mode 100644 index fccd02c088a..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Dir.pm +++ /dev/null @@ -1,246 +0,0 @@ -# IO::Dir.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Dir; - -use 5.006; - -use strict; -use Carp; -use Symbol; -use Exporter; -use IO::File; -our(@ISA, $VERSION, @EXPORT_OK); -use Tie::Hash; -use File::stat; -use File::Spec; - -@ISA = qw(Tie::Hash Exporter); -$VERSION = "1.05"; -$VERSION = eval $VERSION; -@EXPORT_OK = qw(DIR_UNLINK); - -sub DIR_UNLINK () { 1 } - -sub new { - @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]'; - my $class = shift; - my $dh = gensym; - if (@_) { - IO::Dir::open($dh, $_[0]) - or return undef; - } - bless $dh, $class; -} - -sub DESTROY { - my ($dh) = @_; - closedir($dh); -} - -sub open { - @_ == 2 or croak 'usage: $dh->open(DIRNAME)'; - my ($dh, $dirname) = @_; - return undef - unless opendir($dh, $dirname); - # a dir name should always have a ":" in it; assume dirname is - # in current directory - $dirname = ':' . $dirname if ( ($^O eq 'MacOS') && ($dirname !~ /:/) ); - ${*$dh}{io_dir_path} = $dirname; - 1; -} - -sub close { - @_ == 1 or croak 'usage: $dh->close()'; - my ($dh) = @_; - closedir($dh); -} - -sub read { - @_ == 1 or croak 'usage: $dh->read()'; - my ($dh) = @_; - readdir($dh); -} - -sub seek { - @_ == 2 or croak 'usage: $dh->seek(POS)'; - my ($dh,$pos) = @_; - seekdir($dh,$pos); -} - -sub tell { - @_ == 1 or croak 'usage: $dh->tell()'; - my ($dh) = @_; - telldir($dh); -} - -sub rewind { - @_ == 1 or croak 'usage: $dh->rewind()'; - my ($dh) = @_; - rewinddir($dh); -} - -sub TIEHASH { - my($class,$dir,$options) = @_; - - my $dh = $class->new($dir) - or return undef; - - $options ||= 0; - - ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK; - $dh; -} - -sub FIRSTKEY { - my($dh) = @_; - $dh->rewind; - scalar $dh->read; -} - -sub NEXTKEY { - my($dh) = @_; - scalar $dh->read; -} - -sub EXISTS { - my($dh,$key) = @_; - -e File::Spec->catfile(${*$dh}{io_dir_path}, $key); -} - -sub FETCH { - my($dh,$key) = @_; - &lstat(File::Spec->catfile(${*$dh}{io_dir_path}, $key)); -} - -sub STORE { - my($dh,$key,$data) = @_; - my($atime,$mtime) = ref($data) ? @$data : ($data,$data); - my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key); - unless(-e $file) { - my $io = IO::File->new($file,O_CREAT | O_RDWR); - $io->close if $io; - } - utime($atime,$mtime, $file); -} - -sub DELETE { - my($dh,$key) = @_; - - # Only unlink if unlink-ing is enabled - return 0 - unless ${*$dh}{io_dir_unlink}; - - my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key); - - -d $file - ? rmdir($file) - : unlink($file); -} - -1; - -__END__ - -=head1 NAME - -IO::Dir - supply object methods for directory handles - -=head1 SYNOPSIS - - use IO::Dir; - $d = IO::Dir->new("."); - if (defined $d) { - while (defined($_ = $d->read)) { something($_); } - $d->rewind; - while (defined($_ = $d->read)) { something_else($_); } - undef $d; - } - - tie %dir, 'IO::Dir', "."; - foreach (keys %dir) { - print $_, " " , $dir{$_}->size,"\n"; - } - -=head1 DESCRIPTION - -The C<IO::Dir> package provides two interfaces to perl's directory reading -routines. - -The first interface is an object approach. C<IO::Dir> provides an object -constructor and methods, which are just wrappers around perl's built in -directory reading routines. - -=over 4 - -=item new ( [ DIRNAME ] ) - -C<new> is the constructor for C<IO::Dir> objects. It accepts one optional -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> -for details of these functions. - -=over 4 - -=item open ( DIRNAME ) - -=item read () - -=item seek ( POS ) - -=item tell () - -=item rewind () - -=item close () - -=back - -C<IO::Dir> also provides an interface to reading directories via a tied -hash. The tied hash extends the interface beyond just the directory -reading routines by the use of C<lstat>, from the C<File::stat> package, -C<unlink>, C<rmdir> and C<utime>. - -=over 4 - -=item tie %hash, 'IO::Dir', DIRNAME [, OPTIONS ] - -=back - -The keys of the hash will be the names of the entries in the directory. -Reading a value from the hash will be the result of calling -C<File::stat::lstat>. Deleting an element from the hash will -delete the corresponding file or subdirectory, -provided that C<DIR_UNLINK> is included in the C<OPTIONS>. - -Assigning to an entry in the hash will cause the time stamps of the file -to be modified. If the file does not exist then it will be created. Assigning -a single integer to a hash element will cause both the access and -modification times to be changed to that value. Alternatively a reference to -an array of two values can be passed. The first array element will be used to -set the access time and the second element will be used to set the modification -time. - -=head1 SEE ALSO - -L<File::stat> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1997-2003 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/IO/File.pm b/Master/tlpkg/tlperl/lib/IO/File.pm deleted file mode 100644 index e7cdbbed6d7..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/File.pm +++ /dev/null @@ -1,208 +0,0 @@ -# - -package IO::File; - -=head1 NAME - -IO::File - supply object methods for filehandles - -=head1 SYNOPSIS - - use IO::File; - - $fh = new IO::File; - if ($fh->open("< file")) { - print <$fh>; - $fh->close; - } - - $fh = new IO::File "> file"; - if (defined $fh) { - print $fh "bar\n"; - $fh->close; - } - - $fh = new IO::File "file", "r"; - if (defined $fh) { - print <$fh>; - undef $fh; # automatically closes the file - } - - $fh = new IO::File "file", O_WRONLY|O_APPEND; - if (defined $fh) { - print $fh "corge\n"; - - $pos = $fh->getpos; - $fh->setpos($pos); - - undef $fh; # automatically closes the file - } - - autoflush STDOUT 1; - -=head1 DESCRIPTION - -C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends -these classes with methods that are specific to file handles. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( FILENAME [,MODE [,PERMS]] ) - -Creates an C<IO::File>. If it receives any parameters, they are passed to -the method C<open>; if the open fails, the object is destroyed. Otherwise, -it is returned to the caller. - -=item new_tmpfile - -Creates an C<IO::File> opened for read/write on a newly created temporary -file. On systems where this is possible, the temporary file is anonymous -(i.e. it is unlinked after creation, but held open). If the temporary -file cannot be created or opened, the C<IO::File> object is destroyed. -Otherwise, it is returned to the caller. - -=back - -=head1 METHODS - -=over 4 - -=item open( FILENAME [,MODE [,PERMS]] ) - -=item open( FILENAME, IOLAYERS ) - -C<open> accepts one, two or three parameters. With one parameter, -it is just a front end for the built-in C<open> function. With two or three -parameters, the first parameter is a filename that may include -whitespace or other special characters, and the second parameter is -the open mode, optionally followed by a file permission value. - -If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.) -or an ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic -Perl C<open> operator (but protects any special characters). - -If C<IO::File::open> is given a numeric mode, it passes that mode -and the optional permissions value to the Perl C<sysopen> operator. -The permissions default to 0666. - -If C<IO::File::open> is given a mode that includes the C<:> character, -it passes all the three arguments to the three-argument C<open> operator. - -For convenience, C<IO::File> exports the O_XXX constants from the -Fcntl module, if this module is available. - -=item binmode( [LAYER] ) - -C<binmode> sets C<binmode> on the underlying C<IO> object, as documented -in C<perldoc -f binmode>. - -C<binmode> accepts one optional parameter, which is the layer to be -passed on to the C<binmode> call. - -=back - -=head1 NOTE - -Some operating systems may perform C<IO::File::new()> or C<IO::File::open()> -on a directory without errors. This behavior is not portable and not -suggested for use. Using C<opendir()> and C<readdir()> or C<IO::Dir> are -suggested instead. - -=head1 SEE ALSO - -L<perlfunc>, -L<perlop/"I/O Operators">, -L<IO::Handle>, -L<IO::Seekable>, -L<IO::Dir> - -=head1 HISTORY - -Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. - -=cut - -use 5.006_001; -use strict; -our($VERSION, @EXPORT, @EXPORT_OK, @ISA); -use Carp; -use Symbol; -use SelectSaver; -use IO::Seekable; -use File::Spec; - -require Exporter; - -@ISA = qw(IO::Handle IO::Seekable Exporter); - -$VERSION = "1.13"; - -@EXPORT = @IO::Seekable::EXPORT; - -eval { - # Make all Fcntl O_XXX constants available for importing - require Fcntl; - my @O = grep /^O_/, @Fcntl::EXPORT; - Fcntl->import(@O); # first we import what we want to export - push(@EXPORT, @O); -}; - -################################################ -## Constructor -## - -sub new { - my $type = shift; - my $class = ref($type) || $type || "IO::File"; - @_ >= 0 && @_ <= 3 - or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]"; - my $fh = $class->SUPER::new(); - if (@_) { - $fh->open(@_) - or return undef; - } - $fh; -} - -################################################ -## Open -## - -sub open { - @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; - my ($fh, $file) = @_; - if (@_ > 2) { - my ($mode, $perms) = @_[2, 3]; - if ($mode =~ /^\d+$/) { - defined $perms or $perms = 0666; - return sysopen($fh, $file, $mode, $perms); - } elsif ($mode =~ /:/) { - return open($fh, $mode, $file) if @_ == 3; - croak 'usage: $fh->open(FILENAME, IOLAYERS)'; - } - if (defined($file) && length($file) - && ! File::Spec->file_name_is_absolute($file)) - { - $file = File::Spec->rel2abs($file); - } - $file = IO::Handle::_open_mode_string($mode) . " $file\0"; - } - open($fh, $file); -} - -################################################ -## Binmode -## - -sub binmode { - ( @_ == 1 or @_ == 2 ) or croak 'usage $fh->binmode([LAYER])'; - - my($fh, $layer) = @_; - - return binmode $$fh unless $layer; - return binmode $$fh, $layer; -} - -1; diff --git a/Master/tlpkg/tlperl/lib/IO/Handle.pm b/Master/tlpkg/tlperl/lib/IO/Handle.pm deleted file mode 100644 index 329d26ad198..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Handle.pm +++ /dev/null @@ -1,625 +0,0 @@ -package IO::Handle; - -=head1 NAME - -IO::Handle - supply object methods for I/O handles - -=head1 SYNOPSIS - - use IO::Handle; - - $io = new IO::Handle; - if ($io->fdopen(fileno(STDIN),"r")) { - print $io->getline; - $io->close; - } - - $io = new IO::Handle; - if ($io->fdopen(fileno(STDOUT),"w")) { - $io->print("Some text\n"); - } - - # setvbuf is not available by default on Perls 5.8.0 and later. - use IO::Handle '_IOLBF'; - $io->setvbuf($buffer_var, _IOLBF, 1024); - - undef $io; # automatically closes the file if it's open - - autoflush STDOUT 1; - -=head1 DESCRIPTION - -C<IO::Handle> is the base class for all other IO handle classes. It is -not intended that objects of C<IO::Handle> would be created directly, -but instead C<IO::Handle> is inherited from by several other classes -in the IO hierarchy. - -If you are reading this documentation, looking for a replacement for -the C<FileHandle> package, then I suggest you read the documentation -for C<IO::File> too. - -=head1 CONSTRUCTOR - -=over 4 - -=item new () - -Creates a new C<IO::Handle> object. - -=item new_from_fd ( FD, MODE ) - -Creates an C<IO::Handle> like C<new> does. -It requires two parameters, which are passed to the method C<fdopen>; -if the fdopen fails, the object is destroyed. Otherwise, it is returned -to the caller. - -=back - -=head1 METHODS - -See L<perlfunc> for complete descriptions of each of the following -supported C<IO::Handle> methods, which are just front ends for the -corresponding built-in functions: - - $io->close - $io->eof - $io->fileno - $io->format_write( [FORMAT_NAME] ) - $io->getc - $io->read ( BUF, LEN, [OFFSET] ) - $io->print ( ARGS ) - $io->printf ( FMT, [ARGS] ) - $io->stat - $io->sysread ( BUF, LEN, [OFFSET] ) - $io->syswrite ( BUF, [LEN, [OFFSET]] ) - $io->truncate ( LEN ) - -See L<perlvar> for complete descriptions of each of the following -supported C<IO::Handle> methods. All of them return the previous -value of the attribute and takes an optional single argument that when -given will set the value. If no argument is given the previous value -is unchanged (except for $io->autoflush will actually turn ON -autoflush by default). - - $io->autoflush ( [BOOL] ) $| - $io->format_page_number( [NUM] ) $% - $io->format_lines_per_page( [NUM] ) $= - $io->format_lines_left( [NUM] ) $- - $io->format_name( [STR] ) $~ - $io->format_top_name( [STR] ) $^ - $io->input_line_number( [NUM]) $. - -The following methods are not supported on a per-filehandle basis. - - IO::Handle->format_line_break_characters( [STR] ) $: - IO::Handle->format_formfeed( [STR]) $^L - IO::Handle->output_field_separator( [STR] ) $, - IO::Handle->output_record_separator( [STR] ) $\ - - IO::Handle->input_record_separator( [STR] ) $/ - -Furthermore, for doing normal I/O you might need these: - -=over 4 - -=item $io->fdopen ( FD, MODE ) - -C<fdopen> is like an ordinary C<open> except that its first parameter -is not a filename but rather a file handle name, an IO::Handle object, -or a file descriptor number. - -=item $io->opened - -Returns true if the object is currently a valid file descriptor, false -otherwise. - -=item $io->getline - -This works like <$io> described in L<perlop/"I/O Operators"> -except that it's more readable and can be safely called in a -list context but still returns just one line. If used as the conditional -+within a C<while> or C-style C<for> loop, however, you will need to -+emulate the functionality of <$io> with C<< defined($_ = $io->getline) >>. - -=item $io->getlines - -This works like <$io> when called in a list context to read all -the remaining lines in a file, except that it's more readable. -It will also croak() if accidentally called in a scalar context. - -=item $io->ungetc ( ORD ) - -Pushes a character with the given ordinal value back onto the given -handle's input stream. Only one character of pushback per handle is -guaranteed. - -=item $io->write ( BUF, LEN [, OFFSET ] ) - -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>. - -=item $io->error - -Returns a true value if the given handle has experienced any errors -since it was opened or since the last call to C<clearerr>, or if the -handle is invalid. It only returns false for a valid handle with no -outstanding errors. - -=item $io->clearerr - -Clear the given handle's error indicator. Returns -1 if the handle is -invalid, 0 otherwise. - -=item $io->sync - -C<sync> synchronizes a file's in-memory state with that on the -physical medium. C<sync> does not operate at the perlio api level, but -operates on the file descriptor (similar to sysread, sysseek and -systell). This means that any data held at the perlio api level will not -be synchronized. To synchronize data that is buffered at the perlio api -level you must use the flush method. C<sync> is not implemented on all -platforms. Returns "0 but true" on success, C<undef> on error, C<undef> -for an invalid handle. See L<fsync(3c)>. - -=item $io->flush - -C<flush> causes perl to flush any buffered data at the perlio api level. -Any unread data in the buffer will be discarded, and any unwritten data -will be written to the underlying file descriptor. Returns "0 but true" -on success, C<undef> on error. - -=item $io->printflush ( ARGS ) - -Turns on autoflush, print ARGS and then restores the autoflush status of the -C<IO::Handle> object. Returns the return value from print. - -=item $io->blocking ( [ BOOL ] ) - -If called with an argument C<blocking> will turn on non-blocking IO if -C<BOOL> is false, and turn it off if C<BOOL> is true. - -C<blocking> will return the value of the previous setting, or the -current setting if C<BOOL> is not given. - -If an error occurs C<blocking> will return undef and C<$!> will be set. - -=back - - -If the C functions setbuf() and/or setvbuf() are available, then -C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering -policy for an IO::Handle. The calling sequences for the Perl functions -are the same as their C counterparts--including the constants C<_IOFBF>, -C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter -specifies a scalar variable to use as a buffer. You should only -change the buffer before any I/O, or immediately after calling flush. - -WARNING: The IO::Handle::setvbuf() is not available by default on -Perls 5.8.0 and later because setvbuf() is rather specific to using -the stdio library, while Perl prefers the new perlio subsystem instead. - -WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not -be modified> in any way until the IO::Handle is closed or C<setbuf> or -C<setvbuf> is called again, or memory corruption may result! Remember that -the order of global destruction is undefined, so even if your buffer -variable remains in scope until program termination, it may be undefined -before the file IO::Handle is closed. Note that you need to import the -constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf -returns nothing. setvbuf returns "0 but true", on success, C<undef> on -failure. - -Lastly, there is a special method for working under B<-T> and setuid/gid -scripts: - -=over 4 - -=item $io->untaint - -Marks the object as taint-clean, and as such data read from it will also -be considered taint-clean. Note that this is a very trusting action to -take, and appropriate consideration for the data source and potential -vulnerability should be kept in mind. Returns 0 on success, -1 if setting -the taint-clean flag failed. (eg invalid handle) - -=back - -=head1 NOTE - -An C<IO::Handle> object is a reference to a symbol/GLOB reference (see -the C<Symbol> package). Some modules that -inherit from C<IO::Handle> may want to keep object related variables -in the hash table part of the GLOB. In an attempt to prevent modules -trampling on each other I propose the that any such module should prefix -its variables with its own name separated by _'s. For example the IO::Socket -module keeps a C<timeout> variable in 'io_socket_timeout'. - -=head1 SEE ALSO - -L<perlfunc>, -L<perlop/"I/O Operators">, -L<IO::File> - -=head1 BUGS - -Due to backwards compatibility, all filehandles resemble objects -of class C<IO::Handle>, or actually classes derived from that class. -They actually aren't. Which means you can't derive your own -class from C<IO::Handle> and inherit those methods. - -=head1 HISTORY - -Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> - -=cut - -use 5.006_001; -use strict; -our($VERSION, @EXPORT_OK, @ISA); -use Carp; -use Symbol; -use SelectSaver; -use IO (); # Load the XS module - -require Exporter; -@ISA = qw(Exporter); - -$VERSION = "1.25"; -$VERSION = eval $VERSION; - -@EXPORT_OK = qw( - autoflush - output_field_separator - output_record_separator - input_record_separator - input_line_number - format_page_number - format_lines_per_page - format_lines_left - format_name - format_top_name - format_line_break_characters - format_formfeed - format_write - - print - printf - getline - getlines - - printflush - flush - - SEEK_SET - SEEK_CUR - SEEK_END - _IOFBF - _IOLBF - _IONBF -); - -################################################ -## Constructors, destructors. -## - -sub new { - my $class = ref($_[0]) || $_[0] || "IO::Handle"; - @_ == 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: new_from_fd $class FD, MODE"; - my $io = gensym; - shift; - IO::Handle::fdopen($io, @_) - or return undef; - bless $io, $class; -} - -# -# There is no need for DESTROY to do anything, because when the -# last reference to an IO object is gone, Perl automatically -# closes its associated files (if any). However, to avoid any -# attempts to autoload DESTROY, we here define it to do nothing. -# -sub DESTROY {} - - -################################################ -## Open and close. -## - -sub _open_mode_string { - my ($mode) = @_; - $mode =~ /^\+?(<|>>?)$/ - or $mode =~ s/^r(\+?)$/$1</ - or $mode =~ s/^w(\+?)$/$1>/ - or $mode =~ s/^a(\+?)$/$1>>/ - or croak "IO::Handle: bad open mode: $mode"; - $mode; -} - -sub fdopen { - @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)'; - my ($io, $fd, $mode) = @_; - local(*GLOB); - - if (ref($fd) && "".$fd =~ /GLOB\(/o) { - # It's a glob reference; Alias it as we cannot get name of anon GLOBs - my $n = qualify(*GLOB); - *GLOB = *{*$fd}; - $fd = $n; - } elsif ($fd =~ m#^\d+$#) { - # It's an FD number; prefix with "=". - $fd = "=$fd"; - } - - open($io, _open_mode_string($mode) . '&' . $fd) - ? $io : undef; -} - -sub close { - @_ == 1 or croak 'usage: $io->close()'; - my($io) = @_; - - close($io); -} - -################################################ -## Normal I/O functions. -## - -# flock -# select - -sub opened { - @_ == 1 or croak 'usage: $io->opened()'; - defined fileno($_[0]); -} - -sub fileno { - @_ == 1 or croak 'usage: $io->fileno()'; - fileno($_[0]); -} - -sub getc { - @_ == 1 or croak 'usage: $io->getc()'; - getc($_[0]); -} - -sub eof { - @_ == 1 or croak 'usage: $io->eof()'; - eof($_[0]); -} - -sub print { - @_ or croak 'usage: $io->print(ARGS)'; - my $this = shift; - print $this @_; -} - -sub printf { - @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])'; - my $this = shift; - printf $this @_; -} - -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 - croak 'Can\'t call $io->getlines in a scalar context, use $io->getline'; - my $this = shift; - return <$this>; -} - -sub truncate { - @_ == 2 or croak 'usage: $io->truncate(LEN)'; - truncate($_[0], $_[1]); -} - -sub read { - @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])'; - read($_[0], $_[1], $_[2], $_[3] || 0); -} - -sub sysread { - @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])'; - sysread($_[0], $_[1], $_[2], $_[3] || 0); -} - -sub write { - @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])'; - local($\) = ""; - $_[2] = length($_[1]) unless defined $_[2]; - print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); -} - -sub syswrite { - @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; - if (defined($_[2])) { - syswrite($_[0], $_[1], $_[2], $_[3] || 0); - } else { - syswrite($_[0], $_[1]); - } -} - -sub stat { - @_ == 1 or croak 'usage: $io->stat()'; - stat($_[0]); -} - -################################################ -## State modification functions. -## - -sub autoflush { - my $old = new SelectSaver qualify($_[0], caller); - my $prev = $|; - $| = @_ > 1 ? $_[1] : 1; - $prev; -} - -sub output_field_separator { - carp "output_field_separator is not supported on a per-handle basis" - if ref($_[0]); - my $prev = $,; - $, = $_[1] if @_ > 1; - $prev; -} - -sub output_record_separator { - carp "output_record_separator is not supported on a per-handle basis" - if ref($_[0]); - my $prev = $\; - $\ = $_[1] if @_ > 1; - $prev; -} - -sub input_record_separator { - carp "input_record_separator is not supported on a per-handle basis" - if ref($_[0]); - my $prev = $/; - $/ = $_[1] if @_ > 1; - $prev; -} - -sub input_line_number { - local $.; - () = tell qualify($_[0], caller) if ref($_[0]); - my $prev = $.; - $. = $_[1] if @_ > 1; - $prev; -} - -sub format_page_number { - my $old; - $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); - my $prev = $%; - $% = $_[1] if @_ > 1; - $prev; -} - -sub format_lines_per_page { - my $old; - $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); - my $prev = $=; - $= = $_[1] if @_ > 1; - $prev; -} - -sub format_lines_left { - my $old; - $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); - my $prev = $-; - $- = $_[1] if @_ > 1; - $prev; -} - -sub format_name { - my $old; - $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); - my $prev = $~; - $~ = qualify($_[1], caller) if @_ > 1; - $prev; -} - -sub format_top_name { - my $old; - $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); - my $prev = $^; - $^ = qualify($_[1], caller) if @_ > 1; - $prev; -} - -sub format_line_break_characters { - carp "format_line_break_characters is not supported on a per-handle basis" - if ref($_[0]); - my $prev = $:; - $: = $_[1] if @_ > 1; - $prev; -} - -sub format_formfeed { - carp "format_formfeed is not supported on a per-handle basis" - if ref($_[0]); - my $prev = $^L; - $^L = $_[1] if @_ > 1; - $prev; -} - -sub formline { - my $io = shift; - my $picture = shift; - local($^A) = $^A; - local($\) = ""; - formline($picture, @_); - print $io $^A; -} - -sub format_write { - @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )'; - if (@_ == 2) { - my ($io, $fmt) = @_; - my $oldfmt = $io->format_name($fmt); - CORE::write($io); - $io->format_name($oldfmt); - } else { - CORE::write($_[0]); - } -} - -# XXX undocumented -sub fcntl { - @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );'; - my ($io, $op) = @_; - return fcntl($io, $op, $_[2]); -} - -# XXX undocumented -sub ioctl { - @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );'; - my ($io, $op) = @_; - return ioctl($io, $op, $_[2]); -} - -# 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 chech defined(&CONSTANT_NAME) - -sub constant { - no strict 'refs'; - my $name = shift; - (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name}) - ? &{$name}() : undef; -} - - -# so that flush.pl can be deprecated - -sub printflush { - my $io = shift; - my $old; - $old = new SelectSaver qualify($io, caller) if ref($io); - local $| = 1; - if(ref($io)) { - print $io @_; - } - else { - print @_; - } -} - -1; diff --git a/Master/tlpkg/tlperl/lib/IO/Pipe.pm b/Master/tlpkg/tlperl/lib/IO/Pipe.pm deleted file mode 100644 index 827cc48bfcd..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Pipe.pm +++ /dev/null @@ -1,257 +0,0 @@ -# IO::Pipe.pm -# -# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Pipe; - -use 5.006_001; - -use IO::Handle; -use strict; -our($VERSION); -use Carp; -use Symbol; - -$VERSION = "1.13"; - -sub new { - my $type = shift; - my $class = ref($type) || $type || "IO::Pipe"; - @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; - - my $me = bless gensym(), $class; - - my($readfh,$writefh) = @_ ? @_ : $me->handles; - - pipe($readfh, $writefh) - or return undef; - - @{*$me} = ($readfh, $writefh); - - $me; -} - -sub handles { - @_ == 1 or croak 'usage: $pipe->handles()'; - (IO::Pipe::End->new(), IO::Pipe::End->new()); -} - -my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32'; - -sub _doit { - my $me = shift; - my $rw = shift; - - my $pid = $do_spawn ? 0 : fork(); - - if($pid) { # Parent - return $pid; - } - elsif(defined $pid) { # Child or spawn - my $fh; - my $io = $rw ? \*STDIN : \*STDOUT; - my ($mode, $save) = $rw ? "r" : "w"; - if ($do_spawn) { - require Fcntl; - $save = IO::Handle->new_from_fd($io, $mode); - my $handle = shift; - # Close in child: - unless ($^O eq 'MSWin32') { - fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!"; - } - $fh = $rw ? ${*$me}[0] : ${*$me}[1]; - } else { - shift; - $fh = $rw ? $me->reader() : $me->writer(); # close the other end - } - bless $io, "IO::Handle"; - $io->fdopen($fh, $mode); - $fh->close; - - if ($do_spawn) { - $pid = eval { system 1, @_ }; # 1 == P_NOWAIT - my $err = $!; - - $io->fdopen($save, $mode); - $save->close or croak "Cannot close $!"; - croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0; - return $pid; - } else { - exec @_ or - croak "IO::Pipe: Cannot exec: $!"; - } - } - else { - croak "IO::Pipe: Cannot fork: $!"; - } - - # NOT Reached -} - -sub reader { - @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )'; - my $me = shift; - - return undef - unless(ref($me) || ref($me = $me->new)); - - my $fh = ${*$me}[0]; - my $pid; - $pid = $me->_doit(0, $fh, @_) - if(@_); - - close ${*$me}[1]; - bless $me, ref($fh); - *$me = *$fh; # Alias self to handle - $me->fdopen($fh->fileno,"r") - unless defined($me->fileno); - bless $fh; # Really wan't un-bless here - ${*$me}{'io_pipe_pid'} = $pid - if defined $pid; - - $me; -} - -sub writer { - @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )'; - my $me = shift; - - return undef - unless(ref($me) || ref($me = $me->new)); - - my $fh = ${*$me}[1]; - my $pid; - $pid = $me->_doit(1, $fh, @_) - if(@_); - - close ${*$me}[0]; - bless $me, ref($fh); - *$me = *$fh; # Alias self to handle - $me->fdopen($fh->fileno,"w") - unless defined($me->fileno); - bless $fh; # Really wan't un-bless here - ${*$me}{'io_pipe_pid'} = $pid - if defined $pid; - - $me; -} - -package IO::Pipe::End; - -our(@ISA); - -@ISA = qw(IO::Handle); - -sub close { - my $fh = shift; - my $r = $fh->SUPER::close(@_); - - waitpid(${*$fh}{'io_pipe_pid'},0) - if(defined ${*$fh}{'io_pipe_pid'}); - - $r; -} - -1; - -__END__ - -=head1 NAME - -IO::Pipe - supply object methods for pipes - -=head1 SYNOPSIS - - use IO::Pipe; - - $pipe = new IO::Pipe; - - if($pid = fork()) { # Parent - $pipe->reader(); - - while(<$pipe>) { - ... - } - - } - elsif(defined $pid) { # Child - $pipe->writer(); - - print $pipe ... - } - - or - - $pipe = new IO::Pipe; - - $pipe->reader(qw(ls -l)); - - while(<$pipe>) { - ... - } - -=head1 DESCRIPTION - -C<IO::Pipe> provides an interface to creating pipes between -processes. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [READER, WRITER] ) - -Creates an C<IO::Pipe>, which is a reference to a newly created symbol -(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two -arguments, which should be objects blessed into C<IO::Handle>, or a -subclass thereof. These two objects will be used for the system call -to C<pipe>. If no arguments are given then method C<handles> is called -on the new C<IO::Pipe> object. - -These two handles are held in the array part of the GLOB until either -C<reader> or C<writer> is called. - -=back - -=head1 METHODS - -=over 4 - -=item reader ([ARGS]) - -The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a -handle at the reading end of the pipe. If C<ARGS> are given then C<fork> -is called and C<ARGS> are passed to exec. - -=item writer ([ARGS]) - -The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a -handle at the writing end of the pipe. If C<ARGS> are given then C<fork> -is called and C<ARGS> are passed to exec. - -=item handles () - -This method is called during construction by C<IO::Pipe::new> -on the newly created C<IO::Pipe> object. It returns an array of two objects -blessed into C<IO::Pipe::End>, or a subclass thereof. - -=back - -=head1 SEE ALSO - -L<IO::Handle> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/IO/Poll.pm b/Master/tlpkg/tlperl/lib/IO/Poll.pm deleted file mode 100644 index e7fb0135069..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Poll.pm +++ /dev/null @@ -1,209 +0,0 @@ - -# IO::Poll.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Poll; - -use strict; -use IO::Handle; -use Exporter (); -our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); - -@ISA = qw(Exporter); -$VERSION = "0.07"; - -@EXPORT = qw( POLLIN - POLLOUT - POLLERR - POLLHUP - POLLNVAL - ); - -@EXPORT_OK = qw( - POLLPRI - POLLRDNORM - POLLWRNORM - POLLRDBAND - POLLWRBAND - POLLNORM - ); - -# [0] maps fd's to requested masks -# [1] maps fd's to returned masks -# [2] maps fd's to handles -sub new { - my $class = shift; - - my $self = bless [{},{},{}], $class; - - $self; -} - -sub mask { - my $self = shift; - my $io = shift; - my $fd = fileno($io); - return unless defined $fd; - if (@_) { - my $mask = shift; - if($mask) { - $self->[0]{$fd}{$io} = $mask; # the error events are always returned - $self->[1]{$fd} = 0; # output mask - $self->[2]{$io} = $io; # remember handle - } else { - delete $self->[0]{$fd}{$io}; - unless(%{$self->[0]{$fd}}) { - # We no longer have any handles for this FD - delete $self->[1]{$fd}; - delete $self->[0]{$fd}; - } - delete $self->[2]{$io}; - } - } - - return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io}; - return $self->[0]{$fd}{$io}; -} - - -sub poll { - my($self,$timeout) = @_; - - $self->[1] = {}; - - my($fd,$mask,$iom); - my @poll = (); - - while(($fd,$iom) = each %{$self->[0]}) { - $mask = 0; - $mask |= $_ for values(%$iom); - push(@poll,$fd => $mask); - } - - my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; - - return $ret - unless $ret > 0; - - while(@poll) { - my($fd,$got) = splice(@poll,0,2); - $self->[1]{$fd} = $got if $got; - } - - return $ret; -} - -sub events { - my $self = shift; - my $io = shift; - my $fd = fileno($io); - exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io} - ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL) - : 0; -} - -sub remove { - my $self = shift; - my $io = shift; - $self->mask($io,0); -} - -sub handles { - my $self = shift; - return values %{$self->[2]} unless @_; - - my $events = shift || 0; - my($fd,$ev,$io,$mask); - my @handles = (); - - while(($fd,$ev) = each %{$self->[1]}) { - while (($io,$mask) = each %{$self->[0]{$fd}}) { - $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these - push @handles,$self->[2]{$io} if ($ev & $mask) & $events; - } - } - return @handles; -} - -1; - -__END__ - -=head1 NAME - -IO::Poll - Object interface to system poll call - -=head1 SYNOPSIS - - use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP); - - $poll = new IO::Poll; - - $poll->mask($input_handle => POLLIN); - $poll->mask($output_handle => POLLOUT); - - $poll->poll($timeout); - - $ev = $poll->events($input); - -=head1 DESCRIPTION - -C<IO::Poll> is a simple interface to the system level poll routine. - -=head1 METHODS - -=over 4 - -=item mask ( IO [, EVENT_MASK ] ) - -If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the -list of file descriptors and the next call to poll will check for -any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be -removed from the list of file descriptors. - -If EVENT_MASK is not given then the return value will be the current -event mask value for IO. - -=item poll ( [ TIMEOUT ] ) - -Call the system level poll routine. If TIMEOUT is not specified then the -call will block. Returns the number of handles which had events -happen, or -1 on error. - -=item events ( IO ) - -Returns the event mask which represents the events that happened on IO -during the last call to C<poll>. - -=item remove ( IO ) - -Remove IO from the list of file descriptors for the next poll. - -=item handles( [ EVENT_MASK ] ) - -Returns a list of handles. If EVENT_MASK is not given then a list of all -handles known will be returned. If EVENT_MASK is given then a list -of handles will be returned which had one of the events specified by -EVENT_MASK happen during the last call ti C<poll> - -=back - -=head1 SEE ALSO - -L<poll(2)>, L<IO::Handle>, L<IO::Select> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/IO/Seekable.pm b/Master/tlpkg/tlperl/lib/IO/Seekable.pm deleted file mode 100644 index db1effda287..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Seekable.pm +++ /dev/null @@ -1,128 +0,0 @@ -# - -package IO::Seekable; - -=head1 NAME - -IO::Seekable - supply seek based methods for I/O objects - -=head1 SYNOPSIS - - use IO::Seekable; - package IO::Something; - @ISA = qw(IO::Seekable); - -=head1 DESCRIPTION - -C<IO::Seekable> does not have a constructor of its own as it is intended to -be inherited by other C<IO::Handle> based objects. It provides methods -which allow seeking of the file descriptors. - -=over 4 - -=item $io->getpos - -Returns an opaque value that represents the current position of the -IO::File, or C<undef> if this is not possible (eg an unseekable stream such -as a terminal, pipe or socket). If the fgetpos() function is available in -your C library it is used to implements getpos, else perl emulates getpos -using C's ftell() function. - -=item $io->setpos - -Uses the value of a previous getpos call to return to a previously visited -position. Returns "0 but true" on success, C<undef> on failure. - -=back - -See L<perlfunc> for complete descriptions of each of the following -supported C<IO::Seekable> methods, which are just front ends for the -corresponding built-in functions: - -=over 4 - -=item $io->seek ( POS, WHENCE ) - -Seek the IO::File to position POS, relative to WHENCE: - -=over 8 - -=item WHENCE=0 (SEEK_SET) - -POS is absolute position. (Seek relative to the start of the file) - -=item WHENCE=1 (SEEK_CUR) - -POS is an offset from the current position. (Seek relative to current) - -=item WHENCE=2 (SEEK_END) - -POS is an offset from the end of the file. (Seek relative to end) - -=back - -The SEEK_* constants can be imported from the C<Fcntl> module if you -don't wish to use the numbers C<0> C<1> or C<2> in your code. - -Returns C<1> upon success, C<0> otherwise. - -=item $io->sysseek( POS, WHENCE ) - -Similar to $io->seek, but sets the IO::File's position using the system -call lseek(2) directly, so will confuse most perl IO operators except -sysread and syswrite (see L<perlfunc> for full details) - -Returns the new position, or C<undef> on failure. A position -of zero is returned as the string C<"0 but true"> - -=item $io->tell - -Returns the IO::File's current position, or -1 on error. - -=back - -=head1 SEE ALSO - -L<perlfunc>, -L<perlop/"I/O Operators">, -L<IO::Handle> -L<IO::File> - -=head1 HISTORY - -Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt> - -=cut - -use 5.006_001; -use Carp; -use strict; -our($VERSION, @EXPORT, @ISA); -use IO::Handle (); -# XXX we can't get these from IO::Handle or we'll get prototype -# mismatch warnings on C<use POSIX; use IO::File;> :-( -use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); -require Exporter; - -@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); -@ISA = qw(Exporter); - -$VERSION = "1.10"; -$VERSION = eval $VERSION; - -sub seek { - @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)'; - seek($_[0], $_[1], $_[2]); -} - -sub sysseek { - @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)'; - sysseek($_[0], $_[1], $_[2]); -} - -sub tell { - @_ == 1 or croak 'usage: $io->tell()'; - tell($_[0]); -} - -1; diff --git a/Master/tlpkg/tlperl/lib/IO/Select.pm b/Master/tlpkg/tlperl/lib/IO/Select.pm deleted file mode 100644 index fc05fe70e9c..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Select.pm +++ /dev/null @@ -1,381 +0,0 @@ -# IO::Select.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Select; - -use strict; -use warnings::register; -use vars qw($VERSION @ISA); -require Exporter; - -$VERSION = "1.17"; - -@ISA = qw(Exporter); # This is only so we can do version checking - -sub VEC_BITS () {0} -sub FD_COUNT () {1} -sub FIRST_FD () {2} - -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - - my $vec = bless [undef,0], $type; - - $vec->add(@_) - if @_; - - $vec; -} - -sub add -{ - shift->_update('add', @_); -} - - -sub remove -{ - shift->_update('remove', @_); -} - - -sub exists -{ - my $vec = shift; - my $fno = $vec->_fileno(shift); - return undef unless defined $fno; - $vec->[$fno + FIRST_FD]; -} - - -sub _fileno -{ - my($self, $f) = @_; - return unless defined $f; - $f = $f->[0] if ref($f) eq 'ARRAY'; - ($f =~ /^\d+$/) ? $f : fileno($f); -} - -sub _update -{ - my $vec = shift; - my $add = shift eq 'add'; - - my $bits = $vec->[VEC_BITS]; - $bits = '' unless defined $bits; - - my $count = 0; - my $f; - foreach $f (@_) - { - my $fn = $vec->_fileno($f); - next unless defined $fn; - my $i = $fn + FIRST_FD; - if ($add) { - if (defined $vec->[$i]) { - $vec->[$i] = $f; # if array rest might be different, so we update - next; - } - $vec->[FD_COUNT]++; - vec($bits, $fn, 1) = 1; - $vec->[$i] = $f; - } else { # remove - next unless defined $vec->[$i]; - $vec->[FD_COUNT]--; - vec($bits, $fn, 1) = 0; - $vec->[$i] = undef; - } - $count++; - } - $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef; - $count; -} - -sub can_read -{ - my $vec = shift; - my $timeout = shift; - my $r = $vec->[VEC_BITS]; - - defined($r) && (select($r,undef,undef,$timeout) > 0) - ? handles($vec, $r) - : (); -} - -sub can_write -{ - my $vec = shift; - my $timeout = shift; - my $w = $vec->[VEC_BITS]; - - defined($w) && (select(undef,$w,undef,$timeout) > 0) - ? handles($vec, $w) - : (); -} - -sub has_exception -{ - my $vec = shift; - my $timeout = shift; - my $e = $vec->[VEC_BITS]; - - defined($e) && (select(undef,undef,$e,$timeout) > 0) - ? handles($vec, $e) - : (); -} - -sub has_error -{ - warnings::warn("Call to deprecated method 'has_error', use 'has_exception'") - if warnings::enabled(); - goto &has_exception; -} - -sub count -{ - my $vec = shift; - $vec->[FD_COUNT]; -} - -sub bits -{ - my $vec = shift; - $vec->[VEC_BITS]; -} - -sub as_string # for debugging -{ - my $vec = shift; - my $str = ref($vec) . ": "; - my $bits = $vec->bits; - my $count = $vec->count; - $str .= defined($bits) ? unpack("b*", $bits) : "undef"; - $str .= " $count"; - my @handles = @$vec; - splice(@handles, 0, FIRST_FD); - for (@handles) { - $str .= " " . (defined($_) ? "$_" : "-"); - } - $str; -} - -sub _max -{ - my($a,$b,$c) = @_; - $a > $b - ? $a > $c - ? $a - : $c - : $b > $c - ? $b - : $c; -} - -sub select -{ - shift - if defined $_[0] && !ref($_[0]); - - my($r,$w,$e,$t) = @_; - my @result = (); - - my $rb = defined $r ? $r->[VEC_BITS] : undef; - my $wb = defined $w ? $w->[VEC_BITS] : undef; - my $eb = defined $e ? $e->[VEC_BITS] : undef; - - if(select($rb,$wb,$eb,$t) > 0) - { - my @r = (); - my @w = (); - my @e = (); - my $i = _max(defined $r ? scalar(@$r)-1 : 0, - defined $w ? scalar(@$w)-1 : 0, - defined $e ? scalar(@$e)-1 : 0); - - for( ; $i >= FIRST_FD ; $i--) - { - my $j = $i - FIRST_FD; - push(@r, $r->[$i]) - if defined $rb && defined $r->[$i] && vec($rb, $j, 1); - push(@w, $w->[$i]) - if defined $wb && defined $w->[$i] && vec($wb, $j, 1); - push(@e, $e->[$i]) - if defined $eb && defined $e->[$i] && vec($eb, $j, 1); - } - - @result = (\@r, \@w, \@e); - } - @result; -} - - -sub handles -{ - my $vec = shift; - my $bits = shift; - my @h = (); - my $i; - my $max = scalar(@$vec) - 1; - - for ($i = FIRST_FD; $i <= $max; $i++) - { - next unless defined $vec->[$i]; - push(@h, $vec->[$i]) - if !defined($bits) || vec($bits, $i - FIRST_FD, 1); - } - - @h; -} - -1; -__END__ - -=head1 NAME - -IO::Select - OO interface to the select system call - -=head1 SYNOPSIS - - use IO::Select; - - $s = IO::Select->new(); - - $s->add(\*STDIN); - $s->add($some_handle); - - @ready = $s->can_read($timeout); - - @ready = IO::Select->new(@handles)->can_read(0); - -=head1 DESCRIPTION - -The C<IO::Select> package implements an object approach to the system C<select> -function call. It allows the user to see what IO handles, see L<IO::Handle>, -are ready for reading, writing or have an exception pending. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ HANDLES ] ) - -The constructor creates a new object and optionally initialises it with a set -of handles. - -=back - -=head1 METHODS - -=over 4 - -=item add ( HANDLES ) - -Add the list of handles to the C<IO::Select> object. It is these values that -will be returned when an event occurs. C<IO::Select> keeps these values in a -cache which is indexed by the C<fileno> of the handle, so if more than one -handle with the same C<fileno> is specified then only the last one is cached. - -Each handle can be an C<IO::Handle> object, an integer or an array -reference where the first element is an C<IO::Handle> or an integer. - -=item remove ( HANDLES ) - -Remove all the given handles from the object. This method also works -by the C<fileno> of the handles. So the exact handles that were added -need not be passed, just handles that have an equivalent C<fileno> - -=item exists ( HANDLE ) - -Returns a true value (actually the handle itself) if it is present. -Returns undef otherwise. - -=item handles - -Return an array of all registered handles. - -=item can_read ( [ TIMEOUT ] ) - -Return an array of handles that are ready for reading. C<TIMEOUT> is -the maximum amount of time to wait before returning an empty list, in -seconds, possibly fractional. If C<TIMEOUT> is not given and any -handles are registered then the call will block. - -=item can_write ( [ TIMEOUT ] ) - -Same as C<can_read> except check for handles that can be written to. - -=item has_exception ( [ TIMEOUT ] ) - -Same as C<can_read> except check for handles that have an exception -condition, for example pending out-of-band data. - -=item count () - -Returns the number of handles that the object will check for when -one of the C<can_> methods is called or the object is passed to -the C<select> static method. - -=item bits() - -Return the bit string suitable as argument to the core select() call. - -=item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] ) - -C<select> is a static method, that is you call it with the package name -like C<new>. C<READ>, C<WRITE> and C<EXCEPTION> are either C<undef> or -C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as -for the core select call. - -The result will be an array of 3 elements, each a reference to an array -which will hold the handles that are ready for reading, writing and have -exceptions respectively. Upon error an empty list is returned. - -=back - -=head1 EXAMPLE - -Here is a short example which shows how C<IO::Select> could be used -to write a server which communicates with several sockets while also -listening for more connections on a listen socket - - use IO::Select; - use IO::Socket; - - $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080); - $sel = new IO::Select( $lsn ); - - while(@ready = $sel->can_read) { - foreach $fh (@ready) { - if($fh == $lsn) { - # Create a new socket - $new = $lsn->accept; - $sel->add($new); - } - else { - # Process socket - - # Maybe we have finished with the socket - $sel->remove($fh); - $fh->close; - } - } - } - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut - diff --git a/Master/tlpkg/tlperl/lib/IO/Socket.pm b/Master/tlpkg/tlperl/lib/IO/Socket.pm deleted file mode 100644 index 4429f2bb3e6..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Socket.pm +++ /dev/null @@ -1,476 +0,0 @@ -# IO::Socket.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Socket; - -require 5.006; - -use IO::Handle; -use Socket 1.3; -use Carp; -use strict; -our(@ISA, $VERSION, @EXPORT_OK); -use Exporter; -use Errno; - -# legacy - -require IO::Socket::INET; -require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian'); - -@ISA = qw(IO::Handle); - -$VERSION = "1.29"; - -@EXPORT_OK = qw(sockatmark); - -sub import { - my $pkg = shift; - if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast - Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark'); - } else { - my $callpkg = caller; - Exporter::export 'Socket', $callpkg, @_; - } -} - -sub new { - my($class,%arg) = @_; - my $sock = $class->SUPER::new(); - - $sock->autoflush(1); - - ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; - - return scalar(%arg) ? $sock->configure(\%arg) - : $sock; -} - -my @domain2pkg; - -sub register_domain { - my($p,$d) = @_; - $domain2pkg[$d] = $p; -} - -sub configure { - my($sock,$arg) = @_; - my $domain = delete $arg->{Domain}; - - croak 'IO::Socket: Cannot configure a generic socket' - unless defined $domain; - - croak "IO::Socket: Unsupported socket domain" - unless defined $domain2pkg[$domain]; - - croak "IO::Socket: Cannot configure socket in domain '$domain'" - unless ref($sock) eq "IO::Socket"; - - bless($sock, $domain2pkg[$domain]); - $sock->configure($arg); -} - -sub socket { - @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)'; - my($sock,$domain,$type,$protocol) = @_; - - socket($sock,$domain,$type,$protocol) or - return undef; - - ${*$sock}{'io_socket_domain'} = $domain; - ${*$sock}{'io_socket_type'} = $type; - ${*$sock}{'io_socket_proto'} = $protocol; - - $sock; -} - -sub socketpair { - @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)'; - my($class,$domain,$type,$protocol) = @_; - my $sock1 = $class->new(); - my $sock2 = $class->new(); - - socketpair($sock1,$sock2,$domain,$type,$protocol) or - return (); - - ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type; - ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol; - - ($sock1,$sock2); -} - -sub connect { - @_ == 2 or croak 'usage: $sock->connect(NAME)'; - my $sock = shift; - my $addr = shift; - my $timeout = ${*$sock}{'io_socket_timeout'}; - my $err; - my $blocking; - - $blocking = $sock->blocking(0) if $timeout; - if (!connect($sock, $addr)) { - if (defined $timeout && $!{EINPROGRESS}) { - require IO::Select; - - my $sel = new IO::Select $sock; - - if (!$sel->can_write($timeout)) { - $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); - $@ = "connect: timeout"; - } - elsif (!connect($sock,$addr) && not $!{EISCONN}) { - # Some systems refuse to re-connect() to - # an already open socket and set errno to EISCONN. - $err = $!; - $@ = "connect: $!"; - } - } - elsif ($blocking || !$!{EINPROGRESS}) { - $err = $!; - $@ = "connect: $!"; - } - } - - $sock->blocking(1) if $blocking; - - $! = $err if $err; - - $err ? undef : $sock; -} - -sub bind { - @_ == 2 or croak 'usage: $sock->bind(NAME)'; - my $sock = shift; - my $addr = shift; - - return bind($sock, $addr) ? $sock - : undef; -} - -sub listen { - @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])'; - my($sock,$queue) = @_; - $queue = 5 - unless $queue && $queue > 0; - - return listen($sock, $queue) ? $sock - : undef; -} - -sub accept { - @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])'; - my $sock = shift; - my $pkg = shift || $sock; - my $timeout = ${*$sock}{'io_socket_timeout'}; - my $new = $pkg->new(Timeout => $timeout); - my $peer = undef; - - if(defined $timeout) { - require IO::Select; - - my $sel = new IO::Select $sock; - - unless ($sel->can_read($timeout)) { - $@ = 'accept: timeout'; - $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); - return; - } - } - - $peer = accept($new,$sock) - or return; - - return wantarray ? ($new, $peer) - : $new; -} - -sub sockname { - @_ == 1 or croak 'usage: $sock->sockname()'; - getsockname($_[0]); -} - -sub peername { - @_ == 1 or croak 'usage: $sock->peername()'; - my($sock) = @_; - getpeername($sock) - || ${*$sock}{'io_socket_peername'} - || undef; -} - -sub connected { - @_ == 1 or croak 'usage: $sock->connected()'; - my($sock) = @_; - getpeername($sock); -} - -sub send { - @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])'; - my $sock = $_[0]; - my $flags = $_[2] || 0; - my $peer = $_[3] || $sock->peername; - - croak 'send: Cannot determine peer address' - unless($peer); - - my $r = defined(getpeername($sock)) - ? send($sock, $_[1], $flags) - : send($sock, $_[1], $flags, $peer); - - # remember who we send to, if it was successful - ${*$sock}{'io_socket_peername'} = $peer - if(@_ == 4 && defined $r); - - $r; -} - -sub recv { - @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])'; - my $sock = $_[0]; - my $len = $_[2]; - my $flags = $_[3] || 0; - - # remember who we recv'd from - ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); -} - -sub shutdown { - @_ == 2 or croak 'usage: $sock->shutdown(HOW)'; - my($sock, $how) = @_; - shutdown($sock, $how); -} - -sub setsockopt { - @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)'; - setsockopt($_[0],$_[1],$_[2],$_[3]); -} - -my $intsize = length(pack("i",0)); - -sub getsockopt { - @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)'; - my $r = getsockopt($_[0],$_[1],$_[2]); - # Just a guess - $r = unpack("i", $r) - if(defined $r && length($r) == $intsize); - $r; -} - -sub sockopt { - my $sock = shift; - @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_) - : $sock->setsockopt(SOL_SOCKET,@_); -} - -sub atmark { - @_ == 1 or croak 'usage: $sock->atmark()'; - my($sock) = @_; - sockatmark($sock); -} - -sub timeout { - @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])'; - my($sock,$val) = @_; - my $r = ${*$sock}{'io_socket_timeout'}; - - ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val - if(@_ == 2); - - $r; -} - -sub sockdomain { - @_ == 1 or croak 'usage: $sock->sockdomain()'; - my $sock = shift; - ${*$sock}{'io_socket_domain'}; -} - -sub socktype { - @_ == 1 or croak 'usage: $sock->socktype()'; - my $sock = shift; - ${*$sock}{'io_socket_type'} -} - -sub protocol { - @_ == 1 or croak 'usage: $sock->protocol()'; - my($sock) = @_; - ${*$sock}{'io_socket_proto'}; -} - -1; - -__END__ - -=head1 NAME - -IO::Socket - Object interface to socket communications - -=head1 SYNOPSIS - - use IO::Socket; - -=head1 DESCRIPTION - -C<IO::Socket> provides an object interface to creating and using sockets. It -is built upon the L<IO::Handle> interface and inherits all the methods defined -by L<IO::Handle>. - -C<IO::Socket> only defines methods for those operations which are common to all -types of socket. Operations which are specified to a socket in a particular -domain have methods defined in sub classes of C<IO::Socket> - -C<IO::Socket> will export all functions (and constants) defined by L<Socket>. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ARGS] ) - -Creates an C<IO::Socket>, which is a reference to a -newly created symbol (see the C<Symbol> package). C<new> -optionally takes arguments, these arguments are in key-value pairs. -C<new> only looks for one key C<Domain> which tells new which domain -the socket will be in. All other arguments will be passed to the -configuration method of the package for that domain, See below. - - 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 - -=head1 METHODS - -See L<perlfunc> for complete descriptions of each of the following -supported C<IO::Socket> methods, which are just front ends for the -corresponding built-in functions: - - socket - socketpair - bind - listen - accept - send - recv - peername (getpeername) - sockname (getsockname) - shutdown - -Some methods take slightly different arguments to those defined in L<perlfunc> -in attempt to make the interface more flexible. These are - -=over 4 - -=item accept([PKG]) - -perform the system call C<accept> on the socket and return a new -object. The new object will be created in the same class as the listen -socket, unless C<PKG> is specified. This object can be used to -communicate with the client that was trying to connect. - -In a scalar context the new socket is returned, or undef upon -failure. In a list context a two-element array is returned containing -the new socket and the peer address; the list will be empty upon -failure. - -The timeout in the [PKG] can be specified as zero to effect a "poll", -but you shouldn't do that because a new IO::Select object will be -created behind the scenes just to do the single poll. This is -horrendously inefficient. Use rather true select() with a zero -timeout on the handle, or non-blocking IO. - -=item socketpair(DOMAIN, TYPE, PROTOCOL) - -Call C<socketpair> and return a list of two sockets created, or an -empty list on failure. - -=back - -Additional methods that are provided are: - -=over 4 - -=item atmark - -True if the socket is currently positioned at the urgent data mark, -false otherwise. - - use IO::Socket; - - my $sock = IO::Socket::INET->new('some_server'); - $sock->read($data, 1024) until $sock->atmark; - -Note: this is a reasonably new addition to the family of socket -functions, so all systems may not support this yet. If it is -unsupported by the system, an attempt to use this method will -abort the program. - -The atmark() functionality is also exportable as sockatmark() function: - - use IO::Socket 'sockatmark'; - -This allows for a more traditional use of sockatmark() as a procedural -socket function. If your system does not support sockatmark(), the -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 then undef will be returned. - -=item protocol - -Returns the numerical number for the protocol being used on the socket, if -known. If the protocol is unknown, as with an AF_UNIX socket, zero -is returned. - -=item sockdomain - -Returns the numerical number for the socket domain type. For example, for -an AF_INET socket the value of &AF_INET will be returned. - -=item sockopt(OPT [, VAL]) - -Unified method to both set and get options in the SOL_SOCKET level. If called -with one argument then getsockopt is called, otherwise setsockopt is called. - -=item socktype - -Returns the numerical number for the socket type. For example, for -a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. - -=item timeout([VAL]) - -Set or get the timeout value associated with this socket. If called without -any arguments then the current setting is returned. If called with an argument -the current setting is changed and the previous value returned. - -=back - -=head1 SEE ALSO - -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 <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>. -This module is distributed under the same terms as Perl itself. -Feel free to use, modify and redistribute it as long as you retain -the correct attribution. - -=cut diff --git a/Master/tlpkg/tlperl/lib/IO/Socket/INET.pm b/Master/tlpkg/tlperl/lib/IO/Socket/INET.pm deleted file mode 100644 index 96b49911d81..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Socket/INET.pm +++ /dev/null @@ -1,431 +0,0 @@ -# IO::Socket::INET.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Socket::INET; - -use strict; -our(@ISA, $VERSION); -use IO::Socket; -use Socket; -use Carp; -use Exporter; -use Errno; - -@ISA = qw(IO::Socket); -$VERSION = "1.29"; - -my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1; - -IO::Socket::INET->register_domain( AF_INET ); - -my %socket_type = ( tcp => SOCK_STREAM, - udp => SOCK_DGRAM, - icmp => SOCK_RAW - ); - -sub new { - my $class = shift; - unshift(@_, "PeerAddr") if @_ == 1; - return $class->SUPER::new(@_); -} - -sub _sock_info { - my($addr,$port,$proto) = @_; - my $origport = $port; - my @proto = (); - my @serv = (); - - $port = $1 - if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,); - - if(defined $proto && $proto =~ /\D/) { - if(@proto = getprotobyname($proto)) { - $proto = $proto[2] || undef; - } - else { - $@ = "Bad protocol '$proto'"; - return; - } - } - - if(defined $port) { - my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef; - my $pnum = ($port =~ m,^(\d+)$,)[0]; - - @serv = getservbyname($port, $proto[0] || "") - if ($port =~ m,\D,); - - $port = $serv[2] || $defport || $pnum; - unless (defined $port) { - $@ = "Bad service '$origport'"; - return; - } - - $proto = (getprotobyname($serv[3]))[2] || undef - if @serv && !$proto; - } - - return ($addr || undef, - $port || undef, - $proto || undef - ); -} - -sub _error { - my $sock = shift; - my $err = shift; - { - local($!); - my $title = ref($sock).": "; - $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_); - close($sock) - if(defined fileno($sock)); - } - $! = $err; - return undef; -} - -sub _get_addr { - my($sock,$addr_str, $multi) = @_; - my @addr; - if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) { - (undef, undef, undef, undef, @addr) = gethostbyname($addr_str); - } else { - my $h = inet_aton($addr_str); - push(@addr, $h) if defined $h; - } - @addr; -} - -sub configure { - my($sock,$arg) = @_; - my($lport,$rport,$laddr,$raddr,$proto,$type); - - - $arg->{LocalAddr} = $arg->{LocalHost} - if exists $arg->{LocalHost} && !exists $arg->{LocalAddr}; - - ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, - $arg->{LocalPort}, - $arg->{Proto}) - or return _error($sock, $!, $@); - - $laddr = defined $laddr ? inet_aton($laddr) - : INADDR_ANY; - - return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'") - unless(defined $laddr); - - $arg->{PeerAddr} = $arg->{PeerHost} - if exists $arg->{PeerHost} && !exists $arg->{PeerAddr}; - - unless(exists $arg->{Listen}) { - ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, - $arg->{PeerPort}, - $proto) - or return _error($sock, $!, $@); - } - - $proto ||= (getprotobyname('tcp'))[2]; - - my $pname = (getprotobynumber($proto))[0]; - $type = $arg->{Type} || $socket_type{lc $pname}; - - my @raddr = (); - - if(defined $raddr) { - @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed}); - return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") - unless @raddr; - } - - while(1) { - - $sock->socket(AF_INET, $type, $proto) or - return _error($sock, $!, "$!"); - - if (defined $arg->{Blocking}) { - defined $sock->blocking($arg->{Blocking}) - or return _error($sock, $!, "$!"); - } - - if ($arg->{Reuse} || $arg->{ReuseAddr}) { - $sock->sockopt(SO_REUSEADDR,1) or - return _error($sock, $!, "$!"); - } - - if ($arg->{ReusePort}) { - $sock->sockopt(SO_REUSEPORT,1) or - return _error($sock, $!, "$!"); - } - - if ($arg->{Broadcast}) { - $sock->sockopt(SO_BROADCAST,1) or - return _error($sock, $!, "$!"); - } - - if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) { - $sock->bind($lport || 0, $laddr) or - return _error($sock, $!, "$!"); - } - - if(exists $arg->{Listen}) { - $sock->listen($arg->{Listen} || 5) or - return _error($sock, $!, "$!"); - last; - } - - # don't try to connect unless we're given a PeerAddr - last unless exists($arg->{PeerAddr}); - - $raddr = shift @raddr; - - return _error($sock, $EINVAL, 'Cannot determine remote port') - unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); - - last - unless($type == SOCK_STREAM || defined $raddr); - - return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") - unless defined $raddr; - -# my $timeout = ${*$sock}{'io_socket_timeout'}; -# my $before = time() if $timeout; - - undef $@; - if ($sock->connect(pack_sockaddr_in($rport, $raddr))) { -# ${*$sock}{'io_socket_timeout'} = $timeout; - return $sock; - } - - return _error($sock, $!, $@ || "Timeout") - unless @raddr; - -# if ($timeout) { -# my $new_timeout = $timeout - (time() - $before); -# return _error($sock, -# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL), -# "Timeout") if $new_timeout <= 0; -# ${*$sock}{'io_socket_timeout'} = $new_timeout; -# } - - } - - $sock; -} - -sub connect { - @_ == 2 || @_ == 3 or - croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)'; - my $sock = shift; - return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_)); -} - -sub bind { - @_ == 2 || @_ == 3 or - croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)'; - my $sock = shift; - return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_)) -} - -sub sockaddr { - @_ == 1 or croak 'usage: $sock->sockaddr()'; - my($sock) = @_; - my $name = $sock->sockname; - $name ? (sockaddr_in($name))[1] : undef; -} - -sub sockport { - @_ == 1 or croak 'usage: $sock->sockport()'; - my($sock) = @_; - my $name = $sock->sockname; - $name ? (sockaddr_in($name))[0] : undef; -} - -sub sockhost { - @_ == 1 or croak 'usage: $sock->sockhost()'; - my($sock) = @_; - my $addr = $sock->sockaddr; - $addr ? inet_ntoa($addr) : undef; -} - -sub peeraddr { - @_ == 1 or croak 'usage: $sock->peeraddr()'; - my($sock) = @_; - my $name = $sock->peername; - $name ? (sockaddr_in($name))[1] : undef; -} - -sub peerport { - @_ == 1 or croak 'usage: $sock->peerport()'; - my($sock) = @_; - my $name = $sock->peername; - $name ? (sockaddr_in($name))[0] : undef; -} - -sub peerhost { - @_ == 1 or croak 'usage: $sock->peerhost()'; - my($sock) = @_; - my $addr = $sock->peeraddr; - $addr ? inet_ntoa($addr) : undef; -} - -1; - -__END__ - -=head1 NAME - -IO::Socket::INET - Object interface for AF_INET domain sockets - -=head1 SYNOPSIS - - use IO::Socket::INET; - -=head1 DESCRIPTION - -C<IO::Socket::INET> provides an object interface to creating and using sockets -in the AF_INET domain. It is built upon the L<IO::Socket> interface and -inherits all the methods defined by L<IO::Socket>. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ARGS] ) - -Creates an C<IO::Socket::INET> object, which is a reference to a -newly created symbol (see the C<Symbol> package). C<new> -optionally takes arguments, these arguments are in key-value pairs. - -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 - -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. - -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 -first connect will never fail with a timeout as the connect call -will not block. - -The C<PeerAddr> can be a hostname or the IP-address on the -"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic -service name. The service name might be followed by a number in -parenthesis which is used if the service is not known by the system. -The C<PeerPort> specification can also be embedded in the C<PeerAddr> -by preceding it with a ":". - -If C<Proto> is not given and you specify a symbolic C<PeerPort> port, -then the constructor will try to derive C<Proto> from the service -name. As a last resort C<Proto> "tcp" is assumed. The C<Type> -parameter will be deduced from C<Proto> if not specified. - -If the constructor is only passed a single argument, it is assumed to -be a C<PeerAddr> specification. - -If C<Blocking> is set to 0, the connection will be in nonblocking mode. -If not specified it defaults to 1 (blocking mode). - -Examples: - - $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', - PeerPort => 'http(80)', - Proto => 'tcp'); - - $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); - - $sock = IO::Socket::INET->new(Listen => 5, - LocalAddr => 'localhost', - LocalPort => 9000, - Proto => 'tcp'); - - $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"; - - 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 - -=head2 METHODS - -=over 4 - -=item sockaddr () - -Return the address part of the sockaddr structure for the socket - -=item sockport () - -Return the port number that the socket is using on the local host - -=item sockhost () - -Return the address part of the sockaddr structure for the socket in a -text form xx.xx.xx.xx - -=item peeraddr () - -Return the address part of the sockaddr structure for the socket on -the peer host - -=item peerport () - -Return the port number for the socket on the peer host. - -=item peerhost () - -Return the address part of the sockaddr structure for the socket on the -peer host in a text form xx.xx.xx.xx - -=back - -=head1 SEE ALSO - -L<Socket>, L<IO::Socket> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm b/Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm deleted file mode 100644 index 952a0f41f0c..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/Socket/UNIX.pm +++ /dev/null @@ -1,144 +0,0 @@ -# IO::Socket::UNIX.pm -# -# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package IO::Socket::UNIX; - -use strict; -our(@ISA, $VERSION); -use IO::Socket; -use Socket; -use Carp; - -@ISA = qw(IO::Socket); -$VERSION = "1.22"; -$VERSION = eval $VERSION; - -IO::Socket::UNIX->register_domain( AF_UNIX ); - -sub new { - my $class = shift; - unshift(@_, "Peer") if @_ == 1; - return $class->SUPER::new(@_); -} - -sub configure { - my($sock,$arg) = @_; - my($bport,$cport); - - my $type = $arg->{Type} || SOCK_STREAM; - - $sock->socket(AF_UNIX, $type, 0) or - return undef; - - if(exists $arg->{Local}) { - my $addr = sockaddr_un($arg->{Local}); - $sock->bind($addr) or - return undef; - } - if(exists $arg->{Listen} && $type != SOCK_DGRAM) { - $sock->listen($arg->{Listen} || 5) or - return undef; - } - elsif(exists $arg->{Peer}) { - my $addr = sockaddr_un($arg->{Peer}); - $sock->connect($addr) or - return undef; - } - - $sock; -} - -sub hostpath { - @_ == 1 or croak 'usage: $sock->hostpath()'; - my $n = $_[0]->sockname || return undef; - (sockaddr_un($n))[0]; -} - -sub peerpath { - @_ == 1 or croak 'usage: $sock->peerpath()'; - my $n = $_[0]->peername || return undef; - (sockaddr_un($n))[0]; -} - -1; # Keep require happy - -__END__ - -=head1 NAME - -IO::Socket::UNIX - Object interface for AF_UNIX domain sockets - -=head1 SYNOPSIS - - use IO::Socket::UNIX; - -=head1 DESCRIPTION - -C<IO::Socket::UNIX> provides an object interface to creating and using sockets -in the AF_UNIX domain. It is built upon the L<IO::Socket> interface and -inherits all the methods defined by L<IO::Socket>. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ARGS] ) - -Creates an C<IO::Socket::UNIX> object, which is a reference to a -newly created symbol (see the C<Symbol> package). C<new> -optionally takes arguments, these arguments are in key-value pairs. - -In addition to the key-value pairs accepted by L<IO::Socket>, -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 Create a listen socket - -If the constructor is only passed a single argument, it is assumed to -be a C<Peer> specification. - - - 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 - -=head1 METHODS - -=over 4 - -=item hostpath() - -Returns the pathname to the fifo at the local end - -=item peerpath() - -Returns the pathanme to the fifo at the peer end - -=back - -=head1 SEE ALSO - -L<Socket>, L<IO::Socket> - -=head1 AUTHOR - -Graham Barr. Currently maintained by the Perl Porters. Please report all -bugs to <perl5-porters@perl.org>. - -=head1 COPYRIGHT - -Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/IO/String.pm b/Master/tlpkg/tlperl/lib/IO/String.pm deleted file mode 100755 index 4bc8e719601..00000000000 --- a/Master/tlpkg/tlperl/lib/IO/String.pm +++ /dev/null @@ -1,551 +0,0 @@ -package IO::String; - -# Copyright 1998-2005 Gisle Aas. -# -# This library is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -require 5.005_03; -use strict; -use vars qw($VERSION $DEBUG $IO_CONSTANTS); -$VERSION = "1.08"; # $Date: 2005/12/05 12:00:47 $ - -use Symbol (); - -sub new -{ - my $class = shift; - my $self = bless Symbol::gensym(), ref($class) || $class; - tie *$self, $self; - $self->open(@_); - return $self; -} - -sub open -{ - my $self = shift; - return $self->new(@_) unless ref($self); - - if (@_) { - my $bufref = ref($_[0]) ? $_[0] : \$_[0]; - $$bufref = "" unless defined $$bufref; - *$self->{buf} = $bufref; - } - else { - my $buf = ""; - *$self->{buf} = \$buf; - } - *$self->{pos} = 0; - *$self->{lno} = 0; - return $self; -} - -sub pad -{ - my $self = shift; - my $old = *$self->{pad}; - *$self->{pad} = substr($_[0], 0, 1) if @_; - return "\0" unless defined($old) && length($old); - return $old; -} - -sub dump -{ - require Data::Dumper; - my $self = shift; - print Data::Dumper->Dump([$self], ['*self']); - print Data::Dumper->Dump([*$self{HASH}], ['$self{HASH}']); - return; -} - -sub TIEHANDLE -{ - print "TIEHANDLE @_\n" if $DEBUG; - return $_[0] if ref($_[0]); - my $class = shift; - my $self = bless Symbol::gensym(), $class; - $self->open(@_); - return $self; -} - -sub DESTROY -{ - print "DESTROY @_\n" if $DEBUG; -} - -sub close -{ - my $self = shift; - delete *$self->{buf}; - delete *$self->{pos}; - delete *$self->{lno}; - undef *$self if $] eq "5.008"; # workaround for some bug - return 1; -} - -sub opened -{ - my $self = shift; - return defined *$self->{buf}; -} - -sub binmode -{ - my $self = shift; - return 1 unless @_; - # XXX don't know much about layers yet :-( - return 0; -} - -sub getc -{ - my $self = shift; - my $buf; - return $buf if $self->read($buf, 1); - return undef; -} - -sub ungetc -{ - my $self = shift; - $self->setpos($self->getpos() - 1); - return 1; -} - -sub eof -{ - my $self = shift; - return length(${*$self->{buf}}) <= *$self->{pos}; -} - -sub print -{ - my $self = shift; - if (defined $\) { - if (defined $,) { - $self->write(join($,, @_).$\); - } - else { - $self->write(join("",@_).$\); - } - } - else { - if (defined $,) { - $self->write(join($,, @_)); - } - else { - $self->write(join("",@_)); - } - } - return 1; -} -*printflush = \*print; - -sub printf -{ - my $self = shift; - print "PRINTF(@_)\n" if $DEBUG; - my $fmt = shift; - $self->write(sprintf($fmt, @_)); - return 1; -} - - -my($SEEK_SET, $SEEK_CUR, $SEEK_END); - -sub _init_seek_constants -{ - if ($IO_CONSTANTS) { - require IO::Handle; - $SEEK_SET = &IO::Handle::SEEK_SET; - $SEEK_CUR = &IO::Handle::SEEK_CUR; - $SEEK_END = &IO::Handle::SEEK_END; - } - else { - $SEEK_SET = 0; - $SEEK_CUR = 1; - $SEEK_END = 2; - } -} - - -sub seek -{ - my($self,$off,$whence) = @_; - my $buf = *$self->{buf} || return 0; - my $len = length($$buf); - my $pos = *$self->{pos}; - - _init_seek_constants() unless defined $SEEK_SET; - - if ($whence == $SEEK_SET) { $pos = $off } - elsif ($whence == $SEEK_CUR) { $pos += $off } - elsif ($whence == $SEEK_END) { $pos = $len + $off } - else { die "Bad whence ($whence)" } - print "SEEK(POS=$pos,OFF=$off,LEN=$len)\n" if $DEBUG; - - $pos = 0 if $pos < 0; - $self->truncate($pos) if $pos > $len; # extend file - *$self->{pos} = $pos; - return 1; -} - -sub pos -{ - my $self = shift; - my $old = *$self->{pos}; - if (@_) { - my $pos = shift || 0; - my $buf = *$self->{buf}; - my $len = $buf ? length($$buf) : 0; - $pos = $len if $pos > $len; - *$self->{pos} = $pos; - } - return $old; -} - -sub getpos { shift->pos; } - -*sysseek = \&seek; -*setpos = \&pos; -*tell = \&getpos; - - - -sub getline -{ - my $self = shift; - my $buf = *$self->{buf} || return; - my $len = length($$buf); - my $pos = *$self->{pos}; - return if $pos >= $len; - - unless (defined $/) { # slurp - *$self->{pos} = $len; - return substr($$buf, $pos); - } - - unless (length $/) { # paragraph mode - # XXX slow&lazy implementation using getc() - my $para = ""; - my $eol = 0; - my $c; - while (defined($c = $self->getc)) { - if ($c eq "\n") { - $eol++; - next if $eol > 2; - } - elsif ($eol > 1) { - $self->ungetc($c); - last; - } - else { - $eol = 0; - } - $para .= $c; - } - return $para; # XXX wantarray - } - - my $idx = index($$buf,$/,$pos); - if ($idx < 0) { - # return rest of it - *$self->{pos} = $len; - $. = ++ *$self->{lno}; - return substr($$buf, $pos); - } - $len = $idx - $pos + length($/); - *$self->{pos} += $len; - $. = ++ *$self->{lno}; - return substr($$buf, $pos, $len); -} - -sub getlines -{ - die "getlines() called in scalar context\n" unless wantarray; - my $self = shift; - my($line, @lines); - push(@lines, $line) while defined($line = $self->getline); - return @lines; -} - -sub READLINE -{ - goto &getlines if wantarray; - goto &getline; -} - -sub input_line_number -{ - my $self = shift; - my $old = *$self->{lno}; - *$self->{lno} = shift if @_; - return $old; -} - -sub truncate -{ - my $self = shift; - my $len = shift || 0; - my $buf = *$self->{buf}; - if (length($$buf) >= $len) { - substr($$buf, $len) = ''; - *$self->{pos} = $len if $len < *$self->{pos}; - } - else { - $$buf .= ($self->pad x ($len - length($$buf))); - } - return 1; -} - -sub read -{ - my $self = shift; - my $buf = *$self->{buf}; - return undef unless $buf; - - my $pos = *$self->{pos}; - my $rem = length($$buf) - $pos; - my $len = $_[1]; - $len = $rem if $len > $rem; - return undef if $len < 0; - if (@_ > 2) { # read offset - substr($_[0],$_[2]) = substr($$buf, $pos, $len); - } - else { - $_[0] = substr($$buf, $pos, $len); - } - *$self->{pos} += $len; - return $len; -} - -sub write -{ - my $self = shift; - my $buf = *$self->{buf}; - return unless $buf; - - my $pos = *$self->{pos}; - my $slen = length($_[0]); - my $len = $slen; - my $off = 0; - if (@_ > 1) { - $len = $_[1] if $_[1] < $len; - if (@_ > 2) { - $off = $_[2] || 0; - die "Offset outside string" if $off > $slen; - if ($off < 0) { - $off += $slen; - die "Offset outside string" if $off < 0; - } - my $rem = $slen - $off; - $len = $rem if $rem < $len; - } - } - substr($$buf, $pos, $len) = substr($_[0], $off, $len); - *$self->{pos} += $len; - return $len; -} - -*sysread = \&read; -*syswrite = \&write; - -sub stat -{ - my $self = shift; - return unless $self->opened; - return 1 unless wantarray; - my $len = length ${*$self->{buf}}; - - return ( - undef, undef, # dev, ino - 0666, # filemode - 1, # links - $>, # user id - $), # group id - undef, # device id - $len, # size - undef, # atime - undef, # mtime - undef, # ctime - 512, # blksize - int(($len+511)/512) # blocks - ); -} - -sub FILENO { - return undef; # XXX perlfunc says this means the file is closed -} - -sub blocking { - my $self = shift; - my $old = *$self->{blocking} || 0; - *$self->{blocking} = shift if @_; - return $old; -} - -my $notmuch = sub { return }; - -*fileno = $notmuch; -*error = $notmuch; -*clearerr = $notmuch; -*sync = $notmuch; -*flush = $notmuch; -*setbuf = $notmuch; -*setvbuf = $notmuch; - -*untaint = $notmuch; -*autoflush = $notmuch; -*fcntl = $notmuch; -*ioctl = $notmuch; - -*GETC = \&getc; -*PRINT = \&print; -*PRINTF = \&printf; -*READ = \&read; -*WRITE = \&write; -*SEEK = \&seek; -*TELL = \&getpos; -*EOF = \&eof; -*CLOSE = \&close; -*BINMODE = \&binmode; - - -sub string_ref -{ - my $self = shift; - return *$self->{buf}; -} -*sref = \&string_ref; - -1; - -__END__ - -=head1 NAME - -IO::String - Emulate file interface for in-core strings - -=head1 SYNOPSIS - - use IO::String; - $io = IO::String->new; - $io = IO::String->new($var); - tie *IO, 'IO::String'; - - # read data - <$io>; - $io->getline; - read($io, $buf, 100); - - # write data - print $io "string\n"; - $io->print(@data); - syswrite($io, $buf, 100); - - select $io; - printf "Some text %s\n", $str; - - # seek - $pos = $io->getpos; - $io->setpos(0); # rewind - $io->seek(-30, -1); - seek($io, 0, 0); - -=head1 DESCRIPTION - -The C<IO::String> module provides the C<IO::File> interface for in-core -strings. An C<IO::String> object can be attached to a string, and -makes it possible to use the normal file operations for reading or -writing data, as well as for seeking to various locations of the string. -This is useful when you want to use a library module that only -provides an interface to file handles on data that you have in a string -variable. - -Note that perl-5.8 and better has built-in support for "in memory" -files, which are set up by passing a reference instead of a filename -to the open() call. The reason for using this module is that it -makes the code backwards compatible with older versions of Perl. - -The C<IO::String> module provides an interface compatible with -C<IO::File> as distributed with F<IO-1.20>, but the following methods -are not available: new_from_fd, fdopen, format_write, -format_page_number, format_lines_per_page, format_lines_left, -format_name, format_top_name. - -The following methods are specific to the C<IO::String> class: - -=over 4 - -=item $io = IO::String->new - -=item $io = IO::String->new( $string ) - -The constructor returns a newly-created C<IO::String> object. It -takes an optional argument, which is the string to read from or write -into. If no $string argument is given, then an internal buffer -(initially empty) is allocated. - -The C<IO::String> object returned is tied to itself. This means -that you can use most Perl I/O built-ins on it too: readline, <>, getc, -print, printf, syswrite, sysread, close. - -=item $io->open - -=item $io->open( $string ) - -Attaches an existing IO::String object to some other $string, or -allocates a new internal buffer (if no argument is given). The -position is reset to 0. - -=item $io->string_ref - -Returns a reference to the string that is attached to -the C<IO::String> object. Most useful when you let the C<IO::String> -create an internal buffer to write into. - -=item $io->pad - -=item $io->pad( $char ) - -Specifies the padding to use if -the string is extended by either the seek() or truncate() methods. It -is a single character and defaults to "\0". - -=item $io->pos - -=item $io->pos( $newpos ) - -Yet another interface for reading and setting the current read/write -position within the string (the normal getpos/setpos/tell/seek -methods are also available). The pos() method always returns the -old position, and if you pass it an argument it sets the new -position. - -There is (deliberately) a difference between the setpos() and seek() -methods in that seek() extends the string (with the specified -padding) if you go to a location past the end, whereas setpos() -just snaps back to the end. If truncate() is used to extend the string, -then it works as seek(). - -=back - -=head1 BUGS - -In Perl versions < 5.6, the TIEHANDLE interface was incomplete. -If you use such a Perl, then seek(), tell(), eof(), fileno(), binmode() will -not do anything on an C<IO::String> handle. See L<perltie> for -details. - -=head1 SEE ALSO - -L<IO::File>, L<IO::Stringy>, L<perlfunc/open> - -=head1 COPYRIGHT - -Copyright 1998-2005 Gisle Aas. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut |