Initial Windows agent repository
This commit is contained in:
commit
a0db0c2e5b
10589 changed files with 3844063 additions and 0 deletions
247
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Dir.pm
Normal file
247
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Dir.pm
Normal file
|
|
@ -0,0 +1,247 @@
|
|||
# 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.008_001;
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use Symbol;
|
||||
use Exporter;
|
||||
use IO::File;
|
||||
use Tie::Hash;
|
||||
use File::stat;
|
||||
use File::Spec;
|
||||
|
||||
our @ISA = qw(Tie::Hash Exporter);
|
||||
our $VERSION = "1.55";
|
||||
|
||||
our @EXPORT_OK = qw(DIR_UNLINK);
|
||||
|
||||
sub DIR_UNLINK () { 1 }
|
||||
|
||||
sub new {
|
||||
@_ >= 1 && @_ <= 2 or croak 'usage: IO::Dir->new([DIRNAME])';
|
||||
my $class = shift;
|
||||
my $dh = gensym;
|
||||
if (@_) {
|
||||
IO::Dir::open($dh, $_[0])
|
||||
or return undef;
|
||||
}
|
||||
bless $dh, $class;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my ($dh) = @_;
|
||||
local($., $@, $!, $^E, $?);
|
||||
no warnings 'io';
|
||||
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;
|
||||
my $d = IO::Dir->new(".");
|
||||
if (defined $d) {
|
||||
while (defined($_ = $d->read)) { something($_); }
|
||||
$d->rewind;
|
||||
while (defined($_ = $d->read)) { something_else($_); }
|
||||
undef $d;
|
||||
}
|
||||
|
||||
tie my %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 at L<https://github.com/Perl/perl5/issues>.
|
||||
|
||||
=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
|
||||
181
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/File.pm
Normal file
181
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/File.pm
Normal file
|
|
@ -0,0 +1,181 @@
|
|||
#
|
||||
|
||||
package IO::File;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::File - supply object methods for filehandles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::File;
|
||||
|
||||
my $fh = IO::File->new();
|
||||
if ($fh->open("< file")) {
|
||||
print <$fh>;
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
my $fh = IO::File->new("> file");
|
||||
if (defined $fh) {
|
||||
print $fh "bar\n";
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
my $fh = IO::File->new("file", "r");
|
||||
if (defined $fh) {
|
||||
print <$fh>;
|
||||
undef $fh; # automatically closes the file
|
||||
}
|
||||
|
||||
my $fh = IO::File->new("file", O_WRONLY|O_APPEND);
|
||||
if (defined $fh) {
|
||||
print $fh "corge\n";
|
||||
|
||||
my $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.
|
||||
|
||||
=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.008_001;
|
||||
use strict;
|
||||
use Carp;
|
||||
use Symbol;
|
||||
use SelectSaver;
|
||||
use IO::Seekable;
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(IO::Handle IO::Seekable Exporter);
|
||||
|
||||
our $VERSION = "1.55";
|
||||
|
||||
our @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: $class->new([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)';
|
||||
} else {
|
||||
return open($fh, IO::Handle::_open_mode_string($mode), $file);
|
||||
}
|
||||
}
|
||||
open($fh, $file);
|
||||
}
|
||||
|
||||
1;
|
||||
652
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Handle.pm
Normal file
652
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Handle.pm
Normal file
|
|
@ -0,0 +1,652 @@
|
|||
package IO::Handle;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Handle - supply object methods for I/O handles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::Handle;
|
||||
|
||||
my $io = IO::Handle->new();
|
||||
if ($io->fdopen(fileno(STDIN),"r")) {
|
||||
print $io->getline;
|
||||
$io->close;
|
||||
}
|
||||
|
||||
my $io = IO::Handle->new();
|
||||
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(my $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->fcntl( FUNCTION, SCALAR )
|
||||
$io->fileno
|
||||
$io->format_write( [FORMAT_NAME] )
|
||||
$io->getc
|
||||
$io->ioctl( FUNCTION, SCALAR )
|
||||
$io->read ( BUF, LEN, [OFFSET] )
|
||||
$io->print ( ARGS )
|
||||
$io->printf ( FMT, [ARGS] )
|
||||
$io->say ( 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. (For the documentation of the C<open>
|
||||
method, see L<IO::File>.)
|
||||
|
||||
=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 somewhat like C<write> found in C, in that 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).
|
||||
|
||||
=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.
|
||||
|
||||
=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
|
||||
|
||||
|
||||
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 L<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.008_001;
|
||||
use strict;
|
||||
use Carp;
|
||||
use Symbol;
|
||||
use SelectSaver;
|
||||
use IO (); # Load the XS module
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our $VERSION = "1.55";
|
||||
|
||||
our @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
|
||||
say
|
||||
getline
|
||||
getlines
|
||||
|
||||
printflush
|
||||
flush
|
||||
|
||||
SEEK_SET
|
||||
SEEK_CUR
|
||||
SEEK_END
|
||||
_IOFBF
|
||||
_IOLBF
|
||||
_IONBF
|
||||
);
|
||||
|
||||
################################################
|
||||
## Constructors, destructors.
|
||||
##
|
||||
|
||||
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()";
|
||||
}
|
||||
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)";
|
||||
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 say {
|
||||
@_ or croak 'usage: $io->say(ARGS)';
|
||||
my $this = shift;
|
||||
local $\ = "\n";
|
||||
print $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 = SelectSaver->new(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 = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]);
|
||||
my $prev = $%;
|
||||
$% = $_[1] if @_ > 1;
|
||||
$prev;
|
||||
}
|
||||
|
||||
sub format_lines_per_page {
|
||||
my $old;
|
||||
$old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]);
|
||||
my $prev = $=;
|
||||
$= = $_[1] if @_ > 1;
|
||||
$prev;
|
||||
}
|
||||
|
||||
sub format_lines_left {
|
||||
my $old;
|
||||
$old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]);
|
||||
my $prev = $-;
|
||||
$- = $_[1] if @_ > 1;
|
||||
$prev;
|
||||
}
|
||||
|
||||
sub format_name {
|
||||
my $old;
|
||||
$old = SelectSaver->new(qualify($_[0], caller)) if ref($_[0]);
|
||||
my $prev = $~;
|
||||
$~ = qualify($_[1], caller) if @_ > 1;
|
||||
$prev;
|
||||
}
|
||||
|
||||
sub format_top_name {
|
||||
my $old;
|
||||
$old = SelectSaver->new(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(qualify($fmt,caller));
|
||||
CORE::write($io);
|
||||
$io->format_name($oldfmt);
|
||||
} else {
|
||||
CORE::write($_[0]);
|
||||
}
|
||||
}
|
||||
|
||||
sub fcntl {
|
||||
@_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );';
|
||||
my ($io, $op) = @_;
|
||||
return fcntl($io, $op, $_[2]);
|
||||
}
|
||||
|
||||
sub ioctl {
|
||||
@_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );';
|
||||
my ($io, $op) = @_;
|
||||
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
|
||||
#
|
||||
# The SEEK_* and _IO?BF constants were the only constants at that time
|
||||
# any new code should just check 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 = SelectSaver->new(qualify($io, caller)) if ref($io);
|
||||
local $| = 1;
|
||||
if(ref($io)) {
|
||||
print $io @_;
|
||||
}
|
||||
else {
|
||||
print @_;
|
||||
}
|
||||
}
|
||||
|
||||
################################################
|
||||
## 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;
|
||||
256
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Pipe.pm
Normal file
256
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Pipe.pm
Normal file
|
|
@ -0,0 +1,256 @@
|
|||
# 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.008_001;
|
||||
|
||||
use IO::Handle;
|
||||
use strict;
|
||||
use Carp;
|
||||
use Symbol;
|
||||
|
||||
our $VERSION = "1.55";
|
||||
|
||||
sub new {
|
||||
my $type = shift;
|
||||
my $class = ref($type) || $type || "IO::Pipe";
|
||||
@_ == 0 || @_ == 2 or croak "usage: $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 = IO::Pipe->new();
|
||||
|
||||
if($pid = fork()) { # Parent
|
||||
$pipe->reader();
|
||||
|
||||
while(<$pipe>) {
|
||||
...
|
||||
}
|
||||
|
||||
}
|
||||
elsif(defined $pid) { # Child
|
||||
$pipe->writer();
|
||||
|
||||
print $pipe ...
|
||||
}
|
||||
|
||||
or
|
||||
|
||||
$pipe = IO::Pipe->new();
|
||||
|
||||
$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 L<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 at L<https://github.com/Perl/perl5/issues>.
|
||||
|
||||
=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
|
||||
208
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Poll.pm
Normal file
208
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Poll.pm
Normal file
|
|
@ -0,0 +1,208 @@
|
|||
|
||||
# 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 = qw(Exporter);
|
||||
our $VERSION = "1.55";
|
||||
|
||||
our @EXPORT = qw( POLLIN
|
||||
POLLOUT
|
||||
POLLERR
|
||||
POLLHUP
|
||||
POLLNVAL
|
||||
);
|
||||
|
||||
our @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(defined($timeout) ? $timeout * 1000 : -1,@poll);
|
||||
|
||||
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 = IO::Poll->new();
|
||||
|
||||
$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 at L<https://github.com/Perl/perl5/issues>.
|
||||
|
||||
=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
|
||||
126
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Seekable.pm
Normal file
126
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Seekable.pm
Normal file
|
|
@ -0,0 +1,126 @@
|
|||
#
|
||||
|
||||
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.008_001;
|
||||
use Carp;
|
||||
use strict;
|
||||
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;
|
||||
|
||||
our @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our $VERSION = "1.55";
|
||||
|
||||
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;
|
||||
417
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Select.pm
Normal file
417
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Select.pm
Normal file
|
|
@ -0,0 +1,417 @@
|
|||
# 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;
|
||||
require Exporter;
|
||||
|
||||
our $VERSION = "1.55";
|
||||
|
||||
our @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';
|
||||
if($f =~ /^[0-9]+$/) { # plain file number
|
||||
return $f;
|
||||
}
|
||||
elsif(defined(my $fd = fileno($f))) {
|
||||
return $fd;
|
||||
}
|
||||
else {
|
||||
# Neither a plain file number nor an opened filehandle; but maybe it was
|
||||
# previously registered and has since been closed. ->remove still wants to
|
||||
# know what fileno it had
|
||||
foreach my $i ( FIRST_FD .. $#$self ) {
|
||||
return $i - FIRST_FD if defined $self->[$i] && $self->[$i] == $f;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
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);
|
||||
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;
|
||||
}
|
||||
$vec->[FD_COUNT]++;
|
||||
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;
|
||||
}
|
||||
}
|
||||
$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 C<select> system call
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::Select;
|
||||
|
||||
my $s = IO::Select->new();
|
||||
|
||||
$s->add(\*STDIN);
|
||||
$s->add($some_handle);
|
||||
|
||||
my @ready1 = $s->can_read($timeout);
|
||||
|
||||
my @ready2 = 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 (with C<$!>
|
||||
unchanged), in seconds, possibly fractional. If C<TIMEOUT> is not given
|
||||
and any handles are registered then the call will block indefinitely.
|
||||
Upon error, an empty list is returned, with C<$!> set to indicate the
|
||||
error. To distinguish between timeout and error, set C<$!> to zero
|
||||
before calling this method, and check it after an empty list is returned.
|
||||
|
||||
=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.
|
||||
|
||||
If at least one handle is ready for the specified kind of operation,
|
||||
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 timeout, an empty list is returned,
|
||||
with C<$!> unchanged. Upon error, an empty list is returned, with C<$!>
|
||||
set to indicate the error. To distinguish between timeout and error,
|
||||
set C<$!> to zero before calling this method, and check it after 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;
|
||||
|
||||
my $lsn = IO::Socket::INET->new(Listen => 1, LocalPort => 8080);
|
||||
my $sel = IO::Select->new( $lsn );
|
||||
|
||||
while(my @ready = $sel->can_read) {
|
||||
foreach my $fh (@ready) {
|
||||
if($fh == $lsn) {
|
||||
# Create a new socket
|
||||
my $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 at L<https://github.com/Perl/perl5/issues>.
|
||||
|
||||
=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
|
||||
|
||||
933
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Socket.pm
Normal file
933
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Socket.pm
Normal file
|
|
@ -0,0 +1,933 @@
|
|||
|
||||
# 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;
|
||||
|
||||
use 5.008_001;
|
||||
|
||||
use IO::Handle;
|
||||
use Socket 1.3;
|
||||
use Carp;
|
||||
use strict;
|
||||
use Exporter;
|
||||
use Errno;
|
||||
|
||||
# legacy
|
||||
|
||||
require IO::Socket::INET;
|
||||
require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian');
|
||||
|
||||
our @ISA = qw(IO::Handle);
|
||||
|
||||
our $VERSION = "1.55";
|
||||
|
||||
our @EXPORT_OK = qw(sockatmark);
|
||||
|
||||
our $errstr;
|
||||
|
||||
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;
|
||||
|
||||
# "A value of 0 for protocol will let the system select an
|
||||
# appropriate protocol"
|
||||
# so we need to look up what the system selected,
|
||||
# not cache PF_UNSPEC.
|
||||
${*$sock}{'io_socket_proto'} = $protocol if $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} || $!{EWOULDBLOCK})) {
|
||||
require IO::Select;
|
||||
|
||||
my $sel = IO::Select->new( $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);
|
||||
$errstr = $@ = "connect: $err";
|
||||
}
|
||||
elsif(!@$w[0]) {
|
||||
$err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
|
||||
$errstr = $@ = "connect: timeout";
|
||||
}
|
||||
elsif (!connect($sock,$addr) &&
|
||||
not ($!{EISCONN} || ($^O eq 'MSWin32' &&
|
||||
($! == (($] < 5.019004) ? 10022 : Errno::EINVAL))))
|
||||
) {
|
||||
# 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).
|
||||
$err = $!;
|
||||
$errstr = $@ = "connect: $!";
|
||||
}
|
||||
}
|
||||
elsif ($blocking || !($!{EINPROGRESS} || $!{EWOULDBLOCK})) {
|
||||
$err = $!;
|
||||
$errstr = $@ = "connect: $!";
|
||||
}
|
||||
}
|
||||
|
||||
$sock->blocking(1) if $blocking;
|
||||
|
||||
$! = $err if $err;
|
||||
|
||||
$err ? undef : $sock;
|
||||
}
|
||||
|
||||
# Enable/disable blocking IO on sockets.
|
||||
# Without args return the current status of blocking,
|
||||
# with args change the mode as appropriate, returning the
|
||||
# old setting, or in case of error during the mode change
|
||||
# undef.
|
||||
|
||||
sub blocking {
|
||||
my $sock = shift;
|
||||
|
||||
return $sock->SUPER::blocking(@_)
|
||||
if $^O ne 'MSWin32' && $^O ne 'VMS';
|
||||
|
||||
# Windows handles blocking differently
|
||||
#
|
||||
# http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
|
||||
# http://msdn.microsoft.com/library/default.asp?url=/library/en-us/winsock/winsock/ioctlsocket_2.asp
|
||||
#
|
||||
# 0x8004667e is FIONBIO
|
||||
#
|
||||
# which is used to set blocking behaviour.
|
||||
|
||||
# NOTE:
|
||||
# This is a little confusing, the perl keyword for this is
|
||||
# 'blocking' but the OS level behaviour is 'non-blocking', probably
|
||||
# because sockets are blocking by default.
|
||||
# Therefore internally we have to reverse the semantics.
|
||||
|
||||
my $orig= !${*$sock}{io_sock_nonblocking};
|
||||
|
||||
return $orig unless @_;
|
||||
|
||||
my $block = shift;
|
||||
|
||||
if ( !$block != !$orig ) {
|
||||
${*$sock}{io_sock_nonblocking} = $block ? 0 : 1;
|
||||
ioctl($sock, 0x8004667e, pack("L!",${*$sock}{io_sock_nonblocking}))
|
||||
or return undef;
|
||||
}
|
||||
|
||||
return $orig;
|
||||
}
|
||||
|
||||
|
||||
sub close {
|
||||
@_ == 1 or croak 'usage: $sock->close()';
|
||||
my $sock = shift;
|
||||
${*$sock}{'io_socket_peername'} = undef;
|
||||
$sock->SUPER::close();
|
||||
}
|
||||
|
||||
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 = IO::Select->new( $sock );
|
||||
|
||||
unless ($sel->can_read($timeout)) {
|
||||
$errstr = $@ = 'accept: timeout';
|
||||
$! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1);
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
$peer = accept($new,$sock)
|
||||
or return;
|
||||
|
||||
${*$new}{$_} = ${*$sock}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
|
||||
|
||||
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) = @_;
|
||||
${*$sock}{'io_socket_peername'} ||= getpeername($sock);
|
||||
}
|
||||
|
||||
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;
|
||||
|
||||
if ($_[3]) {
|
||||
# the caller explicitly requested a TO, so use it
|
||||
# this is non-portable for "connected" UDP sockets
|
||||
$peer = $_[3];
|
||||
}
|
||||
elsif (!defined getpeername($sock)) {
|
||||
# we're not connected, so we require a peer from somewhere
|
||||
$peer = $sock->peername;
|
||||
|
||||
croak 'send: Cannot determine peer address'
|
||||
unless(defined $peer);
|
||||
}
|
||||
|
||||
my $r = $peer
|
||||
? send($sock, $_[1], $flags, $peer)
|
||||
: send($sock, $_[1], $flags);
|
||||
|
||||
# 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) = @_;
|
||||
${*$sock}{'io_socket_peername'} = undef;
|
||||
shutdown($sock, $how);
|
||||
}
|
||||
|
||||
sub setsockopt {
|
||||
@_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME, OPTVAL)';
|
||||
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;
|
||||
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'};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Socket - Object interface to socket communications
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use IO::Socket qw(AF_INET AF_UNIX);
|
||||
|
||||
# create a new AF_INET socket
|
||||
my $sock = IO::Socket->new(Domain => AF_INET);
|
||||
# which is the same as
|
||||
$sock = IO::Socket::INET->new();
|
||||
|
||||
# create a new AF_UNIX socket
|
||||
$sock = IO::Socket->new(Domain => AF_UNIX);
|
||||
# which is the same as
|
||||
$sock = IO::Socket::UNIX->new();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
C<IO::Socket> provides an object-oriented, L<IO::Handle>-based interface to
|
||||
creating and using sockets via L<Socket>, which provides a near one-to-one
|
||||
interface to the C socket library.
|
||||
|
||||
C<IO::Socket> is a base class that really only defines methods for those
|
||||
operations which are common to all types of sockets. Operations which are
|
||||
specific to a particular socket domain have methods defined in subclasses of
|
||||
C<IO::Socket>. See L<IO::Socket::INET>, L<IO::Socket::UNIX>, and
|
||||
L<IO::Socket::IP> for examples of such a subclass.
|
||||
|
||||
C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
|
||||
|
||||
=head1 CONSTRUCTOR ARGUMENTS
|
||||
|
||||
Given that C<IO::Socket> doesn't have attributes in the traditional sense, the
|
||||
following arguments, rather than attributes, can be passed into the
|
||||
constructor.
|
||||
|
||||
Constructor arguments should be passed in C<< Key => 'Value' >> pairs.
|
||||
|
||||
The only required argument is L<IO::Socket/"Domain">.
|
||||
|
||||
=head2 Blocking
|
||||
|
||||
my $sock = IO::Socket->new(..., Blocking => 1);
|
||||
$sock = IO::Socket->new(..., Blocking => 0);
|
||||
|
||||
If defined but false, the socket will be set to non-blocking mode. If not
|
||||
specified it defaults to C<1> (blocking mode).
|
||||
|
||||
=head2 Domain
|
||||
|
||||
my $sock = IO::Socket->new(Domain => IO::Socket::AF_INET);
|
||||
$sock = IO::Socket->new(Domain => IO::Socket::AF_UNIX);
|
||||
|
||||
The socket domain will define which subclass of C<IO::Socket> to use. The two
|
||||
options available along with this distribution are C<AF_INET> and C<AF_UNIX>.
|
||||
|
||||
C<AF_INET> is for the internet address family of sockets and is handled via
|
||||
L<IO::Socket::INET>. C<AF_INET> sockets are bound to an internet address and
|
||||
port.
|
||||
|
||||
C<AF_UNIX> is for the unix domain socket and is handled via
|
||||
L<IO::Socket::UNIX>. C<AF_UNIX> sockets are bound to the file system as their
|
||||
address name space.
|
||||
|
||||
This argument is B<required>. All other arguments are optional.
|
||||
|
||||
=head2 Listen
|
||||
|
||||
my $sock = IO::Socket->new(..., Listen => 5);
|
||||
|
||||
Listen should be an integer value or left unset.
|
||||
|
||||
If provided, this argument will place the socket into listening mode. New
|
||||
connections can then be accepted using the L<IO::Socket/"accept"> method. The
|
||||
value given is used as the C<listen(2)> queue size.
|
||||
|
||||
If the C<Listen> argument is given, but false, the queue size will be set to
|
||||
5.
|
||||
|
||||
=head2 Timeout
|
||||
|
||||
my $sock = IO::Socket->new(..., Timeout => 5);
|
||||
|
||||
The timeout value, in seconds, for this socket connection. How exactly this
|
||||
value is utilized is defined in the socket domain subclasses that make use of
|
||||
the value.
|
||||
|
||||
=head2 Type
|
||||
|
||||
my $sock = IO::Socket->new(..., Type => IO::Socket::SOCK_STREAM);
|
||||
|
||||
The socket type that will be used. These are usually C<SOCK_STREAM>,
|
||||
C<SOCK_DGRAM>, or C<SOCK_RAW>. If this argument is left undefined an attempt
|
||||
will be made to infer the type from the service name.
|
||||
|
||||
For example, you'll usually use C<SOCK_STREAM> with a C<tcp> connection and
|
||||
C<SOCK_DGRAM> with a C<udp> connection.
|
||||
|
||||
=head1 CONSTRUCTORS
|
||||
|
||||
C<IO::Socket> extends the L<IO::Handle> constructor.
|
||||
|
||||
=head2 new
|
||||
|
||||
my $sock = IO::Socket->new();
|
||||
|
||||
# get a new IO::Socket::INET instance
|
||||
$sock = IO::Socket->new(Domain => IO::Socket::AF_INET);
|
||||
# get a new IO::Socket::UNIX instance
|
||||
$sock = IO::Socket->new(Domain => IO::Socket::AF_UNIX);
|
||||
|
||||
# Domain is the only required argument
|
||||
$sock = IO::Socket->new(
|
||||
Domain => IO::Socket::AF_INET, # AF_INET, AF_UNIX
|
||||
Type => IO::Socket::SOCK_STREAM, # SOCK_STREAM, SOCK_DGRAM, ...
|
||||
Proto => 'tcp', # 'tcp', 'udp', IPPROTO_TCP, IPPROTO_UDP
|
||||
# and so on...
|
||||
);
|
||||
|
||||
Creates an C<IO::Socket>, which is a reference to a newly created symbol (see
|
||||
the L<Symbol> package). C<new> optionally takes arguments, these arguments
|
||||
are defined in L<IO::Socket/"CONSTRUCTOR ARGUMENTS">.
|
||||
|
||||
Any of the L<IO::Socket/"CONSTRUCTOR ARGUMENTS"> may be passed to the
|
||||
constructor, but if any arguments are provided, then one of them must be
|
||||
the L<IO::Socket/"Domain"> argument. The L<IO::Socket/"Domain"> argument can,
|
||||
by default, be either C<AF_INET> or C<AF_UNIX>. Other domains can be used if a
|
||||
proper subclass for the domain family is registered. All other arguments will
|
||||
be passed to the C<configuration> method of the package for that domain.
|
||||
|
||||
If the constructor fails it will return C<undef> and set the C<$errstr> package
|
||||
variable to contain an error message.
|
||||
|
||||
$sock = IO::Socket->new(...)
|
||||
or die "Cannot create socket - $IO::Socket::errstr\n";
|
||||
|
||||
For legacy reasons the error message is also set into the global C<$@>
|
||||
variable, and you may still find older code which looks here instead.
|
||||
|
||||
$sock = IO::Socket->new(...)
|
||||
or die "Cannot create socket - $@\n";
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
C<IO::Socket> inherits all methods from L<IO::Handle> and implements the
|
||||
following new ones.
|
||||
|
||||
=head2 accept
|
||||
|
||||
my $client_sock = $sock->accept();
|
||||
my $inet_sock = $sock->accept('IO::Socket::INET');
|
||||
|
||||
The accept method will 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 a specific package name is specified. This object can be
|
||||
used to communicate with the client that was trying to connect.
|
||||
|
||||
This differs slightly from the C<accept> function in L<perlfunc>.
|
||||
|
||||
In a scalar context the new socket is returned, or C<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.
|
||||
|
||||
=head2 atmark
|
||||
|
||||
my $integer = $sock->atmark();
|
||||
# read in some data on a given socket
|
||||
my $data;
|
||||
$sock->read($data, 1024) until $sock->atmark;
|
||||
|
||||
# or, export the function to use:
|
||||
use IO::Socket 'sockatmark';
|
||||
$sock->read($data, 1024) until sockatmark($sock);
|
||||
|
||||
True if the socket is currently positioned at the urgent data mark, false
|
||||
otherwise. If your system doesn't yet implement C<sockatmark> this will throw
|
||||
an exception.
|
||||
|
||||
If your system does not support C<sockatmark>, the C<use> declaration will
|
||||
fail at compile time.
|
||||
|
||||
=head2 autoflush
|
||||
|
||||
# by default, autoflush will be turned on when referenced
|
||||
$sock->autoflush(); # turns on autoflush
|
||||
# turn off autoflush
|
||||
$sock->autoflush(0);
|
||||
# turn on autoflush
|
||||
$sock->autoflush(1);
|
||||
|
||||
This attribute isn't overridden from L<IO::Handle>'s implementation. However,
|
||||
since we turn it on by default, it's worth mentioning here.
|
||||
|
||||
=head2 bind
|
||||
|
||||
use Socket qw(pack_sockaddr_in);
|
||||
my $port = 3000;
|
||||
my $ip_address = '0.0.0.0';
|
||||
my $packed_addr = pack_sockaddr_in($port, $ip_address);
|
||||
$sock->bind($packed_addr);
|
||||
|
||||
Binds a network address to a socket, just as C<bind(2)> does. Returns true if
|
||||
it succeeded, false otherwise. You should provide a packed address of the
|
||||
appropriate type for the socket.
|
||||
|
||||
=head2 connected
|
||||
|
||||
my $peer_addr = $sock->connected();
|
||||
if ($peer_addr) {
|
||||
say "We're connected to $peer_addr";
|
||||
}
|
||||
|
||||
If the socket is in a connected state, the peer address is returned. If the
|
||||
socket is not in a connected state, C<undef> is returned.
|
||||
|
||||
Note that this method considers a half-open TCP socket to be "in a connected
|
||||
state". Specifically, it does not distinguish between the
|
||||
B<ESTABLISHED> and B<CLOSE-WAIT> TCP states; it returns the peer address,
|
||||
rather than C<undef>, in either case. Thus, in general, it 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 L<IO::Socket/"shutdown"> or
|
||||
C<close>. Only at that point does this function return C<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
|
||||
C<SO_LINGER> enabled with a zero timeout, then the peer's C<close> will
|
||||
generate a C<RST> segment. Upon receipt of that segment, the local TCP
|
||||
transitions immediately to B<CLOSED>, and in that state, this method I<will>
|
||||
return C<undef>.
|
||||
|
||||
=head2 getsockopt
|
||||
|
||||
my $value = $sock->getsockopt(SOL_SOCKET, SO_REUSEADDR);
|
||||
my $buf = $socket->getsockopt(SOL_SOCKET, SO_RCVBUF);
|
||||
say "Receive buffer is $buf bytes";
|
||||
|
||||
Get an option associated with the socket. Levels other than C<SOL_SOCKET>
|
||||
may be specified here. As a convenience, this method will unpack a byte buffer
|
||||
of the correct size back into a number.
|
||||
|
||||
=head2 listen
|
||||
|
||||
$sock->listen(5);
|
||||
|
||||
Does the same thing that the C<listen(2)> system call does. Returns true if it
|
||||
succeeded, false otherwise. Listens to a socket with a given queue size.
|
||||
|
||||
=head2 peername
|
||||
|
||||
my $sockaddr_in = $sock->peername();
|
||||
|
||||
Returns the packed C<sockaddr> address of the other end of the socket
|
||||
connection. It calls C<getpeername>.
|
||||
|
||||
|
||||
=head2 protocol
|
||||
|
||||
my $proto = $sock->protocol();
|
||||
|
||||
Returns the number for the protocol being used on the socket, if
|
||||
known. If the protocol is unknown, as with an C<AF_UNIX> socket, zero
|
||||
is returned.
|
||||
|
||||
=head2 recv
|
||||
|
||||
my $buffer = "";
|
||||
my $length = 1024;
|
||||
my $flags = 0; # default. optional
|
||||
$sock->recv($buffer, $length);
|
||||
$sock->recv($buffer, $length, $flags);
|
||||
|
||||
Similar in functionality to L<perlfunc/recv>.
|
||||
|
||||
Receives a message on a socket. Attempts to receive C<$length> characters of
|
||||
data into C<$buffer> from the specified socket. C<$buffer> will be grown or
|
||||
shrunk to the length actually read. Takes the same flags as the system call of
|
||||
the same name. Returns the address of the sender if socket's protocol supports
|
||||
this; returns an empty string otherwise. If there's an error, returns
|
||||
C<undef>. This call is actually implemented in terms of the C<recvfrom(2)>
|
||||
system call.
|
||||
|
||||
Flags are ORed together values, such as C<MSG_BCAST>, C<MSG_OOB>,
|
||||
C<MSG_TRUNC>. The default value for the flags is C<0>.
|
||||
|
||||
The cached value of L<IO::Socket/"peername"> is updated with the result of
|
||||
C<recv>.
|
||||
|
||||
B<Note:> In Perl v5.30 and newer, if the socket has been marked as C<:utf8>,
|
||||
C<recv> will throw an exception. The C<:encoding(...)> layer implicitly
|
||||
introduces the C<:utf8> layer. See L<perlfunc/binmode>.
|
||||
|
||||
B<Note:> In Perl versions older than v5.30, depending on the status of the
|
||||
socket, either (8-bit) bytes or characters are received. By default all
|
||||
sockets operate on bytes, but for example if the socket has been changed
|
||||
using L<perlfunc/binmode> to operate with the C<:encoding(UTF-8)> I/O layer
|
||||
(see the L<perlfunc/open> pragma), the I/O will operate on UTF8-encoded
|
||||
Unicode characters, not bytes. Similarly for the C<:encoding> layer: in
|
||||
that case pretty much any characters can be read.
|
||||
|
||||
=head2 send
|
||||
|
||||
my $message = "Hello, world!";
|
||||
my $flags = 0; # defaults to zero
|
||||
my $to = '0.0.0.0'; # optional destination
|
||||
my $sent = $sock->send($message);
|
||||
$sent = $sock->send($message, $flags);
|
||||
$sent = $sock->send($message, $flags, $to);
|
||||
|
||||
Similar in functionality to L<perlfunc/send>.
|
||||
|
||||
Sends a message on a socket. Attempts to send the scalar message to the
|
||||
socket. Takes the same flags as the system call of the same name. On
|
||||
unconnected sockets, you must specify a destination to send to, in which case
|
||||
it does a C<sendto(2)> syscall. Returns the number of characters sent, or
|
||||
C<undef> on error. The C<sendmsg(2)> syscall is currently unimplemented.
|
||||
|
||||
The C<flags> option is optional and defaults to C<0>.
|
||||
|
||||
After a successful send with C<$to>, further calls to C<send> on an
|
||||
unconnected socket without C<$to> will send to the same address, and C<$to>
|
||||
will be used as the result of L<IO::Socket/"peername">.
|
||||
|
||||
B<Note:> In Perl v5.30 and newer, if the socket has been marked as C<:utf8>,
|
||||
C<send> will throw an exception. The C<:encoding(...)> layer implicitly
|
||||
introduces the C<:utf8> layer. See L<perlfunc/binmode>.
|
||||
|
||||
B<Note:> In Perl versions older than v5.30, depending on the status of the
|
||||
socket, either (8-bit) bytes or characters are sent. By default all
|
||||
sockets operate on bytes, but for example if the socket has been changed
|
||||
using L<perlfunc/binmode> to operate with the C<:encoding(UTF-8)> I/O layer
|
||||
(see the L<perlfunc/open> pragma), the I/O will operate on UTF8-encoded
|
||||
Unicode characters, not bytes. Similarly for the C<:encoding> layer: in
|
||||
that case pretty much any characters can be sent.
|
||||
|
||||
=head2 setsockopt
|
||||
|
||||
$sock->setsockopt(SOL_SOCKET, SO_REUSEADDR, 1);
|
||||
$sock->setsockopt(SOL_SOCKET, SO_RCVBUF, 64*1024);
|
||||
|
||||
Set option associated with the socket. Levels other than C<SOL_SOCKET>
|
||||
may be specified here. As a convenience, this method will convert a number
|
||||
into a packed byte buffer.
|
||||
|
||||
=head2 shutdown
|
||||
|
||||
$sock->shutdown(SHUT_RD); # we stopped reading data
|
||||
$sock->shutdown(SHUT_WR); # we stopped writing data
|
||||
$sock->shutdown(SHUT_RDWR); # we stopped using this socket
|
||||
|
||||
Shuts down a socket connection in the manner indicated by the value passed in,
|
||||
which has the same interpretation as in the syscall of the same name.
|
||||
|
||||
This is useful with sockets when you want to tell the other side you're done
|
||||
writing but not done reading, or vice versa. It's also a more insistent form
|
||||
of C<close> because it also disables the file descriptor in any
|
||||
forked copies in other processes.
|
||||
|
||||
Returns C<1> for success; on error, returns C<undef> if the socket is
|
||||
not a valid filehandle, or returns C<0> and sets C<$!> for any other failure.
|
||||
|
||||
=head2 sockdomain
|
||||
|
||||
my $domain = $sock->sockdomain();
|
||||
|
||||
Returns the number for the socket domain type. For example, for
|
||||
an C<AF_INET> socket the value of C<&AF_INET> will be returned.
|
||||
|
||||
=head2 socket
|
||||
|
||||
my $sock = IO::Socket->new(); # no values given
|
||||
# now let's actually get a socket with the socket method
|
||||
# domain, type, and protocol are required
|
||||
$sock = $sock->socket(AF_INET, SOCK_STREAM, 'tcp');
|
||||
|
||||
Opens a socket of the specified kind and returns it. Domain, type, and
|
||||
protocol are specified the same as for the syscall of the same name.
|
||||
|
||||
=head2 socketpair
|
||||
|
||||
my ($r, $w) = $sock->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
|
||||
($r, $w) = IO::Socket::UNIX
|
||||
->socketpair(AF_UNIX, SOCK_STREAM, PF_UNSPEC);
|
||||
|
||||
Will return a list of two sockets created (read and write), or an empty list
|
||||
on failure.
|
||||
|
||||
Differs slightly from C<socketpair> in L<perlfunc> in that the argument list
|
||||
is a bit simpler.
|
||||
|
||||
=head2 sockname
|
||||
|
||||
my $packed_addr = $sock->sockname();
|
||||
|
||||
Returns the packed C<sockaddr> address of this end of the connection. It's the
|
||||
same as C<getsockname(2)>.
|
||||
|
||||
=head2 sockopt
|
||||
|
||||
my $value = $sock->sockopt(SO_REUSEADDR);
|
||||
$sock->sockopt(SO_REUSEADDR, 1);
|
||||
|
||||
Unified method to both set and get options in the C<SOL_SOCKET> level. If
|
||||
called with one argument then L<IO::Socket/"getsockopt"> is called, otherwise
|
||||
L<IO::Socket/"setsockopt"> is called.
|
||||
|
||||
=head2 socktype
|
||||
|
||||
my $type = $sock->socktype();
|
||||
|
||||
Returns the number for the socket type. For example, for
|
||||
a C<SOCK_STREAM> socket the value of C<&SOCK_STREAM> will be returned.
|
||||
|
||||
=head2 timeout
|
||||
|
||||
my $seconds = $sock->timeout();
|
||||
my $old_val = $sock->timeout(5); # set new and return old value
|
||||
|
||||
Set or get the timeout value (in seconds) 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.
|
||||
|
||||
This method is available to all C<IO::Socket> implementations but may or may
|
||||
not be used by the individual domain subclasses.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
Let's create a TCP server on C<localhost:3333>.
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use feature 'say';
|
||||
|
||||
use IO::Socket qw(AF_INET AF_UNIX SOCK_STREAM SHUT_WR);
|
||||
|
||||
my $server = IO::Socket->new(
|
||||
Domain => AF_INET,
|
||||
Type => SOCK_STREAM,
|
||||
Proto => 'tcp',
|
||||
LocalHost => '0.0.0.0',
|
||||
LocalPort => 3333,
|
||||
ReusePort => 1,
|
||||
Listen => 5,
|
||||
) || die "Can't open socket: $IO::Socket::errstr";
|
||||
say "Waiting on 3333";
|
||||
|
||||
while (1) {
|
||||
# waiting for a new client connection
|
||||
my $client = $server->accept();
|
||||
|
||||
# get information about a newly connected client
|
||||
my $client_address = $client->peerhost();
|
||||
my $client_port = $client->peerport();
|
||||
say "Connection from $client_address:$client_port";
|
||||
|
||||
# read up to 1024 characters from the connected client
|
||||
my $data = "";
|
||||
$client->recv($data, 1024);
|
||||
say "received data: $data";
|
||||
|
||||
# write response data to the connected client
|
||||
$data = "ok";
|
||||
$client->send($data);
|
||||
|
||||
# notify client that response has been sent
|
||||
$client->shutdown(SHUT_WR);
|
||||
}
|
||||
|
||||
$server->close();
|
||||
|
||||
A client for such a server could be
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use feature 'say';
|
||||
|
||||
use IO::Socket qw(AF_INET AF_UNIX SOCK_STREAM SHUT_WR);
|
||||
|
||||
my $client = IO::Socket->new(
|
||||
Domain => AF_INET,
|
||||
Type => SOCK_STREAM,
|
||||
proto => 'tcp',
|
||||
PeerPort => 3333,
|
||||
PeerHost => '0.0.0.0',
|
||||
) || die "Can't open socket: $IO::Socket::errstr";
|
||||
|
||||
say "Sending Hello World!";
|
||||
my $size = $client->send("Hello World!");
|
||||
say "Sent data of length: $size";
|
||||
|
||||
$client->shutdown(SHUT_WR);
|
||||
|
||||
my $buffer;
|
||||
$client->recv($buffer, 1024);
|
||||
say "Got back $buffer";
|
||||
|
||||
$client->close();
|
||||
|
||||
|
||||
=head1 LIMITATIONS
|
||||
|
||||
On some systems, for an IO::Socket object created with C<new_from_fd>,
|
||||
or created with L<IO::Socket/"accept"> from such an object, the
|
||||
L<IO::Socket/"protocol">, L<IO::Socket/"sockdomain"> and
|
||||
L<IO::Socket/"socktype"> methods may return C<undef>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX>,
|
||||
L<IO::Socket::IP>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Graham Barr. atmark() by Lincoln Stein. Currently maintained by the Perl 5
|
||||
Porters. Please report all bugs at L<https://github.com/Perl/perl5/issues>.
|
||||
|
||||
=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
|
||||
471
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Socket/INET.pm
Normal file
471
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Socket/INET.pm
Normal file
|
|
@ -0,0 +1,471 @@
|
|||
# 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;
|
||||
use IO::Socket;
|
||||
use Socket;
|
||||
use Carp;
|
||||
use Exporter;
|
||||
use Errno;
|
||||
|
||||
our @ISA = qw(IO::Socket);
|
||||
our $VERSION = "1.55";
|
||||
|
||||
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
|
||||
);
|
||||
my %proto_number;
|
||||
$proto_number{tcp} = Socket::IPPROTO_TCP() if defined &Socket::IPPROTO_TCP;
|
||||
$proto_number{udp} = Socket::IPPROTO_UDP() if defined &Socket::IPPROTO_UDP;
|
||||
$proto_number{icmp} = Socket::IPPROTO_ICMP() if defined &Socket::IPPROTO_ICMP;
|
||||
my %proto_name = reverse %proto_number;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
unshift(@_, "PeerAddr") if @_ == 1;
|
||||
return $class->SUPER::new(@_);
|
||||
}
|
||||
|
||||
sub _cache_proto {
|
||||
my @proto = @_;
|
||||
for (map lc($_), $proto[0], split(' ', $proto[1])) {
|
||||
$proto_number{$_} = $proto[2];
|
||||
}
|
||||
$proto_name{$proto[2]} = $proto[0];
|
||||
}
|
||||
|
||||
sub _get_proto_number {
|
||||
my $name = lc(shift);
|
||||
return undef unless defined $name;
|
||||
return $proto_number{$name} if exists $proto_number{$name};
|
||||
|
||||
my @proto = eval { getprotobyname($name) };
|
||||
return undef unless @proto;
|
||||
_cache_proto(@proto);
|
||||
|
||||
return $proto[2];
|
||||
}
|
||||
|
||||
sub _get_proto_name {
|
||||
my $num = shift;
|
||||
return undef unless defined $num;
|
||||
return $proto_name{$num} if exists $proto_name{$num};
|
||||
|
||||
my @proto = eval { getprotobynumber($num) };
|
||||
return undef unless @proto;
|
||||
_cache_proto(@proto);
|
||||
|
||||
return $proto[0];
|
||||
}
|
||||
|
||||
sub _sock_info {
|
||||
my($addr,$port,$proto) = @_;
|
||||
my $origport = $port;
|
||||
my @serv = ();
|
||||
|
||||
$port = $1
|
||||
if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
|
||||
|
||||
if(defined $proto && $proto =~ /\D/) {
|
||||
my $num = _get_proto_number($proto);
|
||||
unless (defined $num) {
|
||||
$IO::Socket::errstr = $@ = "Bad protocol '$proto'";
|
||||
return;
|
||||
}
|
||||
$proto = $num;
|
||||
}
|
||||
|
||||
if(defined $port) {
|
||||
my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef;
|
||||
my $pnum = ($port =~ m,^(\d+)$,)[0];
|
||||
|
||||
@serv = getservbyname($port, _get_proto_name($proto) || "")
|
||||
if ($port =~ m,\D,);
|
||||
|
||||
$port = $serv[2] || $defport || $pnum;
|
||||
unless (defined $port) {
|
||||
$IO::Socket::errstr = $@ = "Bad service '$origport'";
|
||||
return;
|
||||
}
|
||||
|
||||
$proto = _get_proto_number($serv[3]) if @serv && !$proto;
|
||||
}
|
||||
|
||||
return ($addr || undef,
|
||||
$port || undef,
|
||||
$proto || undef
|
||||
);
|
||||
}
|
||||
|
||||
sub _error {
|
||||
my $sock = shift;
|
||||
my $err = shift;
|
||||
{
|
||||
local($!);
|
||||
my $title = ref($sock).": ";
|
||||
$IO::Socket::errstr = $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_);
|
||||
$sock->close()
|
||||
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 ||= _get_proto_number('tcp');
|
||||
|
||||
$type = $arg->{Type} || $socket_type{lc _get_proto_name($proto)};
|
||||
|
||||
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 L<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. If the C<Listen> argument is given, but false,
|
||||
the queue size will be set to 5.
|
||||
|
||||
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 : $IO::Socket::errstr\n";
|
||||
|
||||
If the constructor fails it will return C<undef> and set the
|
||||
C<$IO::Socket::errstr> package variable to contain an error message.
|
||||
|
||||
$sock = IO::Socket::INET->new(...)
|
||||
or die "Cannot create socket - $IO::Socket::errstr\n";
|
||||
|
||||
For legacy reasons the error message is also set into the global C<$@>
|
||||
variable, and you may still find older code which looks here instead.
|
||||
|
||||
$sock = IO::Socket::INET->new(...)
|
||||
or die "Cannot create socket - $@\n";
|
||||
|
||||
=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 at L<https://github.com/Perl/perl5/issues>.
|
||||
|
||||
=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
|
||||
173
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Socket/UNIX.pm
Normal file
173
OGP64/lib/perl5/5.40/x86_64-cygwin-threads/IO/Socket/UNIX.pm
Normal file
|
|
@ -0,0 +1,173 @@
|
|||
# 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;
|
||||
use IO::Socket;
|
||||
use Carp;
|
||||
|
||||
our @ISA = qw(IO::Socket);
|
||||
our $VERSION = "1.55";
|
||||
|
||||
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->{Blocking}) {
|
||||
$sock->blocking($arg->{Blocking}) 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;
|
||||
|
||||
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
|
||||
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 L<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 Queue size for listen
|
||||
|
||||
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.
|
||||
|
||||
If the constructor fails it will return C<undef> and set the
|
||||
C<$IO::Socket::errstr> package variable to contain an error message.
|
||||
|
||||
$sock = IO::Socket::UNIX->new(...)
|
||||
or die "Cannot create socket - $IO::Socket::errstr\n";
|
||||
|
||||
For legacy reasons the error message is also set into the global C<$@>
|
||||
variable, and you may still find older code which looks here instead.
|
||||
|
||||
$sock = IO::Socket::UNIX->new(...)
|
||||
or die "Cannot create socket - $@\n";
|
||||
|
||||
=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 at L<https://github.com/Perl/perl5/issues>.
|
||||
|
||||
=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
|
||||
Loading…
Add table
Add a link
Reference in a new issue