p147685/CardiacPhase
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Initial class construction

Browse Source
This commit is contained in:
João Narciso
2019-05-06 16:34:28 +02:00
parent 67f2d57e03
commit 431ff5f7d4
5813 changed files with 1622108 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

199
Git/usr/share/perl5/vendor_perl/IO/AtomicFile.pm Normal file
View File

@ -0,0 +1,199 @@
package IO::AtomicFile;
### DOCUMENTATION AT BOTTOM OF FILE
# Be strict:
use strict;
# External modules:
use IO::File;
#------------------------------
#
# GLOBALS...
#
#------------------------------
use vars qw($VERSION @ISA);
# The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = "2.111";
# Inheritance:
@ISA = qw(IO::File);
#------------------------------
# new ARGS...
#------------------------------
# Class method, constructor.
# Any arguments are sent to open().
#
sub new {
my $class = shift;
my $self = $class->SUPER::new();
${*$self}{'io_atomicfile_suffix'} = '';
$self->open(@_) if @_;
$self;
}
#------------------------------
# DESTROY
#------------------------------
# Destructor.
#
sub DESTROY {
shift->close(1); ### like close, but raises fatal exception on failure
}
#------------------------------
# open PATH, MODE
#------------------------------
# Class/instance method.
#
sub open {
my ($self, $path, $mode) = @_;
ref($self) or $self = $self->new; ### now we have an instance!
### Create tmp path, and remember this info:
my $temp = "${path}..TMP" . ${*$self}{'io_atomicfile_suffix'};
${*$self}{'io_atomicfile_temp'} = $temp;
${*$self}{'io_atomicfile_path'} = $path;
### Open the file! Returns filehandle on success, for use as a constructor:
$self->SUPER::open($temp, $mode) ? $self : undef;
}
#------------------------------
# _closed [YESNO]
#------------------------------
# Instance method, private.
# Are we already closed? Argument sets new value, returns previous one.
#
sub _closed {
my $self = shift;
my $oldval = ${*$self}{'io_atomicfile_closed'};
${*$self}{'io_atomicfile_closed'} = shift if @_;
$oldval;
}
#------------------------------
# close
#------------------------------
# Instance method.
# Close the handle, and rename the temp file to its final name.
#
sub close {
my ($self, $die) = @_;
unless ($self->_closed(1)) { ### sentinel...
if ($self->SUPER::close()) {
rename(${*$self}{'io_atomicfile_temp'},
${*$self}{'io_atomicfile_path'})
or ($die ? die "close (rename) atomic file: $!\n" : return undef);
} else {
($die ? die "close atomic file: $!\n" : return undef);
}
}
1;
}
#------------------------------
# delete
#------------------------------
# Instance method.
# Close the handle, and delete the temp file.
#
sub delete {
my $self = shift;
unless ($self->_closed(1)) { ### sentinel...
$self->SUPER::close();
return unlink(${*$self}{'io_atomicfile_temp'});
}
1;
}
#------------------------------
# detach
#------------------------------
# Instance method.
# Close the handle, but DO NOT delete the temp file.
#
sub detach {
my $self = shift;
$self->SUPER::close() unless ($self->_closed(1));
1;
}
#------------------------------
1;
__END__
=head1 NAME
IO::AtomicFile - write a file which is updated atomically
=head1 SYNOPSIS
use IO::AtomicFile;
### Write a temp file, and have it install itself when closed:
my $FH = IO::AtomicFile->open("bar.dat", "w");
print $FH "Hello!\n";
$FH->close || die "couldn't install atomic file: $!";
### Write a temp file, but delete it before it gets installed:
my $FH = IO::AtomicFile->open("bar.dat", "w");
print $FH "Hello!\n";
$FH->delete;
### Write a temp file, but neither install it nor delete it:
my $FH = IO::AtomicFile->open("bar.dat", "w");
print $FH "Hello!\n";
$FH->detach;
=head1 DESCRIPTION
This module is intended for people who need to update files
reliably in the face of unexpected program termination.
For example, you generally don't want to be halfway in the middle of
writing I</etc/passwd> and have your program terminate! Even
the act of writing a single scalar to a filehandle is I<not> atomic.
But this module gives you true atomic updates, via rename().
When you open a file I</foo/bar.dat> via this module, you are I<actually>
opening a temporary file I</foo/bar.dat..TMP>, and writing your
output there. The act of closing this file (either explicitly
via close(), or implicitly via the destruction of the object)
will cause rename() to be called... therefore, from the point
of view of the outside world, the file's contents are updated
in a single time quantum.
To ensure that problems do not go undetected, the "close" method
done by the destructor will raise a fatal exception if the rename()
fails. The explicit close() just returns undef.
You can also decide at any point to trash the file you've been
building.
=head1 AUTHOR
=head2 Primary Maintainer
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head2 Original Author
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head1 REVISION
$Revision: 1.2 $
=cut

301
Git/usr/share/perl5/vendor_perl/IO/InnerFile.pm Normal file
View File

@ -0,0 +1,301 @@
package IO::InnerFile;
=head1 NAME
IO::InnerFile - define a file inside another file
=head1 SYNOPSIS
### Read a subset of a file:
$inner = IO::InnerFile->new($fh, $start, $length);
while (<$inner>) {
...
}
=head1 DESCRIPTION
If you have a filehandle that can seek() and tell(), then you
can open an IO::InnerFile on a range of the underlying file.
=head1 PUBLIC INTERFACE
=over
=cut
use Symbol;
# The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = "2.111";
#------------------------------
=item new FILEHANDLE, [START, [LENGTH]]
I<Class method, constructor.>
Create a new inner-file opened on the given FILEHANDLE,
from bytes START to START+LENGTH. Both START and LENGTH
default to 0; negative values are silently coerced to zero.
Note that FILEHANDLE must be able to seek() and tell(), in addition
to whatever other methods you may desire for reading it.
=cut
sub new {
my ($class, $fh, $start, $lg) = @_;
$start = 0 if (!$start or ($start < 0));
$lg = 0 if (!$lg or ($lg < 0));
### Create the underlying "object":
my $a = {
FH => $fh,
CRPOS => 0,
START => $start,
LG => $lg,
};
### Create a new filehandle tied to this object:
$fh = gensym;
tie(*$fh, $class, $a);
return bless($fh, $class);
}
sub TIEHANDLE {
my ($class, $data) = @_;
return bless($data, $class);
}
sub DESTROY {
my ($self) = @_;
$self->close() if (ref($self) eq 'SCALAR');
}
#------------------------------
=item set_length LENGTH
=item get_length
=item add_length NBYTES
I<Instance methods.>
Get/set the virtual length of the inner file.
=cut
sub set_length { tied(${$_[0]})->{LG} = $_[1]; }
sub get_length { tied(${$_[0]})->{LG}; }
sub add_length { tied(${$_[0]})->{LG} += $_[1]; }
#------------------------------
=item set_start START
=item get_start
=item add_start NBYTES
I<Instance methods.>
Get/set the virtual start position of the inner file.
=cut
sub set_start { tied(${$_[0]})->{START} = $_[1]; }
sub get_start { tied(${$_[0]})->{START}; }
sub set_end { tied(${$_[0]})->{LG} = $_[1] - tied(${$_[0]})->{START}; }
sub get_end { tied(${$_[0]})->{LG} + tied(${$_[0]})->{START}; }
#------------------------------
=item binmode
=item close
=item flush
=item getc
=item getline
=item print LIST
=item printf LIST
=item read BUF, NBYTES
=item readline
=item seek OFFFSET, WHENCE
=item tell
=item write ARGS...
I<Instance methods.>
Standard filehandle methods.
=cut
sub write { shift->WRITE(@_) }
sub print { shift->PRINT(@_) }
sub printf { shift->PRINTF(@_) }
sub flush { "0 but true"; }
sub fileno { }
sub binmode { 1; }
sub getc { return GETC(tied(${$_[0]}) ); }
sub read { return READ( tied(${$_[0]}), @_[1,2,3] ); }
sub readline { return READLINE( tied(${$_[0]}) ); }
sub getline { return READLINE( tied(${$_[0]}) ); }
sub close { return CLOSE(tied(${$_[0]}) ); }
sub seek {
my ($self, $ofs, $whence) = @_;
$self = tied( $$self );
$self->{CRPOS} = $ofs if ($whence == 0);
$self->{CRPOS}+= $ofs if ($whence == 1);
$self->{CRPOS} = $self->{LG} + $ofs if ($whence == 2);
$self->{CRPOS} = 0 if ($self->{CRPOS} < 0);
$self->{CRPOS} = $self->{LG} if ($self->{CRPOS} > $self->{LG});
return 1;
}
sub tell {
return tied(${$_[0]})->{CRPOS};
}
sub WRITE {
die "inner files can only open for reading\n";
}
sub PRINT {
die "inner files can only open for reading\n";
}
sub PRINTF {
die "inner files can only open for reading\n";
}
sub GETC {
my ($self) = @_;
return 0 if ($self->{CRPOS} >= $self->{LG});
my $data;
### Save and seek...
my $old_pos = $self->{FH}->tell;
$self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
### ...read...
my $lg = $self->{FH}->read($data, 1);
$self->{CRPOS} += $lg;
### ...and restore:
$self->{FH}->seek($old_pos, 0);
$self->{LG} = $self->{CRPOS} unless ($lg);
return ($lg ? $data : undef);
}
sub READ {
my ($self, $undefined, $lg, $ofs) = @_;
$undefined = undef;
return 0 if ($self->{CRPOS} >= $self->{LG});
$lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
return 0 unless ($lg);
### Save and seek...
my $old_pos = $self->{FH}->tell;
$self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
### ...read...
$lg = $self->{FH}->read($_[1], $lg, $_[3] );
$self->{CRPOS} += $lg;
### ...and restore:
$self->{FH}->seek($old_pos, 0);
$self->{LG} = $self->{CRPOS} unless ($lg);
return $lg;
}
sub READLINE {
my ($self) = @_;
return $self->_readline_helper() unless wantarray;
my @arr;
while(defined(my $line = $self->_readline_helper())) {
push(@arr, $line);
}
return @arr;
}
sub _readline_helper {
my ($self) = @_;
return undef if ($self->{CRPOS} >= $self->{LG});
# Handle slurp mode (CPAN ticket #72710)
if (! defined($/)) {
my $text;
$self->READ($text, $self->{LG} - $self->{CRPOS});
return $text;
}
### Save and seek...
my $old_pos = $self->{FH}->tell;
$self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
### ...read...
my $text = $self->{FH}->getline;
### ...and restore:
$self->{FH}->seek($old_pos, 0);
#### If we detected a new EOF ...
unless (defined $text) {
$self->{LG} = $self->{CRPOS};
return undef;
}
my $lg=length($text);
$lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
$self->{CRPOS} += $lg;
return substr($text, 0,$lg);
}
sub CLOSE { %{$_[0]}=(); }
1;
__END__
=back
=head1 VERSION
$Id: InnerFile.pm,v 1.4 2005/02/10 21:21:53 dfs Exp $
=head1 AUTHOR
Original version by Doru Petrescu (pdoru@kappa.ro).
Documentation and by Eryq (eryq@zeegee.com).
Currently maintained by Dianne Skoll (dfs@roaringpenguin.com).
=cut

184
Git/usr/share/perl5/vendor_perl/IO/Lines.pm Normal file
View File

@ -0,0 +1,184 @@
package IO::Lines;
=head1 NAME
IO::Lines - IO:: interface for reading/writing an array of lines
=head1 SYNOPSIS
use IO::Lines;
### See IO::ScalarArray for details
=head1 DESCRIPTION
This class implements objects which behave just like FileHandle
(or IO::Handle) objects, except that you may use them to write to
(or read from) an array of lines. They can be tiehandle'd as well.
This is a subclass of L<IO::ScalarArray|IO::ScalarArray>
in which the underlying
array has its data stored in a line-oriented-format: that is,
every element ends in a C<"\n">, with the possible exception of the
final element. This makes C<getline()> I<much> more efficient;
if you plan to do line-oriented reading/printing, you want this class.
The C<print()> method will enforce this rule, so you can print
arbitrary data to the line-array: it will break the data at
newlines appropriately.
See L<IO::ScalarArray> for full usage and warnings.
=cut
use Carp;
use strict;
use IO::ScalarArray;
use vars qw($VERSION @ISA);
# The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = "2.111";
# Inheritance:
@ISA = qw(IO::ScalarArray); ### also gets us new_tie :-)
#------------------------------
#
# getline
#
# Instance method, override.
# Return the next line, or undef on end of data.
# Can safely be called in an array context.
# Currently, lines are delimited by "\n".
#
sub getline {
my $self = shift;
if (!defined $/) {
return join( '', $self->_getlines_for_newlines );
}
elsif ($/ eq "\n") {
if (!*$self->{Pos}) { ### full line...
return *$self->{AR}[*$self->{Str}++];
}
else { ### partial line...
my $partial = substr(*$self->{AR}[*$self->{Str}++], *$self->{Pos});
*$self->{Pos} = 0;
return $partial;
}
}
else {
croak 'unsupported $/: must be "\n" or undef';
}
}
#------------------------------
#
# getlines
#
# Instance method, override.
# Return an array comprised of the remaining lines, or () on end of data.
# Must be called in an array context.
# Currently, lines are delimited by "\n".
#
sub getlines {
my $self = shift;
wantarray or croak("can't call getlines in scalar context!");
if ((defined $/) and ($/ eq "\n")) {
return $self->_getlines_for_newlines(@_);
}
else { ### slow but steady
return $self->SUPER::getlines(@_);
}
}
#------------------------------
#
# _getlines_for_newlines
#
# Instance method, private.
# If $/ is newline, do fast getlines.
# This CAN NOT invoke getline!
#
sub _getlines_for_newlines {
my $self = shift;
my ($rArray, $Str, $Pos) = @{*$self}{ qw( AR Str Pos ) };
my @partial = ();
if ($Pos) { ### partial line...
@partial = (substr( $rArray->[ $Str++ ], $Pos ));
*$self->{Pos} = 0;
}
*$self->{Str} = scalar @$rArray; ### about to exhaust @$rArray
return (@partial,
@$rArray[ $Str .. $#$rArray ]); ### remaining full lines...
}
#------------------------------
#
# print ARGS...
#
# Instance method, override.
# Print ARGS to the underlying line array.
#
sub print {
if (defined $\ && $\ ne "\n") {
croak 'unsupported $\: must be "\n" or undef';
}
my $self = shift;
### print STDERR "\n[[ARRAY WAS...\n", @{*$self->{AR}}, "<<EOF>>\n";
my @lines = split /^/, join('', @_); @lines or return 1;
### Did the previous print not end with a newline?
### If so, append first line:
if (@{*$self->{AR}} and (*$self->{AR}[-1] !~ /\n\Z/)) {
*$self->{AR}[-1] .= shift @lines;
}
push @{*$self->{AR}}, @lines; ### add the remainder
### print STDERR "\n[[ARRAY IS NOW...\n", @{*$self->{AR}}, "<<EOF>>\n";
1;
}
#------------------------------
1;
__END__
=head1 VERSION
$Id: Lines.pm,v 1.3 2005/02/10 21:21:53 dfs Exp $
=head1 AUTHORS
=head2 Primary Maintainer
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head2 Principal author
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head2 Other contributors
Thanks to the following individuals for their invaluable contributions
(if I've forgotten or misspelled your name, please email me!):
I<Morris M. Siegel,>
for his $/ patch and the new C<getlines()>.
I<Doug Wilson,>
for the IO::Handle inheritance and automatic tie-ing.
=cut

790
Git/usr/share/perl5/vendor_perl/IO/Scalar.pm Normal file
View File

@ -0,0 +1,790 @@
package IO::Scalar;
=head1 NAME
IO::Scalar - IO:: interface for reading/writing a scalar
=head1 SYNOPSIS
Perform I/O on strings, using the basic OO interface...
use 5.005;
use IO::Scalar;
$data = "My message:\n";
### Open a handle on a string, and append to it:
$SH = new IO::Scalar \$data;
$SH->print("Hello");
$SH->print(", world!\nBye now!\n");
print "The string is now: ", $data, "\n";
### Open a handle on a string, read it line-by-line, then close it:
$SH = new IO::Scalar \$data;
while (defined($_ = $SH->getline)) {
print "Got line: $_";
}
$SH->close;
### Open a handle on a string, and slurp in all the lines:
$SH = new IO::Scalar \$data;
print "All lines:\n", $SH->getlines;
### Get the current position (either of two ways):
$pos = $SH->getpos;
$offset = $SH->tell;
### Set the current position (either of two ways):
$SH->setpos($pos);
$SH->seek($offset, 0);
### Open an anonymous temporary scalar:
$SH = new IO::Scalar;
$SH->print("Hi there!");
print "I printed: ", ${$SH->sref}, "\n"; ### get at value
Don't like OO for your I/O? No problem.
Thanks to the magic of an invisible tie(), the following now
works out of the box, just as it does with IO::Handle:
use 5.005;
use IO::Scalar;
$data = "My message:\n";
### Open a handle on a string, and append to it:
$SH = new IO::Scalar \$data;
print $SH "Hello";
print $SH ", world!\nBye now!\n";
print "The string is now: ", $data, "\n";
### Open a handle on a string, read it line-by-line, then close it:
$SH = new IO::Scalar \$data;
while (<$SH>) {
print "Got line: $_";
}
close $SH;
### Open a handle on a string, and slurp in all the lines:
$SH = new IO::Scalar \$data;
print "All lines:\n", <$SH>;
### Get the current position (WARNING: requires 5.6):
$offset = tell $SH;
### Set the current position (WARNING: requires 5.6):
seek $SH, $offset, 0;
### Open an anonymous temporary scalar:
$SH = new IO::Scalar;
print $SH "Hi there!";
print "I printed: ", ${$SH->sref}, "\n"; ### get at value
And for you folks with 1.x code out there: the old tie() style still works,
though this is I<unnecessary and deprecated>:
use IO::Scalar;
### Writing to a scalar...
my $s;
tie *OUT, 'IO::Scalar', \$s;
print OUT "line 1\nline 2\n", "line 3\n";
print "String is now: $s\n"
### Reading and writing an anonymous scalar...
tie *OUT, 'IO::Scalar';
print OUT "line 1\nline 2\n", "line 3\n";
tied(OUT)->seek(0,0);
while (<OUT>) {
print "Got line: ", $_;
}
Stringification works, too!
my $SH = new IO::Scalar \$data;
print $SH "Hello, ";
print $SH "world!";
print "I printed: $SH\n";
=head1 DESCRIPTION
This class is part of the IO::Stringy distribution;
see L<IO::Stringy> for change log and general information.
The IO::Scalar class implements objects which behave just like
IO::Handle (or FileHandle) objects, except that you may use them
to write to (or read from) scalars. These handles are
automatically tiehandle'd (though please see L<"WARNINGS">
for information relevant to your Perl version).
Basically, this:
my $s;
$SH = new IO::Scalar \$s;
$SH->print("Hel", "lo, "); ### OO style
$SH->print("world!\n"); ### ditto
Or this:
my $s;
$SH = tie *OUT, 'IO::Scalar', \$s;
print OUT "Hel", "lo, "; ### non-OO style
print OUT "world!\n"; ### ditto
Causes $s to be set to:
"Hello, world!\n"
=head1 PUBLIC INTERFACE
=cut
use Carp;
use strict;
use vars qw($VERSION @ISA);
use IO::Handle;
use 5.005;
### Stringification, courtesy of B. K. Oxley (binkley): :-)
use overload '""' => sub { ${*{$_[0]}->{SR}} };
use overload 'bool' => sub { 1 }; ### have to do this, so object is true!
### The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = "2.111";
### Inheritance:
@ISA = qw(IO::Handle);
### This stuff should be got rid of ASAP.
require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
#==============================
=head2 Construction
=over 4
=cut
#------------------------------
=item new [ARGS...]
I<Class method.>
Return a new, unattached scalar handle.
If any arguments are given, they're sent to open().
=cut
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = bless \do { local *FH }, $class;
tie *$self, $class, $self;
$self->open(@_); ### open on anonymous by default
$self;
}
sub DESTROY {
shift->close;
}
#------------------------------
=item open [SCALARREF]
I<Instance method.>
Open the scalar handle on a new scalar, pointed to by SCALARREF.
If no SCALARREF is given, a "private" scalar is created to hold
the file data.
Returns the self object on success, undefined on error.
=cut
sub open {
my ($self, $sref) = @_;
### Sanity:
defined($sref) or do {my $s = ''; $sref = \$s};
(ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";
### Setup:
*$self->{Pos} = 0; ### seek position
*$self->{SR} = $sref; ### scalar reference
$self;
}
#------------------------------
=item opened
I<Instance method.>
Is the scalar handle opened on something?
=cut
sub opened {
*{shift()}->{SR};
}
#------------------------------
=item close
I<Instance method.>
Disassociate the scalar handle from its underlying scalar.
Done automatically on destroy.
=cut
sub close {
my $self = shift;
%{*$self} = ();
1;
}
=back
=cut
#==============================
=head2 Input and output
=over 4
=cut
#------------------------------
=item flush
I<Instance method.>
No-op, provided for OO compatibility.
=cut
sub flush { "0 but true" }
#------------------------------
=item fileno
I<Instance method.>
No-op, returns undef
=cut
sub fileno { }
#------------------------------
=item getc
I<Instance method.>
Return the next character, or undef if none remain.
=cut
sub getc {
my $self = shift;
### Return undef right away if at EOF; else, move pos forward:
return undef if $self->eof;
substr(${*$self->{SR}}, *$self->{Pos}++, 1);
}
#------------------------------
=item getline
I<Instance method.>
Return the next line, or undef on end of string.
Can safely be called in an array context.
Currently, lines are delimited by "\n".
=cut
sub getline {
my $self = shift;
### Return undef right away if at EOF:
return undef if $self->eof;
### Get next line:
my $sr = *$self->{SR};
my $i = *$self->{Pos}; ### Start matching at this point.
### Minimal impact implementation!
### We do the fast thing (no regexps) if using the
### classic input record separator.
### Case 1: $/ is undef: slurp all...
if (!defined($/)) {
*$self->{Pos} = length $$sr;
return substr($$sr, $i);
}
### Case 2: $/ is "\n": zoom zoom zoom...
elsif ($/ eq "\012") {
### Seek ahead for "\n"... yes, this really is faster than regexps.
my $len = length($$sr);
for (; $i < $len; ++$i) {
last if ord (substr ($$sr, $i, 1)) == 10;
}
### Extract the line:
my $line;
if ($i < $len) { ### We found a "\n":
$line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
*$self->{Pos} = $i+1; ### Remember where we finished up.
}
else { ### No "\n"; slurp the remainder:
$line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
*$self->{Pos} = $len;
}
return $line;
}
### Case 3: $/ is ref to int. Do fixed-size records.
### (Thanks to Dominique Quatravaux.)
elsif (ref($/)) {
my $len = length($$sr);
my $i = ${$/} + 0;
my $line = substr ($$sr, *$self->{Pos}, $i);
*$self->{Pos} += $i;
*$self->{Pos} = $len if (*$self->{Pos} > $len);
return $line;
}
### Case 4: $/ is either "" (paragraphs) or something weird...
### This is Graham's general-purpose stuff, which might be
### a tad slower than Case 2 for typical data, because
### of the regexps.
else {
pos($$sr) = $i;
### If in paragraph mode, skip leading lines (and update i!):
length($/) or
(($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));
### If we see the separator in the buffer ahead...
if (length($/)
? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp!
: $$sr =~ m,\n\n,g ### (a paragraph)
) {
*$self->{Pos} = pos $$sr;
return substr($$sr, $i, *$self->{Pos}-$i);
}
### Else if no separator remains, just slurp the rest:
else {
*$self->{Pos} = length $$sr;
return substr($$sr, $i);
}
}
}
#------------------------------
=item getlines
I<Instance method.>
Get all remaining lines.
It will croak() if accidentally called in a scalar context.
=cut
sub getlines {
my $self = shift;
wantarray or croak("can't call getlines in scalar context!");
my ($line, @lines);
push @lines, $line while (defined($line = $self->getline));
@lines;
}
#------------------------------
=item print ARGS...
I<Instance method.>
Print ARGS to the underlying scalar.
B<Warning:> this continues to always cause a seek to the end
of the string, but if you perform seek()s and tell()s, it is
still safer to explicitly seek-to-end before subsequent print()s.
=cut
sub print {
my $self = shift;
*$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
1;
}
sub _unsafe_print {
my $self = shift;
my $append = join('', @_) . $\;
${*$self->{SR}} .= $append;
*$self->{Pos} += length($append);
1;
}
sub _old_print {
my $self = shift;
${*$self->{SR}} .= join('', @_) . $\;
*$self->{Pos} = length(${*$self->{SR}});
1;
}
#------------------------------
=item read BUF, NBYTES, [OFFSET]
I<Instance method.>
Read some bytes from the scalar.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.
=cut
sub read {
my $self = $_[0];
my $n = $_[2];
my $off = $_[3] || 0;
my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
$n = length($read);
*$self->{Pos} += $n;
($off ? substr($_[1], $off) : $_[1]) = $read;
return $n;
}
#------------------------------
=item write BUF, NBYTES, [OFFSET]
I<Instance method.>
Write some bytes to the scalar.
=cut
sub write {
my $self = $_[0];
my $n = $_[2];
my $off = $_[3] || 0;
my $data = substr($_[1], $off, $n);
$n = length($data);
$self->print($data);
return $n;
}
#------------------------------
=item sysread BUF, LEN, [OFFSET]
I<Instance method.>
Read some bytes from the scalar.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.
=cut
sub sysread {
my $self = shift;
$self->read(@_);
}
#------------------------------
=item syswrite BUF, NBYTES, [OFFSET]
I<Instance method.>
Write some bytes to the scalar.
=cut
sub syswrite {
my $self = shift;
$self->write(@_);
}
=back
=cut
#==============================
=head2 Seeking/telling and other attributes
=over 4
=cut
#------------------------------
=item autoflush
I<Instance method.>
No-op, provided for OO compatibility.
=cut
sub autoflush {}
#------------------------------
=item binmode
I<Instance method.>
No-op, provided for OO compatibility.
=cut
sub binmode {}
#------------------------------
=item clearerr
I<Instance method.> Clear the error and EOF flags. A no-op.
=cut
sub clearerr { 1 }
#------------------------------
=item eof
I<Instance method.> Are we at end of file?
=cut
sub eof {
my $self = shift;
(*$self->{Pos} >= length(${*$self->{SR}}));
}
#------------------------------
=item seek OFFSET, WHENCE
I<Instance method.> Seek to a given position in the stream.
=cut
sub seek {
my ($self, $pos, $whence) = @_;
my $eofpos = length(${*$self->{SR}});
### Seek:
if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET
elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR
elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END
else { croak "bad seek whence ($whence)" }
### Fixup:
if (*$self->{Pos} < 0) { *$self->{Pos} = 0 }
if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
return 1;
}
#------------------------------
=item sysseek OFFSET, WHENCE
I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.>
=cut
sub sysseek {
my $self = shift;
$self->seek (@_);
}
#------------------------------
=item tell
I<Instance method.>
Return the current position in the stream, as a numeric offset.
=cut
sub tell { *{shift()}->{Pos} }
#------------------------------
#
# use_RS [YESNO]
#
# I<Instance method.>
# Obey the current setting of $/, like IO::Handle does?
# Default is false in 1.x, but cold-welded true in 2.x and later.
#
sub use_RS {
my ($self, $yesno) = @_;
carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
}
#------------------------------
=item setpos POS
I<Instance method.>
Set the current position, using the opaque value returned by C<getpos()>.
=cut
sub setpos { shift->seek($_[0],0) }
#------------------------------
=item getpos
I<Instance method.>
Return the current position in the string, as an opaque object.
=cut
*getpos = \&tell;
#------------------------------
=item sref
I<Instance method.>
Return a reference to the underlying scalar.
=cut
sub sref { *{shift()}->{SR} }
#------------------------------
# Tied handle methods...
#------------------------------
# Conventional tiehandle interface:
sub TIEHANDLE {
((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar"))
? $_[1]
: shift->new(@_));
}
sub GETC { shift->getc(@_) }
sub PRINT { shift->print(@_) }
sub PRINTF { shift->print(sprintf(shift, @_)) }
sub READ { shift->read(@_) }
sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
sub WRITE { shift->write(@_); }
sub CLOSE { shift->close(@_); }
sub SEEK { shift->seek(@_); }
sub TELL { shift->tell(@_); }
sub EOF { shift->eof(@_); }
sub BINMODE { 1; }
#------------------------------------------------------------
1;
__END__
=back
=cut
=head1 WARNINGS
Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
it was missing support for C<seek()>, C<tell()>, and C<eof()>.
Attempting to use these functions with an IO::Scalar will not work
prior to 5.005_57. IO::Scalar will not have the relevant methods
invoked; and even worse, this kind of bug can lie dormant for a while.
If you turn warnings on (via C<$^W> or C<perl -w>),
and you see something like this...
attempt to seek on unopened filehandle
...then you are probably trying to use one of these functions
on an IO::Scalar with an old Perl. The remedy is to simply
use the OO version; e.g.:
$SH->seek(0,0); ### GOOD: will work on any 5.005
seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond
=head1 VERSION
$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $
=head1 AUTHORS
=head2 Primary Maintainer
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head2 Principal author
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head2 Other contributors
The full set of contributors always includes the folks mentioned
in L<IO::Stringy/"CHANGE LOG">. But just the same, special
thanks to the following individuals for their invaluable contributions
(if I've forgotten or misspelled your name, please email me!):
I<Andy Glew,>
for contributing C<getc()>.
I<Brandon Browning,>
for suggesting C<opened()>.
I<David Richter,>
for finding and fixing the bug in C<PRINTF()>.
I<Eric L. Brine,>
for his offset-using read() and write() implementations.
I<Richard Jones,>
for his patches to massively improve the performance of C<getline()>
and add C<sysread> and C<syswrite>.
I<B. K. Oxley (binkley),>
for stringification and inheritance improvements,
and sundry good ideas.
I<Doug Wilson,>
for the IO::Handle inheritance and automatic tie-ing.
=head1 SEE ALSO
L<IO::String>, which is quite similar but which was designed
more-recently and with an IO::Handle-like interface in mind,
so you could mix OO- and native-filehandle usage without using tied().
I<Note:> as of version 2.x, these classes all work like
their IO::Handle counterparts, so we have comparable
functionality to IO::String.
=cut

803
Git/usr/share/perl5/vendor_perl/IO/ScalarArray.pm Normal file
View File

@ -0,0 +1,803 @@
package IO::ScalarArray;
=head1 NAME
IO::ScalarArray - IO:: interface for reading/writing an array of scalars
=head1 SYNOPSIS
Perform I/O on strings, using the basic OO interface...
use IO::ScalarArray;
@data = ("My mes", "sage:\n");
### Open a handle on an array, and append to it:
$AH = new IO::ScalarArray \@data;
$AH->print("Hello");
$AH->print(", world!\nBye now!\n");
print "The array is now: ", @data, "\n";
### Open a handle on an array, read it line-by-line, then close it:
$AH = new IO::ScalarArray \@data;
while (defined($_ = $AH->getline)) {
print "Got line: $_";
}
$AH->close;
### Open a handle on an array, and slurp in all the lines:
$AH = new IO::ScalarArray \@data;
print "All lines:\n", $AH->getlines;
### Get the current position (either of two ways):
$pos = $AH->getpos;
$offset = $AH->tell;
### Set the current position (either of two ways):
$AH->setpos($pos);
$AH->seek($offset, 0);
### Open an anonymous temporary array:
$AH = new IO::ScalarArray;
$AH->print("Hi there!");
print "I printed: ", @{$AH->aref}, "\n"; ### get at value
Don't like OO for your I/O? No problem.
Thanks to the magic of an invisible tie(), the following now
works out of the box, just as it does with IO::Handle:
use IO::ScalarArray;
@data = ("My mes", "sage:\n");
### Open a handle on an array, and append to it:
$AH = new IO::ScalarArray \@data;
print $AH "Hello";
print $AH ", world!\nBye now!\n";
print "The array is now: ", @data, "\n";
### Open a handle on a string, read it line-by-line, then close it:
$AH = new IO::ScalarArray \@data;
while (<$AH>) {
print "Got line: $_";
}
close $AH;
### Open a handle on a string, and slurp in all the lines:
$AH = new IO::ScalarArray \@data;
print "All lines:\n", <$AH>;
### Get the current position (WARNING: requires 5.6):
$offset = tell $AH;
### Set the current position (WARNING: requires 5.6):
seek $AH, $offset, 0;
### Open an anonymous temporary scalar:
$AH = new IO::ScalarArray;
print $AH "Hi there!";
print "I printed: ", @{$AH->aref}, "\n"; ### get at value
And for you folks with 1.x code out there: the old tie() style still works,
though this is I<unnecessary and deprecated>:
use IO::ScalarArray;
### Writing to a scalar...
my @a;
tie *OUT, 'IO::ScalarArray', \@a;
print OUT "line 1\nline 2\n", "line 3\n";
print "Array is now: ", @a, "\n"
### Reading and writing an anonymous scalar...
tie *OUT, 'IO::ScalarArray';
print OUT "line 1\nline 2\n", "line 3\n";
tied(OUT)->seek(0,0);
while (<OUT>) {
print "Got line: ", $_;
}
=head1 DESCRIPTION
This class is part of the IO::Stringy distribution;
see L<IO::Stringy> for change log and general information.
The IO::ScalarArray class implements objects which behave just like
IO::Handle (or FileHandle) objects, except that you may use them
to write to (or read from) arrays of scalars. Logically, an
array of scalars defines an in-core "file" whose contents are
the concatenation of the scalars in the array. The handles created by
this class are automatically tiehandle'd (though please see L<"WARNINGS">
for information relevant to your Perl version).
For writing large amounts of data with individual print() statements,
this class is likely to be more efficient than IO::Scalar.
Basically, this:
my @a;
$AH = new IO::ScalarArray \@a;
$AH->print("Hel", "lo, "); ### OO style
$AH->print("world!\n"); ### ditto
Or this:
my @a;
$AH = new IO::ScalarArray \@a;
print $AH "Hel", "lo, "; ### non-OO style
print $AH "world!\n"; ### ditto
Causes @a to be set to the following array of 3 strings:
( "Hel" ,
"lo, " ,
"world!\n" )
See L<IO::Scalar> and compare with this class.
=head1 PUBLIC INTERFACE
=cut
use Carp;
use strict;
use vars qw($VERSION @ISA);
use IO::Handle;
# The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = "2.111";
# Inheritance:
@ISA = qw(IO::Handle);
require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
#==============================
=head2 Construction
=over 4
=cut
#------------------------------
=item new [ARGS...]
I<Class method.>
Return a new, unattached array handle.
If any arguments are given, they're sent to open().
=cut
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = bless \do { local *FH }, $class;
tie *$self, $class, $self;
$self->open(@_); ### open on anonymous by default
$self;
}
sub DESTROY {
shift->close;
}
#------------------------------
=item open [ARRAYREF]
I<Instance method.>
Open the array handle on a new array, pointed to by ARRAYREF.
If no ARRAYREF is given, a "private" array is created to hold
the file data.
Returns the self object on success, undefined on error.
=cut
sub open {
my ($self, $aref) = @_;
### Sanity:
defined($aref) or do {my @a; $aref = \@a};
(ref($aref) eq "ARRAY") or croak "open needs a ref to a array";
### Setup:
$self->setpos([0,0]);
*$self->{AR} = $aref;
$self;
}
#------------------------------
=item opened
I<Instance method.>
Is the array handle opened on something?
=cut
sub opened {
*{shift()}->{AR};
}
#------------------------------
=item close
I<Instance method.>
Disassociate the array handle from its underlying array.
Done automatically on destroy.
=cut
sub close {
my $self = shift;
%{*$self} = ();
1;
}
=back
=cut
#==============================
=head2 Input and output
=over 4
=cut
#------------------------------
=item flush
I<Instance method.>
No-op, provided for OO compatibility.
=cut
sub flush { "0 but true" }
#------------------------------
=item fileno
I<Instance method.>
No-op, returns undef
=cut
sub fileno { }
#------------------------------
=item getc
I<Instance method.>
Return the next character, or undef if none remain.
This does a read(1), which is somewhat costly.
=cut
sub getc {
my $buf = '';
($_[0]->read($buf, 1) ? $buf : undef);
}
#------------------------------
=item getline
I<Instance method.>
Return the next line, or undef on end of data.
Can safely be called in an array context.
Currently, lines are delimited by "\n".
=cut
sub getline {
my $self = shift;
my ($str, $line) = (undef, '');
### Minimal impact implementation!
### We do the fast thing (no regexps) if using the
### classic input record separator.
### Case 1: $/ is undef: slurp all...
if (!defined($/)) {
return undef if ($self->eof);
### Get the rest of the current string, followed by remaining strings:
my $ar = *$self->{AR};
my @slurp = (
substr($ar->[*$self->{Str}], *$self->{Pos}),
@$ar[(1 + *$self->{Str}) .. $#$ar ]
);
### Seek to end:
$self->_setpos_to_eof;
return join('', @slurp);
}
### Case 2: $/ is "\n":
elsif ($/ eq "\012") {
### Until we hit EOF (or exited because of a found line):
until ($self->eof) {
### If at end of current string, go fwd to next one (won't be EOF):
if ($self->_eos) {++*$self->{Str}, *$self->{Pos}=0};
### Get ref to current string in array, and set internal pos mark:
$str = \(*$self->{AR}[*$self->{Str}]); ### get current string
pos($$str) = *$self->{Pos}; ### start matching from here
### Get from here to either \n or end of string, and add to line:
$$str =~ m/\G(.*?)((\n)|\Z)/g; ### match to 1st \n or EOS
$line .= $1.$2; ### add it
*$self->{Pos} += length($1.$2); ### move fwd by len matched
return $line if $3; ### done, got line with "\n"
}
return ($line eq '') ? undef : $line; ### return undef if EOF
}
### Case 3: $/ is ref to int. Bail out.
elsif (ref($/)) {
croak '$/ given as a ref to int; currently unsupported';
}
### Case 4: $/ is either "" (paragraphs) or something weird...
### Bail for now.
else {
croak '$/ as given is currently unsupported';
}
}
#------------------------------
=item getlines
I<Instance method.>
Get all remaining lines.
It will croak() if accidentally called in a scalar context.
=cut
sub getlines {
my $self = shift;
wantarray or croak("can't call getlines in scalar context!");
my ($line, @lines);
push @lines, $line while (defined($line = $self->getline));
@lines;
}
#------------------------------
=item print ARGS...
I<Instance method.>
Print ARGS to the underlying array.
Currently, this always causes a "seek to the end of the array"
and generates a new array entry. This may change in the future.
=cut
sub print {
my $self = shift;
push @{*$self->{AR}}, join('', @_) . (defined($\) ? $\ : ""); ### add the data
$self->_setpos_to_eof;
1;
}
#------------------------------
=item read BUF, NBYTES, [OFFSET];
I<Instance method.>
Read some bytes from the array.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.
=cut
sub read {
my $self = $_[0];
### we must use $_[1] as a ref
my $n = $_[2];
my $off = $_[3] || 0;
### print "getline\n";
my $justread;
my $len;
($off ? substr($_[1], $off) : $_[1]) = '';
### Stop when we have zero bytes to go, or when we hit EOF:
my @got;
until (!$n or $self->eof) {
### If at end of current string, go forward to next one (won't be EOF):
if ($self->_eos) {
++*$self->{Str};
*$self->{Pos} = 0;
}
### Get longest possible desired substring of current string:
$justread = substr(*$self->{AR}[*$self->{Str}], *$self->{Pos}, $n);
$len = length($justread);
push @got, $justread;
$n -= $len;
*$self->{Pos} += $len;
}
$_[1] .= join('', @got);
return length($_[1])-$off;
}
#------------------------------
=item write BUF, NBYTES, [OFFSET];
I<Instance method.>
Write some bytes into the array.
=cut
sub write {
my $self = $_[0];
my $n = $_[2];
my $off = $_[3] || 0;
my $data = substr($_[1], $n, $off);
$n = length($data);
$self->print($data);
return $n;
}
=back
=cut
#==============================
=head2 Seeking/telling and other attributes
=over 4
=cut
#------------------------------
=item autoflush
I<Instance method.>
No-op, provided for OO compatibility.
=cut
sub autoflush {}
#------------------------------
=item binmode
I<Instance method.>
No-op, provided for OO compatibility.
=cut
sub binmode {}
#------------------------------
=item clearerr
I<Instance method.> Clear the error and EOF flags. A no-op.
=cut
sub clearerr { 1 }
#------------------------------
=item eof
I<Instance method.> Are we at end of file?
=cut
sub eof {
### print "checking EOF [*$self->{Str}, *$self->{Pos}]\n";
### print "SR = ", $#{*$self->{AR}}, "\n";
return 0 if (*{$_[0]}->{Str} < $#{*{$_[0]}->{AR}}); ### before EOA
return 1 if (*{$_[0]}->{Str} > $#{*{$_[0]}->{AR}}); ### after EOA
### ### at EOA, past EOS:
((*{$_[0]}->{Str} == $#{*{$_[0]}->{AR}}) && ($_[0]->_eos));
}
#------------------------------
#
# _eos
#
# I<Instance method, private.> Are we at end of the CURRENT string?
#
sub _eos {
(*{$_[0]}->{Pos} >= length(*{$_[0]}->{AR}[*{$_[0]}->{Str}])); ### past last char
}
#------------------------------
=item seek POS,WHENCE
I<Instance method.>
Seek to a given position in the stream.
Only a WHENCE of 0 (SEEK_SET) is supported.
=cut
sub seek {
my ($self, $pos, $whence) = @_;
### Seek:
if ($whence == 0) { $self->_seek_set($pos); }
elsif ($whence == 1) { $self->_seek_cur($pos); }
elsif ($whence == 2) { $self->_seek_end($pos); }
else { croak "bad seek whence ($whence)" }
return 1;
}
#------------------------------
#
# _seek_set POS
#
# Instance method, private.
# Seek to $pos relative to start:
#
sub _seek_set {
my ($self, $pos) = @_;
### Advance through array until done:
my $istr = 0;
while (($pos >= 0) && ($istr < scalar(@{*$self->{AR}}))) {
if (length(*$self->{AR}[$istr]) > $pos) { ### it's in this string!
return $self->setpos([$istr, $pos]);
}
else { ### it's in next string
$pos -= length(*$self->{AR}[$istr++]); ### move forward one string
}
}
### If we reached this point, pos is at or past end; zoom to EOF:
return $self->_setpos_to_eof;
}
#------------------------------
#
# _seek_cur POS
#
# Instance method, private.
# Seek to $pos relative to current position.
#
sub _seek_cur {
my ($self, $pos) = @_;
$self->_seek_set($self->tell + $pos);
}
#------------------------------
#
# _seek_end POS
#
# Instance method, private.
# Seek to $pos relative to end.
# We actually seek relative to beginning, which is simple.
#
sub _seek_end {
my ($self, $pos) = @_;
$self->_seek_set($self->_tell_eof + $pos);
}
#------------------------------
=item tell
I<Instance method.>
Return the current position in the stream, as a numeric offset.
=cut
sub tell {
my $self = shift;
my $off = 0;
my ($s, $str_s);
for ($s = 0; $s < *$self->{Str}; $s++) { ### count all "whole" scalars
defined($str_s = *$self->{AR}[$s]) or $str_s = '';
###print STDERR "COUNTING STRING $s (". length($str_s) . ")\n";
$off += length($str_s);
}
###print STDERR "COUNTING POS ($self->{Pos})\n";
return ($off += *$self->{Pos}); ### plus the final, partial one
}
#------------------------------
#
# _tell_eof
#
# Instance method, private.
# Get position of EOF, as a numeric offset.
# This is identical to the size of the stream - 1.
#
sub _tell_eof {
my $self = shift;
my $len = 0;
foreach (@{*$self->{AR}}) { $len += length($_) }
$len;
}
#------------------------------
=item setpos POS
I<Instance method.>
Seek to a given position in the array, using the opaque getpos() value.
Don't expect this to be a number.
=cut
sub setpos {
my ($self, $pos) = @_;
(ref($pos) eq 'ARRAY') or
die "setpos: only use a value returned by getpos!\n";
(*$self->{Str}, *$self->{Pos}) = @$pos;
}
#------------------------------
#
# _setpos_to_eof
#
# Fast-forward to EOF.
#
sub _setpos_to_eof {
my $self = shift;
$self->setpos([scalar(@{*$self->{AR}}), 0]);
}
#------------------------------
=item getpos
I<Instance method.>
Return the current position in the array, as an opaque value.
Don't expect this to be a number.
=cut
sub getpos {
[*{$_[0]}->{Str}, *{$_[0]}->{Pos}];
}
#------------------------------
=item aref
I<Instance method.>
Return a reference to the underlying array.
=cut
sub aref {
*{shift()}->{AR};
}
=back
=cut
#------------------------------
# Tied handle methods...
#------------------------------
### Conventional tiehandle interface:
sub TIEHANDLE { (defined($_[1]) && UNIVERSAL::isa($_[1],"IO::ScalarArray"))
? $_[1]
: shift->new(@_) }
sub GETC { shift->getc(@_) }
sub PRINT { shift->print(@_) }
sub PRINTF { shift->print(sprintf(shift, @_)) }
sub READ { shift->read(@_) }
sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
sub WRITE { shift->write(@_); }
sub CLOSE { shift->close(@_); }
sub SEEK { shift->seek(@_); }
sub TELL { shift->tell(@_); }
sub EOF { shift->eof(@_); }
sub BINMODE { 1; }
#------------------------------------------------------------
1;
__END__
# SOME PRIVATE NOTES:
#
# * The "current position" is the position before the next
# character to be read/written.
#
# * Str gives the string index of the current position, 0-based
#
# * Pos gives the offset within AR[Str], 0-based.
#
# * Inital pos is [0,0]. After print("Hello"), it is [1,0].
=head1 WARNINGS
Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
it was missing support for C<seek()>, C<tell()>, and C<eof()>.
Attempting to use these functions with an IO::ScalarArray will not work
prior to 5.005_57. IO::ScalarArray will not have the relevant methods
invoked; and even worse, this kind of bug can lie dormant for a while.
If you turn warnings on (via C<$^W> or C<perl -w>),
and you see something like this...
attempt to seek on unopened filehandle
...then you are probably trying to use one of these functions
on an IO::ScalarArray with an old Perl. The remedy is to simply
use the OO version; e.g.:
$AH->seek(0,0); ### GOOD: will work on any 5.005
seek($AH,0,0); ### WARNING: will only work on 5.005_57 and beyond
=head1 VERSION
$Id: ScalarArray.pm,v 1.7 2005/02/10 21:21:53 dfs Exp $
=head1 AUTHOR
=head2 Primary Maintainer
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head2 Principal author
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head2 Other contributors
Thanks to the following individuals for their invaluable contributions
(if I've forgotten or misspelled your name, please email me!):
I<Andy Glew,>
for suggesting C<getc()>.
I<Brandon Browning,>
for suggesting C<opened()>.
I<Eric L. Brine,>
for his offset-using read() and write() implementations.
I<Doug Wilson,>
for the IO::Handle inheritance and automatic tie-ing.
=cut
#------------------------------
1;

3223
Git/usr/share/perl5/vendor_perl/IO/Socket/SSL.pm Normal file
View File

File diff suppressed because it is too large Load Diff

379
Git/usr/share/perl5/vendor_perl/IO/Socket/SSL/Intercept.pm Normal file
View File

@ -0,0 +1,379 @@
package IO::Socket::SSL::Intercept;
use strict;
use warnings;
use Carp 'croak';
use IO::Socket::SSL::Utils;
use Net::SSLeay;
our $VERSION = '2.056';
sub new {
my ($class,%args) = @_;
my $cacert = delete $args{proxy_cert};
if ( ! $cacert ) {
if ( my $f = delete $args{proxy_cert_file} ) {
$cacert = PEM_file2cert($f);
} else {
croak "no proxy_cert or proxy_cert_file given";
}
}
my $cakey = delete $args{proxy_key};
if ( ! $cakey ) {
if ( my $f = delete $args{proxy_key_file} ) {
$cakey = PEM_file2key($f);
} else {
croak "no proxy_cert or proxy_cert_file given";
}
}
my $certkey = delete $args{cert_key};
if ( ! $certkey ) {
if ( my $f = delete $args{cert_key_file} ) {
$certkey = PEM_file2key($f);
}
}
my $cache = delete $args{cache} || {};
if (ref($cache) eq 'CODE') {
# check cache type
my $type = $cache->('type');
if (!$type) {
# old cache interface - change into new interface
# get: $cache->(fp)
# set: $cache->(fp,cert,key)
my $oc = $cache;
$cache = sub {
my ($fp,$create_cb) = @_;
my @ck = $oc->($fp);
$oc->($fp, @ck = &$create_cb) if !@ck;
return @ck;
};
} elsif ($type == 1) {
# current interface:
# get/set: $cache->(fp,cb_create)
} else {
die "invalid type of cache: $type";
}
}
my $self = bless {
cacert => $cacert,
cakey => $cakey,
certkey => $certkey,
cache => $cache,
serial => delete $args{serial},
};
return $self;
}
sub DESTROY {
# call various ssl _free routines
my $self = shift or return;
for ( \$self->{cacert},
map { \$_->{cert} } ref($self->{cache}) ne 'CODE' ? values %{$self->{cache}} :()) {
$$_ or next;
CERT_free($$_);
$$_ = undef;
}
for ( \$self->{cakey}, \$self->{pubkey} ) {
$$_ or next;
KEY_free($$_);
$$_ = undef;
}
}
sub clone_cert {
my ($self,$old_cert,$clone_key) = @_;
my $hash = CERT_asHash($old_cert);
my $create_cb = sub {
# if not in cache create new certificate based on original
# copy most but not all extensions
if (my $ext = $hash->{ext}) {
@$ext = grep {
defined($_->{sn}) && $_->{sn} !~m{^(?:
authorityInfoAccess |
subjectKeyIdentifier |
authorityKeyIdentifier |
certificatePolicies |
crlDistributionPoints
)$}x
} @$ext;
}
my ($clone,$key) = CERT_create(
%$hash,
issuer_cert => $self->{cacert},
issuer_key => $self->{cakey},
key => $self->{certkey},
serial =>
! defined($self->{serial}) ? (unpack('L',$hash->{x509_digest_sha256}))[0] :
ref($self->{serial}) eq 'CODE' ? $self->{serial}($old_cert,$hash) :
++$self->{serial},
);
return ($clone,$key);
};
$clone_key ||= substr(unpack("H*", $hash->{x509_digest_sha256}),0,32);
my $c = $self->{cache};
return $c->($clone_key,$create_cb) if ref($c) eq 'CODE';
my $e = $c->{$clone_key} ||= do {
my ($cert,$key) = &$create_cb;
{ cert => $cert, key => $key };
};
$e->{atime} = time();
return ($e->{cert},$e->{key});
}
sub STORABLE_freeze { my $self = shift; $self->serialize() }
sub STORABLE_thaw { my ($class,undef,$data) = @_; $class->unserialize($data) }
sub serialize {
my $self = shift;
my $data = pack("N",2); # version
$data .= pack("N/a", PEM_cert2string($self->{cacert}));
$data .= pack("N/a", PEM_key2string($self->{cakey}));
if ( $self->{certkey} ) {
$data .= pack("N/a", PEM_key2string($self->{certkey}));
} else {
$data .= pack("N/a", '');
}
$data .= pack("N",$self->{serial});
if ( ref($self->{cache}) eq 'HASH' ) {
while ( my($k,$v) = each %{ $self->{cache}} ) {
$data .= pack("N/aN/aN/aN", $k,
PEM_cert2string($k->{cert}),
$k->{key} ? PEM_key2string($k->{key}) : '',
$k->{atime});
}
}
return $data;
}
sub unserialize {
my ($class,$data) = @_;
unpack("N",substr($data,0,4,'')) == 2 or
croak("serialized with wrong version");
( my $cacert,my $cakey,my $certkey,my $serial,$data)
= unpack("N/aN/aN/aNa*",$data);
my $self = bless {
serial => $serial,
cacert => PEM_string2cert($cacert),
cakey => PEM_string2key($cakey),
$certkey ? ( certkey => PEM_string2key($certkey)):(),
}, ref($class)||$class;
$self->{cache} = {} if $data ne '';
while ( $data ne '' ) {
(my $key,my $cert,my $certkey, my $atime,$data) = unpack("N/aN/aNa*",$data);
$self->{cache}{$key} = {
cert => PEM_string2cert($cert),
$key ? ( key => PEM_string2key($certkey)):(),
atime => $atime
};
}
return $self;
}
1;
__END__
=head1 NAME
IO::Socket::SSL::Intercept -- SSL interception (man in the middle)
=head1 SYNOPSIS
use IO::Socket::SSL::Intercept;
# create interceptor with proxy certificates
my $mitm = IO::Socket::SSL::Intercept->new(
proxy_cert_file => 'proxy_cert.pem',
proxy_key_file => 'proxy_key.pem',
...
);
my $listen = IO::Socket::INET->new( LocalAddr => .., Listen => .. );
while (1) {
# TCP accept new client
my $client = $listen->accept or next;
# SSL connect to server
my $server = IO::Socket::SSL->new(
PeerAddr => ..,
SSL_verify_mode => ...,
...
) or die "ssl connect failed: $!,$SSL_ERROR";
# clone server certificate
my ($cert,$key) = $mitm->clone_cert( $server->peer_certificate );
# and upgrade client side to SSL with cloned certificate
IO::Socket::SSL->start_SSL($client,
SSL_server => 1,
SSL_cert => $cert,
SSL_key => $key
) or die "upgrade failed: $SSL_ERROR";
# now transfer data between $client and $server and analyze
# the unencrypted data
...
}
=head1 DESCRIPTION
This module provides functionality to clone certificates and sign them with a
proxy certificate, thus making it easy to intercept SSL connections (man in the
middle). It also manages a cache of the generated certificates.
=head1 How Intercepting SSL Works
Intercepting SSL connections is useful for analyzing encrypted traffic for
security reasons or for testing. It does not break the end-to-end security of
SSL, e.g. a properly written client will notice the interception unless you
explicitly configure the client to trust your interceptor.
Intercepting SSL works the following way:
=over 4
=item *
Create a new CA certificate, which will be used to sign the cloned certificates.
This proxy CA certificate should be trusted by the client, or (a properly
written client) will throw error messages or deny the connections because it
detected a man in the middle attack.
Due to the way the interception works there no support for client side
certificates is possible.
Using openssl such a proxy CA certificate and private key can be created with:
openssl genrsa -out proxy_key.pem 1024
openssl req -new -x509 -extensions v3_ca -key proxy_key.pem -out proxy_cert.pem
# export as PKCS12 for import into browser
openssl pkcs12 -export -in proxy_cert.pem -inkey proxy_key.pem -out proxy_cert.p12
=item *
Configure client to connect to use intercepting proxy or somehow redirect
connections from client to the proxy (e.g. packet filter redirects, ARP or DNS
spoofing etc).
=item *
Accept the TCP connection from the client, e.g. don't do any SSL handshakes with
the client yet.
=item *
Establish the SSL connection to the server and verify the servers certificate as
usually. Then create a new certificate based on the original servers
certificate, but signed by your proxy CA.
This is the step where IO::Socket::SSL::Intercept helps.
=item *
Upgrade the TCP connection to the client to SSL using the cloned certificate
from the server. If the client trusts your proxy CA it will accept the upgrade
to SSL.
=item *
Transfer data between client and server. While the connections to client and
server are both encrypted with SSL you will read/write the unencrypted data in
your proxy application.
=back
=head1 METHODS
IO::Socket::SSL::Intercept helps creating the cloned certificate with the
following methods:
=over 4
=item B<< $mitm = IO::Socket::SSL::Intercept->new(%args) >>
This creates a new interceptor object. C<%args> should be
=over 8
=item proxy_cert X509 | proxy_cert_file filename
This is the proxy certificate.
It can be either given by an X509 object from L<Net::SSLeay>s internal
representation, or using a file in PEM format.
=item proxy_key EVP_PKEY | proxy_key_file filename
This is the key for the proxy certificate.
It can be either given by an EVP_PKEY object from L<Net::SSLeay>s internal
representation, or using a file in PEM format.
The key should not have a passphrase.
=item pubkey EVP_PKEY | pubkey_file filename
This optional argument specifies the public key used for the cloned certificate.
It can be either given by an EVP_PKEY object from L<Net::SSLeay>s internal
representation, or using a file in PEM format.
If not given it will create a new public key on each call of C<new>.
=item serial INTEGER|CODE
This optional argument gives the starting point for the serial numbers of the
newly created certificates. If not set the serial number will be created based
on the digest of the original certificate. If the value is code it will be
called with C<< serial(original_cert,CERT_asHash(original_cert)) >> and should
return the new serial number.
=item cache HASH | SUBROUTINE
This optional argument gives a way to cache created certificates, so that they
don't get recreated on future accesses to the same host.
If the argument ist not given an internal HASH ist used.
If the argument is a hash it will store for each generated certificate a hash
reference with C<cert> and C<atime> in the hash, where C<atime> is the time of
last access (to expire unused entries) and C<cert> is the certificate. Please
note, that the certificate is in L<Net::SSLeay>s internal X509 format and can
thus not be simply dumped and restored.
The key for the hash is an C<ident> either given to C<clone_cert> or generated
from the original certificate.
If the argument is a subroutine it will be called as C<< $cache->(ident,sub) >>.
This call should return either an existing (cached) C<< (cert,key) >> or
call C<sub> without arguments to create a new C<< (cert,key) >>, store it
and return it.
If called with C<< $cache->('type') >> the function should just return 1 to
signal that it supports the current type of cache. If it reutrns nothing
instead the older cache interface is assumed for compatibility reasons.
=back
=item B<< ($clone_cert,$key) = $mitm->clone_cert($original_cert,[ $ident ]) >>
This clones the given certificate.
An ident as the key into the cache can be given (like C<host:port>), if not it
will be created from the properties of the original certificate.
It returns the cloned certificate and its key (which is the same for alle
created certificates).
=item B<< $string = $mitm->serialize >>
This creates a serialized version of the object (e.g. a string) which can then
be used to persistantly store created certificates over restarts of the
application. The cache will only be serialized if it is a HASH.
To work together with L<Storable> the C<STORABLE_freeze> function is defined to
call C<serialize>.
=item B<< $mitm = IO::Socket::SSL::Intercept->unserialize($string) >>
This restores an Intercept object from a serialized string.
To work together with L<Storable> the C<STORABLE_thaw> function is defined to
call C<unserialize>.
=back
=head1 AUTHOR
Steffen Ullrich

12738
Git/usr/share/perl5/vendor_perl/IO/Socket/SSL/PublicSuffix.pm Normal file
View File

File diff suppressed because it is too large Load Diff

743
Git/usr/share/perl5/vendor_perl/IO/Socket/SSL/Utils.pm Normal file
View File

@ -0,0 +1,743 @@
package IO::Socket::SSL::Utils;
use strict;
use warnings;
use Carp 'croak';
use Net::SSLeay;
# old versions of Exporter do not export 'import' yet
require Exporter;
*import = \&Exporter::import;
our $VERSION = '2.014';
our @EXPORT = qw(
PEM_file2cert PEM_string2cert PEM_cert2file PEM_cert2string
PEM_file2key PEM_string2key PEM_key2file PEM_key2string
KEY_free CERT_free
KEY_create_rsa CERT_asHash CERT_create
);
sub PEM_file2cert {
my $file = shift;
my $bio = Net::SSLeay::BIO_new_file($file,'r') or
croak "cannot read $file: $!";
my $cert = Net::SSLeay::PEM_read_bio_X509($bio);
Net::SSLeay::BIO_free($bio);
$cert or croak "cannot parse $file as PEM X509 cert: ".
Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
return $cert;
}
sub PEM_cert2file {
my ($cert,$file) = @_;
my $string = Net::SSLeay::PEM_get_string_X509($cert)
or croak("cannot get string from cert");
open( my $fh,'>',$file ) or croak("cannot write $file: $!");
print $fh $string;
}
sub PEM_string2cert {
my $string = shift;
my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem());
Net::SSLeay::BIO_write($bio,$string);
my $cert = Net::SSLeay::PEM_read_bio_X509($bio);
Net::SSLeay::BIO_free($bio);
$cert or croak "cannot parse string as PEM X509 cert: ".
Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
return $cert;
}
sub PEM_cert2string {
my $cert = shift;
return Net::SSLeay::PEM_get_string_X509($cert)
|| croak("cannot get string from cert");
}
sub PEM_file2key {
my $file = shift;
my $bio = Net::SSLeay::BIO_new_file($file,'r') or
croak "cannot read $file: $!";
my $key = Net::SSLeay::PEM_read_bio_PrivateKey($bio);
Net::SSLeay::BIO_free($bio);
$key or croak "cannot parse $file as PEM private key: ".
Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
return $key;
}
sub PEM_key2file {
my ($key,$file) = @_;
my $string = Net::SSLeay::PEM_get_string_PrivateKey($key)
or croak("cannot get string from key");
open( my $fh,'>',$file ) or croak("cannot write $file: $!");
print $fh $string;
}
sub PEM_string2key {
my $string = shift;
my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem());
Net::SSLeay::BIO_write($bio,$string);
my $key = Net::SSLeay::PEM_read_bio_PrivateKey($bio);
Net::SSLeay::BIO_free($bio);
$key or croak "cannot parse string as PEM private key: ".
Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
return $key;
}
sub PEM_key2string {
my $key = shift;
return Net::SSLeay::PEM_get_string_PrivateKey($key)
|| croak("cannot get string from key");
}
sub CERT_free {
my $cert = shift or return;
Net::SSLeay::X509_free($cert);
}
sub KEY_free {
my $key = shift or return;
Net::SSLeay::EVP_PKEY_free($key);
}
sub KEY_create_rsa {
my $bits = shift || 2048;
my $key = Net::SSLeay::EVP_PKEY_new();
my $rsa = Net::SSLeay::RSA_generate_key($bits, 0x10001); # 0x10001 = RSA_F4
Net::SSLeay::EVP_PKEY_assign_RSA($key,$rsa);
return $key;
}
if (defined &Net::SSLeay::EC_KEY_generate_key) {
push @EXPORT,'KEY_create_ec';
*KEY_create_ec = sub {
my $curve = shift || 'prime256v1';
my $key = Net::SSLeay::EVP_PKEY_new();
my $ec = Net::SSLeay::EC_KEY_generate_key($curve);
Net::SSLeay::EVP_PKEY_assign_EC_KEY($key,$ec);
return $key;
}
}
# extract information from cert
my %gen2i = qw( OTHERNAME 0 EMAIL 1 DNS 2 X400 3 DIRNAME 4 EDIPARTY 5 URI 6 IP 7 RID 8 );
my %i2gen = reverse %gen2i;
sub CERT_asHash {
my $cert = shift;
my $digest_name = shift || 'sha256';
my %hash = (
version => Net::SSLeay::X509_get_version($cert),
not_before => _asn1t2t(Net::SSLeay::X509_get_notBefore($cert)),
not_after => _asn1t2t(Net::SSLeay::X509_get_notAfter($cert)),
serial => Net::SSLeay::P_ASN1_INTEGER_get_dec(
Net::SSLeay::X509_get_serialNumber($cert)),
signature_alg => Net::SSLeay::OBJ_obj2txt (
Net::SSLeay::P_X509_get_signature_alg($cert)),
crl_uri => [ Net::SSLeay::P_X509_get_crl_distribution_points($cert) ],
keyusage => [ Net::SSLeay::P_X509_get_key_usage($cert) ],
extkeyusage => {
oid => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,0) ],
nid => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,1) ],
sn => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,2) ],
ln => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,3) ],
},
"pubkey_digest_$digest_name" => Net::SSLeay::X509_pubkey_digest(
$cert,_digest($digest_name)),
"x509_digest_$digest_name" => Net::SSLeay::X509_digest(
$cert,_digest($digest_name)),
"fingerprint_$digest_name" => Net::SSLeay::X509_get_fingerprint(
$cert,$digest_name),
);
my $subj = Net::SSLeay::X509_get_subject_name($cert);
my %subj;
for ( 0..Net::SSLeay::X509_NAME_entry_count($subj)-1 ) {
my $e = Net::SSLeay::X509_NAME_get_entry($subj,$_);
my $o = Net::SSLeay::X509_NAME_ENTRY_get_object($e);
$subj{ Net::SSLeay::OBJ_obj2txt($o) } =
Net::SSLeay::P_ASN1_STRING_get(
Net::SSLeay::X509_NAME_ENTRY_get_data($e));
}
$hash{subject} = \%subj;
if ( my @names = Net::SSLeay::X509_get_subjectAltNames($cert) ) {
my $alt = $hash{subjectAltNames} = [];
while (my ($t,$v) = splice(@names,0,2)) {
$t = $i2gen{$t} || die "unknown type $t in subjectAltName";
if ( $t eq 'IP' ) {
if (length($v) == 4) {
$v = join('.',unpack("CCCC",$v));
} elsif ( length($v) == 16 ) {
my @v = unpack("nnnnnnnn",$v);
my ($best0,$last0);
for(my $i=0;$i<@v;$i++) {
if ($v[$i] == 0) {
if ($last0) {
$last0->[1] = $i;
$last0->[2]++;
$best0 = $last0 if ++$last0->[2]>$best0->[2];
} else {
$last0 = [ $i,$i,0 ];
$best0 ||= $last0;
}
} else {
$last0 = undef;
}
}
if ($best0) {
$v = '';
$v .= join(':', map { sprintf( "%x",$_) } @v[0..$best0->[0]-1]) if $best0->[0]>0;
$v .= '::';
$v .= join(':', map { sprintf( "%x",$_) } @v[$best0->[1]+1..$#v]) if $best0->[1]<$#v;
} else {
$v = join(':', map { sprintf( "%x",$_) } @v);
}
}
}
push @$alt,[$t,$v]
}
}
my $issuer = Net::SSLeay::X509_get_issuer_name($cert);
my %issuer;
for ( 0..Net::SSLeay::X509_NAME_entry_count($issuer)-1 ) {
my $e = Net::SSLeay::X509_NAME_get_entry($issuer,$_);
my $o = Net::SSLeay::X509_NAME_ENTRY_get_object($e);
$issuer{ Net::SSLeay::OBJ_obj2txt($o) } =
Net::SSLeay::P_ASN1_STRING_get(
Net::SSLeay::X509_NAME_ENTRY_get_data($e));
}
$hash{issuer} = \%issuer;
my @ext;
for( 0..Net::SSLeay::X509_get_ext_count($cert)-1 ) {
my $e = Net::SSLeay::X509_get_ext($cert,$_);
my $o = Net::SSLeay::X509_EXTENSION_get_object($e);
my $nid = Net::SSLeay::OBJ_obj2nid($o);
push @ext, {
oid => Net::SSLeay::OBJ_obj2txt($o),
nid => ( $nid > 0 ) ? $nid : undef,
sn => ( $nid > 0 ) ? Net::SSLeay::OBJ_nid2sn($nid) : undef,
critical => Net::SSLeay::X509_EXTENSION_get_critical($e),
data => Net::SSLeay::X509V3_EXT_print($e),
}
}
$hash{ext} = \@ext;
if ( defined(&Net::SSLeay::P_X509_get_ocsp_uri)) {
$hash{ocsp_uri} = [ Net::SSLeay::P_X509_get_ocsp_uri($cert) ];
} else {
$hash{ocsp_uri} = [];
for( @ext ) {
$_->{sn} or next;
$_->{sn} eq 'authorityInfoAccess' or next;
push @{ $hash{ocsp_uri}}, $_->{data} =~m{\bOCSP - URI:(\S+)}g;
}
}
return \%hash;
}
sub CERT_create {
my %args = @_%2 ? %{ shift() } : @_;
my $cert = Net::SSLeay::X509_new();
my $digest_name = delete $args{digest} || 'sha256';
Net::SSLeay::ASN1_INTEGER_set(
Net::SSLeay::X509_get_serialNumber($cert),
delete $args{serial} || rand(2**32),
);
# version default to 2 (V3)
Net::SSLeay::X509_set_version($cert,
delete $args{version} || 2 );
# not_before default to now
Net::SSLeay::ASN1_TIME_set(
Net::SSLeay::X509_get_notBefore($cert),
delete $args{not_before} || time()
);
# not_after default to now+365 days
Net::SSLeay::ASN1_TIME_set(
Net::SSLeay::X509_get_notAfter($cert),
delete $args{not_after} || time() + 365*86400
);
# set subject
my $subj_e = Net::SSLeay::X509_get_subject_name($cert);
my $subj = delete $args{subject} || {
organizationName => 'IO::Socket::SSL',
commonName => 'IO::Socket::SSL Test'
};
while ( my ($k,$v) = each %$subj ) {
# Not everything we get is nice - try with MBSTRING_UTF8 first and if it
# fails try V_ASN1_T61STRING and finally V_ASN1_OCTET_STRING
Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,0x1000,$v,-1,0)
or Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,20,$v,-1,0)
or Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,4,$v,-1,0)
or croak("failed to add entry for $k - ".
Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()));
}
my @ext = (
&Net::SSLeay::NID_subject_key_identifier => 'hash',
&Net::SSLeay::NID_authority_key_identifier => 'keyid',
);
if ( my $altsubj = delete $args{subjectAltNames} ) {
push @ext,
&Net::SSLeay::NID_subject_alt_name =>
join(',', map { "$_->[0]:$_->[1]" } @$altsubj)
}
my $key = delete $args{key} || KEY_create_rsa();
Net::SSLeay::X509_set_pubkey($cert,$key);
my $is = delete $args{issuer};
my $issuer_cert = delete $args{issuer_cert} || $is && $is->[0] || $cert;
my $issuer_key = delete $args{issuer_key} || $is && $is->[1] || $key;
my %purpose;
if (my $p = delete $args{purpose}) {
if (!ref($p)) {
$purpose{lc($2)} = (!$1 || $1 eq '+') ? 1:0
while $p =~m{([+-]?)(\w+)}g;
} elsif (ref($p) eq 'ARRAY') {
for(@$p) {
m{^([+-]?)(\w+)$} or die "invalid entry in purpose: $_";
$purpose{lc($2)} = (!$1 || $1 eq '+') ? 1:0
}
} else {
while( my ($k,$v) = each %$p) {
$purpose{lc($k)} = ($v && $v ne '-')?1:0;
}
}
}
if (delete $args{CA}) {
# add defaults for CA
%purpose = (
ca => 1, sslca => 1, emailca => 1, objca => 1,
%purpose
);
}
if (!%purpose) {
%purpose = (server => 1, client => 1);
}
my (%key_usage,%ext_key_usage,%cert_type,%basic_constraints);
my %dS = ( digitalSignature => \%key_usage );
my %kE = ( keyEncipherment => \%key_usage );
my %CA = ( 'CA:TRUE' => \%basic_constraints, %dS, keyCertSign => \%key_usage );
my @disable;
for(
[ client => { %dS, %kE, clientAuth => \%ext_key_usage, client => \%cert_type } ],
[ server => { %dS, %kE, serverAuth => \%ext_key_usage, server => \%cert_type } ],
[ email => { %dS, %kE, emailProtection => \%ext_key_usage, email => \%cert_type } ],
[ objsign => { %dS, %kE, codeSigning => \%ext_key_usage, objsign => \%cert_type } ],
[ CA => { %CA }],
[ sslCA => { %CA, sslCA => \%cert_type }],
[ emailCA => { %CA, emailCA => \%cert_type }],
[ objCA => { %CA, objCA => \%cert_type }],
[ emailProtection => { %dS, %kE, emailProtection => \%ext_key_usage, email => \%cert_type } ],
[ codeSigning => { %dS, %kE, codeSigning => \%ext_key_usage, objsign => \%cert_type } ],
[ timeStamping => { timeStamping => \%ext_key_usage } ],
[ digitalSignature => { digitalSignature => \%key_usage } ],
[ nonRepudiation => { nonRepudiation => \%key_usage } ],
[ keyEncipherment => { keyEncipherment => \%key_usage } ],
[ dataEncipherment => { dataEncipherment => \%key_usage } ],
[ keyAgreement => { keyAgreement => \%key_usage } ],
[ keyCertSign => { keyCertSign => \%key_usage } ],
[ cRLSign => { cRLSign => \%key_usage } ],
[ encipherOnly => { encipherOnly => \%key_usage } ],
[ decipherOnly => { decipherOnly => \%key_usage } ],
[ clientAuth => { clientAuth => \%ext_key_usage } ],
[ serverAuth => { serverAuth => \%ext_key_usage } ],
) {
exists $purpose{lc($_->[0])} or next;
if (delete $purpose{lc($_->[0])}) {
while (my($k,$h) = each %{$_->[1]}) {
$h->{$k} = 1;
}
} else {
push @disable, $_->[1];
}
}
die "unknown purpose ".join(",",keys %purpose) if %purpose;
for(@disable) {
while (my($k,$h) = each %$_) {
delete $h->{$k};
}
}
if (%basic_constraints) {
push @ext,&Net::SSLeay::NID_basic_constraints,
=> join(",",'critical', sort keys %basic_constraints);
} else {
push @ext, &Net::SSLeay::NID_basic_constraints => 'critical,CA:FALSE';
}
push @ext,&Net::SSLeay::NID_key_usage
=> join(",",'critical', sort keys %key_usage) if %key_usage;
push @ext,&Net::SSLeay::NID_netscape_cert_type
=> join(",",sort keys %cert_type) if %cert_type;
push @ext,&Net::SSLeay::NID_ext_key_usage
=> join(",",sort keys %ext_key_usage) if %ext_key_usage;
Net::SSLeay::P_X509_add_extensions($cert, $issuer_cert, @ext);
my %have_ext;
for(my $i=0;$i<@ext;$i+=2) {
$have_ext{ $ext[$i] }++
}
for my $ext (@{ $args{ext} || [] }) {
my $nid = $ext->{nid}
|| $ext->{sn} && Net::SSLeay::OBJ_sn2nid($ext->{sn})
|| croak "cannot determine NID of extension";
$have_ext{$nid} and next;
my $val = $ext->{data};
if ($nid == 177) {
# authorityInfoAccess:
# OpenSSL i2v does not output the same way as expected by i2v :(
for (split(/\n/,$val)) {
s{ - }{;}; # "OCSP - URI:..." -> "OCSP;URI:..."
$_ = "critical,$_" if $ext->{critical};
Net::SSLeay::P_X509_add_extensions($cert,$issuer_cert,$nid,$_);
}
} else {
$val = "critical,$val" if $ext->{critical};
Net::SSLeay::P_X509_add_extensions($cert, $issuer_cert, $nid, $val);
}
}
Net::SSLeay::X509_set_issuer_name($cert,
Net::SSLeay::X509_get_subject_name($issuer_cert));
Net::SSLeay::X509_sign($cert,$issuer_key,_digest($digest_name));
return ($cert,$key);
}
if ( defined &Net::SSLeay::ASN1_TIME_timet ) {
*_asn1t2t = \&Net::SSLeay::ASN1_TIME_timet
} else {
require Time::Local;
my %mon2i = qw(
Jan 0 Feb 1 Mar 2 Apr 3 May 4 Jun 5
Jul 6 Aug 7 Sep 8 Oct 9 Nov 10 Dec 11
);
*_asn1t2t = sub {
my $t = Net::SSLeay::P_ASN1_TIME_put2string( shift );
my ($mon,$d,$h,$m,$s,$y,$tz) = split(/[\s:]+/,$t);
defined( $mon = $mon2i{$mon} ) or die "invalid month in $t";
$tz ||= $y =~s{^(\d+)([A-Z]\S*)}{$1} && $2;
if ( ! $tz ) {
return Time::Local::timelocal($s,$m,$h,$d,$mon,$y)
} elsif ( $tz eq 'GMT' ) {
return Time::Local::timegm($s,$m,$h,$d,$mon,$y)
} else {
die "unexpected TZ $tz from ASN1_TIME_print";
}
}
}
{
my %digest;
sub _digest {
my $digest_name = shift;
return $digest{$digest_name} ||= do {
Net::SSLeay::SSLeay_add_ssl_algorithms();
Net::SSLeay::EVP_get_digestbyname($digest_name)
or die "Digest algorithm $digest_name is not available";
};
}
}
1;
__END__
=head1 NAME
IO::Socket::SSL::Utils -- loading, storing, creating certificates and keys
=head1 SYNOPSIS
use IO::Socket::SSL::Utils;
my $cert = PEM_file2cert('cert.pem'); # load certificate from file
my $string = PEM_cert2string($cert); # convert certificate to PEM string
CERT_free($cert); # free memory within OpenSSL
my $key = KEY_create_rsa(2048); # create new 2048-bit RSA key
PEM_string2file($key,"key.pem"); # and write it to file
KEY_free($key); # free memory within OpenSSL
=head1 DESCRIPTION
This module provides various utility functions to work with certificates and
private keys, shielding some of the complexity of the underlying Net::SSLeay and
OpenSSL.
=head1 FUNCTIONS
=over 4
=item *
Functions converting between string or file and certificates and keys.
They croak if the operation cannot be completed.
=over 8
=item PEM_file2cert(file) -> cert
=item PEM_cert2file(cert,file)
=item PEM_string2cert(string) -> cert
=item PEM_cert2string(cert) -> string
=item PEM_file2key(file) -> key
=item PEM_key2file(key,file)
=item PEM_string2key(string) -> key
=item PEM_key2string(key) -> string
=back
=item *
Functions for cleaning up.
Each loaded or created cert and key must be freed to not leak memory.
=over 8
=item CERT_free(cert)
=item KEY_free(key)
=back
=item * KEY_create_rsa(bits) -> key
Creates an RSA key pair, bits defaults to 2048.
=item * KEY_create_ec(curve) -> key
Creates an EC key, curve defaults to C<prime256v1>.
=item * CERT_asHash(cert,[digest_algo]) -> hash
Extracts the information from the certificate into a hash and uses the given
digest_algo (default: SHA-256) to determine digest of pubkey and cert.
The resulting hash contains:
=over 8
=item subject
Hash with the parts of the subject, e.g. commonName, countryName,
organizationName, stateOrProvinceName, localityName.
=item subjectAltNames
Array with list of alternative names. Each entry in the list is of
C<[type,value]>, where C<type> can be OTHERNAME, EMAIL, DNS, X400, DIRNAME,
EDIPARTY, URI, IP or RID.
=item issuer
Hash with the parts of the issuer, e.g. commonName, countryName,
organizationName, stateOrProvinceName, localityName.
=item not_before, not_after
The time frame, where the certificate is valid, as time_t, e.g. can be converted
with localtime or similar functions.
=item serial
The serial number
=item crl_uri
List of URIs for CRL distribution.
=item ocsp_uri
List of URIs for revocation checking using OCSP.
=item keyusage
List of keyUsage information in the certificate.
=item extkeyusage
List of extended key usage information from the certificate. Each entry in
this list consists of a hash with oid, nid, ln and sn.
=item pubkey_digest_xxx
Binary digest of the pubkey using the given digest algorithm, e.g.
pubkey_digest_sha256 if (the default) SHA-256 was used.
=item x509_digest_xxx
Binary digest of the X.509 certificate using the given digest algorithm, e.g.
x509_digest_sha256 if (the default) SHA-256 was used.
=item fingerprint_xxx
Fingerprint of the certificate using the given digest algorithm, e.g.
fingerprint_sha256 if (the default) SHA-256 was used. Contrary to digest_* this
is an ASCII string with a list if hexadecimal numbers, e.g.
"73:59:75:5C:6D...".
=item signature_alg
Algorithm used to sign certificate, e.g. C<sha256WithRSAEncryption>.
=item ext
List of extensions.
Each entry in the list is a hash with oid, nid, sn, critical flag (boolean) and
data (string representation given by X509V3_EXT_print).
=item version
Certificate version, usually 2 (x509v3)
=back
=item * CERT_create(hash) -> (cert,key)
Creates a certificate based on the given hash.
If the issuer is not specified the certificate will be self-signed.
The following keys can be given:
=over 8
=item subject
Hash with the parts of the subject, e.g. commonName, countryName, ... as
described in C<CERT_asHash>.
Default points to IO::Socket::SSL.
=item not_before
A time_t value when the certificate starts to be valid. Defaults to current
time.
=item not_after
A time_t value when the certificate ends to be valid. Defaults to current
time plus one 365 days.
=item serial
The serial number. If not given a random number will be used.
=item version
The version of the certificate, default 2 (x509v3).
=item CA true|false
If true declare certificate as CA, defaults to false.
=item purpose string|array|hash
Set the purpose of the certificate.
The different purposes can be given as a string separated by non-word character,
as array or hash. With string or array each purpose can be prefixed with '+'
(enable) or '-' (disable) and same can be done with the value when given as a
hash. By default enabling the purpose is assumed.
If the CA option is given and true the defaults "ca,sslca,emailca,objca" are
assumed, but can be overridden with explicit purpose.
If the CA option is given and false the defaults "server,client" are assumed.
If no CA option and no purpose is given it defaults to "server,client".
Purpose affects basicConstraints, keyUsage, extKeyUsage and netscapeCertType.
The following purposes are defined (case is not important):
client
server
email
objsign
CA
sslCA
emailCA
objCA
emailProtection
codeSigning
timeStamping
digitalSignature
nonRepudiation
keyEncipherment
dataEncipherment
keyAgreement
keyCertSign
cRLSign
encipherOnly
decipherOnly
Examples:
# root-CA for SSL certificates
purpose => 'sslCA' # or CA => 1
# server certificate and CA (typically self-signed)
purpose => 'sslCA,server'
# client certificate
purpose => 'client',
=item ext [{ sn => .., data => ... }, ... ]
List of extensions. The type of the extension can be specified as name with
C<sn> or as NID with C<nid> and the data with C<data>. These data must be in the
same syntax as expected within openssl.cnf, e.g. something like
C<OCSP;URI=http://...>. Additionally the critical flag can be set with
C<critical => 1>.
=item key key
use given key as key for certificate, otherwise a new one will be generated and
returned
=item issuer_cert cert
set issuer for new certificate
=item issuer_key key
sign new certificate with given key
=item issuer [ cert, key ]
Instead of giving issuer_key and issuer_cert as separate arguments they can be
given both together.
=item digest algorithm
specify the algorithm used to sign the certificate, default SHA-256.
=back
=back
=head1 AUTHOR
Steffen Ullrich

446
Git/usr/share/perl5/vendor_perl/IO/Stringy.pm Normal file
View File

@ -0,0 +1,446 @@
package IO::Stringy;
use vars qw($VERSION);
$VERSION = "2.111";
1;
__END__
=head1 NAME
IO-stringy - I/O on in-core objects like strings and arrays
=head1 SYNOPSIS
IO::
::AtomicFile adpO Write a file which is updated atomically ERYQ
::Lines bdpO I/O handle to read/write to array of lines ERYQ
::Scalar RdpO I/O handle to read/write to a string ERYQ
::ScalarArray RdpO I/O handle to read/write to array of scalars ERYQ
::Wrap RdpO Wrap old-style FHs in standard OO interface ERYQ
::WrapTie adpO Tie your handles & retain full OO interface ERYQ
=head1 DESCRIPTION
This toolkit primarily provides modules for performing both traditional
and object-oriented i/o) on things I<other> than normal filehandles;
in particular, L<IO::Scalar|IO::Scalar>, L<IO::ScalarArray|IO::ScalarArray>,
and L<IO::Lines|IO::Lines>.
In the more-traditional IO::Handle front, we
have L<IO::AtomicFile|IO::AtomicFile>
which may be used to painlessly create files which are updated
atomically.
And in the "this-may-prove-useful" corner, we have L<IO::Wrap|IO::Wrap>,
whose exported wraphandle() function will clothe anything that's not
a blessed object in an IO::Handle-like wrapper... so you can just
use OO syntax and stop worrying about whether your function's caller
handed you a string, a globref, or a FileHandle.
=head1 WARNINGS
Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
it was missing support for C<seek()>, C<tell()>, and C<eof()>.
Attempting to use these functions with an IO::Scalar, IO::ScalarArray,
IO::Lines, etc. B<will not work> prior to 5.005_57.
None of the relevant methods will be invoked by Perl;
and even worse, this kind of bug can lie dormant for a while.
If you turn warnings on (via C<$^W> or C<perl -w>), and you see
something like this...
seek() on unopened file
...then you are probably trying to use one of these functions
on one of our IO:: classes with an old Perl. The remedy is to simply
use the OO version; e.g.:
$SH->seek(0,0); ### GOOD: will work on any 5.005
seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond
=head1 INSTALLATION
=head2 Requirements
As of version 2.x, this toolkit requires Perl 5.005 for
the IO::Handle subclasses, and 5.005_57 or better is
B<strongly> recommended. See L<"WARNINGS"> for details.
=head2 Directions
Most of you already know the drill...
perl Makefile.PL
make
make test
make install
For everyone else out there...
if you've never installed Perl code before, or you're trying to use
this in an environment where your sysadmin or ISP won't let you do
interesting things, B<relax:> since this module contains no binary
extensions, you can cheat. That means copying the directory tree
under my "./lib" directory into someplace where your script can "see"
it. For example, under Linux:
cp -r IO-stringy-1.234/lib/* /path/to/my/perl/
Now, in your Perl code, do this:
use lib "/path/to/my/perl";
use IO::Scalar; ### or whatever
Ok, now you've been told. At this point, anyone who whines about
not being given enough information gets an unflattering haiku
written about them in the next change log. I'll do it.
Don't think I won't.
=head1 VERSION
$Id: Stringy.pm,v 1.3 2005/02/10 21:24:05 dfs Exp $
=head1 TO DO
=over 4
=item (2000/08/02) Finalize $/ support
Graham Barr submitted this patch half a I<year> ago;
Like a moron, I lost his message under a ton of others,
and only now have the experimental implementation done.
Will the sudden sensitivity to $/ hose anyone out there?
I'm worried, so you have to enable it explicitly in 1.x.
It will be on by default in 2.x, though only IO::Scalar
has been implemented.
=item (2001/08/08) Remove IO::WrapTie from new IO:: classes
It's not needed. Backwards compatibility could be maintained
by having new_tie() be identical to new(). Heck, I'll bet
that IO::WrapTie should be reimplemented so the returned
object is just like an IO::Scalar in its use of globrefs.
=back
=head1 CHANGE LOG
=over 4
=item Version 2.110 (2005/02/10)
Maintainership taken over by DSKOLL <dfs@roaringpenguin.com>
Closed the following bugs at
https://rt.cpan.org/NoAuth/Bugs.html?Dist=IO-stringy:
=item
2208 IO::ScalarArray->getline does not return undef for EOF if undef($/)
=item
7132 IO-stringy/Makefile.PL bug - name should be module name
=item
11249 IO::Scalar flush shouldn't return undef
=item
2172 $\ (output record separator) not respected
=item
8605 IO::InnerFile::seek() should return 1 on success
=item
4798 *.html in lib/
=item
4369 Improvement: handling of fixed-size reads in IO::Scalar
(Actually, bug 4369 was closed in Version 2.109)
=item Version 2.109 (2003/12/21)
IO::Scalar::getline now works with ref to int.
I<Thanks to Dominique Quatravaux for this patch.>
=item Version 2.108 (2001/08/20)
The terms-of-use have been placed in the distribution file "COPYING".
Also, small documentation tweaks were made.
=item Version 2.105 (2001/08/09)
Added support for various seek() whences to IO::ScalarArray.
Added support for consulting $/ in IO::Scalar and IO::ScalarArray.
The old C<use_RS()> is not even an option.
Unsupported record separators will cause a croak().
Added a lot of regression tests to supoprt the above.
Better on-line docs (hyperlinks to individual functions).
=item Version 2.103 (2001/08/08)
After sober consideration I have reimplemented IO::Scalar::print()
so that it once again always seeks to the end of the string.
Benchmarks show the new implementation to be just as fast as
Juergen's contributed patch; until someone can convince me otherwise,
the current, safer implementation stays.
I thought more about giving IO::Scalar two separate handles,
one for reading and one for writing, as suggested by Binkley.
His points about what tell() and eof() return are, I think,
show-stoppers for this feature. Even the manpages for stdio's fseek()
seem to imply a I<single> file position indicator, not two.
So I think I will take this off the TO DO list.
B<Remedy:> you can always have two handles open on the same
scalar, one which you only write to, and one which you only read from.
That should give the same effect.
=item Version 2.101 (2001/08/07)
B<Alpha release.>
This is the initial release of the "IO::Scalar and friends are
now subclasses of IO::Handle". I'm flinging it against the wall.
Please tell me if the banana sticks. When it does, the banana
will be called 2.2x.
First off, I<many many thanks to Doug Wilson>, who
has provided an I<invaluable> service by patching IO::Scalar
and friends so that they (1) inherit from IO::Handle, (2) automatically
tie themselves so that the C<new()> objects can be used in native i/o
constructs, and (3) doing it so that the whole damn thing passes
its regression tests. As Doug knows, my globref Kung-Fu was not
up to the task; he graciously provided the patches. This has earned
him a seat at the L<Co-Authors|"AUTHOR"> table, and the
right to have me address him as I<sensei>.
Performance of IO::Scalar::print() has been improved by as much as 2x
for lots of little prints, with the cost of forcing those
who print-then-seek-then-print to explicitly seek to end-of-string
before printing again.
I<Thanks to Juergen Zeller for this patch.>
Added the COPYING file, which had been missing from prior versions.
I<Thanks to Albert Chin-A-Young for pointing this out.>
IO::Scalar consults $/ by default (1.x ignored it by default).
Yes, I still need to support IO::ScalarArray.
=item Version 1.221 (2001/08/07)
I threatened in L<"INSTALLATION"> to write an unflattering haiku
about anyone who whined that I gave them insufficient information...
but it turns out that I left out a crucial direction. D'OH!
I<Thanks to David Beroff for the "patch" and the haiku...>
Enough info there?
Here's unflattering haiku:
Forgot the line, "make"! ;-)
=item Version 1.220 (2001/04/03)
Added untested SEEK, TELL, and EOF methods to IO::Scalar
and IO::ScalarArray to support corresponding functions for
tied filehandles: untested, because I'm still running 5.00556
and Perl is complaining about "tell() on unopened file".
I<Thanks to Graham Barr for the suggestion.>
Removed not-fully-blank lines from modules; these were causing
lots of POD-related warnings.
I<Thanks to Nicolas Joly for the suggestion.>
=item Version 1.219 (2001/02/23)
IO::Scalar objects can now be made sensitive to $/ .
Pains were taken to keep the fast code fast while adding this feature.
I<Cheers to Graham Barr for submitting his patch;
jeers to me for losing his email for 6 months.>
=item Version 1.218 (2001/02/23)
IO::Scalar has a new sysseek() method.
I<Thanks again to Richard Jones.>
New "TO DO" section, because people who submit patches/ideas should
at least know that they're in the system... and that I won't lose
their stuff. Please read it.
New entries in L<"AUTHOR">.
Please read those too.
=item Version 1.216 (2000/09/28)
B<IO::Scalar and IO::ScalarArray now inherit from IO::Handle.>
I thought I'd remembered a problem with this ages ago, related to
the fact that these IO:: modules don't have "real" filehandles,
but the problem apparently isn't surfacing now.
If you suddenly encounter Perl warnings during global destruction
(especially if you're using tied filehandles), then please let me know!
I<Thanks to B. K. Oxley (binkley) for this.>
B<Nasty bug fixed in IO::Scalar::write().>
Apparently, the offset and the number-of-bytes arguments were,
for all practical purposes, I<reversed.> You were okay if
you did all your writing with print(), but boy was I<this> a stupid bug!
I<Thanks to Richard Jones for finding this one.
For you, Rich, a double-length haiku:>
Newspaper headline
typeset by dyslexic man
loses urgency
BABY EATS FISH is
simply not equivalent
to FISH EATS BABY
B<New sysread and syswrite methods for IO::Scalar.>
I<Thanks again to Richard Jones for this.>
=item Version 1.215 (2000/09/05)
Added 'bool' overload to '""' overload, so object always evaluates
to true. (Whew. Glad I caught this before it went to CPAN.)
=item Version 1.214 (2000/09/03)
Evaluating an IO::Scalar in a string context now yields
the underlying string.
I<Thanks to B. K. Oxley (binkley) for this.>
=item Version 1.213 (2000/08/16)
Minor documentation fixes.
=item Version 1.212 (2000/06/02)
Fixed IO::InnerFile incompatibility with Perl5.004.
I<Thanks to many folks for reporting this.>
=item Version 1.210 (2000/04/17)
Added flush() and other no-op methods.
I<Thanks to Doru Petrescu for suggesting this.>
=item Version 1.209 (2000/03/17)
Small bug fixes.
=item Version 1.208 (2000/03/14)
Incorporated a number of contributed patches and extensions,
mostly related to speed hacks, support for "offset", and
WRITE/CLOSE methods.
I<Thanks to Richard Jones, Doru Petrescu, and many others.>
=item Version 1.206 (1999/04/18)
Added creation of ./testout when Makefile.PL is run.
=item Version 1.205 (1999/01/15)
Verified for Perl5.005.
=item Version 1.202 (1998/04/18)
New IO::WrapTie and IO::AtomicFile added.
=item Version 1.110
Added IO::WrapTie.
=item Version 1.107
Added IO::Lines, and made some bug fixes to IO::ScalarArray.
Also, added getc().
=item Version 1.105
No real changes; just upgraded IO::Wrap to have a $VERSION string.
=back
=head1 AUTHOR
=over 4
=item Primary Maintainer
Dianne Skoll (F<dfs@roaringpenguin.com>).
=item Original Author
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=item Co-Authors
For all their bug reports and patch submissions, the following
are officially recognized:
Richard Jones
B. K. Oxley (binkley)
Doru Petrescu
Doug Wilson (for picking up the ball I dropped, and doing tie() right)
=back
Go to F<http://www.zeegee.com> for the latest downloads
and on-line documentation for this module.
Enjoy. Yell if it breaks.
=cut

228
Git/usr/share/perl5/vendor_perl/IO/Wrap.pm Normal file
View File

@ -0,0 +1,228 @@
package IO::Wrap;
# SEE DOCUMENTATION AT BOTTOM OF FILE
require 5.002;
use strict;
use vars qw(@ISA @EXPORT $VERSION);
@ISA = qw(Exporter);
@EXPORT = qw(wraphandle);
use FileHandle;
use Carp;
# The package version, both in 1.23 style *and* usable by MakeMaker:
$VERSION = "2.111";
#------------------------------
# wraphandle RAW
#------------------------------
sub wraphandle {
my $raw = shift;
new IO::Wrap $raw;
}
#------------------------------
# new STREAM
#------------------------------
sub new {
my ($class, $stream) = @_;
no strict 'refs';
### Convert raw scalar to globref:
ref($stream) or $stream = \*$stream;
### Wrap globref and incomplete objects:
if ((ref($stream) eq 'GLOB') or ### globref
(ref($stream) eq 'FileHandle') && !defined(&FileHandle::read)) {
return bless \$stream, $class;
}
$stream; ### already okay!
}
#------------------------------
# I/O methods...
#------------------------------
sub close {
my $self = shift;
return close($$self);
}
sub fileno {
my $self = shift;
my $fh = $$self;
return fileno($fh);
}
sub getline {
my $self = shift;
my $fh = $$self;
return scalar(<$fh>);
}
sub getlines {
my $self = shift;
wantarray or croak("Can't call getlines in scalar context!");
my $fh = $$self;
<$fh>;
}
sub print {
my $self = shift;
print { $$self } @_;
}
sub read {
my $self = shift;
return read($$self, $_[0], $_[1]);
}
sub seek {
my $self = shift;
return seek($$self, $_[0], $_[1]);
}
sub tell {
my $self = shift;
return tell($$self);
}
#------------------------------
1;
__END__
=head1 NAME
IO::Wrap - wrap raw filehandles in IO::Handle interface
=head1 SYNOPSIS
use IO::Wrap;
### Do stuff with any kind of filehandle (including a bare globref), or
### any kind of blessed object that responds to a print() message.
###
sub do_stuff {
my $fh = shift;
### At this point, we have no idea what the user gave us...
### a globref? a FileHandle? a scalar filehandle name?
$fh = wraphandle($fh);
### At this point, we know we have an IO::Handle-like object!
$fh->print("Hey there!");
...
}
=head1 DESCRIPTION
Let's say you want to write some code which does I/O, but you don't
want to force the caller to provide you with a FileHandle or IO::Handle
object. You want them to be able to say:
do_stuff(\*STDOUT);
do_stuff('STDERR');
do_stuff($some_FileHandle_object);
do_stuff($some_IO_Handle_object);
And even:
do_stuff($any_object_with_a_print_method);
Sure, one way to do it is to force the caller to use tiehandle().
But that puts the burden on them. Another way to do it is to
use B<IO::Wrap>, which provides you with the following functions:
=over 4
=item wraphandle SCALAR
This function will take a single argument, and "wrap" it based on
what it seems to be...
=over 4
=item *
B<A raw scalar filehandle name,> like C<"STDOUT"> or C<"Class::HANDLE">.
In this case, the filehandle name is wrapped in an IO::Wrap object,
which is returned.
=item *
B<A raw filehandle glob,> like C<\*STDOUT>.
In this case, the filehandle glob is wrapped in an IO::Wrap object,
which is returned.
=item *
B<A blessed FileHandle object.>
In this case, the FileHandle is wrapped in an IO::Wrap object if and only
if your FileHandle class does not support the C<read()> method.
=item *
B<Any other kind of blessed object,> which is assumed to be already
conformant to the IO::Handle interface.
In this case, you just get back that object.
=back
=back
If you get back an IO::Wrap object, it will obey a basic subset of
the IO:: interface. That is, the following methods (note: I said
I<methods>, not named operators) should work on the thing you get back:
close
getline
getlines
print ARGS...
read BUFFER,NBYTES
seek POS,WHENCE
tell
=head1 NOTES
Clearly, when wrapping a raw external filehandle (like \*STDOUT),
I didn't want to close the file descriptor when the "wrapper" object is
destroyed... since the user might not appreciate that! Hence,
there's no DESTROY method in this class.
When wrapping a FileHandle object, however, I believe that Perl will
invoke the FileHandle::DESTROY when the last reference goes away,
so in that case, the filehandle is closed if the wrapped FileHandle
really was the last reference to it.
=head1 WARNINGS
This module does not allow you to wrap filehandle names which are given
as strings that lack the package they were opened in. That is, if a user
opens FOO in package Foo, they must pass it to you either as C<\*FOO>
or as C<"Foo::FOO">. However, C<"STDIN"> and friends will work just fine.
=head1 VERSION
$Id: Wrap.pm,v 1.2 2005/02/10 21:21:53 dfs Exp $
=head1 AUTHOR
=item Primary Maintainer
Dianne Skoll (F<dfs@roaringpenguin.com>).
=item Original Author
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=cut

491
Git/usr/share/perl5/vendor_perl/IO/WrapTie.pm Normal file
View File

@ -0,0 +1,491 @@
# SEE DOCUMENTATION AT BOTTOM OF FILE
#------------------------------------------------------------
package IO::WrapTie;
#------------------------------------------------------------
require 5.004; ### for tie
use strict;
use vars qw(@ISA @EXPORT $VERSION);
use Exporter;
# Inheritance, exporting, and package version:
@ISA = qw(Exporter);
@EXPORT = qw(wraptie);
$VERSION = "2.111";
# Function, exported.
sub wraptie {
IO::WrapTie::Master->new(@_);
}
# Class method; BACKWARDS-COMPATIBILITY ONLY!
sub new {
shift;
IO::WrapTie::Master->new(@_);
}
#------------------------------------------------------------
package IO::WrapTie::Master;
#------------------------------------------------------------
use strict;
use vars qw(@ISA $AUTOLOAD);
use IO::Handle;
# We inherit from IO::Handle to get methods which invoke i/o operators,
# like print(), on our tied handle:
@ISA = qw(IO::Handle);
#------------------------------
# new SLAVE, TIEARGS...
#------------------------------
# Create a new subclass of IO::Handle which...
#
# (1) Handles i/o OPERATORS because it is tied to an instance of
# an i/o-like class, like IO::Scalar.
#
# (2) Handles i/o METHODS by delegating them to that same tied object!.
#
# Arguments are the slave class (e.g., IO::Scalar), followed by all
# the arguments normally sent into that class's TIEHANDLE method.
# In other words, much like the arguments to tie(). :-)
#
# NOTE:
# The thing $x we return must be a BLESSED REF, for ($x->print()).
# The underlying symbol must be a FILEHANDLE, for (print $x "foo").
# It has to have a way of getting to the "real" back-end object...
#
sub new {
my $master = shift;
my $io = IO::Handle->new; ### create a new handle
my $slave = shift;
tie *$io, $slave, @_; ### tie: will invoke slave's TIEHANDLE
bless $io, $master; ### return a master
}
#------------------------------
# AUTOLOAD
#------------------------------
# Delegate method invocations on the master to the underlying slave.
#
sub AUTOLOAD {
my $method = $AUTOLOAD;
$method =~ s/.*:://;
my $self = shift; tied(*$self)->$method(\@_);
}
#------------------------------
# PRELOAD
#------------------------------
# Utility.
#
# Most methods like print(), getline(), etc. which work on the tied object
# via Perl's i/o operators (like 'print') are inherited from IO::Handle.
#
# Other methods, like seek() and sref(), we must delegate ourselves.
# AUTOLOAD takes care of these.
#
# However, it may be necessary to preload delegators into your
# own class. PRELOAD will do this.
#
sub PRELOAD {
my $class = shift;
foreach (@_) {
eval "sub ${class}::$_ { my \$s = shift; tied(*\$s)->$_(\@_) }";
}
}
# Preload delegators for some standard methods which we can't simply
# inherit from IO::Handle... for example, some IO::Handle methods
# assume that there is an underlying file descriptor.
#
PRELOAD IO::WrapTie::Master
qw(open opened close read clearerr eof seek tell setpos getpos);
#------------------------------------------------------------
package IO::WrapTie::Slave;
#------------------------------------------------------------
# Teeny private class providing a new_tie constructor...
#
# HOW IT ALL WORKS:
#
# Slaves inherit from this class.
#
# When you send a new_tie() message to a tie-slave class (like IO::Scalar),
# it first determines what class should provide its master, via TIE_MASTER.
# In this case, IO::Scalar->TIE_MASTER would return IO::Scalar::Master.
# Then, we create a new master (an IO::Scalar::Master) with the same args
# sent to new_tie.
#
# In general, the new() method of the master is inherited directly
# from IO::WrapTie::Master.
#
sub new_tie {
my $self = shift;
$self->TIE_MASTER->new($self,@_); ### e.g., IO::Scalar::Master->new(@_)
}
# Default class method for new_tie().
# All your tie-slave class (like IO::Scalar) has to do is override this
# method with a method that returns the name of an appropriate "master"
# class for tying that slave.
#
sub TIE_MASTER { 'IO::WrapTie::Master' }
#------------------------------
1;
__END__
package IO::WrapTie; ### for doc generator
=head1 NAME
IO::WrapTie - wrap tieable objects in IO::Handle interface
I<This is currently Alpha code, released for comments.
Please give me your feedback!>
=head1 SYNOPSIS
First of all, you'll need tie(), so:
require 5.004;
I<Function interface (experimental).>
Use this with any existing class...
use IO::WrapTie;
use FooHandle; ### implements TIEHANDLE interface
### Suppose we want a "FooHandle->new(&FOO_RDWR, 2)".
### We can instead say...
$FH = wraptie('FooHandle', &FOO_RDWR, 2);
### Now we can use...
print $FH "Hello, "; ### traditional operator syntax...
$FH->print("world!\n"); ### ...and OO syntax as well!
I<OO interface (preferred).>
You can inherit from the IO::WrapTie::Slave mixin to get a
nifty C<new_tie()> constructor...
#------------------------------
package FooHandle; ### a class which can TIEHANDLE
use IO::WrapTie;
@ISA = qw(IO::WrapTie::Slave); ### inherit new_tie()
...
#------------------------------
package main;
$FH = FooHandle->new_tie(&FOO_RDWR, 2); ### $FH is an IO::WrapTie::Master
print $FH "Hello, "; ### traditional operator syntax
$FH->print("world!\n"); ### OO syntax
See IO::Scalar as an example. It also shows you how to create classes
which work both with and without 5.004.
=head1 DESCRIPTION
Suppose you have a class C<FooHandle>, where...
=over 4
=item *
B<FooHandle does not inherit from IO::Handle;> that is, it performs
filehandle-like I/O, but to something other than an underlying
file descriptor. Good examples are IO::Scalar (for printing to a
string) and IO::Lines (for printing to an array of lines).
=item *
B<FooHandle implements the TIEHANDLE interface> (see L<perltie>);
that is, it provides methods TIEHANDLE, GETC, PRINT, PRINTF,
READ, and READLINE.
=item *
B<FooHandle implements the traditional OO interface> of
FileHandle and IO::Handle; i.e., it contains methods like getline(),
read(), print(), seek(), tell(), eof(), etc.
=back
Normally, users of your class would have two options:
=over 4
=item *
B<Use only OO syntax,> and forsake named I/O operators like 'print'.
=item *
B<Use with tie,> and forsake treating it as a first-class object
(i.e., class-specific methods can only be invoked through the underlying
object via tied()... giving the object a "split personality").
=back
But now with IO::WrapTie, you can say:
$WT = wraptie('FooHandle', &FOO_RDWR, 2);
$WT->print("Hello, world\n"); ### OO syntax
print $WT "Yes!\n"; ### Named operator syntax too!
$WT->weird_stuff; ### Other methods!
And if you're authoring a class like FooHandle, just have it inherit
from C<IO::WrapTie::Slave> and that first line becomes even prettier:
$WT = FooHandle->new_tie(&FOO_RDWR, 2);
B<The bottom line:> now, almost any class can look and work exactly like
an IO::Handle... and be used both with OO and non-OO filehandle syntax.
=head1 HOW IT ALL WORKS
=head2 The data structures
Consider this example code, using classes in this distribution:
use IO::Scalar;
use IO::WrapTie;
$WT = wraptie('IO::Scalar',\$s);
print $WT "Hello, ";
$WT->print("world!\n");
In it, the wraptie() function creates a data structure as follows:
* $WT is a blessed reference to a tied filehandle
$WT glob; that glob is tied to the "Slave" object.
| * You would do all your i/o with $WT directly.
|
|
| ,---isa--> IO::WrapTie::Master >--isa--> IO::Handle
V /
.-------------.
| |
| | * Perl i/o operators work on the tied object,
| "Master" | invoking the TIEHANDLE methods.
| | * Method invocations are delegated to the tied
| | slave.
`-------------'
|
tied(*$WT) | .---isa--> IO::WrapTie::Slave
V /
.-------------.
| |
| "Slave" | * Instance of FileHandle-like class which doesn't
| | actually use file descriptors, like IO::Scalar.
| IO::Scalar | * The slave can be any kind of object.
| | * Must implement the TIEHANDLE interface.
`-------------'
I<NOTE:> just as an IO::Handle is really just a blessed reference to a
I<traditional> filehandle glob... so also, an IO::WrapTie::Master
is really just a blessed reference to a filehandle
glob I<which has been tied to some "slave" class.>
=head2 How wraptie() works
=over 4
=item 1.
The call to function C<wraptie(SLAVECLASS, TIEARGS...)> is
passed onto C<IO::WrapTie::Master::new()>.
Note that class IO::WrapTie::Master is a subclass of IO::Handle.
=item 2.
The C<IO::WrapTie::Master::new> method creates a new IO::Handle object,
reblessed into class IO::WrapTie::Master. This object is the I<master>,
which will be returned from the constructor. At the same time...
=item 3.
The C<new> method also creates the I<slave>: this is an instance
of SLAVECLASS which is created by tying the master's IO::Handle
to SLAVECLASS via C<tie(HANDLE, SLAVECLASS, TIEARGS...)>.
This call to C<tie()> creates the slave in the following manner:
=item 4.
Class SLAVECLASS is sent the message C<TIEHANDLE(TIEARGS...)>; it
will usually delegate this to C<SLAVECLASS::new(TIEARGS...)>, resulting
in a new instance of SLAVECLASS being created and returned.
=item 5.
Once both master and slave have been created, the master is returned
to the caller.
=back
=head2 How I/O operators work (on the master)
Consider using an i/o operator on the master:
print $WT "Hello, world!\n";
Since the master ($WT) is really a [blessed] reference to a glob,
the normal Perl i/o operators like C<print> may be used on it.
They will just operate on the symbol part of the glob.
Since the glob is tied to the slave, the slave's PRINT method
(part of the TIEHANDLE interface) will be automatically invoked.
If the slave is an IO::Scalar, that means IO::Scalar::PRINT will be
invoked, and that method happens to delegate to the C<print()> method
of the same class. So the I<real> work is ultimately done by
IO::Scalar::print().
=head2 How methods work (on the master)
Consider using a method on the master:
$WT->print("Hello, world!\n");
Since the master ($WT) is blessed into the class IO::WrapTie::Master,
Perl first attempts to find a C<print()> method there. Failing that,
Perl next attempts to find a C<print()> method in the superclass,
IO::Handle. It just so happens that there I<is> such a method;
that method merely invokes the C<print> i/o operator on the self object...
and for that, see above!
But let's suppose we're dealing with a method which I<isn't> part
of IO::Handle... for example:
my $sref = $WT->sref;
In this case, the intuitive behavior is to have the master delegate the
method invocation to the slave (now do you see where the designations
come from?). This is indeed what happens: IO::WrapTie::Master contains
an AUTOLOAD method which performs the delegation.
So: when C<sref()> can't be found in IO::Handle, the AUTOLOAD method
of IO::WrapTie::Master is invoked, and the standard behavior of
delegating the method to the underlying slave (here, an IO::Scalar)
is done.
Sometimes, to get this to work properly, you may need to create
a subclass of IO::WrapTie::Master which is an effective master for
I<your> class, and do the delegation there.
=head1 NOTES
B<Why not simply use the object's OO interface?>
Because that means forsaking the use of named operators
like print(), and you may need to pass the object to a subroutine
which will attempt to use those operators:
$O = FooHandle->new(&FOO_RDWR, 2);
$O->print("Hello, world\n"); ### OO syntax is okay, BUT....
sub nope { print $_[0] "Nope!\n" }
X nope($O); ### ERROR!!! (not a glob ref)
B<Why not simply use tie()?>
Because (1) you have to use tied() to invoke methods in the
object's public interface (yuck), and (2) you may need to pass
the tied symbol to another subroutine which will attempt to treat
it in an OO-way... and that will break it:
tie *T, 'FooHandle', &FOO_RDWR, 2;
print T "Hello, world\n"; ### Operator is okay, BUT...
tied(*T)->other_stuff; ### yuck! AND...
sub nope { shift->print("Nope!\n") }
X nope(\*T); ### ERROR!!! (method "print" on unblessed ref)
B<Why a master and slave?
Why not simply write FooHandle to inherit from IO::Handle?>
I tried this, with an implementation similar to that of IO::Socket.
The problem is that I<the whole point is to use this with objects
that don't have an underlying file/socket descriptor.>.
Subclassing IO::Handle will work fine for the OO stuff, and fine with
named operators I<if> you tie()... but if you just attempt to say:
$IO = FooHandle->new(&FOO_RDWR, 2);
print $IO "Hello!\n";
you get a warning from Perl like:
Filehandle GEN001 never opened
because it's trying to do system-level i/o on an (unopened) file
descriptor. To avoid this, you apparently have to tie() the handle...
which brings us right back to where we started! At least the
IO::WrapTie mixin lets us say:
$IO = FooHandle->new_tie(&FOO_RDWR, 2);
print $IO "Hello!\n";
and so is not I<too> bad. C<:-)>
=head1 WARNINGS
Remember: this stuff is for doing FileHandle-like i/o on things
I<without underlying file descriptors>. If you have an underlying
file descriptor, you're better off just inheriting from IO::Handle.
B<Be aware that new_tie() always returns an instance of a
kind of IO::WrapTie::Master...> it does B<not> return an instance
of the i/o class you're tying to!
Invoking some methods on the master object causes AUTOLOAD to delegate
them to the slave object... so it I<looks> like you're manipulating a
"FooHandle" object directly, but you're not.
I have not explored all the ramifications of this use of tie().
I<Here there be dragons>.
=head1 VERSION
$Id: WrapTie.pm,v 1.2 2005/02/10 21:21:53 dfs Exp $
=head1 AUTHOR
=item Primary Maintainer
Dianne Skoll (F<dfs@roaringpenguin.com>).
=item Original Author
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=cut