CosmicRage/VIPMudCosmicRageScripts
5
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

made the pack completely portable and wrote relevent bat files to go with it

Browse Source
This commit is contained in:
Draqoken
2025-04-09 17:04:56 +03:00
parent 5e77d7e9cf
commit 5e4144c3c0
7417 changed files with 2181044 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files

207
gitportable/usr/share/perl5/vendor_perl/IO/AtomicFile.pm Normal file
View File

@@ -0,0 +1,207 @@
package IO::AtomicFile;
use strict;
use warnings;
use parent 'IO::File';
our $VERSION = '2.113';
#------------------------------
# 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 strict;
use warnings;
use feature 'say';
use IO::AtomicFile;
# Write a temp file, and have it install itself when closed:
my $fh = IO::AtomicFile->open("bar.dat", "w");
$fh->say("Hello!");
$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");
$fh->say("Hello!");
$fh->delete;
# Write a temp file, but neither install it nor delete it:
my $fh = IO::AtomicFile->open("bar.dat", "w");
$fh->say("Hello!");
$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 C<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 C<close>, or implicitly via the destruction of the object)
will cause C<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 C<close> method
done by the destructor will raise a fatal exception if the C<rename>
fails. The explicit C<close> just returns C<undef>.
You can also decide at any point to trash the file you've been
building.
=head1 METHODS
L<IO::AtomicFile> inherits all methods from L<IO::File> and
implements the following new ones.
=head2 close
$fh->close();
This method calls its parent L<IO::File/"close"> and then renames its temporary file
as the original file name.
=head2 delete
$fh->delete();
This method calls its parent L<IO::File/"close"> and then deletes the temporary file.
=head2 detach
$fh->detach();
This method calls its parent L<IO::File/"close">. Unlike L<IO::AtomicFile/"delete"> it
does not then delete the temporary file.
=head1 AUTHOR
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head1 CONTRIBUTORS
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head1 COPYRIGHT & LICENSE
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut

629
gitportable/usr/share/perl5/vendor_perl/IO/HTML.pm Normal file
View File

@@ -0,0 +1,629 @@
#---------------------------------------------------------------------
package IO::HTML;
#
# Copyright 2020 Christopher J. Madsen
#
# Author: Christopher J. Madsen <perl@cjmweb.net>
# Created: 14 Jan 2012
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the
# GNU General Public License or the Artistic License for more details.
#
# ABSTRACT: Open an HTML file with automatic charset detection
#---------------------------------------------------------------------
use 5.008;
use strict;
use warnings;
use Carp 'croak';
use Encode 2.10 qw(decode find_encoding); # need utf-8-strict encoding
use Exporter 5.57 'import';
our $VERSION = '1.004';
# This file is part of IO-HTML 1.004 (September 26, 2020)
our $bytes_to_check ||= 1024;
our $default_encoding ||= 'cp1252';
our @EXPORT = qw(html_file);
our @EXPORT_OK = qw(find_charset_in html_file_and_encoding html_outfile
sniff_encoding);
our %EXPORT_TAGS = (
rw => [qw( html_file html_file_and_encoding html_outfile )],
all => [ @EXPORT, @EXPORT_OK ],
);
#=====================================================================
sub html_file
{
(&html_file_and_encoding)[0]; # return just the filehandle
} # end html_file
# Note: I made html_file and html_file_and_encoding separate functions
# (instead of making html_file context-sensitive) because I wanted to
# use html_file in function calls (i.e. list context) without having
# to write "scalar html_file" all the time.
sub html_file_and_encoding
{
my ($filename, $options) = @_;
$options ||= {};
open(my $in, '<:raw', $filename) or croak "Failed to open $filename: $!";
my ($encoding, $bom) = sniff_encoding($in, $filename, $options);
if (not defined $encoding) {
croak "No default encoding specified"
unless defined($encoding = $default_encoding);
$encoding = find_encoding($encoding) if $options->{encoding};
} # end if we didn't find an encoding
binmode $in, sprintf(":encoding(%s):crlf",
$options->{encoding} ? $encoding->name : $encoding);
return ($in, $encoding, $bom);
} # end html_file_and_encoding
#---------------------------------------------------------------------
sub html_outfile
{
my ($filename, $encoding, $bom) = @_;
if (not defined $encoding) {
croak "No default encoding specified"
unless defined($encoding = $default_encoding);
} # end if we didn't find an encoding
elsif (ref $encoding) {
$encoding = $encoding->name;
}
open(my $out, ">:encoding($encoding)", $filename)
or croak "Failed to open $filename: $!";
print $out "\x{FeFF}" if $bom;
return $out;
} # end html_outfile
#---------------------------------------------------------------------
sub sniff_encoding
{
my ($in, $filename, $options) = @_;
$filename = 'file' unless defined $filename;
$options ||= {};
my $pos = tell $in;
croak "Could not seek $filename: $!" if $pos < 0;
croak "Could not read $filename: $!"
unless defined read $in, my($buf), $bytes_to_check;
seek $in, $pos, 0 or croak "Could not seek $filename: $!";
# Check for BOM:
my $bom;
my $encoding = do {
if ($buf =~ /^\xFe\xFF/) {
$bom = 2;
'UTF-16BE';
} elsif ($buf =~ /^\xFF\xFe/) {
$bom = 2;
'UTF-16LE';
} elsif ($buf =~ /^\xEF\xBB\xBF/) {
$bom = 3;
'utf-8-strict';
} else {
find_charset_in($buf, $options); # check for <meta charset>
}
}; # end $encoding
if ($bom) {
seek $in, $bom, 1 or croak "Could not seek $filename: $!";
$bom = 1;
}
elsif (not defined $encoding) { # try decoding as UTF-8
my $test = decode('utf-8-strict', $buf, Encode::FB_QUIET);
if ($buf =~ /^(?: # nothing left over
| [\xC2-\xDF] # incomplete 2-byte char
| [\xE0-\xEF] [\x80-\xBF]? # incomplete 3-byte char
| [\xF0-\xF4] [\x80-\xBF]{0,2} # incomplete 4-byte char
)\z/x and $test =~ /[^\x00-\x7F]/) {
$encoding = 'utf-8-strict';
} # end if valid UTF-8 with at least one multi-byte character:
} # end if testing for UTF-8
if (defined $encoding and $options->{encoding} and not ref $encoding) {
$encoding = find_encoding($encoding);
} # end if $encoding is a string and we want an object
return wantarray ? ($encoding, $bom) : $encoding;
} # end sniff_encoding
#=====================================================================
# Based on HTML5 8.2.2.2 Determining the character encoding:
# Get attribute from current position of $_
sub _get_attribute
{
m!\G[\x09\x0A\x0C\x0D /]+!gc; # skip whitespace or /
return if /\G>/gc or not /\G(=?[^\x09\x0A\x0C\x0D =]*)/gc;
my ($name, $value) = (lc $1, '');
if (/\G[\x09\x0A\x0C\x0D ]*=[\x09\x0A\x0C\x0D ]*/gc) {
if (/\G"/gc) {
# Double-quoted attribute value
/\G([^"]*)("?)/gc;
return unless $2; # Incomplete attribute (missing closing quote)
$value = lc $1;
} elsif (/\G'/gc) {
# Single-quoted attribute value
/\G([^']*)('?)/gc;
return unless $2; # Incomplete attribute (missing closing quote)
$value = lc $1;
} else {
# Unquoted attribute value
/\G([^\x09\x0A\x0C\x0D >]*)/gc;
$value = lc $1;
}
} # end if attribute has value
return wantarray ? ($name, $value) : 1;
} # end _get_attribute
# Examine a meta value for a charset:
sub _get_charset_from_meta
{
for (shift) {
while (/charset[\x09\x0A\x0C\x0D ]*=[\x09\x0A\x0C\x0D ]*/ig) {
return $1 if (/\G"([^"]*)"/gc or
/\G'([^']*)'/gc or
/\G(?!['"])([^\x09\x0A\x0C\x0D ;]+)/gc);
}
} # end for value
return undef;
} # end _get_charset_from_meta
#---------------------------------------------------------------------
sub find_charset_in
{
for (shift) {
my $options = shift || {};
# search only the first $bytes_to_check bytes (default 1024)
my $stop = length > $bytes_to_check ? $bytes_to_check : length;
my $expect_pragma = (defined $options->{need_pragma}
? $options->{need_pragma} : 1);
pos() = 0;
while (pos() < $stop) {
if (/\G<!--.*?(?<=--)>/sgc) {
} # Skip comment
elsif (m!\G<meta(?=[\x09\x0A\x0C\x0D /])!gic) {
my ($got_pragma, $need_pragma, $charset);
while (my ($name, $value) = &_get_attribute) {
if ($name eq 'http-equiv' and $value eq 'content-type') {
$got_pragma = 1;
} elsif ($name eq 'content' and not defined $charset) {
$need_pragma = $expect_pragma
if defined($charset = _get_charset_from_meta($value));
} elsif ($name eq 'charset') {
$charset = $value;
$need_pragma = 0;
}
} # end while more attributes in this <meta> tag
if (defined $need_pragma and (not $need_pragma or $got_pragma)) {
$charset = 'UTF-8' if $charset =~ /^utf-?16/;
$charset = 'cp1252' if $charset eq 'iso-8859-1'; # people lie
if (my $encoding = find_encoding($charset)) {
return $options->{encoding} ? $encoding : $encoding->name;
} # end if charset is a recognized encoding
} # end if found charset
} # end elsif <meta
elsif (m!\G</?[a-zA-Z][^\x09\x0A\x0C\x0D >]*!gc) {
1 while &_get_attribute;
} # end elsif some other tag
elsif (m{\G<[!/?][^>]*}gc) {
} # skip unwanted things
elsif (m/\G</gc) {
} # skip < that doesn't open anything we recognize
# Advance to the next <:
m/\G[^<]+/gc;
} # end while not at search boundary
} # end for string
return undef; # Couldn't find a charset
} # end find_charset_in
#---------------------------------------------------------------------
# Shortcuts for people who don't like exported functions:
*file = \&html_file;
*file_and_encoding = \&html_file_and_encoding;
*outfile = \&html_outfile;
#=====================================================================
# Package Return Value:
1;
__END__
=head1 NAME
IO::HTML - Open an HTML file with automatic charset detection
=head1 VERSION
This document describes version 1.004 of
IO::HTML, released September 26, 2020.
=head1 SYNOPSIS
use IO::HTML; # exports html_file by default
use HTML::TreeBuilder;
my $tree = HTML::TreeBuilder->new_from_file(
html_file('foo.html')
);
# Alternative interface:
open(my $in, '<:raw', 'bar.html');
my $encoding = IO::HTML::sniff_encoding($in, 'bar.html');
=head1 DESCRIPTION
IO::HTML provides an easy way to open a file containing HTML while
automatically determining its encoding. It uses the HTML5 encoding
sniffing algorithm specified in section 8.2.2.2 of the draft standard.
The algorithm as implemented here is:
=over
=item 1.
If the file begins with a byte order mark indicating UTF-16LE,
UTF-16BE, or UTF-8, then that is the encoding.
=item 2.
If the first C<$bytes_to_check> bytes of the file contain a C<< <meta> >> tag that
indicates the charset, and Encode recognizes the specified charset
name, then that is the encoding. (This portion of the algorithm is
implemented by C<find_charset_in>.)
The C<< <meta> >> tag can be in one of two formats:
<meta charset="...">
<meta http-equiv="Content-Type" content="...charset=...">
The search is case-insensitive, and the order of attributes within the
tag is irrelevant. Any additional attributes of the tag are ignored.
The first matching tag with a recognized encoding ends the search.
=item 3.
If the first C<$bytes_to_check> bytes of the file are valid UTF-8 (with at least 1
non-ASCII character), then the encoding is UTF-8.
=item 4.
If all else fails, use the default character encoding. The HTML5
standard suggests the default encoding should be locale dependent, but
currently it is always C<cp1252> unless you set
C<$IO::HTML::default_encoding> to a different value. Note:
C<sniff_encoding> does not apply this step; only C<html_file> does
that.
=back
=head1 SUBROUTINES
=head2 html_file
$filehandle = html_file($filename, \%options);
This function (exported by default) is the primary entry point. It
opens the file specified by C<$filename> for reading, uses
C<sniff_encoding> to find a suitable encoding layer, and applies it.
It also applies the C<:crlf> layer. If the file begins with a BOM,
the filehandle is positioned just after the BOM.
The optional second argument is a hashref containing options. The
possible keys are described under C<find_charset_in>.
If C<sniff_encoding> is unable to determine the encoding, it defaults
to C<$IO::HTML::default_encoding>, which is set to C<cp1252>
(a.k.a. Windows-1252) by default. According to the standard, the
default should be locale dependent, but that is not currently
implemented.
It dies if the file cannot be opened, or if C<sniff_encoding> cannot
determine the encoding and C<$IO::HTML::default_encoding> has been set
to C<undef>.
=head2 html_file_and_encoding
($filehandle, $encoding, $bom)
= html_file_and_encoding($filename, \%options);
This function (exported only by request) is just like C<html_file>,
but returns more information. In addition to the filehandle, it
returns the name of the encoding used, and a flag indicating whether a
byte order mark was found (if C<$bom> is true, the file began with a
BOM). This may be useful if you want to write the file out again
(especially in conjunction with the C<html_outfile> function).
The optional second argument is a hashref containing options. The
possible keys are described under C<find_charset_in>.
It dies if the file cannot be opened, or if C<sniff_encoding> cannot
determine the encoding and C<$IO::HTML::default_encoding> has been set
to C<undef>.
The result of calling C<html_file_and_encoding> in scalar context is undefined
(in the C sense of there is no guarantee what you'll get).
=head2 html_outfile
$filehandle = html_outfile($filename, $encoding, $bom);
This function (exported only by request) opens C<$filename> for output
using C<$encoding>, and writes a BOM to it if C<$bom> is true.
If C<$encoding> is C<undef>, it defaults to C<$IO::HTML::default_encoding>.
C<$encoding> may be either an encoding name or an Encode::Encoding object.
It dies if the file cannot be opened, or if both C<$encoding> and
C<$IO::HTML::default_encoding> are C<undef>.
=head2 sniff_encoding
($encoding, $bom) = sniff_encoding($filehandle, $filename, \%options);
This function (exported only by request) runs the HTML5 encoding
sniffing algorithm on C<$filehandle> (which must be seekable, and
should have been opened in C<:raw> mode). C<$filename> is used only
for error messages (if there's a problem using the filehandle), and
defaults to "file" if omitted. The optional third argument is a
hashref containing options. The possible keys are described under
C<find_charset_in>.
It returns Perl's canonical name for the encoding, which is not
necessarily the same as the MIME or IANA charset name. It returns
C<undef> if the encoding cannot be determined. C<$bom> is true if the
file began with a byte order mark. In scalar context, it returns only
C<$encoding>.
The filehandle's position is restored to its original position
(normally the beginning of the file) unless C<$bom> is true. In that
case, the position is immediately after the BOM.
Tip: If you want to run C<sniff_encoding> on a file you've already
loaded into a string, open an in-memory file on the string, and pass
that handle:
($encoding, $bom) = do {
open(my $fh, '<', \$string); sniff_encoding($fh)
};
(This only makes sense if C<$string> contains bytes, not characters.)
=head2 find_charset_in
$encoding = find_charset_in($string_containing_HTML, \%options);
This function (exported only by request) looks for charset information
in a C<< <meta> >> tag in a possibly-incomplete HTML document using
the "two step" algorithm specified by HTML5. It does not look for a BOM.
The C<< <meta> >> tag must begin within the first C<$IO::HTML::bytes_to_check>
bytes of the string.
It returns Perl's canonical name for the encoding, which is not
necessarily the same as the MIME or IANA charset name. It returns
C<undef> if no charset is specified or if the specified charset is not
recognized by the Encode module.
The optional second argument is a hashref containing options. The
following keys are recognized:
=over
=item C<encoding>
If true, return the L<Encode::Encoding> object instead of its name.
Defaults to false.
=item C<need_pragma>
If true (the default), follow the HTML5 spec and examine the
C<content> attribute only of C<< <meta http-equiv="Content-Type" >>.
If set to 0, relax the HTML5 spec, and look for "charset=" in the
C<content> attribute of I<every> meta tag.
=back
=head1 EXPORTS
By default, only C<html_file> is exported. Other functions may be
exported on request.
For people who prefer not to export functions, all functions beginning
with C<html_> have an alias without that prefix (e.g. you can call
C<IO::HTML::file(...)> instead of C<IO::HTML::html_file(...)>. These
aliases are not exportable.
=for Pod::Coverage
file
file_and_encoding
outfile
The following export tags are available:
=over
=item C<:all>
All exportable functions.
=item C<:rw>
C<html_file>, C<html_file_and_encoding>, C<html_outfile>.
=back
=head1 SEE ALSO
The HTML5 specification, section 8.2.2.2 Determining the character encoding:
L<http://www.w3.org/TR/html5/syntax.html#determining-the-character-encoding>
=head1 DIAGNOSTICS
=over
=item C<< Could not read %s: %s >>
The specified file could not be read from for the reason specified by C<$!>.
=item C<< Could not seek %s: %s >>
The specified file could not be rewound for the reason specified by C<$!>.
=item C<< Failed to open %s: %s >>
The specified file could not be opened for reading for the reason
specified by C<$!>.
=item C<< No default encoding specified >>
The C<sniff_encoding> algorithm didn't find an encoding to use, and
you set C<$IO::HTML::default_encoding> to C<undef>.
=back
=head1 CONFIGURATION AND ENVIRONMENT
There are two global variables that affect IO::HTML. If you need to
change them, you should do so using C<local> if possible:
my $file = do {
# This file may define the charset later in the header
local $IO::HTML::bytes_to_check = 4096;
html_file(...);
};
=over
=item C<$bytes_to_check>
This is the number of bytes that C<sniff_encoding> will read from the
stream. It is also the number of bytes that C<find_charset_in> will
search for a C<< <meta> >> tag containing charset information.
It must be a positive integer.
The HTML 5 specification recommends using the default value of 1024,
but some pages do not follow the specification.
=item C<$default_encoding>
This is the encoding that C<html_file> and C<html_file_and_encoding>
will use if no encoding can be detected by C<sniff_encoding>.
The default value is C<cp1252> (a.k.a. Windows-1252).
Setting it to C<undef> will cause the file subroutines to croak if
C<sniff_encoding> fails to determine the encoding. (C<sniff_encoding>
itself does not use C<$default_encoding>).
=back
=head1 DEPENDENCIES
IO::HTML has no non-core dependencies for Perl 5.8.7+. With earlier
versions of Perl 5.8, you need to upgrade L<Encode> to at least
version 2.10, and
you may need to upgrade L<Exporter> to at least version
5.57.
=head1 INCOMPATIBILITIES
None reported.
=head1 BUGS AND LIMITATIONS
No bugs have been reported.
=head1 AUTHOR
Christopher J. Madsen S<C<< <perl AT cjmweb.net> >>>
Please report any bugs or feature requests
to S<C<< <bug-IO-HTML AT rt.cpan.org> >>>
or through the web interface at
L<< http://rt.cpan.org/Public/Bug/Report.html?Queue=IO-HTML >>.
You can follow or contribute to IO-HTML's development at
L<< https://github.com/madsen/io-html >>.
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Christopher J. Madsen.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=head1 DISCLAIMER OF WARRANTY
BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
NECESSARY SERVICING, REPAIR, OR CORRECTION.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE
LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
=cut

335
gitportable/usr/share/perl5/vendor_perl/IO/InnerFile.pm Normal file
View File

@@ -0,0 +1,335 @@
package IO::InnerFile;
use strict;
use warnings;
use Symbol;
our $VERSION = '2.113';
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');
}
sub set_length { tied(${$_[0]})->{LG} = $_[1]; }
sub get_length { tied(${$_[0]})->{LG}; }
sub add_length { tied(${$_[0]})->{LG} += $_[1]; }
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}; }
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__
__END__
=head1 NAME
IO::InnerFile - define a file inside another file
=head1 SYNOPSIS
use strict;
use warnings;
use IO::InnerFile;
# Read a subset of a file:
my $fh = _some_file_handle;
my $start = 10;
my $length = 50;
my $inner = IO::InnerFile->new($fh, $start, $length);
while (my $line = <$inner>) {
# ...
}
=head1 DESCRIPTION
If you have a file handle that can C<seek> and C<tell>, then you
can open an L<IO::InnerFile> on a range of the underlying file.
=head1 CONSTRUCTORS
L<IO::InnerFile> implements the following constructors.
=head2 new
my $inner = IO::InnerFile->new($fh);
$inner = IO::InnerFile->new($fh, 10);
$inner = IO::InnerFile->new($fh, 10, 50);
Create a new L<IO::InnerFile> opened on the given file handle.
The file handle supplied B<MUST> be able to both C<seek> and C<tell>.
The second and third parameters are start and length. Both are defaulted
to zero (C<0>). Negative values are silently coerced to zero.
=head1 METHODS
L<IO::InnerFile> implements the following methods.
=head2 add_length
$inner->add_length(30);
Add to the virtual length of the inner file by the number given in bytes.
=head2 add_start
$inner->add_start(30);
Add to the virtual position of the inner file by the number given in bytes.
=head2 binmode
$inner->binmode();
This is a NOOP method just to satisfy the normal L<IO::File> interface.
=head2 close
=head2 fileno
$inner->fileno();
This is a NOOP method just to satisfy the normal L<IO::File> interface.
=head2 flush
$inner->flush();
This is a NOOP method just to satisfy the normal L<IO::File> interface.
=head2 get_end
my $num_bytes = $inner->get_end();
Get the virtual end position of the inner file in bytes.
=head2 get_length
my $num_bytes = $inner->get_length();
Get the virtual length of the inner file in bytes.
=head2 get_start
my $num_bytes = $inner->get_start();
Get the virtual position of the inner file in bytes.
=head2 getc
=head2 getline
=head2 print LIST
=head2 printf
=head2 read
=head2 readline
=head2 seek
=head2 set_end
$inner->set_end(30);
Set the virtual end of the inner file in bytes (this basically just alters the length).
=head2 set_length
$inner->set_length(30);
Set the virtual length of the inner file in bytes.
=head2 set_start
$inner->set_start(30);
Set the virtual start position of the inner file in bytes.
=head2 tell
=head2 write
=head1 AUTHOR
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head1 CONTRIBUTORS
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head1 COPYRIGHT & LICENSE
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut

174
gitportable/usr/share/perl5/vendor_perl/IO/Lines.pm Normal file
View File

@@ -0,0 +1,174 @@
package IO::Lines;
use strict;
use Carp;
use IO::ScalarArray;
# The package version, both in 1.23 style *and* usable by MakeMaker:
our $VERSION = '2.113';
# Inheritance:
our @ISA = qw(IO::ScalarArray); ### also gets us new_tie :-)
=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. C<tiehandle> capable 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
#------------------------------
#
# 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 AUTHOR
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head1 CONTRIBUTORS
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head1 COPYRIGHT & LICENSE
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut

724
gitportable/usr/share/perl5/vendor_perl/IO/Scalar.pm Normal file
View File

@@ -0,0 +1,724 @@
package IO::Scalar;
use strict;
use Carp;
use IO::Handle;
### 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:
our $VERSION = '2.113';
### Inheritance:
our @ISA = qw(IO::Handle);
### This stuff should be got rid of ASAP.
require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
#==============================
=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 C<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
=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 AUTHOR
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head1 CONTRIBUTORS
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head1 COPYRIGHT & LICENSE
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut

751
gitportable/usr/share/perl5/vendor_perl/IO/ScalarArray.pm Normal file
View File

@@ -0,0 +1,751 @@
package IO::ScalarArray;
use strict;
use Carp;
use IO::Handle;
# The package version, both in 1.23 style *and* usable by MakeMaker:
our $VERSION = '2.113';
# Inheritance:
our @ISA = qw(IO::Handle);
require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
=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 C<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
=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 AUTHOR
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head1 CONTRIBUTORS
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head1 COPYRIGHT & LICENSE
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut

3813
gitportable/usr/share/perl5/vendor_perl/IO/Socket/SSL.pm Normal file
View File

File diff suppressed because it is too large Load Diff

380
gitportable/usr/share/perl5/vendor_perl/IO/Socket/SSL/Intercept.pm Normal file
View File

@@ -0,0 +1,380 @@
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,
ignore_invalid_args => 1,
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 returns 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 persistently 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

16132
gitportable/usr/share/perl5/vendor_perl/IO/Socket/SSL/PublicSuffix.pm Normal file
View File

File diff suppressed because it is too large Load Diff

800
gitportable/usr/share/perl5/vendor_perl/IO/Socket/SSL/Utils.pm Normal file
View File

@@ -0,0 +1,800 @@
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.015';
our @EXPORT = qw(
PEM_file2cert PEM_file2certs PEM_string2cert PEM_cert2file PEM_certs2file 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;
}
use constant PEM_R_NO_START_LINE => 108;
sub PEM_file2certs {
my $file = shift;
my $bio = Net::SSLeay::BIO_new_file($file,'r') or
croak "cannot read $file: $!";
my @certs;
while (1) {
if (my $cert = Net::SSLeay::PEM_read_bio_X509($bio)) {
push @certs, $cert;
} else {
Net::SSLeay::BIO_free($bio);
my $error = Net::SSLeay::ERR_get_error();
last if ($error & 0xfff) == PEM_R_NO_START_LINE && @certs;
croak "cannot parse $file as PEM X509 cert: " .
Net::SSLeay::ERR_error_string($error);
}
}
return @certs;
}
sub PEM_certs2file {
my $file = shift;
open( my $fh,'>',$file ) or croak("cannot write $file: $!");
for my $cert (@_) {
my $string = Net::SSLeay::PEM_get_string_X509($cert)
or croak("cannot get string from cert");
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 {
Net::SSLeay::X509_free($_) for @_;
}
sub KEY_free {
Net::SSLeay::EVP_PKEY_free($_) for @_;
}
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),
);
for([ subject => Net::SSLeay::X509_get_subject_name($cert) ],
[ issuer => Net::SSLeay::X509_get_issuer_name($cert) ]) {
my ($what,$subj) = @$_;
my %subj;
for ( 0..Net::SSLeay::X509_NAME_entry_count($subj)-1 ) {
my $e = Net::SSLeay::X509_NAME_get_entry($subj,$_);
my $k = Net::SSLeay::OBJ_obj2txt(
Net::SSLeay::X509_NAME_ENTRY_get_object($e));
my $v = Net::SSLeay::P_ASN1_STRING_get(
Net::SSLeay::X509_NAME_ENTRY_get_data($e));
if (!exists $subj{$k}) {
$subj{$k} = $v;
} elsif (!ref $subj{$k}) {
$subj{$k} = [ $subj{$k}, $v ];
} else {
push @{$subj{$k}}, $v;
}
}
$hash{$what} = \%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 @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
for (ref($v) ? @$v : ($v)) {
Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,0x1000,$_,-1,0)
or Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,20,$_,-1,0)
or Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,4,$_,-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 (@{ delete $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);
}
}
die "unknown arguments: ". join(" ", sort keys %args)
if !delete $args{ignore_invalid_args} && %args;
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;
$cert = PEM_file2cert('cert.pem'); # load certificate from file
my $hash = CERT_asHash($cert); # get details from certificate
PEM_cert2file($cert,'cert.pem'); # write certificate to file
CERT_free($cert); # free memory within OpenSSL
@certs = PEM_file2certs('chain.pem'); # load multiple certificates from file
PEM_certs2file('chain.pem', @certs); # write multiple certificates to file
CERT_free(@certs); # free memory for all within OpenSSL
my $cert = PEM_string2cert($pem); # load certificate from PEM string
$pem = PEM_cert2string($cert); # convert certificate to PEM string
$key = KEY_create_rsa(2048); # create new 2048-bit RSA key
PEM_key2file($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_file2certs(file) -> @certs
=item PEM_certs2file(file,@certs)
=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(@certs)
=item KEY_free(@keys)
=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. If there are multiple
values for any of these parts the hash value will be an array ref with the
values in order instead of just a scalar.
=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. If there are multiple
values for any of these parts the hash value will be an array ref with the
values in order instead of just a scalar.
=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.
=item ignore_invalid_args
ignore any unknown arguments which might be in the argument list (which might be
in the arguments for example as result from CERT_asHash)
=back
=back
=head1 AUTHOR
Steffen Ullrich

63
gitportable/usr/share/perl5/vendor_perl/IO/Stringy.pm Normal file
View File

@@ -0,0 +1,63 @@
package IO::Stringy;
use strict;
use Exporter;
our $VERSION = '2.113';
1;
__END__
=head1 NAME
IO-stringy - I/O on in-core objects like strings and arrays
=head1 SYNOPSIS
use strict;
use warnings;
use IO::AtomicFile; # Write a file which is updated atomically
use IO::InnerFile; # define a file inside another file
use IO::Lines; # I/O handle to read/write to array of lines
use IO::Scalar; # I/O handle to read/write to a string
use IO::ScalarArray; # I/O handle to read/write to array of scalars
use IO::Wrap; # Wrap old-style FHs in standard OO interface
use IO::WrapTie; # Tie your handles & retain full OO interface
# ...
=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 AUTHOR
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head1 CONTRIBUTORS
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head1 COPYRIGHT & LICENSE
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut

315
gitportable/usr/share/perl5/vendor_perl/IO/Wrap.pm Normal file
View File

@@ -0,0 +1,315 @@
package IO::Wrap;
use strict;
use Exporter;
use FileHandle;
use Carp;
our $VERSION = '2.113';
our @ISA = qw(Exporter);
our @EXPORT = qw(wraphandle);
#------------------------------
# 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 the IO::Handle interface
=head1 SYNOPSIS
use strict;
use warnings;
use IO::Wrap;
# this is a fairly senseless use case as IO::Handle already does this.
my $wrap_fh = IO::Wrap->new(\*STDIN);
my $line = $wrap_fh->getline();
# Do stuff with any kind of filehandle (including a bare globref), or
# any kind of blessed object that responds to a print() message.
# already have a globref? a FileHandle? a scalar filehandle name?
$wrap_fh = IO::Wrap->new($some_unknown_thing);
# At this point, we know we have an IO::Handle-like object! YAY
$wrap_fh->print("Hey there!");
You can also do this using a convenience wrapper function
use strict;
use warnings;
use IO::Wrap qw(wraphandle);
# this is a fairly senseless use case as IO::Handle already does this.
my $wrap_fh = wraphandle(\*STDIN);
my $line = $wrap_fh->getline();
# Do stuff with any kind of filehandle (including a bare globref), or
# any kind of blessed object that responds to a print() message.
# already have a globref? a FileHandle? a scalar filehandle name?
$wrap_fh = wraphandle($some_unknown_thing);
# At this point, we know we have an IO::Handle-like object! YAY
$wrap_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 L<FileHandle> or L<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 C<tiehandle()>.
But that puts the burden on them. Another way to do it is to
use B<IO::Wrap>.
Clearly, when wrapping a raw external filehandle (like C<\*STDOUT>),
I didn't want to close the file descriptor when the wrapper object is
destroyed; the user might not appreciate that! Hence, there's no
C<DESTROY> method in this class.
When wrapping a L<FileHandle> object, however, I believe that Perl will
invoke the C<FileHandle::DESTROY> when the last reference goes away,
so in that case, the filehandle is closed if the wrapped L<FileHandle>
really was the last reference to it.
=head1 FUNCTIONS
L<IO::Wrap> makes the following functions available.
=head2 wraphandle
# wrap a filehandle glob
my $fh = wraphandle(\*STDIN);
# wrap a raw filehandle glob by name
$fh = wraphandle('STDIN');
# wrap a handle in an object
$fh = wraphandle('Class::HANDLE');
# wrap a blessed FileHandle object
use FileHandle;
my $fho = FileHandle->new("/tmp/foo.txt", "r");
$fh = wraphandle($fho);
# wrap any other blessed object that shares IO::Handle's interface
$fh = wraphandle($some_object);
This function is simply a wrapper to the L<IO::Wrap/"new"> constructor method.
=head1 METHODS
L<IO::Wrap> implements the following methods.
=head2 close
$fh->close();
The C<close> method will attempt to close the system file descriptor. For a
more complete description, read L<perlfunc/close>.
=head2 fileno
my $int = $fh->fileno();
The C<fileno> method returns the file descriptor for the wrapped filehandle.
See L<perlfunc/fileno> for more information.
=head2 getline
my $data = $fh->getline();
The C<getline> method mimics the function by the same name in L<IO::Handle>.
It's like calling C<< my $data = <$fh>; >> but only in scalar context.
=head2 getlines
my @data = $fh->getlines();
The C<getlines> method mimics the function by the same name in L<IO::Handle>.
It's like calling C<< my @data = <$fh>; >> but only in list context. Calling
this method in scalar context will result in a croak.
=head2 new
# wrap a filehandle glob
my $fh = IO::Wrap->new(\*STDIN);
# wrap a raw filehandle glob by name
$fh = IO::Wrap->new('STDIN');
# wrap a handle in an object
$fh = IO::Wrap->new('Class::HANDLE');
# wrap a blessed FileHandle object
use FileHandle;
my $fho = FileHandle->new("/tmp/foo.txt", "r");
$fh = IO::Wrap->new($fho);
# wrap any other blessed object that shares IO::Handle's interface
$fh = IO::Wrap->new($some_object);
The C<new> constructor method takes in a single argument and decides to wrap
it or not it based on what it seems to be.
A raw scalar file handle name, like C<"STDOUT"> or C<"Class::HANDLE"> can be
wrapped, returning an L<IO::Wrap> object instance.
A raw filehandle glob, like C<\*STDOUT> can also be wrapped, returning an
L<IO::Wrawp> object instance.
A blessed L<FileHandle> object can also be wrapped. This is a special case
where an L<IO::Wrap> object instance will only be returned in the case that
your L<FileHandle> object doesn't support the C<read> method.
Also, any other kind of blessed object that conforms to the
L<IO::Handle> interface can be passed in. In this case, you just get back
that object.
In other words, we only wrap it into an L<IO::Wrap> object when what you've
supplied doesn't already conform to the L<IO::Handle> interface.
If you get back an L<IO::Wrap> object, it will obey a basic subset of
the C<IO::> interface. It will do so with object B<methods>, not B<operators>.
=head3 CAVEATS
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.
=head2 print
$fh->print("Some string");
$fh->print("more", " than one", " string");
The C<print> method will attempt to print a string or list of strings to the
filehandle. For a more complete description, read
L<perlfunc/print>.
=head2 read
my $buffer;
# try to read 30 chars into the buffer starting at the
# current cursor position.
my $num_chars_read = $fh->read($buffer, 30);
The L<read> method attempts to read a number of characters, starting at the
filehandle's current cursor position. It returns the number of characters
actually read. See L<perlfunc/read> for more information.
=head2 seek
use Fcntl qw(:seek); # import the SEEK_CUR, SEEK_SET, SEEK_END constants
# seek to the position in bytes
$fh->seek(0, SEEK_SET);
# seek to the position in bytes from the current position
$fh->seek(22, SEEK_CUR);
# seek to the EOF plus bytes
$fh->seek(0, SEEK_END);
The C<seek> method will attempt to set the cursor to a given position in bytes
for the wrapped file handle. See L<perlfunc/seek> for more information.
=head2 tell
my $bytes = $fh->tell();
The C<tell> method will attempt to return the current position of the cursor
in bytes for the wrapped file handle. See L<perlfunc/tell> for more
information.
=head1 AUTHOR
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head1 CONTRIBUTORS
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head1 COPYRIGHT & LICENSE
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut

484
gitportable/usr/share/perl5/vendor_perl/IO/WrapTie.pm Normal file
View File

@@ -0,0 +1,484 @@
package IO::WrapTie;
use strict;
use Exporter;
# Inheritance, exporting, and package version:
our @ISA = qw(Exporter);
our @EXPORT = qw(wraptie);
our $VERSION = '2.113';
# Function, exported.
sub wraptie {
IO::WrapTie::Master->new(@_);
}
# Class method; BACKWARDS-COMPATIBILITY ONLY!
sub new {
shift;
IO::WrapTie::Master->new(@_);
}
#------------------------------------------------------------
package # hide from pause
IO::WrapTie::Master;
#------------------------------------------------------------
use strict;
use vars qw($AUTOLOAD);
use IO::Handle;
# We inherit from IO::Handle to get methods which invoke i/o operators,
# like print(), on our tied handle:
our @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 C<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 # hide from pause
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 L<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 *
C<FooHandle> does not inherit from L<IO::Handle>. That is, it performs
file handle-like I/O, but to something other than an underlying
file descriptor. Good examples are L<IO::Scalar> (for printing to a
string) and L<IO::Lines> (for printing to an array of lines).
=item *
C<FooHandle> implements the C<TIEHANDLE> interface (see L<perltie>).
That is, it provides methods C<TIEHANDLE>, C<GETC>, C<PRINT>, C<PRINTF>,
C<READ>, and C<READLINE>.
=item *
C<FooHandle> implements the traditional OO interface of
L<FileHandle> and L<IO::Handle>. i.e., it contains methods like C<getline>,
C<read>, C<print>, C<seek>, C<tell>, C<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 C<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 C<tied>... giving the object a "split personality").
=back
But now with L<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 C<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 L<IO::Handle> and be used both with OO and non-OO file handle 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 C<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 C<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 C<TIEHANDLE> interface.
`-------------'
I<NOTE:> just as an L<IO::Handle> is really just a blessed reference to a
I<traditional> file handle glob. So also, an C<IO::WrapTie::Master>
is really just a blessed reference to a file handle
glob I<which has been tied to some "slave" class.>
=head2 How C<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 C<IO::WrapTie::Master> is a subclass of L<IO::Handle>.
=item 2.
The C<< IO::WrapTie::Master->new >> method creates a new L<IO::Handle> object,
re-blessed into class C<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 C<SLAVECLASS> which is created by tying the master's L<IO::Handle>
to C<SLAVECLASS> via C<tie>.
This call to C<tie> creates the slave in the following manner:
=item 4.
Class C<SLAVECLASS> is sent the message C<TIEHANDLE>; it
will usually delegate this to C<< SLAVECLASS->new(TIEARGS) >>, resulting
in a new instance of C<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 C<$WT> is really a C<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 C<PRINT> method
(part of the C<TIEHANDLE> interface) will be automatically invoked.
If the slave is an L<IO::Scalar>, that means L<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
L<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 C<$WT> is blessed into the class C<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 super class,
L<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 L<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: C<IO::WrapTie::Master> contains
an C<AUTOLOAD> method which performs the delegation.
So: when C<sref> can't be found in L<IO::Handle>, the C<AUTOLOAD> method
of C<IO::WrapTie::Master> is invoked, and the standard behavior of
delegating the method to the underlying slave (here, an L<IO::Scalar>)
is done.
Sometimes, to get this to work properly, you may need to create
a subclass of C<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 C<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 C<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 C<FooHandle> to inherit from L<IO::Handle?>
I tried this, with an implementation similar to that of L<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 L<IO::Handle> will work fine for the OO stuff, and fine with
named operators I<if> you C<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 C<tie> the handle...
which brings us right back to where we started! At least the
L<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 L<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 L<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 C<AUTOLOAD> to delegate
them to the slave object... so it I<looks> like you're manipulating a
C<FooHandle> object directly, but you're not.
I have not explored all the ramifications of this use of C<tie>.
I<Here there be dragons>.
=head1 AUTHOR
Eryq (F<eryq@zeegee.com>).
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
=head1 CONTRIBUTORS
Dianne Skoll (F<dfs@roaringpenguin.com>).
=head1 COPYRIGHT & LICENSE
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut