GSP/GSP-Agent-Windows
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial Windows agent repository

Browse source
This commit is contained in:
Frank Harris 2026-06-08 10:45:20 -05:00
commit a0db0c2e5b
10589 changed files with 3844063 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

1751
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Extract.pm Normal file
View file

File diff suppressed because it is too large Load diff

2322
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip.pm Normal file
View file

File diff suppressed because it is too large Load diff

1392
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/Archive.pm Normal file
View file

File diff suppressed because it is too large Load diff

131
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/BufferedFileHandle.pm Normal file
View file

@ -0,0 +1,131 @@
package Archive::Zip::BufferedFileHandle;
# File handle that uses a string internally and can seek
# This is given as a demo for getting a zip file written
# to a string.
# I probably should just use IO::Scalar instead.
# Ned Konz, March 2000
use strict;
use IO::File;
use Carp;
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.68';
$VERSION = eval $VERSION;
}
sub new {
my $class = shift || __PACKAGE__;
$class = ref($class) || $class;
my $self = bless(
{
content => '',
position => 0,
size => 0
},
$class
);
return $self;
}
# Utility method to read entire file
sub readFromFile {
my $self = shift;
my $fileName = shift;
my $fh = IO::File->new($fileName, "r");
CORE::binmode($fh);
if (!$fh) {
Carp::carp("Can't open $fileName: $!\n");
return undef;
}
local $/ = undef;
$self->{content} = <$fh>;
$self->{size} = length($self->{content});
return $self;
}
sub contents {
my $self = shift;
if (@_) {
$self->{content} = shift;
$self->{size} = length($self->{content});
}
return $self->{content};
}
sub binmode { 1 }
sub close { 1 }
sub opened { 1 }
sub eof {
my $self = shift;
return $self->{position} >= $self->{size};
}
sub seek {
my $self = shift;
my $pos = shift;
my $whence = shift;
# SEEK_SET
if ($whence == 0) { $self->{position} = $pos; }
# SEEK_CUR
elsif ($whence == 1) { $self->{position} += $pos; }
# SEEK_END
elsif ($whence == 2) { $self->{position} = $self->{size} + $pos; }
else { return 0; }
return 1;
}
sub tell { return shift->{position}; }
# Copy my data to given buffer
sub read {
my $self = shift;
my $buf = \($_[0]);
shift;
my $len = shift;
my $offset = shift || 0;
$$buf = '' if not defined($$buf);
my $bytesRead =
($self->{position} + $len > $self->{size})
? ($self->{size} - $self->{position})
: $len;
substr($$buf, $offset, $bytesRead) =
substr($self->{content}, $self->{position}, $bytesRead);
$self->{position} += $bytesRead;
return $bytesRead;
}
# Copy given buffer to me
sub write {
my $self = shift;
my $buf = \($_[0]);
shift;
my $len = shift;
my $offset = shift || 0;
$$buf = '' if not defined($$buf);
my $bufLen = length($$buf);
my $bytesWritten =
($offset + $len > $bufLen)
? $bufLen - $offset
: $len;
substr($self->{content}, $self->{position}, $bytesWritten) =
substr($$buf, $offset, $bytesWritten);
$self->{size} = length($self->{content});
return $bytesWritten;
}
sub clearerr() { 1 }
1;

80
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/DirectoryMember.pm Normal file
View file

@ -0,0 +1,80 @@
package Archive::Zip::DirectoryMember;
use strict;
use File::Path;
use vars qw( $VERSION @ISA );
BEGIN {
$VERSION = '1.68';
@ISA = qw( Archive::Zip::Member );
}
use Archive::Zip qw(
:ERROR_CODES
:UTILITY_METHODS
);
sub _newNamed {
my $class = shift;
my $fileName = shift; # FS name
my $newName = shift; # Zip name
$newName = _asZipDirName($fileName) unless $newName;
my $self = $class->new(@_);
$self->{'externalFileName'} = $fileName;
$self->fileName($newName);
if (-e $fileName) {
# -e does NOT do a full stat, so we need to do one now
if (-d _ ) {
my @stat = stat(_);
$self->unixFileAttributes($stat[2]);
my $mod_t = $stat[9];
if ($^O eq 'MSWin32' and !$mod_t) {
$mod_t = time();
}
$self->setLastModFileDateTimeFromUnix($mod_t);
} else { # hmm.. trying to add a non-directory?
_error($fileName, ' exists but is not a directory');
return undef;
}
} else {
$self->unixFileAttributes($self->DEFAULT_DIRECTORY_PERMISSIONS);
$self->setLastModFileDateTimeFromUnix(time());
}
return $self;
}
sub externalFileName {
shift->{'externalFileName'};
}
sub isDirectory {
return 1;
}
sub extractToFileNamed {
my $self = shift;
my $name = shift; # local FS name
my $attribs = $self->unixFileAttributes() & 07777;
mkpath($name, 0, $attribs); # croaks on error
utime($self->lastModTime(), $self->lastModTime(), $name);
return AZ_OK;
}
sub fileName {
my $self = shift;
my $newName = shift;
$newName =~ s{/?$}{/} if defined($newName);
return $self->SUPER::fileName($newName);
}
# So people don't get too confused. This way it looks like the problem
# is in their code...
sub contents {
return wantarray ? (undef, AZ_OK) : undef;
}
1;

344
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/FAQ.pod Normal file
View file

@ -0,0 +1,344 @@
=head1 NAME
Archive::Zip::FAQ - Answers to a few frequently asked questions about Archive::Zip
=head1 DESCRIPTION
It seems that I keep answering the same questions over and over again. I
assume that this is because my documentation is deficient, rather than that
people don't read the documentation.
So this FAQ is an attempt to cut down on the number of personal answers I have
to give. At least I can now say "You I<did> read the FAQ, right?".
The questions are not in any particular order. The answers assume the current
version of Archive::Zip; some of the answers depend on newly added/fixed
functionality.
=head1 Install problems on RedHat 8 or 9 with Perl 5.8.0
B<Q:> Archive::Zip won't install on my RedHat 9 system! It's broke!
B<A:> This has become something of a FAQ.
Basically, RedHat broke some versions of Perl by setting LANG to UTF8.
They apparently have a fixed version out as an update.
You might try running CPAN or creating your Makefile after exporting the LANG
environment variable as
C<LANG=C>
L<https://bugzilla.redhat.com/bugzilla/show_bug.cgi?id=87682>
=head1 Why is my zip file so big?
B<Q:> My zip file is actually bigger than what I stored in it! Why?
B<A:> Some things to make sure of:
=over 4
=item Make sure that you are requesting COMPRESSION_DEFLATED if you are storing strings.
$member->desiredCompressionMethod( COMPRESSION_DEFLATED );
=item Don't make lots of little files if you can help it.
Since zip computes the compression tables for each member, small
members without much entropy won't compress well. Instead, if you've
got lots of repeated strings in your data, try to combine them into
one big member.
=item Make sure that you are requesting COMPRESSION_STORED if you are storing things that are already compressed.
If you're storing a .zip, .jpg, .mp3, or other compressed file in a zip,
then don't compress them again. They'll get bigger.
=back
=head1 Sample code?
B<Q:> Can you send me code to do (whatever)?
B<A:> Have you looked in the C<examples/> directory yet? It contains:
=over 4
=item examples/calcSizes.pl -- How to find out how big a Zip file will be before writing it
=item examples/copy.pl -- Copies one Zip file to another
=item examples/extract.pl -- extract file(s) from a Zip
=item examples/mailZip.pl -- make and mail a zip file
=item examples/mfh.pl -- demo for use of MockFileHandle
=item examples/readScalar.pl -- shows how to use IO::Scalar as the source of a Zip read
=item examples/selfex.pl -- a brief example of a self-extracting Zip
=item examples/unzipAll.pl -- uses Archive::Zip::Tree to unzip an entire Zip
=item examples/updateZip.pl -- shows how to read/modify/write a Zip
=item examples/updateTree.pl -- shows how to update a Zip in place
=item examples/writeScalar.pl -- shows how to use IO::Scalar as the destination of a Zip write
=item examples/writeScalar2.pl -- shows how to use IO::String as the destination of a Zip write
=item examples/zip.pl -- Constructs a Zip file
=item examples/zipcheck.pl -- One way to check a Zip file for validity
=item examples/zipinfo.pl -- Prints out information about a Zip archive file
=item examples/zipGrep.pl -- Searches for text in Zip files
=item examples/ziptest.pl -- Lists a Zip file and checks member CRCs
=item examples/ziprecent.pl -- Puts recent files into a zipfile
=item examples/ziptest.pl -- Another way to check a Zip file for validity
=back
=head1 Can't Read/modify/write same Zip file
B<Q:> Why can't I open a Zip file, add a member, and write it back? I get an
error message when I try.
B<A:> Because Archive::Zip doesn't (and can't, generally) read file contents into memory,
the original Zip file is required to stay around until the writing of the new
file is completed.
The best way to do this is to write the Zip to a temporary file and then
rename the temporary file to have the old name (possibly after deleting the
old one).
Archive::Zip v1.02 added the archive methods C<overwrite()> and
C<overwriteAs()> to do this simply and carefully.
See C<examples/updateZip.pl> for an example of this technique.
=head1 File creation time not set
B<Q:> Upon extracting files, I see that their modification (and access) times are
set to the time in the Zip archive. However, their creation time is not set to
the same time. Why?
B<A:> Mostly because Perl doesn't give cross-platform access to I<creation time>.
Indeed, many systems (like Unix) don't support such a concept.
However, if yours does, you can easily set it. Get the modification time from
the member using C<lastModTime()>.
=head1 Can't use Archive::Zip on gzip files
B<Q:> Can I use Archive::Zip to extract Unix gzip files?
B<A:> No.
There is a distinction between Unix gzip files, and Zip archives that
also can use the gzip compression.
Depending on the format of the gzip file, you can use L<Compress::Raw::Zlib>, or
L<Archive::Tar> to decompress it (and de-archive it in the case of Tar files).
You can unzip PKZIP/WinZip/etc/ archives using Archive::Zip (that's what
it's for) as long as any compressed members are compressed using
Deflate compression.
=head1 Add a directory/tree to a Zip
B<Q:> How can I add a directory (or tree) full of files to a Zip?
B<A:> You can use the Archive::Zip::addTree*() methods:
use Archive::Zip;
my $zip = Archive::Zip->new();
# add all readable files and directories below . as xyz/*
$zip->addTree( '.', 'xyz' );
# add all readable plain files below /abc as def/*
$zip->addTree( '/abc', 'def', sub { -f && -r } );
# add all .c files below /tmp as stuff/*
$zip->addTreeMatching( '/tmp', 'stuff', '\.c$' );
# add all .o files below /tmp as stuff/* if they aren't writable
$zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { ! -w } );
# add all .so files below /tmp that are smaller than 200 bytes as stuff/*
$zip->addTreeMatching( '/tmp', 'stuff', '\.o$', sub { -s < 200 } );
# and write them into a file
$zip->writeToFileNamed('xxx.zip');
=head1 Extract a directory/tree
B<Q:> How can I extract some (or all) files from a Zip into a different
directory?
B<A:> You can use the Archive::Zip::extractTree() method:
??? ||
# now extract the same files into /tmpx
$zip->extractTree( 'stuff', '/tmpx' );
=head1 Update a directory/tree
B<Q:> How can I update a Zip from a directory tree, adding or replacing only
the newer files?
B<A:> You can use the Archive::Zip::updateTree() method that was added in version 1.09.
=head1 Zip times might be off by 1 second
B<Q:> It bothers me greatly that my file times are wrong by one second about half
the time. Why don't you do something about it?
B<A:> Get over it. This is a result of the Zip format storing times in DOS
format, which has a resolution of only two seconds.
=head1 Zip times don't include time zone information
B<Q:> My file times don't respect time zones. What gives?
B<A:> If this is important to you, please submit patches to read the various
Extra Fields that encode times with time zones. I'm just using the DOS
Date/Time, which doesn't have a time zone.
=head1 How do I make a self-extracting Zip
B<Q:> I want to make a self-extracting Zip file. Can I do this?
B<A:> Yes. You can write a self-extracting archive stub (that is, a version of
unzip) to the output filehandle that you pass to writeToFileHandle(). See
examples/selfex.pl for how to write a self-extracting archive.
However, you should understand that this will only work on one kind of
platform (the one for which the stub was compiled).
=head1 How can I deal with Zips with prepended garbage (i.e. from Sircam)
B<Q:> How can I tell if a Zip has been damaged by adding garbage to the
beginning or inside the file?
B<A:> I added code for this for the Amavis virus scanner. You can query archives
for their 'eocdOffset' property, which should be 0:
if ($zip->eocdOffset > 0)
{ warn($zip->eocdOffset . " bytes of garbage at beginning or within Zip") }
When members are extracted, this offset will be used to adjust the start of
the member if necessary.
=head1 Can't extract Shrunk files
B<Q:> I'm trying to extract a file out of a Zip produced by PKZIP, and keep
getting this error message:
error: Unsupported compression combination: read 6, write 0
B<A:> You can't uncompress this archive member. Archive::Zip only supports uncompressed
members, and compressed members that are compressed using the compression
supported by Compress::Raw::Zlib. That means only Deflated and Stored members.
Your file is compressed using the Shrink format, which is not supported by
Compress::Raw::Zlib.
You could, perhaps, use a command-line UnZip program (like the Info-Zip
one) to extract this.
=head1 Can't do decryption
B<Q:> How do I decrypt encrypted Zip members?
B<A:> With some other program or library. Archive::Zip doesn't support decryption,
and probably never will (unless I<you> write it).
=head1 How to test file integrity?
B<Q:> How can Archive::Zip can test the validity of a Zip file?
B<A:> If you try to decompress the file, the gzip streams will report errors
if you have garbage. Most of the time.
If you try to open the file and a central directory structure can't be
found, an error will be reported.
When a file is being read, if we can't find a proper PK.. signature in
the right places we report a format error.
If there is added garbage at the beginning of a Zip file (as inserted
by some viruses), you can find out about it, but Archive::Zip will ignore it,
and you can still use the archive. When it gets written back out the
added stuff will be gone.
There are two ready-to-use utilities in the examples directory that can
be used to test file integrity, or that you can use as examples
for your own code:
=over 4
=item examples/zipcheck.pl shows how to use an attempted extraction to test a file.
=item examples/ziptest.pl shows how to test CRCs in a file.
=back
=head1 Duplicate files in Zip?
B<Q:> Archive::Zip let me put the same file in my Zip twice! Why don't you prevent this?
B<A:> As far as I can tell, this is not disallowed by the Zip spec. If you
think it's a bad idea, check for it yourself:
$zip->addFile($someFile, $someName) unless $zip->memberNamed($someName);
I can even imagine cases where this might be useful (for instance, multiple
versions of files).
=head1 File ownership/permissions/ACLS/etc
B<Q:> Why doesn't Archive::Zip deal with file ownership, ACLs, etc.?
B<A:> There is no standard way to represent these in the Zip file format. If
you want to send me code to properly handle the various extra fields that
have been used to represent these through the years, I'll look at it.
=head1 I can't compile but ActiveState only has an old version of Archive::Zip
B<Q:> I've only installed modules using ActiveState's PPM program and
repository. But they have a much older version of Archive::Zip than is in CPAN. Will
you send me a newer PPM?
B<A:> Probably not, unless I get lots of extra time. But there's no reason you
can't install the version from CPAN. Archive::Zip is pure Perl, so all you need is
NMAKE, which you can get for free from Microsoft (see the FAQ in the
ActiveState documentation for details on how to install CPAN modules).
=head1 My JPEGs (or MP3's) don't compress when I put them into Zips!
B<Q:> How come my JPEGs and MP3's don't compress much when I put them into Zips?
B<A:> Because they're already compressed.
=head1 Under Windows, things lock up/get damaged
B<Q:> I'm using Windows. When I try to use Archive::Zip, my machine locks up/makes
funny sounds/displays a BSOD/corrupts data. How can I fix this?
B<A:> First, try the newest version of Compress::Raw::Zlib. I know of
Windows-related problems prior to v1.14 of that library.
=head1 Zip contents in a scalar
B<Q:> I want to read a Zip file from (or write one to) a scalar variable instead
of a file. How can I do this?
B<A:> Use C<IO::String> and the C<readFromFileHandle()> and
C<writeToFileHandle()> methods.
See C<examples/readScalar.pl> and C<examples/writeScalar.pl>.
=head1 Reading from streams
B<Q:> How do I read from a stream (like for the Info-Zip C<funzip> program)?
B<A:> This is not currently supported, though writing to a stream is.

64
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/FileMember.pm Normal file
View file

@ -0,0 +1,64 @@
package Archive::Zip::FileMember;
use strict;
use vars qw( $VERSION @ISA );
BEGIN {
$VERSION = '1.68';
@ISA = qw ( Archive::Zip::Member );
}
use Archive::Zip qw(
:UTILITY_METHODS
);
sub externalFileName {
shift->{'externalFileName'};
}
# Return true if I depend on the named file
sub _usesFileNamed {
my $self = shift;
my $fileName = shift;
my $xfn = $self->externalFileName();
return undef if ref($xfn);
return $xfn eq $fileName;
}
sub fh {
my $self = shift;
$self->_openFile()
if !defined($self->{'fh'}) || !$self->{'fh'}->opened();
return $self->{'fh'};
}
# opens my file handle from my file name
sub _openFile {
my $self = shift;
my ($status, $fh) = _newFileHandle($self->externalFileName(), 'r');
if (!$status) {
_ioError("Can't open", $self->externalFileName());
return undef;
}
$self->{'fh'} = $fh;
_binmode($fh);
return $fh;
}
# Make sure I close my file handle
sub endRead {
my $self = shift;
undef $self->{'fh'}; # _closeFile();
return $self->SUPER::endRead(@_);
}
sub _become {
my $self = shift;
my $newClass = shift;
return $self if ref($self) eq $newClass;
delete($self->{'externalFileName'});
delete($self->{'fh'});
return $self->SUPER::_become($newClass);
}
1;

1564
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/Member.pm Normal file
View file

File diff suppressed because it is too large Load diff

348
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/MemberRead.pm Normal file
View file

@ -0,0 +1,348 @@
package Archive::Zip::MemberRead;
=head1 NAME
Archive::Zip::MemberRead - A wrapper that lets you read Zip archive members as if they were files.
=cut
=head1 SYNOPSIS
use Archive::Zip;
use Archive::Zip::MemberRead;
$zip = Archive::Zip->new("file.zip");
$fh = Archive::Zip::MemberRead->new($zip, "subdir/abc.txt");
while (defined($line = $fh->getline()))
{
print $fh->input_line_number . "#: $line\n";
}
$read = $fh->read($buffer, 32*1024);
print "Read $read bytes as :$buffer:\n";
=head1 DESCRIPTION
The Archive::Zip::MemberRead module lets you read Zip archive member data
just like you read data from files.
=head1 METHODS
=over 4
=cut
use strict;
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
use vars qw{$VERSION};
my $nl;
BEGIN {
$VERSION = '1.68';
$VERSION = eval $VERSION;
# Requirement for newline conversion. Should check for e.g., DOS and OS/2 as well, but am too lazy.
$nl = $^O eq 'MSWin32' ? "\r\n" : "\n";
}
=item Archive::Zip::Member::readFileHandle()
You can get a C<Archive::Zip::MemberRead> from an archive member by
calling C<readFileHandle()>:
my $member = $zip->memberNamed('abc/def.c');
my $fh = $member->readFileHandle();
while (defined($line = $fh->getline()))
{
# ...
}
$fh->close();
=cut
sub Archive::Zip::Member::readFileHandle {
return Archive::Zip::MemberRead->new(shift());
}
=item Archive::Zip::MemberRead->new($zip, $fileName)
=item Archive::Zip::MemberRead->new($zip, $member)
=item Archive::Zip::MemberRead->new($member)
Construct a new Archive::Zip::MemberRead on the specified member.
my $fh = Archive::Zip::MemberRead->new($zip, 'fred.c')
=cut
sub new {
my ($class, $zip, $file) = @_;
my ($self, $member);
if ($zip && $file) # zip and filename, or zip and member
{
$member = ref($file) ? $file : $zip->memberNamed($file);
} elsif ($zip && !$file && ref($zip)) # just member
{
$member = $zip;
} else {
die(
'Archive::Zip::MemberRead::new needs a zip and filename, zip and member, or member'
);
}
$self = {};
bless($self, $class);
$self->set_member($member);
return $self;
}
sub set_member {
my ($self, $member) = @_;
$self->{member} = $member;
$self->set_compression(COMPRESSION_STORED);
$self->rewind();
}
sub set_compression {
my ($self, $compression) = @_;
$self->{member}->desiredCompressionMethod($compression) if $self->{member};
}
=item setLineEnd(expr)
Set the line end character to use. This is set to \n by default
except on Windows systems where it is set to \r\n. You will
only need to set this on systems which are not Windows or Unix
based and require a line end different from \n.
This is a class method so call as C<Archive::Zip::MemberRead>->C<setLineEnd($nl)>
=cut
sub setLineEnd {
shift;
$nl = shift;
}
=item rewind()
Rewinds an C<Archive::Zip::MemberRead> so that you can read from it again
starting at the beginning.
=cut
sub rewind {
my $self = shift;
$self->_reset_vars();
$self->{member}->rewindData() if $self->{member};
}
sub _reset_vars {
my $self = shift;
$self->{line_no} = 0;
$self->{at_end} = 0;
delete $self->{buffer};
}
=item input_record_separator(expr)
If the argument is given, input_record_separator for this
instance is set to it. The current setting (which may be
the global $/) is always returned.
=cut
sub input_record_separator {
my $self = shift;
if (@_) {
$self->{sep} = shift;
$self->{sep_re} =
_sep_as_re($self->{sep}); # Cache the RE as an optimization
}
return exists $self->{sep} ? $self->{sep} : $/;
}
# Return the input_record_separator in use as an RE fragment
# Note that if we have a per-instance input_record_separator
# we can just return the already converted value. Otherwise,
# the conversion must be done on $/ every time since we cannot
# know whether it has changed or not.
sub _sep_re {
my $self = shift;
# Important to phrase this way: sep's value may be undef.
return exists $self->{sep} ? $self->{sep_re} : _sep_as_re($/);
}
# Convert the input record separator into an RE and return it.
sub _sep_as_re {
my $sep = shift;
if (defined $sep) {
if ($sep eq '') {
return "(?:$nl){2,}";
} else {
$sep =~ s/\n/$nl/og;
return quotemeta $sep;
}
} else {
return undef;
}
}
=item input_line_number()
Returns the current line number, but only if you're using C<getline()>.
Using C<read()> will not update the line number.
=cut
sub input_line_number {
my $self = shift;
return $self->{line_no};
}
=item close()
Closes the given file handle.
=cut
sub close {
my $self = shift;
$self->_reset_vars();
$self->{member}->endRead();
}
=item buffer_size([ $size ])
Gets or sets the buffer size used for reads.
Default is the chunk size used by Archive::Zip.
=cut
sub buffer_size {
my ($self, $size) = @_;
if (!$size) {
return $self->{chunkSize} || Archive::Zip::chunkSize();
} else {
$self->{chunkSize} = $size;
}
}
=item getline()
Returns the next line from the currently open member.
Makes sense only for text files.
A read error is considered fatal enough to die.
Returns undef on eof. All subsequent calls would return undef,
unless a rewind() is called.
Note: The line returned has the input_record_separator (default: newline) removed.
=item getline( { preserve_line_ending => 1 } )
Returns the next line including the line ending.
=cut
sub getline {
my ($self, $argref) = @_;
my $size = $self->buffer_size();
my $sep = $self->_sep_re();
my $preserve_line_ending;
if (ref $argref eq 'HASH') {
$preserve_line_ending = $argref->{'preserve_line_ending'};
$sep =~ s/\\([^A-Za-z_0-9])+/$1/g;
}
for (; ;) {
if ( $sep
&& defined($self->{buffer})
&& $self->{buffer} =~ s/^(.*?)$sep//s) {
my $line = $1;
$self->{line_no}++;
if ($preserve_line_ending) {
return $line . $sep;
} else {
return $line;
}
} elsif ($self->{at_end}) {
$self->{line_no}++ if $self->{buffer};
return delete $self->{buffer};
}
my ($temp, $status) = $self->{member}->readChunk($size);
if ($status != AZ_OK && $status != AZ_STREAM_END) {
die "ERROR: Error reading chunk from archive - $status";
}
$self->{at_end} = $status == AZ_STREAM_END;
$self->{buffer} .= $$temp;
}
}
=item read($buffer, $num_bytes_to_read)
Simulates a normal C<read()> system call.
Returns the no. of bytes read. C<undef> on error, 0 on eof, I<e.g.>:
$fh = Archive::Zip::MemberRead->new($zip, "sreeji/secrets.bin");
while (1)
{
$read = $fh->read($buffer, 1024);
die "FATAL ERROR reading my secrets !\n" if (!defined($read));
last if (!$read);
# Do processing.
....
}
=cut
#
# All these $_ are required to emulate read().
#
sub read {
my $self = $_[0];
my $size = $_[2];
my ($temp, $status, $ret);
($temp, $status) = $self->{member}->readChunk($size);
if ($status != AZ_OK && $status != AZ_STREAM_END) {
$_[1] = undef;
$ret = undef;
} else {
$_[1] = $$temp;
$ret = length($$temp);
}
return $ret;
}
1;
=back
=head1 AUTHOR
Sreeji K. Das E<lt>sreeji_k@yahoo.comE<gt>
See L<Archive::Zip> by Ned Konz without which this module does not make
any sense!
Minor mods by Ned Konz.
=head1 COPYRIGHT
Copyright 2002 Sreeji K. Das.
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut

69
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/MockFileHandle.pm Normal file
View file

@ -0,0 +1,69 @@
package Archive::Zip::MockFileHandle;
# Output file handle that calls a custom write routine
# Ned Konz, March 2000
# This is provided to help with writing zip files
# when you have to process them a chunk at a time.
use strict;
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.68';
$VERSION = eval $VERSION;
}
sub new {
my $class = shift || __PACKAGE__;
$class = ref($class) || $class;
my $self = bless(
{
'position' => 0,
'size' => 0
},
$class
);
return $self;
}
sub eof {
my $self = shift;
return $self->{'position'} >= $self->{'size'};
}
# Copy given buffer to me
sub print {
my $self = shift;
my $bytes = join('', @_);
my $bytesWritten = $self->writeHook($bytes);
if ($self->{'position'} + $bytesWritten > $self->{'size'}) {
$self->{'size'} = $self->{'position'} + $bytesWritten;
}
$self->{'position'} += $bytesWritten;
return $bytesWritten;
}
# Called on each write.
# Override in subclasses.
# Return number of bytes written (0 on error).
sub writeHook {
my $self = shift;
my $bytes = shift;
return length($bytes);
}
sub binmode { 1 }
sub close { 1 }
sub clearerr { 1 }
# I'm write-only!
sub read { 0 }
sub tell { return shift->{'position'} }
sub opened { 1 }
1;

77
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/NewFileMember.pm Normal file
View file

@ -0,0 +1,77 @@
package Archive::Zip::NewFileMember;
use strict;
use vars qw( $VERSION @ISA );
BEGIN {
$VERSION = '1.68';
@ISA = qw ( Archive::Zip::FileMember );
}
use Archive::Zip qw(
:CONSTANTS
:ERROR_CODES
:UTILITY_METHODS
);
# Given a file name, set up for eventual writing.
sub _newFromFileNamed {
my $class = shift;
my $fileName = shift; # local FS format
my $newName = shift;
$newName = _asZipDirName($fileName) unless defined($newName);
return undef unless (stat($fileName) && -r _ && !-d _ );
my $self = $class->new(@_);
$self->{'fileName'} = $newName;
$self->{'externalFileName'} = $fileName;
$self->{'compressionMethod'} = COMPRESSION_STORED;
my @stat = stat(_);
$self->{'compressedSize'} = $self->{'uncompressedSize'} = $stat[7];
$self->desiredCompressionMethod(
($self->compressedSize() > 0)
? COMPRESSION_DEFLATED
: COMPRESSION_STORED
);
$self->unixFileAttributes($stat[2]);
$self->setLastModFileDateTimeFromUnix($stat[9]);
$self->isTextFile(-T _ );
return $self;
}
sub rewindData {
my $self = shift;
my $status = $self->SUPER::rewindData(@_);
return $status unless $status == AZ_OK;
return AZ_IO_ERROR unless $self->fh();
$self->fh()->clearerr();
$self->fh()->seek(0, IO::Seekable::SEEK_SET)
or return _ioError("rewinding", $self->externalFileName());
return AZ_OK;
}
# Return bytes read. Note that first parameter is a ref to a buffer.
# my $data;
# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
sub _readRawChunk {
my ($self, $dataRef, $chunkSize) = @_;
return (0, AZ_OK) unless $chunkSize;
my $bytesRead = $self->fh()->read($$dataRef, $chunkSize)
or return (0, _ioError("reading data"));
return ($bytesRead, AZ_OK);
}
# If I already exist, extraction is a no-op.
sub extractToFileNamed {
my $self = shift;
my $name = shift; # local FS name
if (File::Spec->rel2abs($name) eq
File::Spec->rel2abs($self->externalFileName()) and -r $name) {
return AZ_OK;
} else {
return $self->SUPER::extractToFileNamed($name, @_);
}
}
1;

64
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/StringMember.pm Normal file
View file

@ -0,0 +1,64 @@
package Archive::Zip::StringMember;
use strict;
use vars qw( $VERSION @ISA );
BEGIN {
$VERSION = '1.68';
@ISA = qw( Archive::Zip::Member );
}
use Archive::Zip qw(
:CONSTANTS
:ERROR_CODES
);
# Create a new string member. Default is COMPRESSION_STORED.
# Can take a ref to a string as well.
sub _newFromString {
my $class = shift;
my $string = shift;
my $name = shift;
my $self = $class->new(@_);
$self->contents($string);
$self->fileName($name) if defined($name);
# Set the file date to now
$self->setLastModFileDateTimeFromUnix(time());
$self->unixFileAttributes($self->DEFAULT_FILE_PERMISSIONS);
return $self;
}
sub _become {
my $self = shift;
my $newClass = shift;
return $self if ref($self) eq $newClass;
delete($self->{'contents'});
return $self->SUPER::_become($newClass);
}
# Get or set my contents. Note that we do not call the superclass
# version of this, because it calls us.
sub contents {
my $self = shift;
my $string = shift;
if (defined($string)) {
$self->{'contents'} =
pack('C0a*', (ref($string) eq 'SCALAR') ? $$string : $string);
$self->{'uncompressedSize'} = $self->{'compressedSize'} =
length($self->{'contents'});
$self->{'compressionMethod'} = COMPRESSION_STORED;
}
return wantarray ? ($self->{'contents'}, AZ_OK) : $self->{'contents'};
}
# Return bytes read. Note that first parameter is a ref to a buffer.
# my $data;
# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
sub _readRawChunk {
my ($self, $dataRef, $chunkSize) = @_;
$$dataRef = substr($self->contents(), $self->_readOffset(), $chunkSize);
return (length($$dataRef), AZ_OK);
}
1;

48
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/Tree.pm Normal file
View file

@ -0,0 +1,48 @@
package Archive::Zip::Tree;
use strict;
use vars qw{$VERSION};
BEGIN {
$VERSION = '1.68';
}
use Archive::Zip;
warn(
"Archive::Zip::Tree is deprecated; its methods have been moved into Archive::Zip."
) if $^W;
1;
__END__
=head1 NAME
Archive::Zip::Tree - (DEPRECATED) methods for adding/extracting trees using Archive::Zip
=head1 DESCRIPTION
This module is deprecated, because all its methods were moved into the main
Archive::Zip module.
It is included in the distribution merely to avoid breaking old code.
See L<Archive::Zip>.
=head1 AUTHOR
Ned Konz, perl@bike-nomad.com
=head1 COPYRIGHT
Copyright (c) 2000-2002 Ned Konz. All rights reserved. This program is free
software; you can redistribute it and/or modify it under the same terms
as Perl itself.
=head1 SEE ALSO
L<Archive::Zip>
=cut

475
OGP64/usr/share/perl5/vendor_perl/5.40/Archive/Zip/ZipFileMember.pm Normal file
View file

@ -0,0 +1,475 @@
package Archive::Zip::ZipFileMember;
use strict;
use vars qw( $VERSION @ISA );
BEGIN {
$VERSION = '1.68';
@ISA = qw ( Archive::Zip::FileMember );
}
use Archive::Zip qw(
:CONSTANTS
:ERROR_CODES
:PKZIP_CONSTANTS
:UTILITY_METHODS
);
# Create a new Archive::Zip::ZipFileMember
# given a filename and optional open file handle
#
sub _newFromZipFile {
my $class = shift;
my $fh = shift;
my $externalFileName = shift;
my $archiveZip64 = @_ ? shift : 0;
my $possibleEocdOffset = @_ ? shift : 0; # normally 0
my $self = $class->new(
'eocdCrc32' => 0,
'diskNumberStart' => 0,
'localHeaderRelativeOffset' => 0,
'dataOffset' => 0, # localHeaderRelativeOffset + header length
@_
);
$self->{'externalFileName'} = $externalFileName;
$self->{'fh'} = $fh;
$self->{'archiveZip64'} = $archiveZip64;
$self->{'possibleEocdOffset'} = $possibleEocdOffset;
return $self;
}
sub isDirectory {
my $self = shift;
return (substr($self->fileName, -1, 1) eq '/'
and $self->uncompressedSize == 0);
}
# Seek to the beginning of the local header, just past the signature.
# Verify that the local header signature is in fact correct.
# Update the localHeaderRelativeOffset if necessary by adding the possibleEocdOffset.
# Returns status.
sub _seekToLocalHeader {
my $self = shift;
my $where = shift; # optional
my $previousWhere = shift; # optional
$where = $self->localHeaderRelativeOffset() unless defined($where);
# avoid loop on certain corrupt files (from Julian Field)
return _formatError("corrupt zip file")
if defined($previousWhere) && $where == $previousWhere;
my $status;
my $signature;
$status = $self->fh()->seek($where, IO::Seekable::SEEK_SET);
return _ioError("seeking to local header") unless $status;
($status, $signature) =
_readSignature($self->fh(), $self->externalFileName(),
LOCAL_FILE_HEADER_SIGNATURE, 1);
return $status if $status == AZ_IO_ERROR;
# retry with EOCD offset if any was given.
if ($status == AZ_FORMAT_ERROR && $self->{'possibleEocdOffset'}) {
$status = $self->_seekToLocalHeader(
$self->localHeaderRelativeOffset() + $self->{'possibleEocdOffset'},
$where
);
if ($status == AZ_OK) {
$self->{'localHeaderRelativeOffset'} +=
$self->{'possibleEocdOffset'};
$self->{'possibleEocdOffset'} = 0;
}
}
return $status;
}
# Because I'm going to delete the file handle, read the local file
# header if the file handle is seekable. If it is not, I assume that
# I've already read the local header.
# Return ( $status, $self )
sub _become {
my $self = shift;
my $newClass = shift;
return $self if ref($self) eq $newClass;
my $status = AZ_OK;
if (_isSeekable($self->fh())) {
my $here = $self->fh()->tell();
$status = $self->_seekToLocalHeader();
$status = $self->_readLocalFileHeader() if $status == AZ_OK;
$self->fh()->seek($here, IO::Seekable::SEEK_SET);
return $status unless $status == AZ_OK;
}
delete($self->{'eocdCrc32'});
delete($self->{'diskNumberStart'});
delete($self->{'localHeaderRelativeOffset'});
delete($self->{'dataOffset'});
delete($self->{'archiveZip64'});
delete($self->{'possibleEocdOffset'});
return $self->SUPER::_become($newClass);
}
sub diskNumberStart {
shift->{'diskNumberStart'};
}
sub localHeaderRelativeOffset {
shift->{'localHeaderRelativeOffset'};
}
sub dataOffset {
shift->{'dataOffset'};
}
# Skip local file header, updating only extra field stuff.
# Assumes that fh is positioned before signature.
sub _skipLocalFileHeader {
my $self = shift;
my $header;
my $bytesRead = $self->fh()->read($header, LOCAL_FILE_HEADER_LENGTH);
if ($bytesRead != LOCAL_FILE_HEADER_LENGTH) {
return _ioError("reading local file header");
}
my $fileNameLength;
my $extraFieldLength;
my $bitFlag;
(
undef, # $self->{'versionNeededToExtract'},
$bitFlag,
undef, # $self->{'compressionMethod'},
undef, # $self->{'lastModFileDateTime'},
undef, # $crc32,
undef, # $compressedSize,
undef, # $uncompressedSize,
$fileNameLength,
$extraFieldLength
) = unpack(LOCAL_FILE_HEADER_FORMAT, $header);
if ($fileNameLength) {
$self->fh()->seek($fileNameLength, IO::Seekable::SEEK_CUR)
or return _ioError("skipping local file name");
}
my $zip64 = 0;
if ($extraFieldLength) {
$bytesRead =
$self->fh()->read($self->{'localExtraField'}, $extraFieldLength);
if ($bytesRead != $extraFieldLength) {
return _ioError("reading local extra field");
}
if ($self->{'archiveZip64'}) {
my $status;
($status, $zip64) =
$self->_extractZip64ExtraField($self->{'localExtraField'}, undef, undef);
return $status if $status != AZ_OK;
$self->{'zip64'} ||= $zip64;
}
}
$self->{'dataOffset'} = $self->fh()->tell();
if ($bitFlag & GPBF_HAS_DATA_DESCRIPTOR_MASK) {
# Read the crc32, compressedSize, and uncompressedSize from the
# extended data descriptor, which directly follows the compressed data.
#
# Skip over the compressed file data (assumes that EOCD compressedSize
# was correct)
$self->fh()->seek($self->{'compressedSize'}, IO::Seekable::SEEK_CUR)
or return _ioError("seeking to extended local header");
# these values should be set correctly from before.
my $oldCrc32 = $self->{'eocdCrc32'};
my $oldCompressedSize = $self->{'compressedSize'};
my $oldUncompressedSize = $self->{'uncompressedSize'};
my $status = $self->_readDataDescriptor($zip64);
return $status unless $status == AZ_OK;
# The buffer with encrypted data is prefixed with a new
# encrypted 12 byte header. The size only changes when
# the buffer is also compressed
$self->isEncrypted && $oldUncompressedSize > $self->{'uncompressedSize'}
and $oldUncompressedSize -= DATA_DESCRIPTOR_LENGTH;
return _formatError(
"CRC or size mismatch while skipping data descriptor")
if ( $oldCrc32 != $self->{'crc32'}
|| $oldUncompressedSize != $self->{'uncompressedSize'});
$self->{'crc32'} = 0
if $self->compressionMethod() == COMPRESSION_STORED ;
}
return AZ_OK;
}
# Read from a local file header into myself. Returns AZ_OK (in
# scalar context) or a pair (AZ_OK, $headerSize) (in list
# context) if successful.
# Assumes that fh is positioned after signature.
# Note that crc32, compressedSize, and uncompressedSize will be 0 if
# GPBF_HAS_DATA_DESCRIPTOR_MASK is set in the bitFlag.
sub _readLocalFileHeader {
my $self = shift;
my $header;
my $bytesRead = $self->fh()->read($header, LOCAL_FILE_HEADER_LENGTH);
if ($bytesRead != LOCAL_FILE_HEADER_LENGTH) {
return _ioError("reading local file header");
}
my $fileNameLength;
my $crc32;
my $compressedSize;
my $uncompressedSize;
my $extraFieldLength;
(
$self->{'versionNeededToExtract'}, $self->{'bitFlag'},
$self->{'compressionMethod'}, $self->{'lastModFileDateTime'},
$crc32, $compressedSize,
$uncompressedSize, $fileNameLength,
$extraFieldLength
) = unpack(LOCAL_FILE_HEADER_FORMAT, $header);
if ($fileNameLength) {
my $fileName;
$bytesRead = $self->fh()->read($fileName, $fileNameLength);
if ($bytesRead != $fileNameLength) {
return _ioError("reading local file name");
}
$self->fileName($fileName);
}
my $zip64 = 0;
if ($extraFieldLength) {
$bytesRead =
$self->fh()->read($self->{'localExtraField'}, $extraFieldLength);
if ($bytesRead != $extraFieldLength) {
return _ioError("reading local extra field");
}
if ($self->{'archiveZip64'}) {
my $status;
($status, $zip64) =
$self->_extractZip64ExtraField($self->{'localExtraField'},
$uncompressedSize,
$compressedSize);
return $status if $status != AZ_OK;
$self->{'zip64'} ||= $zip64;
}
}
$self->{'dataOffset'} = $self->fh()->tell();
if ($self->hasDataDescriptor()) {
# Read the crc32, compressedSize, and uncompressedSize from the
# extended data descriptor.
# Skip over the compressed file data (assumes that EOCD compressedSize
# was correct)
$self->fh()->seek($self->{'compressedSize'}, IO::Seekable::SEEK_CUR)
or return _ioError("seeking to extended local header");
my $status = $self->_readDataDescriptor($zip64);
return $status unless $status == AZ_OK;
} else {
return _formatError(
"CRC or size mismatch after reading data descriptor")
if ( $self->{'crc32'} != $crc32
|| $self->{'uncompressedSize'} != $uncompressedSize);
}
return
wantarray
? (AZ_OK,
SIGNATURE_LENGTH,
LOCAL_FILE_HEADER_LENGTH +
$fileNameLength +
$extraFieldLength)
: AZ_OK;
}
# This will read the data descriptor, which is after the end of compressed file
# data in members that have GPBF_HAS_DATA_DESCRIPTOR_MASK set in their bitFlag.
# The only reliable way to find these is to rely on the EOCD compressedSize.
# Assumes that file is positioned immediately after the compressed data.
# Returns status; sets crc32, compressedSize, and uncompressedSize.
sub _readDataDescriptor {
my $self = shift;
my $zip64 = shift;
my $signatureData;
my $header;
my $crc32;
my $compressedSize;
my $uncompressedSize;
my $bytesRead = $self->fh()->read($signatureData, SIGNATURE_LENGTH);
return _ioError("reading header signature")
if $bytesRead != SIGNATURE_LENGTH;
my $signature = unpack(SIGNATURE_FORMAT, $signatureData);
my $dataDescriptorLength;
my $dataDescriptorFormat;
my $dataDescriptorLengthNoSig;
my $dataDescriptorFormatNoSig;
if (! $zip64) {
$dataDescriptorLength = DATA_DESCRIPTOR_LENGTH;
$dataDescriptorFormat = DATA_DESCRIPTOR_FORMAT;
$dataDescriptorLengthNoSig = DATA_DESCRIPTOR_LENGTH_NO_SIG;
$dataDescriptorFormatNoSig = DATA_DESCRIPTOR_FORMAT_NO_SIG
}
else {
$dataDescriptorLength = DATA_DESCRIPTOR_ZIP64_LENGTH;
$dataDescriptorFormat = DATA_DESCRIPTOR_ZIP64_FORMAT;
$dataDescriptorLengthNoSig = DATA_DESCRIPTOR_ZIP64_LENGTH_NO_SIG;
$dataDescriptorFormatNoSig = DATA_DESCRIPTOR_ZIP64_FORMAT_NO_SIG
}
# unfortunately, the signature appears to be optional.
if ($signature == DATA_DESCRIPTOR_SIGNATURE
&& ($signature != $self->{'crc32'})) {
$bytesRead = $self->fh()->read($header, $dataDescriptorLength);
return _ioError("reading data descriptor")
if $bytesRead != $dataDescriptorLength;
($crc32, $compressedSize, $uncompressedSize) =
unpack($dataDescriptorFormat, $header);
} else {
$bytesRead = $self->fh()->read($header, $dataDescriptorLengthNoSig);
return _ioError("reading data descriptor")
if $bytesRead != $dataDescriptorLengthNoSig;
$crc32 = $signature;
($compressedSize, $uncompressedSize) =
unpack($dataDescriptorFormatNoSig, $header);
}
$self->{'eocdCrc32'} = $self->{'crc32'}
unless defined($self->{'eocdCrc32'});
$self->{'crc32'} = $crc32;
$self->{'compressedSize'} = $compressedSize;
$self->{'uncompressedSize'} = $uncompressedSize;
return AZ_OK;
}
# Read a Central Directory header. Return AZ_OK on success.
# Assumes that fh is positioned right after the signature.
sub _readCentralDirectoryFileHeader {
my $self = shift;
my $fh = $self->fh();
my $header = '';
my $bytesRead = $fh->read($header, CENTRAL_DIRECTORY_FILE_HEADER_LENGTH);
if ($bytesRead != CENTRAL_DIRECTORY_FILE_HEADER_LENGTH) {
return _ioError("reading central dir header");
}
my ($fileNameLength, $extraFieldLength, $fileCommentLength);
(
$self->{'versionMadeBy'},
$self->{'fileAttributeFormat'},
$self->{'versionNeededToExtract'},
$self->{'bitFlag'},
$self->{'compressionMethod'},
$self->{'lastModFileDateTime'},
$self->{'crc32'},
$self->{'compressedSize'},
$self->{'uncompressedSize'},
$fileNameLength,
$extraFieldLength,
$fileCommentLength,
$self->{'diskNumberStart'},
$self->{'internalFileAttributes'},
$self->{'externalFileAttributes'},
$self->{'localHeaderRelativeOffset'}
) = unpack(CENTRAL_DIRECTORY_FILE_HEADER_FORMAT, $header);
$self->{'eocdCrc32'} = $self->{'crc32'};
if ($fileNameLength) {
$bytesRead = $fh->read($self->{'fileName'}, $fileNameLength);
if ($bytesRead != $fileNameLength) {
_ioError("reading central dir filename");
}
}
if ($extraFieldLength) {
$bytesRead = $fh->read($self->{'cdExtraField'}, $extraFieldLength);
if ($bytesRead != $extraFieldLength) {
return _ioError("reading central dir extra field");
}
if ($self->{'archiveZip64'}) {
my ($status, $zip64) =
$self->_extractZip64ExtraField($self->{'cdExtraField'},
$self->{'uncompressedSize'},
$self->{'compressedSize'},
$self->{'localHeaderRelativeOffset'},
$self->{'diskNumberStart'});
return $status if $status != AZ_OK;
$self->{'zip64'} ||= $zip64;
}
}
if ($fileCommentLength) {
$bytesRead = $fh->read($self->{'fileComment'}, $fileCommentLength);
if ($bytesRead != $fileCommentLength) {
return _ioError("reading central dir file comment");
}
}
# NK 10/21/04: added to avoid problems with manipulated headers
if ( $self->{'uncompressedSize'} != $self->{'compressedSize'}
and $self->{'compressionMethod'} == COMPRESSION_STORED) {
$self->{'uncompressedSize'} = $self->{'compressedSize'};
}
$self->desiredCompressionMethod($self->compressionMethod());
return AZ_OK;
}
sub rewindData {
my $self = shift;
my $status = $self->SUPER::rewindData(@_);
return $status unless $status == AZ_OK;
return AZ_IO_ERROR unless $self->fh();
$self->fh()->clearerr();
# Seek to local file header.
# The only reason that I'm doing this this way is that the extraField
# length seems to be different between the CD header and the LF header.
$status = $self->_seekToLocalHeader();
return $status unless $status == AZ_OK;
# skip local file header
$status = $self->_skipLocalFileHeader();
return $status unless $status == AZ_OK;
# Seek to beginning of file data
$self->fh()->seek($self->dataOffset(), IO::Seekable::SEEK_SET)
or return _ioError("seeking to beginning of file data");
return AZ_OK;
}
# Return bytes read. Note that first parameter is a ref to a buffer.
# my $data;
# my ( $bytesRead, $status) = $self->readRawChunk( \$data, $chunkSize );
sub _readRawChunk {
my ($self, $dataRef, $chunkSize) = @_;
return (0, AZ_OK) unless $chunkSize;
my $bytesRead = $self->fh()->read($$dataRef, $chunkSize)
or return (0, _ioError("reading data"));
return ($bytesRead, AZ_OK);
}
1;

662
OGP64/usr/share/perl5/vendor_perl/5.40/Class/Inspector.pm Normal file
View file

@ -0,0 +1,662 @@
package Class::Inspector;
use 5.006;
# We don't want to use strict refs anywhere in this module, since we do a
# lot of things in here that aren't strict refs friendly.
use strict qw{vars subs};
use warnings;
use File::Spec ();
# ABSTRACT: Get information about a class and its structure
our $VERSION = '1.36'; # VERSION
# If Unicode is available, enable it so that the
# pattern matches below match unicode method names.
# We can safely ignore any failure here.
BEGIN {
local $@;
eval {
require utf8;
utf8->import;
};
}
# Predefine some regexs
our $RE_IDENTIFIER = qr/\A[^\W\d]\w*\z/s;
our $RE_CLASS = qr/\A[^\W\d]\w*(?:(?:\'|::)\w+)*\z/s;
# Are we on something Unix-like?
our $UNIX = !! ( $File::Spec::ISA[0] eq 'File::Spec::Unix' );
#####################################################################
# Basic Methods
sub _resolved_inc_handler {
my $class = shift;
my $filename = $class->_inc_filename(shift) or return undef;
foreach my $inc ( @INC ) {
my $ref = ref $inc;
if($ref eq 'CODE') {
my @ret = $inc->($inc, $filename);
if(@ret == 1 && ! defined $ret[0]) {
# do nothing.
} elsif(@ret) {
return 1;
}
}
elsif($ref eq 'ARRAY' && ref($inc->[0]) eq 'CODE') {
my @ret = $inc->[0]->($inc, $filename);
if(@ret) {
return 1;
}
}
elsif($ref && eval { $inc->can('INC') }) {
my @ret = $inc->INC($filename);
if(@ret) {
return 1;
}
}
}
'';
}
sub installed {
my $class = shift;
!! ($class->loaded_filename($_[0]) or $class->resolved_filename($_[0]) or $class->_resolved_inc_handler($_[0]));
}
sub loaded {
my $class = shift;
my $name = $class->_class(shift) or return undef;
$class->_loaded($name);
}
sub _loaded {
my $class = shift;
my $name = shift;
# Handle by far the two most common cases
# This is very fast and handles 99% of cases.
return 1 if defined ${"${name}::VERSION"};
return 1 if @{"${name}::ISA"};
# Are there any symbol table entries other than other namespaces
foreach ( keys %{"${name}::"} ) {
next if substr($_, -2, 2) eq '::';
return 1 if defined &{"${name}::$_"};
}
# No functions, and it doesn't have a version, and isn't anything.
# As an absolute last resort, check for an entry in %INC
my $filename = $class->_inc_filename($name);
return 1 if defined $INC{$filename};
'';
}
sub filename {
my $class = shift;
my $name = $class->_class(shift) or return undef;
File::Spec->catfile( split /(?:\'|::)/, $name ) . '.pm';
}
sub resolved_filename {
my $class = shift;
my $filename = $class->_inc_filename(shift) or return undef;
my @try_first = @_;
# Look through the @INC path to find the file
foreach ( @try_first, @INC ) {
my $full = "$_/$filename";
next unless -e $full;
return $UNIX ? $full : $class->_inc_to_local($full);
}
# File not found
'';
}
sub loaded_filename {
my $class = shift;
my $filename = $class->_inc_filename(shift);
$UNIX ? $INC{$filename} : $class->_inc_to_local($INC{$filename});
}
#####################################################################
# Sub Related Methods
sub functions {
my $class = shift;
my $name = $class->_class(shift) or return undef;
return undef unless $class->loaded( $name );
# Get all the CODE symbol table entries
my @functions = sort grep { /$RE_IDENTIFIER/o }
grep { defined &{"${name}::$_"} }
keys %{"${name}::"};
\@functions;
}
sub function_refs {
my $class = shift;
my $name = $class->_class(shift) or return undef;
return undef unless $class->loaded( $name );
# Get all the CODE symbol table entries, but return
# the actual CODE refs this time.
my @functions = map { \&{"${name}::$_"} }
sort grep { /$RE_IDENTIFIER/o }
grep { defined &{"${name}::$_"} }
keys %{"${name}::"};
\@functions;
}
sub function_exists {
my $class = shift;
my $name = $class->_class( shift ) or return undef;
my $function = shift or return undef;
# Only works if the class is loaded
return undef unless $class->loaded( $name );
# Does the GLOB exist and its CODE part exist
defined &{"${name}::$function"};
}
sub methods {
my $class = shift;
my $name = $class->_class( shift ) or return undef;
my @arguments = map { lc $_ } @_;
# Process the arguments to determine the options
my %options = ();
foreach ( @arguments ) {
if ( $_ eq 'public' ) {
# Only get public methods
return undef if $options{private};
$options{public} = 1;
} elsif ( $_ eq 'private' ) {
# Only get private methods
return undef if $options{public};
$options{private} = 1;
} elsif ( $_ eq 'full' ) {
# Return the full method name
return undef if $options{expanded};
$options{full} = 1;
} elsif ( $_ eq 'expanded' ) {
# Returns class, method and function ref
return undef if $options{full};
$options{expanded} = 1;
} else {
# Unknown or unsupported options
return undef;
}
}
# Only works if the class is loaded
return undef unless $class->loaded( $name );
# Get the super path ( not including UNIVERSAL )
# Rather than using Class::ISA, we'll use an inlined version
# that implements the same basic algorithm.
my @path = ();
my @queue = ( $name );
my %seen = ( $name => 1 );
while ( my $cl = shift @queue ) {
push @path, $cl;
unshift @queue, grep { ! $seen{$_}++ }
map { s/^::/main::/; s/\'/::/g; $_ } ## no critic
map { "$_" }
( @{"${cl}::ISA"} );
}
# Find and merge the function names across the entire super path.
# Sort alphabetically and return.
my %methods = ();
foreach my $namespace ( @path ) {
my @functions = grep { ! $methods{$_} }
grep { /$RE_IDENTIFIER/o }
grep { defined &{"${namespace}::$_"} }
keys %{"${namespace}::"};
foreach ( @functions ) {
$methods{$_} = $namespace;
}
}
# Filter to public or private methods if needed
my @methodlist = sort keys %methods;
@methodlist = grep { ! /^\_/ } @methodlist if $options{public};
@methodlist = grep { /^\_/ } @methodlist if $options{private};
# Return in the correct format
@methodlist = map { "$methods{$_}::$_" } @methodlist if $options{full};
@methodlist = map {
[ "$methods{$_}::$_", $methods{$_}, $_, \&{"$methods{$_}::$_"} ]
} @methodlist if $options{expanded};
\@methodlist;
}
#####################################################################
# Search Methods
sub subclasses {
my $class = shift;
my $name = $class->_class( shift ) or return undef;
# Prepare the search queue
my @found = ();
my @queue = grep { $_ ne 'main' } $class->_subnames('');
while ( @queue ) {
my $c = shift(@queue); # c for class
if ( $class->_loaded($c) ) {
# At least one person has managed to misengineer
# a situation in which ->isa could die, even if the
# class is real. Trap these cases and just skip
# over that (bizarre) class. That would at limit
# problems with finding subclasses to only the
# modules that have broken ->isa implementation.
local $@;
eval {
if ( $c->isa($name) ) {
# Add to the found list, but don't add the class itself
push @found, $c unless $c eq $name;
}
};
}
# Add any child namespaces to the head of the queue.
# This keeps the queue length shorted, and allows us
# not to have to do another sort at the end.
unshift @queue, map { "${c}::$_" } $class->_subnames($c);
}
@found ? \@found : '';
}
sub _subnames {
my ($class, $name) = @_;
return sort
grep { ## no critic
substr($_, -2, 2, '') eq '::'
and
/$RE_IDENTIFIER/o
}
keys %{"${name}::"};
}
#####################################################################
# Children Related Methods
# These can go undocumented for now, until I decide if its best to
# just search the children in namespace only, or if I should do it via
# the file system.
# Find all the loaded classes below us
sub children {
my $class = shift;
my $name = $class->_class(shift) or return ();
# Find all the Foo:: elements in our symbol table
no strict 'refs';
map { "${name}::$_" } sort grep { s/::$// } keys %{"${name}::"}; ## no critic
}
# As above, but recursively
sub recursive_children {
my $class = shift;
my $name = $class->_class(shift) or return ();
my @children = ( $name );
# Do the search using a nicer, more memory efficient
# variant of actual recursion.
my $i = 0;
no strict 'refs';
while ( my $namespace = $children[$i++] ) {
push @children, map { "${namespace}::$_" }
grep { ! /^::/ } # Ignore things like ::ISA::CACHE::
grep { s/::$// } ## no critic
keys %{"${namespace}::"};
}
sort @children;
}
#####################################################################
# Private Methods
# Checks and expands ( if needed ) a class name
sub _class {
my $class = shift;
my $name = shift or return '';
# Handle main shorthand
return 'main' if $name eq '::';
$name =~ s/\A::/main::/;
# Check the class name is valid
$name =~ /$RE_CLASS/o ? $name : '';
}
# Create a INC-specific filename, which always uses '/'
# regardless of platform.
sub _inc_filename {
my $class = shift;
my $name = $class->_class(shift) or return undef;
join( '/', split /(?:\'|::)/, $name ) . '.pm';
}
# Convert INC-specific file name to local file name
sub _inc_to_local {
# Shortcut in the Unix case
return $_[1] if $UNIX;
# On other places, we have to deal with an unusual path that might look
# like C:/foo/bar.pm which doesn't fit ANY normal pattern.
# Putting it through splitpath/dir and back again seems to normalise
# it to a reasonable amount.
my $class = shift;
my $inc_name = shift or return undef;
my ($vol, $dir, $file) = File::Spec->splitpath( $inc_name );
$dir = File::Spec->catdir( File::Spec->splitdir( $dir || "" ) );
File::Spec->catpath( $vol, $dir, $file || "" );
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::Inspector - Get information about a class and its structure
=head1 VERSION
version 1.36
=head1 SYNOPSIS
use Class::Inspector;
# Is a class installed and/or loaded
Class::Inspector->installed( 'Foo::Class' );
Class::Inspector->loaded( 'Foo::Class' );
# Filename related information
Class::Inspector->filename( 'Foo::Class' );
Class::Inspector->resolved_filename( 'Foo::Class' );
# Get subroutine related information
Class::Inspector->functions( 'Foo::Class' );
Class::Inspector->function_refs( 'Foo::Class' );
Class::Inspector->function_exists( 'Foo::Class', 'bar' );
Class::Inspector->methods( 'Foo::Class', 'full', 'public' );
# Find all loaded subclasses or something
Class::Inspector->subclasses( 'Foo::Class' );
=head1 DESCRIPTION
Class::Inspector allows you to get information about a loaded class. Most or
all of this information can be found in other ways, but they aren't always
very friendly, and usually involve a relatively high level of Perl wizardry,
or strange and unusual looking code. Class::Inspector attempts to provide
an easier, more friendly interface to this information.
=head1 METHODS
=head2 installed
my $bool = Class::Inspector->installed($class);
The C<installed> static method tries to determine if a class is installed
on the machine, or at least available to Perl. It does this by wrapping
around C<resolved_filename>.
Returns true if installed/available, false if the class is not installed,
or C<undef> if the class name is invalid.
=head2 loaded
my $bool = Class::Inspector->loaded($class);
The C<loaded> static method tries to determine if a class is loaded by
looking for symbol table entries.
This method it uses to determine this will work even if the class does not
have its own file, but is contained inside a single file with multiple
classes in it. Even in the case of some sort of run-time loading class
being used, these typically leave some trace in the symbol table, so an
L<Autoload> or L<Class::Autouse>-based class should correctly appear
loaded.
Returns true if the class is loaded, false if not, or C<undef> if the
class name is invalid.
=head2 filename
my $filename = Class::Inspector->filename($class);
For a given class, returns the base filename for the class. This will NOT
be a fully resolved filename, just the part of the filename BELOW the
C<@INC> entry.
print Class->filename( 'Foo::Bar' );
> Foo/Bar.pm
This filename will be returned with the right separator for the local
platform, and should work on all platforms.
Returns the filename on success or C<undef> if the class name is invalid.
=head2 resolved_filename
my $filename = Class::Inspector->resolved_filename($class);
my $filename = Class::Inspector->resolved_filename($class, @try_first);
For a given class, the C<resolved_filename> static method returns the fully
resolved filename for a class. That is, the file that the class would be
loaded from.
This is not necessarily the file that the class WAS loaded from, as the
value returned is determined each time it runs, and the C<@INC> include
path may change.
To get the actual file for a loaded class, see the C<loaded_filename>
method.
Returns the filename for the class, or C<undef> if the class name is
invalid.
=head2 loaded_filename
my $filename = Class::Inspector->loaded_filename($class);
For a given loaded class, the C<loaded_filename> static method determines
(via the C<%INC> hash) the name of the file that it was originally loaded
from.
Returns a resolved file path, or false if the class did not have it's own
file.
=head2 functions
my $arrayref = Class::Inspector->functions($class);
For a loaded class, the C<functions> static method returns a list of the
names of all the functions in the classes immediate namespace.
Note that this is not the METHODS of the class, just the functions.
Returns a reference to an array of the function names on success, or C<undef>
if the class name is invalid or the class is not loaded.
=head2 function_refs
my $arrayref = Class::Inspector->function_refs($class);
For a loaded class, the C<function_refs> static method returns references to
all the functions in the classes immediate namespace.
Note that this is not the METHODS of the class, just the functions.
Returns a reference to an array of C<CODE> refs of the functions on
success, or C<undef> if the class is not loaded.
=head2 function_exists
my $bool = Class::Inspector->function_exists($class, $functon);
Given a class and function name the C<function_exists> static method will
check to see if the function exists in the class.
Note that this is as a function, not as a method. To see if a method
exists for a class, use the C<can> method for any class or object.
Returns true if the function exists, false if not, or C<undef> if the
class or function name are invalid, or the class is not loaded.
=head2 methods
my $arrayref = Class::Inspector->methods($class, @options);
For a given class name, the C<methods> static method will returns ALL
the methods available to that class. This includes all methods available
from every class up the class' C<@ISA> tree.
Returns a reference to an array of the names of all the available methods
on success, or C<undef> if the class name is invalid or the class is not
loaded.
A number of options are available to the C<methods> method that will alter
the results returned. These should be listed after the class name, in any
order.
# Only get public methods
my $method = Class::Inspector->methods( 'My::Class', 'public' );
=over 4
=item public
The C<public> option will return only 'public' methods, as defined by the Perl
convention of prepending an underscore to any 'private' methods. The C<public>
option will effectively remove any methods that start with an underscore.
=item private
The C<private> options will return only 'private' methods, as defined by the
Perl convention of prepending an underscore to an private methods. The
C<private> option will effectively remove an method that do not start with an
underscore.
B<Note: The C<public> and C<private> options are mutually exclusive>
=item full
C<methods> normally returns just the method name. Supplying the C<full> option
will cause the methods to be returned as the full names. That is, instead of
returning C<[ 'method1', 'method2', 'method3' ]>, you would instead get
C<[ 'Class::method1', 'AnotherClass::method2', 'Class::method3' ]>.
=item expanded
The C<expanded> option will cause a lot more information about method to be
returned. Instead of just the method name, you will instead get an array
reference containing the method name as a single combined name, a la C<full>,
the separate class and method, and a CODE ref to the actual function ( if
available ). Please note that the function reference is not guaranteed to
be available. C<Class::Inspector> is intended at some later time, to work
with modules that have some kind of common run-time loader in place ( e.g
C<Autoloader> or C<Class::Autouse> for example.
The response from C<methods( 'Class', 'expanded' )> would look something like
the following.
[
[ 'Class::method1', 'Class', 'method1', \&Class::method1 ],
[ 'Another::method2', 'Another', 'method2', \&Another::method2 ],
[ 'Foo::bar', 'Foo', 'bar', \&Foo::bar ],
]
=back
=head2 subclasses
my $arrayref = Class::Inspector->subclasses($class);
The C<subclasses> static method will search then entire namespace (and thus
B<all> currently loaded classes) to find all classes that are subclasses
of the class provided as a the parameter.
The actual test will be done by calling C<isa> on the class as a static
method. (i.e. C<My::Class-E<gt>isa($class)>.
Returns a reference to a list of the loaded classes that match the class
provided, or false is none match, or C<undef> if the class name provided
is invalid.
=head1 SEE ALSO
L<http://ali.as/>, L<Class::Handle>, L<Class::Inspector::Functions>
=head1 AUTHOR
Original author: Adam Kennedy E<lt>adamk@cpan.orgE<gt>
Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
Contributors:
Tom Wyant
Steffen Müller
Kivanc Yazan (KYZN)
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2002-2019 by Adam Kennedy.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

136
OGP64/usr/share/perl5/vendor_perl/5.40/Class/Inspector/Functions.pm Normal file
View file

@ -0,0 +1,136 @@
package Class::Inspector::Functions;
use 5.006;
use strict;
use warnings;
use Exporter ();
use Class::Inspector ();
use base qw( Exporter );
# ABSTRACT: Get information about a class and its structure
our $VERSION = '1.36'; # VERSION
BEGIN {
our @EXPORT = qw(
installed
loaded
filename
functions
methods
subclasses
);
our @EXPORT_OK = qw(
resolved_filename
loaded_filename
function_refs
function_exists
);
#children
#recursive_children
our %EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] );
foreach my $meth (@EXPORT, @EXPORT_OK) {
my $sub = Class::Inspector->can($meth);
no strict 'refs';
*{$meth} = sub {&$sub('Class::Inspector', @_)};
}
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Class::Inspector::Functions - Get information about a class and its structure
=head1 VERSION
version 1.36
=head1 SYNOPSIS
use Class::Inspector::Functions;
# Class::Inspector provides a non-polluting,
# method based interface!
# Is a class installed and/or loaded
installed( 'Foo::Class' );
loaded( 'Foo::Class' );
# Filename related information
filename( 'Foo::Class' );
resolved_filename( 'Foo::Class' );
# Get subroutine related information
functions( 'Foo::Class' );
function_refs( 'Foo::Class' );
function_exists( 'Foo::Class', 'bar' );
methods( 'Foo::Class', 'full', 'public' );
# Find all loaded subclasses or something
subclasses( 'Foo::Class' );
=head1 DESCRIPTION
Class::Inspector::Functions is a function based interface of
L<Class::Inspector>. For a thorough documentation of the available
functions, please check the manual for the main module.
=head2 Exports
The following functions are exported by default.
installed
loaded
filename
functions
methods
subclasses
The following functions are exported only by request.
resolved_filename
loaded_filename
function_refs
function_exists
All the functions may be imported using the C<:ALL> tag.
=head1 SEE ALSO
L<http://ali.as/>, L<Class::Handle>, L<Class::Inspector>
=head1 AUTHOR
Original author: Adam Kennedy E<lt>adamk@cpan.orgE<gt>
Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
Contributors:
Tom Wyant
Steffen Müller
Kivanc Yazan (KYZN)
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2002-2019 by Adam Kennedy.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

210
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Format.pm Normal file
View file

@ -0,0 +1,210 @@
# Copyright (c) 1995-2009 Graham Barr. This program is free
# software; you can redistribute it and/or modify it under the same terms
# as Perl itself.
package Date::Format;
use strict;
require Exporter;
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Date formatting subroutines
use Date::Format::Generic;
our @ISA = qw(Exporter);
our @EXPORT = qw(time2str strftime ctime asctime);
sub time2str ($;$$$)
{
my ($fmt, $time, $zone, $lang) = @_;
my $pkg = defined $lang
? do { require Date::Language; Date::Language->new($lang) }
: 'Date::Format::Generic';
$pkg->time2str($fmt, $time, $zone);
}
sub strftime ($\@;$)
{
Date::Format::Generic->strftime(@_);
}
sub ctime ($;$)
{
my ($t,$tz) = @_;
Date::Format::Generic->time2str("%a %b %e %T %Y\n", $t, $tz);
}
sub asctime (\@;$)
{
my ($t,$tz) = @_;
Date::Format::Generic->strftime("%a %b %e %T %Y\n", $t, $tz);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Format - Date formatting subroutines
=head1 VERSION
version 2.35
=head1 SYNOPSIS
use Date::Format;
my @lt = localtime(time);
my $template = "....";
print time2str($template, time);
print strftime($template, @lt);
my $zone;
print time2str($template, time, $zone);
print strftime($template, @lt, $zone);
print ctime(time);
print asctime(@lt);
print ctime(time, $zone);
print asctime(@lt, $zone);
=head1 DESCRIPTION
This module provides routines to format dates into ASCII strings. They
correspond to the C library routines C<strftime> and C<ctime>.
=over 4
=item time2str(TEMPLATE, TIME [, ZONE [, LANGUAGE]])
C<time2str> converts C<TIME> into an ASCII string using the conversion
specification given in C<TEMPLATE>. C<ZONE> if given specifies the zone
which the output is required to be in, C<ZONE> defaults to your current zone.
C<LANGUAGE> if given specifies the language for day and month names
(e.g. C<'German'>, C<'French'>); defaults to C<'English'>.
=item strftime(TEMPLATE, TIME [, ZONE])
C<strftime> is similar to C<time2str> with the exception that the time is
passed as an array, such as the array returned by C<localtime>.
=item ctime(TIME [, ZONE])
C<ctime> calls C<time2str> with the given arguments using the
conversion specification C<"%a %b %e %T %Y\n">
=item asctime(TIME [, ZONE])
C<asctime> calls C<time2str> with the given arguments using the
conversion specification C<"%a %b %e %T %Y\n">
=back
=head1 NAME
Date::Format - Date formatting subroutines
=head1 MULTI-LANGUAGE SUPPORT
Date::Format is capable of formatting into several languages. You can
pass an optional language name directly to C<time2str>:
time2str("%a %b %e %T %Y\n", time, undef, 'German');
time2str("%a %b %e %T %Y\n", time, 'GMT', 'French');
Alternatively, create a language-specific object and call methods on it,
see L<Date::Language>:
my $lang = Date::Language->new('German');
$lang->time2str("%a %b %e %T %Y\n", time);
=head1 CONVERSION SPECIFICATION
Each conversion specification is replaced by appropriate
characters as described in the following list. The
appropriate characters are determined by the LC_TIME
category of the program's locale.
%% PERCENT
%a day of the week abbr
%A day of the week
%b month abbr
%B month
%c MM/DD/YY HH:MM:SS
%C ctime format: Sat Nov 19 21:05:57 1994
%d numeric day of the month, with leading zeros (eg 01..31)
%e like %d, but a leading zero is replaced by a space (eg 1..32)
%D MM/DD/YY
%G GPS week number (weeks since January 6, 1980)
%h month abbr
%H hour, 24 hour clock, leading 0's)
%I hour, 12 hour clock, leading 0's)
%j day of the year
%k hour
%l hour, 12 hour clock
%L month number, starting with 1
%m month number, starting with 01
%M minute, leading 0's
%n NEWLINE
%o ornate day of month -- "1st", "2nd", "25th", etc.
%p AM or PM
%P am or pm (Yes %p and %P are backwards :)
%q Quarter number, starting with 1
%r time format: 09:05:57 PM
%R time format: 21:05
%s seconds since the Epoch, UCT
%S seconds, leading 0's
%t TAB
%T time format: 21:05:57
%U week number, Sunday as first day of week
%w day of the week, numerically, Sunday == 0
%W week number, Monday as first day of week
%x date format: 11/19/94
%X time format: 21:05:57
%y year (2 digits)
%Y year (4 digits)
%Z timezone in ascii. eg: PST
%z timezone in format -/+0000
C<%d>, C<%e>, C<%H>, C<%I>, C<%j>, C<%k>, C<%l>, C<%m>, C<%M>, C<%q>,
C<%y> and C<%Y> can be output in Roman numerals by prefixing the letter
with C<O>, e.g. C<%OY> will output the year as roman numerals.
=head1 LIMITATION
The functions in this module are limited to the time range that can be
represented by the time_t data type, i.e. 1901-12-13 20:45:53 GMT to
2038-01-19 03:14:07 GMT.
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
=head1 COPYRIGHT
Copyright (c) 1995-2009 Graham Barr. This program is free
software; you can redistribute it and/or modify it under the same terms
as Perl itself.
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

264
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Format/Generic.pm Normal file
View file

@ -0,0 +1,264 @@
##
##
##
package Date::Format::Generic;
use strict;
use warnings;
our ($epoch, $tzname);
use Time::Zone;
use Time::Local;
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Date formatting subroutines
sub ctime
{
my($me,$t,$tz) = @_;
$me->time2str("%a %b %e %T %Y\n", $t, $tz);
}
sub asctime
{
my($me,$t,$tz) = @_;
$me->strftime("%a %b %e %T %Y\n", $t, $tz);
}
sub _subs
{
my $fn;
$_[1] =~ s/
%(O?[%a-zA-Z])
/
($_[0]->can("format_$1") || sub { $1 })->($_[0]);
/sgeox;
$_[1];
}
sub strftime
{
my($pkg,$fmt,$time);
($pkg,$fmt,$time,$tzname) = @_;
my $me = ref($pkg) ? $pkg : bless [];
if(defined $tzname)
{
$tzname = uc $tzname;
$tzname = sprintf("%+05d",$tzname)
unless($tzname =~ /\D/);
$epoch = timelocal(@{$time}[0..5]);
@$me = gmtime($epoch + tz_offset($tzname));
}
else
{
@$me = @$time;
undef $epoch;
}
_subs($me,$fmt);
}
sub time2str
{
my($pkg,$fmt,$time);
($pkg,$fmt,$time,$tzname) = @_;
my $me = ref($pkg) ? $pkg : bless [], $pkg;
$epoch = $time;
if(defined $tzname)
{
$tzname = uc $tzname;
$tzname = sprintf("%+05d",$tzname)
unless($tzname =~ /\D/);
$time += tz_offset($tzname);
@$me = gmtime($time);
}
else
{
@$me = localtime($time);
}
$me->[9] = $time;
_subs($me,$fmt);
}
my(@DoW,@MoY,@DoWs,@MoYs,@AMPM,%format,@Dsuf);
@DoW = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
@MoY = qw(January February March April May June
July August September October November December);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
%format = ('x' => "%m/%d/%y",
'C' => "%a %b %e %T %Z %Y",
'X' => "%H:%M:%S",
);
my @locale;
my $locale = "/usr/share/lib/locale/LC_TIME/default";
local *LOCALE;
if(open(LOCALE,"$locale"))
{
chop(@locale = <LOCALE>);
close(LOCALE);
@MoYs = @locale[0 .. 11];
@MoY = @locale[12 .. 23];
@DoWs = @locale[24 .. 30];
@DoW = @locale[31 .. 37];
@format{"X","x","C"} = @locale[38 .. 40];
@AMPM = @locale[41 .. 42];
}
sub wkyr {
my($wstart, $wday, $yday) = @_;
$wday = ($wday + 7 - $wstart) % 7;
return int(($yday - $wday + 13) / 7 - 1);
}
##
## these 6 formatting routines need to be *copied* into the language
## specific packages
##
my @roman = ('',qw(I II III IV V VI VII VIII IX));
sub roman {
my $n = shift;
$n =~ s/(\d)$//;
my $r = $roman[ $1 ];
if($n =~ s/(\d)$//) {
(my $t = $roman[$1]) =~ tr/IVX/XLC/;
$r = $t . $r;
}
if($n =~ s/(\d)$//) {
(my $t = $roman[$1]) =~ tr/IVX/CDM/;
$r = $t . $r;
}
if($n =~ s/(\d)$//) {
(my $t = $roman[$1]) =~ tr/IVX/M../;
$r = $t . $r;
}
$r;
}
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_P { lc($_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0]) }
sub format_d { sprintf("%02d",$_[0]->[3]) }
sub format_e { sprintf("%2d",$_[0]->[3]) }
sub format_H { sprintf("%02d",$_[0]->[2]) }
sub format_I { sprintf("%02d",$_[0]->[2] % 12 || 12)}
sub format_j { sprintf("%03d",$_[0]->[7] + 1) }
sub format_k { sprintf("%2d",$_[0]->[2]) }
sub format_l { sprintf("%2d",$_[0]->[2] % 12 || 12)}
sub format_L { $_[0]->[4] + 1 }
sub format_m { sprintf("%02d",$_[0]->[4] + 1) }
sub format_M { sprintf("%02d",$_[0]->[1]) }
sub format_q { sprintf("%01d",int($_[0]->[4] / 3) + 1) }
sub format_s {
$epoch = timelocal(@{$_[0]}[0..5])
unless defined $epoch;
sprintf("%d",$epoch)
}
sub format_S { sprintf("%02d",$_[0]->[0]) }
sub format_U { wkyr(0, $_[0]->[6], $_[0]->[7]) }
sub format_w { $_[0]->[6] }
sub format_W { wkyr(1, $_[0]->[6], $_[0]->[7]) }
sub format_y { sprintf("%02d",$_[0]->[5] % 100) }
sub format_Y { sprintf("%04d",$_[0]->[5] + 1900) }
sub format_Z {
my $o = tz_local_offset($_[0]->[9]);
defined $tzname ? $tzname : uc tz_name($o, $_[0]->[8]);
}
sub format_z {
my $t = $_[0]->[9];
my $o = defined $tzname ? tz_offset($tzname, $t) : tz_offset(undef,$t);
sprintf("%+03d%02d", int($o / 3600), int(abs($o) % 3600) / 60);
}
sub format_c { &format_x . " " . &format_X }
sub format_D { &format_m . "/" . &format_d . "/" . &format_y }
sub format_r { &format_I . ":" . &format_M . ":" . &format_S . " " . &format_p }
sub format_R { &format_H . ":" . &format_M }
sub format_T { &format_H . ":" . &format_M . ":" . &format_S }
sub format_t { "\t" }
sub format_n { "\n" }
sub format_o { sprintf("%2d%s",$_[0]->[3],$Dsuf[$_[0]->[3]]) }
sub format_x { my $f = $format{'x'}; _subs($_[0],$f); }
sub format_X { my $f = $format{'X'}; _subs($_[0],$f); }
sub format_C { my $f = $format{'C'}; _subs($_[0],$f); }
sub format_Od { roman(format_d(@_)) }
sub format_Oe { roman(format_e(@_)) }
sub format_OH { roman(format_H(@_)) }
sub format_OI { roman(format_I(@_)) }
sub format_Oj { roman(format_j(@_)) }
sub format_Ok { roman(format_k(@_)) }
sub format_Ol { roman(format_l(@_)) }
sub format_Om { roman(format_m(@_)) }
sub format_OM { roman(format_M(@_)) }
sub format_Oq { roman(format_q(@_)) }
sub format_Oy { roman(format_y(@_)) }
sub format_OY { roman(format_Y(@_)) }
sub format_G { int(($_[0]->[9] - 315993600) / 604800) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Format::Generic - Date formatting subroutines
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

187
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language.pm Normal file
View file

@ -0,0 +1,187 @@
package Date::Language;
use strict;
use Time::Local;
use Carp;
require Date::Format;
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Language specific date formatting and parsing
use base qw(Date::Format::Generic);
sub _build_lookups
{
my $pkg = caller;
no strict 'refs';
@{"${pkg}::MoY"}{@{"${pkg}::MoY"}} = (0 .. scalar(@{"${pkg}::MoY"}));
@{"${pkg}::MoY"}{@{"${pkg}::MoYs"}} = (0 .. scalar(@{"${pkg}::MoYs"}));
@{"${pkg}::DoW"}{@{"${pkg}::DoW"}} = (0 .. scalar(@{"${pkg}::DoW"}));
@{"${pkg}::DoW"}{@{"${pkg}::DoWs"}} = (0 .. scalar(@{"${pkg}::DoWs"}));
}
sub new
{
my $self = shift;
my $type = shift || $self;
$type =~ s/^(\w+)$/Date::Language::$1/;
croak "Bad language"
unless $type =~ /^[\w:]+$/;
eval "require $type"
or croak $@;
bless [], $type;
}
# Stop AUTOLOAD being called ;-)
sub DESTROY {}
sub AUTOLOAD
{
our $AUTOLOAD;
if($AUTOLOAD =~ /::strptime\Z/o)
{
my $self = $_[0];
my $type = ref($self) || $self;
require Date::Parse;
no strict 'refs';
*{"${type}::strptime"} = Date::Parse::gen_parser(
\%{"${type}::DoW"},
\%{"${type}::MoY"},
\@{"${type}::Dsuf"},
1);
goto &{"${type}::strptime"};
}
croak "Undefined method &$AUTOLOAD called";
}
sub format_Z {
my $tz = Date::Format::Generic::format_Z(@_);
my $pkg = ref($_[0]) || 'Date::Language';
no strict 'refs';
my $tz_map = \%{"${pkg}::TZ"};
return exists $tz_map->{$tz} ? $tz_map->{$tz} : $tz;
}
sub str2time
{
my $me = shift;
my @t = $me->strptime(@_);
return undef
unless @t;
my($ss,$mm,$hh,$day,$month,$year,$zone) = @t;
my @lt = localtime(time);
$hh ||= 0;
$mm ||= 0;
$ss ||= 0;
$month = $lt[4]
unless(defined $month);
$day = $lt[3]
unless(defined $day);
$year = ($month > $lt[4]) ? ($lt[5] - 1) : $lt[5]
unless(defined $year);
return defined $zone ? timegm($ss,$mm,$hh,$day,$month,$year) - $zone
: timelocal($ss,$mm,$hh,$day,$month,$year);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language - Language specific date formatting and parsing
=head1 VERSION
version 2.35
=head1 SYNOPSIS
use Date::Language;
my $lang = Date::Language->new('German');
$lang->time2str("%a %b %e %T %Y\n", time);
=head1 DESCRIPTION
L<Date::Language> provides objects to parse and format dates for specific languages. Available languages are
Afar French Russian_cp1251
Amharic Gedeo Russian_koi8r
Austrian German Sidama
Brazilian Greek Somali
Chinese Hungarian Spanish
Chinese_GB Icelandic Swedish
Czech Italian Tigrinya
Danish Norwegian TigrinyaEritrean
Dutch Oromo TigrinyaEthiopian
English Romanian Turkish
Finnish Russian Bulgarian
Occitan
=head1 NAME
Date::Language - Language specific date formatting and parsing
=head1 METHODS
=over
=item time2str
See L<Date::Format/time2str>
=item strftime
See L<Date::Format/strftime>
=item ctime
See L<Date::Format/ctime>
=item asctime
See L<Date::Format/asctime>
=item str2time
See L<Date::Parse/str2time>
=item strptime
See L<Date::Parse/strptime>
=back
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

79
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Afar.pm Normal file
View file

@ -0,0 +1,79 @@
##
## Afar tables
##
package Date::Language::Afar;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Afar localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = qw(Acaada Etleeni Talaata Arbaqa Kamiisi Gumqata Sabti);
@MoY = (
"Qunxa Garablu",
"Kudo",
"Ciggilta Kudo",
"Agda Baxis",
"Caxah Alsa",
"Qasa Dirri",
"Qado Dirri",
"Liiqen",
"Waysu",
"Diteli",
"Ximoli",
"Kaxxa Garablu"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(saaku carra);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Afar - Afar localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

117
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Amharic.pm Normal file
View file

@ -0,0 +1,117 @@
##
## Amharic tables
##
package Date::Language::Amharic;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Amharic localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
if ( $] >= 5.006 ) {
@DoW = (
"\x{12a5}\x{1211}\x{12f5}",
"\x{1230}\x{129e}",
"\x{121b}\x{12ad}\x{1230}\x{129e}",
"\x{1228}\x{1261}\x{12d5}",
"\x{1210}\x{1219}\x{1235}",
"\x{12d3}\x{122d}\x{1265}",
"\x{1245}\x{12f3}\x{121c}"
);
@MoY = (
"\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}",
"\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}",
"\x{121b}\x{122d}\x{127d}",
"\x{12a4}\x{1355}\x{1228}\x{120d}",
"\x{121c}\x{12ed}",
"\x{1301}\x{1295}",
"\x{1301}\x{120b}\x{12ed}",
"\x{12a6}\x{1308}\x{1235}\x{1275}",
"\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}",
"\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}",
"\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}",
"\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = ( "\x{1320}\x{12cb}\x{1275}", "\x{12a8}\x{1230}\x{12d3}\x{1275}" );
@Dsuf = ("\x{129b}" x 31);
}
else {
@DoW = (
"እሑድ",
"ሰኞ",
"ማክሰኞ",
"ረቡዕ",
"ሐሙስ",
"ዓርብ",
"ቅዳሜ"
);
@MoY = (
"ጃንዩወሪ",
"ፌብሩወሪ",
"ማርች",
"ኤፕረል",
"ሜይ",
"ጁን",
"ጁላይ",
"ኦገስት",
"ሴፕቴምበር",
"ኦክተውበር",
"ኖቬምበር",
"ዲሴምበር"
);
@DoWs = map { substr($_,0,9) } @DoW;
@MoYs = map { substr($_,0,9) } @MoY;
@AMPM = ( "ጠዋት", "ከሰዓት" );
@Dsuf = ("ኛ" x 31);
}
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Amharic - Amharic localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

61
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Arabic.pm Normal file
View file

@ -0,0 +1,61 @@
package Date::Language::Arabic;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Arabic localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = qw(الأحد الاثنين الثلاثاء الأربعاء الخميس الجمعة السبت);
@MoY = qw(يناير فبراير مسيرة أبريل مايو يونيو يوليو أغسطس سبتمبر أكتوبر نوفمبر ديسمبر);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
$MoYs[6] = 'يوليو';
@AMPM = qw(صباحا مساءا);
@Dsuf = ((qw(er e e e e e e e e e)) x 3, 'er'); #To be amended
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Arabic - Arabic localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

78
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Austrian.pm Normal file
View file

@ -0,0 +1,78 @@
##
## Austrian tables
##
package Date::Language::Austrian;
use strict;
use warnings;
use utf8;
use Date::Language ();
use Date::Language::English ();
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Austrian localization for Date::Format
use base 'Date::Language';
our @MoY = qw(Jänner Feber März April Mai Juni
Juli August September Oktober November Dezember);
our @MoYs = qw(Jän Feb Mär Apr Mai Jun Jul Aug Sep Oct Nov Dez);
our @DoW = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
our @DoWs = qw(So Mo Di Mi Do Fr Sa);
our @AMPM = @{Date::Language::English::AMPM};
our @Dsuf = @{Date::Language::English::Dsuf};
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Timezone abbreviation translations (English → German, same as German locale)
our %TZ = (
'CET' => 'MEZ', # Mitteleuropäische Zeit
'CEST' => 'MESZ', # Mitteleuropäische Sommerzeit
'WET' => 'WEZ', # Westeuropäische Zeit
'WEST' => 'WESZ', # Westeuropäische Sommerzeit
'EET' => 'OEZ', # Osteuropäische Zeit
'EEST' => 'OESZ', # Osteuropäische Sommerzeit
);
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Austrian - Austrian localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

66
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Brazilian.pm Normal file
View file

@ -0,0 +1,66 @@
##
## Brazilian tables, contributed by Christian Tosta (tosta@cce.ufmg.br)
##
package Date::Language::Brazilian;
use strict;
use warnings;
use utf8;
use Date::Language ();
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Brazilian localization for Date::Format
use base 'Date::Language';
our @DoW = qw(Domingo Segunda Terça Quarta Quinta Sexta Sábado);
our @MoY = qw(Janeiro Fevereiro Março Abril Maio Junho
Julho Agosto Setembro Outubro Novembro Dezembro);
our @DoWs = map { substr($_,0,3) } @DoW;
our @MoYs = map { substr($_,0,3) } @MoY;
our @AMPM = qw(AM PM);
our @Dsuf = (qw(mo ro do ro to to to mo vo no)) x 3;
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Brazilian - Brazilian localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

113
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Bulgarian.pm Normal file
View file

@ -0,0 +1,113 @@
##
## Bulgarian tables contributed by Krasimir Berov
##
package Date::Language::Bulgarian;
use strict;
use warnings;
use utf8;
use base qw(Date::Language);
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Bulgarian localization for Date::Format
@DoW = qw(неделя понеделник вторник сряда четвъртък петък събота);
@MoY = qw(януари февруари март април май юни
юли август септември октомври ноември декември);
@DoWs = qw(нд пн вт ср чт пт сб);
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = (qw(ти ви ри ти ти ти ти ми ми ти)) x 3;
@Dsuf[11,12,13] = qw(ти ти ти);
@Dsuf[30,31] = qw(ти ви);
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { ($_[0]->[3]<10?' ':'').$_[0]->[3].$Dsuf[$_[0]->[3]] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Bulgarian - Bulgarian localization for Date::Format
=head1 VERSION
version 2.35
=head1 SYNOPSIS
use strict;
use warnings;
use Date::Language;
local $\=$/;
my $template ='%a %b %e %T %Y (%Y-%m-%d %H:%M:%S)';
my $time=1290883821; #or just use time();
my @lt = localtime($time);
my %languages = qw(English GMT German EEST Bulgarian EET);
binmode(select,':utf8');
foreach my $l(keys %languages){
my $lang = Date::Language->new($l);
my $zone = $languages{$l};
print $/. "$l $zone";
print $lang->time2str($template, $time);
print $lang->time2str($template, $time, $zone);
print $lang->strftime($template, \@lt);
}
=head1 DESCRIPTION
This is Bulgarian localization for Date::Format.
It is important to note that this module source code is in utf8.
All strings which it outputs are in utf8, so it is safe to use it
currently only with English. You are left alone to try and convert
the output when using different Date::Language::* in the same application.
This should be addresed in the future.
=head1 NAME
Date::Language::Bulgarian - localization for Date::Format
=head1 AUTHOR
Krasimir Berov (berov@cpan.org)
=head1 COPYRIGHT
Copyright (c) 2010 Krasimir Berov. This program is free
software; you can redistribute it and/or modify it under the same terms
as Perl itself.
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

67
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Chinese.pm Normal file
View file

@ -0,0 +1,67 @@
##
## English tables
##
package Date::Language::Chinese;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base qw(Date::Language);
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Chinese localization for Date::Format
our @DoW = qw(星期日 星期一 星期二 星期三 星期四 星期五 星期六);
our @MoY = qw(一月 二月 三月 四月 五月 六月
七月 八月 九月 十月 十一月 十二月);
our @DoWs = map { $_ } @DoW;
our @MoYs = map { $_ } @MoY;
our @AMPM = qw(上午 下午);
our @Dsuf = (qw(日 日 日 日 日 日 日 日 日 日)) x 3;
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2d%s",$_[0]->[3],"日") }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Chinese - Chinese localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

94
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Chinese_GB.pm Normal file
View file

@ -0,0 +1,94 @@
##
## Chinese GB2312 tables (GB2312 byte encoding)
##
package Date::Language::Chinese_GB;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Chinese localization for Date::Format (GB2312)
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = (
"\xd0\xc7\xc6\xda\xc8\xd5", # 星期日
"\xd0\xc7\xc6\xda\xd2\xbb", # 星期一
"\xd0\xc7\xc6\xda\xb6\xfe", # 星期二
"\xd0\xc7\xc6\xda\xc8\xfd", # 星期三
"\xd0\xc7\xc6\xda\xcb\xc4", # 星期四
"\xd0\xc7\xc6\xda\xce\xe5", # 星期五
"\xd0\xc7\xc6\xda\xc1\xf9", # 星期六
);
@MoY = (
"\xd2\xbb\xd4\xc2", # 一月
"\xb6\xfe\xd4\xc2", # 二月
"\xc8\xfd\xd4\xc2", # 三月
"\xcb\xc4\xd4\xc2", # 四月
"\xce\xe5\xd4\xc2", # 五月
"\xc1\xf9\xd4\xc2", # 六月
"\xc6\xdf\xd4\xc2", # 七月
"\xb0\xcb\xd4\xc2", # 八月
"\xbe\xc5\xd4\xc2", # 九月
"\xca\xae\xd4\xc2", # 十月
"\xca\xae\xd2\xbb\xd4\xc2", # 十一月
"\xca\xae\xb6\xfe\xd4\xc2", # 十二月
);
@DoWs = map { $_ } @DoW;
@MoYs = map { $_ } @MoY;
@AMPM = (
"\xc9\xcf\xce\xe7", # 上午
"\xcf\xc2\xce\xe7", # 下午
);
@Dsuf = ("\xc8\xd5") x 31; # 日
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2d%s",$_[0]->[3],"\xc8\xd5") } # 日
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Chinese_GB - Chinese localization for Date::Format (GB2312)
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

89
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Czech.pm Normal file
View file

@ -0,0 +1,89 @@
##
## Czech tables
##
## Contributed by Honza Pazdziora
package Date::Language::Czech;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Czech localization for Date::Format
our @MoY = qw(leden únor bøezen duben kvìten èerven èervenec srpen záøí
øíjen listopad prosinec);
our @MoYs = qw(led únor bøe dub kvì èvn èec srp záøí øíj lis pro);
our @MoY2 = @MoY;
for (@MoY2)
{ s!en$!na! or s!ec$!ce! or s!ad$!adu! or s!or$!ora!; }
our @DoW = qw(nedìle pondìlí úterý støeda ètvrtek pátek sobota);
our @DoWs = qw(Ne Po Út St Èt Pá So);
our @AMPM = qw(dop. odp.);
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_d { $_[0]->[3] }
sub format_m { $_[0]->[4] + 1 }
sub format_o { $_[0]->[3] . '.' }
sub format_Q { $MoY2[$_[0]->[4]] }
sub time2str {
my $ref = shift;
my @a = @_;
$a[0] =~ s/(%[do]\.?\s?)%B/$1%Q/;
$ref->SUPER::time2str(@a);
}
sub strftime {
my $ref = shift;
my @a = @_;
$a[0] =~ s/(%[do]\.?\s?)%B/$1%Q/;
$ref->SUPER::time2str(@a);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Czech - Czech localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

67
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Danish.pm Normal file
View file

@ -0,0 +1,67 @@
##
## Danish tables
##
package Date::Language::Danish;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base 'Date::Language';
use Date::Language::English ();
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Danish localization for Date::Format
our @MoY = qw(Januar Februar Marts April Maj Juni
Juli August September Oktober November December);
our @MoYs = qw(Jan Feb Mar Apr Maj Jun Jul Aug Sep Okt Nov Dec);
our @DoW = qw(Søndag Mandag Tirsdag Onsdag Torsdag Fredag Lørdag);
our @DoWs = qw(Søn Man Tir Ons Tor Fre Lør);
our @AMPM = @{Date::Language::English::AMPM};
our @Dsuf = @{Date::Language::English::Dsuf};
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Danish - Danish localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

69
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Dutch.pm Normal file
View file

@ -0,0 +1,69 @@
##
## Dutch tables
## Contributed by Johannes la Poutre <jlpoutre@corp.nl.home.com>
##
package Date::Language::Dutch;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Dutch localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@MoY = qw(januari februari maart april mei juni juli
augustus september oktober november december);
@MoYs = map(substr($_, 0, 3), @MoY);
$MoYs[2] = 'mrt'; # mrt is more common (Frank Maas)
@DoW = map($_ . "dag", qw(zon maan dins woens donder vrij zater));
@DoWs = map(substr($_, 0, 2), @DoW);
# these aren't normally used...
@AMPM = qw(VM NM);
@Dsuf = ('e') x 31;
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2de",$_[0]->[3]) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Dutch - Dutch localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

66
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/English.pm Normal file
View file

@ -0,0 +1,66 @@
##
## English tables
##
package Date::Language::English;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: English localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
@MoY = qw(January February March April May June
July August September October November December);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::English - English localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

74
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Finnish.pm Normal file
View file

@ -0,0 +1,74 @@
##
## Finnish tables
## Contributed by Matthew Musgrove <muskrat@mindless.com>
## Corrected by roke
##
package Date::Language::Finnish;
use strict;
use warnings;
use utf8;
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Finnish localization for Date::Format
use Date::Language ();
# In Finnish, the names of the months and days are only capitalized at the beginning of sentences.
our @MoY = map($_ . "kuu", qw(tammi helmi maalis huhti touko kesä heinä elo syys loka marras joulu));
our @DoW = qw(sunnuntai maanantai tiistai keskiviikko torstai perjantai lauantai);
# it is not customary to use abbreviated names of months or days
# per Graham's suggestion:
our @MoYs = @MoY;
our @DoWs = @DoW;
# the short form of ordinals
our @Dsuf = ('.') x 31;
# doesn't look like this is normally used...
our @AMPM = qw(ap ip);
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2de",$_[0]->[3]) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Finnish - Finnish localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

67
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/French.pm Normal file
View file

@ -0,0 +1,67 @@
##
## French tables, contributed by Emmanuel Bataille (bem@residents.frmug.org)
##
package Date::Language::French;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: French localization for Date::Format
our @DoW = qw(dimanche lundi mardi mercredi jeudi vendredi samedi);
our @MoY = qw(janvier février mars avril mai juin
juillet août septembre octobre novembre décembre);
our @DoWs = map { substr($_,0,3) } @DoW;
our @MoYs = map { substr($_,0,3) } @MoY;
$MoYs[6] = 'jul';
our @AMPM = qw(AM PM);
our @Dsuf = ('e', 'er', ('e') x 30);
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2d%s",$_[0]->[3],$Dsuf[$_[0]->[3]]) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::French - French localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

81
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Gedeo.pm Normal file
View file

@ -0,0 +1,81 @@
##
## Gedeo tables
##
package Date::Language::Gedeo;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Gedeo localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = qw( Sanbbattaa Sanno Masano Roobe Hamusse Arbe Qiddamme);
@MoY = (
"Oritto",
"Birre'a",
"Onkkollessa",
"Saddasa",
"Arrasa",
"Qammo",
"Ella",
"Waacibajje",
"Canissa",
"Addolessa",
"Bittitotessa",
"Hegeya"
);
@DoWs = map { substr($_,0,3) } @DoW;
$DoWs[0] = "Snb";
$DoWs[1] = "Sno";
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(gorsa warreti-udumma);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Gedeo - Gedeo localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

77
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/German.pm Normal file
View file

@ -0,0 +1,77 @@
##
## German tables
##
package Date::Language::German;
use strict;
use warnings;
use utf8;
use Date::Language::English ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: German localization for Date::Format
our @MoY = qw(Januar Februar März April Mai Juni
Juli August September Oktober November Dezember);
our @MoYs = qw(Jan Feb Mär Apr Mai Jun Jul Aug Sep Okt Nov Dez);
our @DoW = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
our @DoWs = qw(So Mo Di Mi Do Fr Sa);
our @AMPM = @{Date::Language::English::AMPM};
our @Dsuf = @{Date::Language::English::Dsuf};
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Timezone abbreviation translations (English → German)
our %TZ = (
'CET' => 'MEZ', # Mitteleuropäische Zeit
'CEST' => 'MESZ', # Mitteleuropäische Sommerzeit
'WET' => 'WEZ', # Westeuropäische Zeit
'WEST' => 'WESZ', # Westeuropäische Sommerzeit
'EET' => 'OEZ', # Osteuropäische Zeit
'EEST' => 'OESZ', # Osteuropäische Sommerzeit
);
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2d.",$_[0]->[3]) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::German - German localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

119
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Greek.pm Normal file
View file

@ -0,0 +1,119 @@
##
## Greek tables
##
## Traditional date format is: DoW DD{eta} MoY Year (%A %o %B %Y)
##
## Matthew Musgrove <muskrat@mindless.com>
## Translations graciously provided by Menelaos Stamatelos <men@kwsn.net>
## This module returns unicode (utf8) encoded characters. You will need to
## take the necessary steps for this to display correctly.
##
package Date::Language::Greek;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Greek localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = (
"Κυριακή",
"Δευτέρα",
"Τρίτη",
"Τετάρτη",
"Πέμπτη",
"Παρασκευή",
"Σάββατο",
);
@MoY = (
"Ιανουαρίου",
"Φεβρουαρίου",
"Μαρτίου",
"Απριλίου",
"Μαΐου",
"Ιουνίου",
"Ιουλίου",
"Αυγούστου",
"Σεπτεμτου",
"Οκτωβρίου",
"Νοεμβρίου",
"Δεκεμβρίου",
);
@DoWs = (
"Κυ",
"Δε",
"Τρ",
"Τε",
"Πε",
"Πα",
"Σα",
);
@MoYs = (
"Ιαν",
"Φε",
"Μαρ",
"Απρ",
"Μα",
"Ιουν",
"Ιουλ",
"Αυγ",
"Σεπ",
"Οκ",
"Νο",
"Δε",
);
@AMPM = ("πμ", "μμ");
@Dsuf = ("η" x 31);
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_o { sprintf("%2d%s",$_[0]->[3],"η") }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Greek - Greek localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

116
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Hungarian.pm Normal file
View file

@ -0,0 +1,116 @@
##
## Hungarian tables based on English
##
#
# This is a just-because-I-stumbled-across-it
# -and-my-wife-is-Hungarian release: if Graham or
# someone adds to docs to Date::Format, I'd be
# glad to correct bugs and extend as needed.
#
package Date::Language::Hungarian;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Hungarian localization for Date::Format
our @DoW = qw(Vasárnap Hétfő Kedd Szerda Csütörtök Péntek Szombat);
our @MoY = qw(Január Február Március Április Május Június
Július Augusztus Szeptember Október November December);
our @DoWs = map { substr($_,0,3) } @DoW;
our @MoYs = map { substr($_,0,3) } @MoY;
our @AMPM = qw(DE. DU.);
# There is no 'th or 'nd in Hungarian, just a dot
our @Dsuf = (".") x 31;
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_P { lc($_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0]) }
sub format_o { $_[0]->[3].'.' }
sub format_D { &format_y . "." . &format_m . "." . &format_d }
sub format_y { sprintf("%02d",$_[0]->[5] % 100) }
sub format_d { sprintf("%02d",$_[0]->[3]) }
sub format_m { sprintf("%02d",$_[0]->[4] + 1) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Hungarian - Hungarian localization for Date::Format
=head1 VERSION
version 2.35
=head1 SYNOPSIS
my $lang = Date::Language->new('Hungarian');
print $lang->time2str("%a %b %e %T %Y", time);
my @lt = localtime(time);
my $template = "%a %b %e %T %Y";
print $lang->time2str($template, time);
print $lang->strftime($template, @lt);
my $zone = "EST";
print $lang->time2str($template, time, $zone);
print $lang->strftime($template, @lt, $zone);
print $lang->ctime(time);
print $lang->asctime(@lt);
print $lang->ctime(time, $zone);
print $lang->asctime(@lt, $zone);
See L<Date::Format>.
=head1 NAME
Date::Language::Hungarian - Magyar format for Date::Format
=head1 AUTHOR
Paula Goddard (paula -at- paulacska -dot- com)
=head1 LICENCE
Made available under the same terms as Perl itself.
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

67
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Icelandic.pm Normal file
View file

@ -0,0 +1,67 @@
##
## Icelandic tables
##
package Date::Language::Icelandic;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base 'Date::Language';
use Date::Language::English ();
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Icelandic localization for Date::Format
our @MoY = qw(Janúar Febrúar Mars Apríl Maí Júni
Júli Ágúst September Október Nóvember Desember);
our @MoYs = qw(Jan Feb Mar Apr Maí Jún Júl Ágú Sep Okt Nóv Des);
our @DoW = qw(Sunnudagur Mánudagur Þriðjudagur Miðvikudagur Fimmtudagur Föstudagur Laugardagur);
our @DoWs = qw(Sun Mán Þri Mið Fim Fös Lau);
our @AMPM = @{Date::Language::English::AMPM};
our @Dsuf = @{Date::Language::English::Dsuf};
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Icelandic - Icelandic localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

65
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Italian.pm Normal file
View file

@ -0,0 +1,65 @@
##
## Italian tables
##
package Date::Language::Italian;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Italian localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@MoY = qw(Gennaio Febbraio Marzo Aprile Maggio Giugno
Luglio Agosto Settembre Ottobre Novembre Dicembre);
@MoYs = qw(Gen Feb Mar Apr Mag Giu Lug Ago Set Ott Nov Dic);
@DoW = qw(Domenica Lunedi Martedi Mercoledi Giovedi Venerdi Sabato);
@DoWs = qw(Dom Lun Mar Mer Gio Ven Sab);
use Date::Language::English ();
@AMPM = @{Date::Language::English::AMPM};
@Dsuf = @{Date::Language::English::Dsuf};
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Italian - Italian localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

66
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Norwegian.pm Normal file
View file

@ -0,0 +1,66 @@
##
## Norwegian tables
##
package Date::Language::Norwegian;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base 'Date::Language';
use Date::Language::English ();
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Norwegian localization for Date::Format
our @MoY = qw(Januar Februar Mars April Mai Juni
Juli August September Oktober November Desember);
our @MoYs = qw(Jan Feb Mar Apr Mai Jun Jul Aug Sep Okt Nov Des);
our @DoW = qw(Søndag Mandag Tirsdag Onsdag Torsdag Fredag Lørdag);
our @DoWs = qw(Søn Man Tir Ons Tor Fre Lør);
our @AMPM = @{Date::Language::English::AMPM};
our @Dsuf = @{Date::Language::English::Dsuf};
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Norwegian - Norwegian localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

65
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Occitan.pm Normal file
View file

@ -0,0 +1,65 @@
##
## Occitan tables, contributed by Quentn PAGÈS
##
package Date::Language::Occitan;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Occitan localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = qw(dimenge diluns dimars dimècres dijòus divendres dissabte);
@MoY = qw(genièr febrièr març abrial mai junh
julhet agost setembre octòbre novembre decembre);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
$MoYs[6] = 'jul';
@AMPM = qw(AM PM);
@Dsuf = ((qw(er e e e e e e e e e)) x 3, 'er');
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Occitan - Occitan localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

67
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Oromo.pm Normal file
View file

@ -0,0 +1,67 @@
##
## Oromo tables
##
package Date::Language::Oromo;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Oromo localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = qw(Dilbata Wiixata Qibxata Roobii Kamiisa Jimaata Sanbata);
@MoY = qw(Amajjii Guraandhala Bitooteessa Elba Caamsa Waxabajjii
Adooleessa Hagayya Fuulbana Onkololeessa Sadaasa Muddee);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(WD WB);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Oromo - Oromo localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

67
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Portuguese.pm Normal file
View file

@ -0,0 +1,67 @@
##
## Portuguese tables
##
package Date::Language::Portuguese;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Portuguese localization for Date::Format
our @DoW = qw(domingo segunda-feira terça-feira quarta-feira quinta-feira sexta-feira sábado);
our @MoY = qw(janeiro fevereiro março abril maio junho
julho agosto setembro outubro novembro dezembro);
our @DoWs = map { substr($_,0,3) } @DoW;
our @MoYs = map { substr($_,0,3) } @MoY;
our @AMPM = qw(AM PM);
our @Dsuf = ('º') x 32;
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_o { sprintf("%2d%s",$_[0]->[3],$Dsuf[$_[0]->[3]]) }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Portuguese - Portuguese localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

67
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Romanian.pm Normal file
View file

@ -0,0 +1,67 @@
##
## Italian tables
##
package Date::Language::Romanian;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Romanian localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@MoY = qw(ianuarie februarie martie aprilie mai iunie
iulie august septembrie octombrie noembrie decembrie);
@DoW = qw(duminica luni marti miercuri joi vineri sambata);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = ('') x 31;
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Romanian - Romanian localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

151
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Russian.pm Normal file
View file

@ -0,0 +1,151 @@
##
## Russian tables (KOI8-R byte encoding)
##
## Contributed by Danil Pismenny <dapi@mail.ru>
package Date::Language::Russian;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Russian localization for Date::Format (KOI8-R)
our (@DoW, @DoWs, @MoY, @MoYs, @MoY2, @DoWs2, @AMPM, @Dsuf, %MoY, %DoW);
@MoY = (
"\xf1\xce\xd7\xc1\xd2\xd1", # Января
"\xe6\xc5\xd7\xd2\xc1\xcc\xd1", # Февраля
"\xed\xc1\xd2\xd4\xc1", # Марта
"\xe1\xd0\xd2\xc5\xcc\xd1", # Апреля
"\xed\xc1\xd1", # Мая
"\xe9\xc0\xce\xd1", # Июня
"\xe9\xc0\xcc\xd1", # Июля
"\xe1\xd7\xc7\xd5\xd3\xd4\xc1", # Августа
"\xf3\xc5\xce\xd4\xd1\xc2\xd2\xd1", # Сентября
"\xef\xcb\xd4\xd1\xc2\xd2\xd1", # Октября
"\xee\xcf\xd1\xc2\xd2\xd1", # Ноября
"\xe4\xc5\xcb\xc1\xc2\xd2\xd1", # Декабря
);
@MoY2 = (
"\xf1\xce\xd7\xc1\xd2\xd8", # Январь
"\xe6\xc5\xd7\xd2\xc1\xcc\xd8", # Февраль
"\xed\xc1\xd2\xd4", # Март
"\xe1\xd0\xd2\xc5\xcc\xd8", # Апрель
"\xed\xc1\xca", # Май
"\xe9\xc0\xce\xd8", # Июнь
"\xe9\xc0\xcc\xd8", # Июль
"\xe1\xd7\xc7\xd5\xd3\xd4", # Август
"\xf3\xc5\xce\xd4\xd1\xc2\xd2\xd8", # Сентябрь
"\xef\xcb\xd4\xd1\xc2\xd2\xd8", # Октябрь
"\xee\xcf\xd1\xc2\xd2\xd8", # Ноябрь
"\xe4\xc5\xcb\xc1\xc2\xd2\xd8", # Декабрь
);
@MoYs = (
"\xf1\xce\xd7", # Янв
"\xe6\xc5\xd7", # Фев
"\xed\xd2\xd4", # Мрт
"\xe1\xd0\xd2", # Апр
"\xed\xc1\xca", # Май
"\xe9\xc0\xce", # Июн
"\xe9\xc0\xcc", # Июл
"\xe1\xd7\xc7", # Авг
"\xf3\xc5\xce", # Сен
"\xef\xcb\xd4", # Окт
"\xee\xcf\xd1", # Ноя
"\xe4\xc5\xcb", # Дек
);
@DoW = (
"\xf0\xcf\xce\xc5\xc4\xc5\xcc\xd8\xce\xc9\xcb", # Понедельник
"\xf7\xd4\xcf\xd2\xce\xc9\xcb", # Вторник
"\xf3\xd2\xc5\xc4\xc1", # Среда
"\xfe\xc5\xd4\xd7\xc5\xd2\xc7", # Четверг
"\xf0\xd1\xd4\xce\xc9\xc3\xc1", # Пятница
"\xf3\xd5\xc2\xc2\xcf\xd4\xc1", # Суббота
"\xf7\xcf\xd3\xcb\xd2\xc5\xd3\xc5\xce\xd8\xc5", # Воскресенье
);
@DoWs = (
"\xf0\xce", # Пн
"\xf7\xd4", # Вт
"\xf3\xd2", # Ср
"\xfe\xd4", # Чт
"\xf0\xd4", # Пт
"\xf3\xc2", # Сб
"\xf7\xd3", # Вс
);
@DoWs2 = (
"\xf0\xce\xc4", # Пнд
"\xf7\xd4\xd2", # Втр
"\xf3\xd2\xc4", # Срд
"\xfe\xd4\xd7", # Чтв
"\xf0\xd4\xce", # Птн
"\xf3\xc2\xd4", # Сбт
"\xf7\xd3\xcb", # Вск
);
@AMPM = (
"\xc4\xd0", # дп
"\xd0\xd0", # пп
);
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_d { $_[0]->[3] }
sub format_m { $_[0]->[4] + 1 }
sub format_o { $_[0]->[3] . '.' }
sub format_Q { $MoY2[$_[0]->[4]] }
sub str2time {
my ($self,$value) = @_;
map {$value=~s/(\s|^)$DoWs2[$_](\s)/$DoWs[$_]$2/ig} (0..6);
$value=~s/(\s+|^)\xed\xc1\xd2(\s+)/$1\xed\xd2\xd4$2/;
return $self->SUPER::str2time($value);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Russian - Russian localization for Date::Format (KOI8-R)
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

98
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Russian_cp1251.pm Normal file
View file

@ -0,0 +1,98 @@
##
## Russian cp1251 (CP1251 byte encoding)
##
package Date::Language::Russian_cp1251;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Russian localization for Date::Format (CP1251)
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = (
"\xc2\xee\xf1\xea\xf0\xe5\xf1\xe5\xed\xfc\xe5", # Воскресенье
"\xcf\xee\xed\xe5\xe4\xe5\xeb\xfc\xed\xe8\xea", # Понедельник
"\xc2\xf2\xee\xf0\xed\xe8\xea", # Вторник
"\xd1\xf0\xe5\xe4\xe0", # Среда
"\xd7\xe5\xf2\xe2\xe5\xf0\xe3", # Четверг
"\xcf\xff\xf2\xed\xe8\xf6\xe0", # Пятница
"\xd1\xf3\xe1\xe1\xee\xf2\xe0", # Суббота
);
@MoY = (
"\xdf\xed\xe2\xe0\xf0\xfc", # Январь
"\xd4\xe5\xe2\xf0\xe0\xeb\xfc", # Февраль
"\xcc\xe0\xf0\xf2", # Март
"\xc0\xef\xf0\xe5\xeb\xfc", # Апрель
"\xcc\xe0\xe9", # Май
"\xc8\xfe\xed\xfc", # Июнь
"\xc8\xfe\xeb\xfc", # Июль
"\xc0\xe2\xe3\xf3\xf1\xf2", # Август
"\xd1\xe5\xed\xf2\xff\xe1\xf0\xfc", # Сентябрь
"\xce\xea\xf2\xff\xe1\xf0\xfc", # Октябрь
"\xcd\xee\xff\xe1\xf0\xfc", # Ноябрь
"\xc4\xe5\xea\xe0\xe1\xf0\xfc", # Декабрь
);
@DoWs = (
"\xc2\xf1\xea", # Вск
"\xcf\xed\xe4", # Пнд
"\xc2\xf2\xf0", # Втр
"\xd1\xf0\xe4", # Срд
"\xd7\xf2\xe2", # Чтв
"\xcf\xf2\xed", # Птн
"\xd1\xe1\xf2", # Сбт
);
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = ('e') x 31;
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2de",$_[0]->[3]) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Russian_cp1251 - Russian localization for Date::Format (CP1251)
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

98
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Russian_koi8r.pm Normal file
View file

@ -0,0 +1,98 @@
##
## Russian koi8r (KOI8-R byte encoding)
##
package Date::Language::Russian_koi8r;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Russian localization for Date::Format (KOI8-R variant)
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = (
"\xf7\xcf\xd3\xcb\xd2\xc5\xd3\xc5\xce\xd8\xc5", # Воскресенье
"\xf0\xcf\xce\xc5\xc4\xc5\xcc\xd8\xce\xc9\xcb", # Понедельник
"\xf7\xd4\xcf\xd2\xce\xc9\xcb", # Вторник
"\xf3\xd2\xc5\xc4\xc1", # Среда
"\xfe\xc5\xd4\xd7\xc5\xd2\xc7", # Четверг
"\xf0\xd1\xd4\xce\xc9\xc3\xc1", # Пятница
"\xf3\xd5\xc2\xc2\xcf\xd4\xc1", # Суббота
);
@MoY = (
"\xf1\xce\xd7\xc1\xd2\xd8", # Январь
"\xe6\xc5\xd7\xd2\xc1\xcc\xd8", # Февраль
"\xed\xc1\xd2\xd4", # Март
"\xe1\xd0\xd2\xc5\xcc\xd8", # Апрель
"\xed\xc1\xca", # Май
"\xe9\xc0\xce\xd8", # Июнь
"\xe9\xc0\xcc\xd8", # Июль
"\xe1\xd7\xc7\xd5\xd3\xd4", # Август
"\xf3\xc5\xce\xd4\xd1\xc2\xd2\xd8", # Сентябрь
"\xef\xcb\xd4\xd1\xc2\xd2\xd8", # Октябрь
"\xee\xcf\xd1\xc2\xd2\xd8", # Ноябрь
"\xe4\xc5\xcb\xc1\xc2\xd2\xd8", # Декабрь
);
@DoWs = (
"\xf7\xd3\xcb", # Вск
"\xf0\xce\xc4", # Пнд
"\xf7\xd4\xd2", # Втр
"\xf3\xd2\xc4", # Срд
"\xfe\xd4\xd7", # Чтв
"\xf0\xd4\xce", # Птн
"\xf3\xc2\xd4", # Сбт
);
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(AM PM);
@Dsuf = ('e') x 31;
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2de",$_[0]->[3]) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Russian_koi8r - Russian localization for Date::Format (KOI8-R variant)
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

67
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Sidama.pm Normal file
View file

@ -0,0 +1,67 @@
##
## Sidama tables
##
package Date::Language::Sidama;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Sidama localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = qw(Sambata Sanyo Maakisanyo Roowe Hamuse Arbe Qidaame);
@MoY = qw(January February March April May June
July August September October November December);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = qw(soodo hawwaro);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Sidama - Sidama localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

92
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Somali.pm Normal file
View file

@ -0,0 +1,92 @@
##
## Somali tables
##
package Date::Language::Somali;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Somali localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = qw(Axad Isniin Salaaso Arbaco Khamiis Jimco Sabti);
@MoY = (
"Bisha Koobaad",
"Bisha Labaad",
"Bisha Saddexaad",
"Bisha Afraad",
"Bisha Shanaad",
"Bisha Lixaad",
"Bisha Todobaad",
"Bisha Sideedaad",
"Bisha Sagaalaad",
"Bisha Tobnaad",
"Bisha Kow iyo Tobnaad",
"Bisha Laba iyo Tobnaad"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = (
"Kob",
"Lab",
"Sad",
"Afr",
"Sha",
"Lix",
"Tod",
"Sid",
"Sag",
"Tob",
"KIT",
"LIT"
);
@AMPM = qw(SN GN);
@Dsuf = (qw(th st nd rd th th th th th th)) x 3;
@Dsuf[11,12,13] = qw(th th th);
@Dsuf[30,31] = qw(th st);
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Somali - Somali localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

65
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Spanish.pm Normal file
View file

@ -0,0 +1,65 @@
##
## Spanish tables
##
package Date::Language::Spanish;
use strict;
use warnings;
use utf8;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Spanish localization for Date::Format
our @DoW = qw(domingo lunes martes miércoles jueves viernes sábado);
our @MoY = qw(enero febrero marzo abril mayo junio
julio agosto septiembre octubre noviembre diciembre);
our @DoWs = map { substr($_,0,3) } @DoW;
our @MoYs = map { substr($_,0,3) } @MoY;
our @AMPM = qw(AM PM);
our @Dsuf = ((qw(ro do ro to to to mo vo no mo)) x 3, 'ro');
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Spanish - Spanish localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

67
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Swedish.pm Normal file
View file

@ -0,0 +1,67 @@
##
## Swedish tables
## Contributed by Matthew Musgrove <muskrat@mindless.com>
## Corrected by dempa
##
package Date::Language::Swedish;
use strict;
use warnings;
use base 'Date::Language';
use Date::Language::English ();
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Swedish localization for Date::Format
our @MoY = qw(januari februari mars april maj juni juli augusti september oktober november december);
our @MoYs = map { substr($_,0,3) } @MoY;
our @DoW = map($_ . "dagen", qw(sön mån tis ons tors fre lör));
our @DoWs = map { substr($_,0,2) } @DoW;
# the ordinals are not typically used in modern times
our @Dsuf = ('a' x 2, 'e' x 29);
our @AMPM = @{Date::Language::English::AMPM};
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
sub format_o { sprintf("%2de",$_[0]->[3]) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Swedish - Swedish localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

88
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Tigrinya.pm Normal file
View file

@ -0,0 +1,88 @@
##
## Tigrinya tables
##
package Date::Language::Tigrinya;
use strict;
use warnings;
use Date::Language ();
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Tigrinya localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
@DoW = (
"\x{1230}\x{1295}\x{1260}\x{1275}",
"\x{1230}\x{1291}\x{12ed}",
"\x{1230}\x{1209}\x{1235}",
"\x{1228}\x{1261}\x{12d5}",
"\x{1213}\x{1219}\x{1235}",
"\x{12d3}\x{122d}\x{1262}",
"\x{1240}\x{12f3}\x{121d}"
);
@MoY = (
"\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}",
"\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}",
"\x{121b}\x{122d}\x{127d}",
"\x{12a4}\x{1355}\x{1228}\x{120d}",
"\x{121c}\x{12ed}",
"\x{1301}\x{1295}",
"\x{1301}\x{120b}\x{12ed}",
"\x{12a6}\x{1308}\x{1235}\x{1275}",
"\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}",
"\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}",
"\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}",
"\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = (
"\x{1295}/\x{1230}",
"\x{12F5}/\x{1230}"
);
@Dsuf = ("\x{12ed}" x 31);
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Tigrinya - Tigrinya localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

121
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/TigrinyaEritrean.pm Normal file
View file

@ -0,0 +1,121 @@
##
## Tigrinya-Eritrean tables
##
package Date::Language::TigrinyaEritrean;
use strict;
use warnings;
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: TigrinyaEritrean localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
if ( $] >= 5.006 ) {
@DoW = (
"\x{1230}\x{1295}\x{1260}\x{1275}",
"\x{1230}\x{1291}\x{12ed}",
"\x{1230}\x{1209}\x{1235}",
"\x{1228}\x{1261}\x{12d5}",
"\x{1213}\x{1219}\x{1235}",
"\x{12d3}\x{122d}\x{1262}",
"\x{1240}\x{12f3}\x{121d}"
);
@MoY = (
"\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}",
"\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}",
"\x{121b}\x{122d}\x{127d}",
"\x{12a4}\x{1355}\x{1228}\x{120d}",
"\x{121c}\x{12ed}",
"\x{1301}\x{1295}",
"\x{1301}\x{120b}\x{12ed}",
"\x{12a6}\x{1308}\x{1235}\x{1275}",
"\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}",
"\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}",
"\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}",
"\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = (
"\x{1295}/\x{1230}",
"\x{12F5}/\x{1230}"
);
@Dsuf = ("\x{12ed}" x 31);
}
else {
@DoW = (
"ሰንበት",
"ሰኑይ",
"ሰሉስ",
"ረቡዕ",
"ሓሙስ",
"ዓርቢ",
"ቀዳም"
);
@MoY = (
"ጥሪ",
"ለካቲት",
"መጋቢት",
"ሚያዝያ",
"ግንቦት",
"ሰነ",
"ሓምለ",
"ነሓሰ",
"መስከረም",
"ጥቅምቲ",
"ሕዳር",
"ታሕሳስ"
);
@DoWs = map { substr($_,0,9) } @DoW;
@MoYs = map { substr($_,0,9) } @MoY;
@AMPM = (
"ን/ሰ",
"ድ/ሰ"
);
@Dsuf = ("ይ" x 31);
}
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::TigrinyaEritrean - TigrinyaEritrean localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

123
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/TigrinyaEthiopian.pm Normal file
View file

@ -0,0 +1,123 @@
##
## Tigrinya-Ethiopian tables
##
package Date::Language::TigrinyaEthiopian;
use strict;
use warnings;
use Date::Language ();
use base qw(Date::Language);
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: TigrinyaEthiopian localization for Date::Format
our (@DoW, @DoWs, @MoY, @MoYs, @AMPM, @Dsuf, %MoY, %DoW);
if ( $] >= 5.006 ) {
@DoW = (
"\x{1230}\x{1295}\x{1260}\x{1275}",
"\x{1230}\x{1291}\x{12ed}",
"\x{1230}\x{1209}\x{1235}",
"\x{1228}\x{1261}\x{12d5}",
"\x{1213}\x{1219}\x{1235}",
"\x{12d3}\x{122d}\x{1262}",
"\x{1240}\x{12f3}\x{121d}"
);
@MoY = (
"\x{1303}\x{1295}\x{12e9}\x{12c8}\x{122a}",
"\x{134c}\x{1265}\x{1229}\x{12c8}\x{122a}",
"\x{121b}\x{122d}\x{127d}",
"\x{12a4}\x{1355}\x{1228}\x{120d}",
"\x{121c}\x{12ed}",
"\x{1301}\x{1295}",
"\x{1301}\x{120b}\x{12ed}",
"\x{12a6}\x{1308}\x{1235}\x{1275}",
"\x{1234}\x{1355}\x{1274}\x{121d}\x{1260}\x{122d}",
"\x{12a6}\x{12ad}\x{1270}\x{12cd}\x{1260}\x{122d}",
"\x{1296}\x{126c}\x{121d}\x{1260}\x{122d}",
"\x{12f2}\x{1234}\x{121d}\x{1260}\x{122d}"
);
@DoWs = map { substr($_,0,3) } @DoW;
@MoYs = map { substr($_,0,3) } @MoY;
@AMPM = (
"\x{1295}/\x{1230}",
"\x{12F5}/\x{1230}"
);
@Dsuf = ("\x{12ed}" x 31);
}
else {
@DoW = (
"ሰንበት",
"ሰኑይ",
"ሰሉስ",
"ረቡዕ",
"ሓሙስ",
"ዓርቢ",
"ቀዳም"
);
@MoY = (
"ጃንዩወሪ",
"ፌብሩወሪ",
"ማርች",
"ኤፕረል",
"ሜይ",
"ጁን",
"ጁላይ",
"ኦገስት",
"ሴፕቴምበር",
"ኦክተውበር",
"ኖቬምበር",
"ዲሴምበር"
);
@DoWs = map { substr($_,0,9) } @DoW;
@MoYs = map { substr($_,0,9) } @MoY;
@AMPM = (
"ን/ሰ",
"ድ/ሰ"
);
@Dsuf = ("ይ" x 31);
}
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[$_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[$_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::TigrinyaEthiopian - TigrinyaEthiopian localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

87
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Language/Turkish.pm Normal file
View file

@ -0,0 +1,87 @@
#----------------------------------------------------#
#
# Turkish tables
# Burak Gürsoy <burak@cpan.org>
# Last modified: Sat Nov 15 20:28:32 2003
#
# use Date::Language;
# my $turkish = Date::Language->new('Turkish');
# print $turkish->time2str("%e %b %Y, %a %T\n", time);
# print $turkish->str2time("25 Haz 1996 21:09:55 +0100");
#----------------------------------------------------#
package Date::Language::Turkish;
use strict;
use warnings;
use utf8;
use base 'Date::Language';
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Turkish localization for Date::Format
our @DoW = qw(Pazar Pazartesi Salı Çarşamba Perşembe Cuma Cumartesi);
our @MoY = qw(Ocak Şubat Mart Nisan Mayıs Haziran Temmuz Ağustos Eylül Ekim Kasım Aralık);
our @DoWs = map { substr($_,0,3) } @DoW;
$DoWs[1] = 'Pzt'; # Since we'll get two 'Paz' s
$DoWs[-1] = 'Cmt'; # Since we'll get two 'Cum' s
our @MoYs = map { substr($_,0,3) } @MoY;
our @AMPM = ('',''); # no am-pm thingy
# not easy as in english... maybe we can just use a dot "." ? :)
our %DsufMAP = (
(map {$_ => 'inci', $_+10 => 'inci', $_+20 => 'inci' } 1,2,5,8 ),
(map {$_ => 'nci', $_+10 => 'nci', $_+20 => 'nci' } 7 ),
(map {$_ => 'nci', $_+10 => 'nci', $_+20 => 'nci' } 2 ),
(map {$_ => 'üncü', $_+10 => 'üncü', $_+20 => 'üncü' } 3,4 ),
(map {$_ => 'uncu', $_+10 => 'uncu', $_+20 => 'uncu' } 9 ),
(map {$_ => 'ncı', $_+10 => 'ncı', $_+20 => 'ncı' } 6 ),
(map {$_ => 'uncu', } 10,30 ),
20 => 'nci',
31 => 'inci',
);
our @Dsuf = map{ $DsufMAP{$_} } sort {$a <=> $b} keys %DsufMAP;
our ( %MoY, %DoW );
Date::Language::_build_lookups();
# Formatting routines
sub format_a { $DoWs[$_[0]->[6]] }
sub format_A { $DoW[ $_[0]->[6]] }
sub format_b { $MoYs[$_[0]->[4]] }
sub format_B { $MoY[ $_[0]->[4]] }
sub format_h { $MoYs[$_[0]->[4]] }
sub format_p { '' } # disable
sub format_P { '' } # disable
sub format_o { sprintf("%2d%s",$_[0]->[3],$Dsuf[$_[0]->[3]-1]) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Language::Turkish - Turkish localization for Date::Format
=head1 VERSION
version 2.35
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

477
OGP64/usr/share/perl5/vendor_perl/5.40/Date/Parse.pm Normal file
View file

@ -0,0 +1,477 @@
# Copyright (c) 1995-2009 Graham Barr. This program is free
# software; you can redistribute it and/or modify it under the same terms
# as Perl itself.
package Date::Parse;
require 5.000;
use strict;
use Time::Local;
use Carp;
use Time::Zone;
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(&strtotime &str2time &strptime);
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Parse date strings into time values
my %month = (
january => 0,
february => 1,
march => 2,
april => 3,
may => 4,
june => 5,
july => 6,
august => 7,
september => 8,
sept => 8,
october => 9,
november => 10,
december => 11,
);
my %day = (
sunday => 0,
monday => 1,
tuesday => 2,
tues => 2,
wednesday => 3,
wednes => 3,
thursday => 4,
thur => 4,
thurs => 4,
friday => 5,
saturday => 6,
);
my @suf = (qw(th st nd rd th th th th th th)) x 3;
@suf[11,12,13] = qw(th th th);
#Abbreviations
map { $month{substr($_,0,3)} = $month{$_} } keys %month;
map { $day{substr($_,0,3)} = $day{$_} } keys %day;
my $strptime = <<'ESQ';
my %month = map { lc $_ } %$mon_ref;
my $daypat = join("|", map { lc $_ } reverse sort keys %$day_ref);
my $monpat = join("|", reverse sort keys %month);
my $sufpat = join("|", reverse sort map { lc $_ } @$suf_ref);
my %ampm = (
'a' => 0, # AM
'p' => 12, # PM
);
my($AM, $PM) = (0,12);
sub {
my $dtstr = lc shift;
my $merid = 24;
my($century,$year,$month,$day,$hh,$mm,$ss,$zone,$dst,$frac);
$zone = tz_offset(shift) if @_;
1 while $dtstr =~ s#\([^\(\)]*\)# #o;
$dtstr =~ s#(\A|\n|\Z)# #sog;
# ignore day names
$dtstr =~ s#([\d\w\s])[\.\,]\s#$1 #sog;
$dtstr =~ s/(?<!\d),|,(?!\d)/ /g;
$dtstr =~ s#($daypat)\s*(den\s)?\b# #o;
# Time: 12:00 or 12:00:00 with optional am/pm
return unless $dtstr =~ /\S/;
# ISO compact: YYYYMMDD without delimiter (month and day must be exactly 2 digits)
if ($dtstr =~ s/\s(\d{4})(\d\d)(\d\d)(?:[-Tt ](\d\d?)(?:([-:]?)(\d\d?)(?:\5(\d\d?)(?:[.,](\d+))?)?)?)?(?=\D)/ /) {
($year,$month,$day,$hh,$mm,$ss,$frac) = ($1,$2-1,$3,$4,$6,$7,$8);
}
# Date with explicit delimiter: YYYY[-:]MM[-:]DD
elsif ($dtstr =~ s/\s(\d{4})([-:])(\d\d?)\2(\d\d?)(?:[-Tt ](\d\d?)(?:([-:]?)(\d\d?)(?:\6(\d\d?)(?:[.,](\d+))?)?)?)?(?=\D)/ /) {
($year,$month,$day,$hh,$mm,$ss,$frac) = ($1,$3-1,$4,$5,$7,$8,$9);
}
# default C++ boost timestamp is effectively %Y-%b-%d %H:%M:%S.%f
# details: https://svn.boost.org/trac/boost/ticket/8839
if ($dtstr =~ s/\s(\d{4})([-:]?)(\w{3,})\2(\d\d?)(?:[-Tt ](\d\d?)(?:([-:]?)(\d\d?)(?:\6(\d\d?)(?:[.,](\d+))?)?)?)?(?=\D)/ /) {
($year,$month,$day,$hh,$mm,$ss,$frac) = ($1,$month{$3},$4,$5,$7,$8,$9);
}
unless (defined $hh) {
if ($dtstr =~ s#[:\s](\d\d?):(\d\d?)(:(\d\d?)(?:\.\d+)?)?(z)?\s*(?:([ap])\.?m?\.?)?\s# #o) {
($hh,$mm,$ss) = ($1,$2,$4);
$zone = 0 if $5;
$merid = $ampm{$6} if $6;
}
# Time: 12 am
elsif ($dtstr =~ s#\s(\d\d?)\s*([ap])\.?m?\.?\s# #o) {
($hh,$mm,$ss) = ($1,0,0);
$merid = $ampm{$2};
}
}
if (defined $hh and $hh <= 12 and $dtstr =~ s# ([ap])\.?m?\.?\s# #o) {
$merid = $ampm{$1};
}
unless (defined $year) {
# Date: 12-June-96 (using - . or /)
if ($dtstr =~ s#\s(\d\d?)([\-\./])($monpat)(\2(\d\d+))?\s# #o) {
($month,$day) = ($month{$3},$1);
$year = $5 if $5;
}
# Date: 12-12-96 (using '-', '.' or '/' )
elsif ($dtstr =~ s#\s(\d+)([\-\./])(\d\d?)(\2(\d+))?\s# #o) {
($month,$day) = ($1 - 1,$3);
if ($5) {
$year = $5;
# Possible match for 1995-01-24 (short mainframe date format);
($year,$month,$day) = ($1, $3 - 1, $5) if $month > 12;
return if length($year) > 2 and $year < 1901;
}
}
elsif ($dtstr =~ s#\s(\d+)\s*($sufpat)?\s*($monpat)# #o) {
($month,$day) = ($month{$3},$1);
}
elsif ($dtstr =~ s#($monpat)\s*(\d+)\s*($sufpat)?\s# #o) {
$month = $month{$1};
if ($2 > 31) { $year = $2 } else { $day = $2 }
}
elsif ($dtstr =~ s#($monpat)([\/-])(\d+)[\/-]# #o) {
($month,$day) = ($month{$1},$3);
}
# Date: 961212 (YYMMDD — only consume if month is in range 1-12)
elsif ($dtstr =~ /\s(\d\d)(\d\d)(\d\d)\s/o && $2 >= 1 && $2 <= 12) {
$dtstr =~ s/\s(\d\d)(\d\d)(\d\d)\s/ /;
($year,$month,$day) = ($1,$2-1,$3);
}
$year = $1 if !defined($year) and $dtstr =~ s#\s(\d{2}(\d{2})?)[\s\.,]# #o;
}
# Zone
$dst = 1 if $dtstr =~ s#\bdst\b##o;
if ($dtstr =~ s#\s"?([a-z]{3,4})(dst|\d+[a-z]*|_[a-z]+)?"?\s# #o) {
$dst = 1 if $2 and $2 eq 'dst';
$zone = tz_offset($1);
return unless defined $zone;
}
elsif ($dtstr =~ s#\s([a-z]{3,4})?([\-\+]?)-?(\d\d?):?(\d\d)?(00)?\s# #o) {
my $m = defined($4) ? "$2$4" : 0;
my $h = "$2$3";
$zone = defined($1) ? tz_offset($1) : 0;
return unless defined $zone;
$zone += 60 * ($m + (60 * $h));
}
if ($dtstr =~ /\S/) {
# now for some dumb dates
if ($dtstr =~ s/^\s*(ut?|z)\s*$//) {
$zone = 0;
}
elsif ($dtstr =~ s#\s([a-z]{3,4})?([\-\+]?)-?(\d\d?)(\d\d)?(00)?\s# #o) {
my $m = defined($4) ? "$2$4" : 0;
my $h = "$2$3";
$zone = defined($1) ? tz_offset($1) : 0;
return unless defined $zone;
$zone += 60 * ($m + (60 * $h));
}
return if $dtstr =~ /\S/o;
}
if (defined $hh) {
if ($hh == 12) {
$hh = 0 if $merid == $AM;
}
elsif ($merid == $PM) {
$hh += 12;
}
}
if (defined $year && $year >= 100) {
$century = int($year / 100);
$year -= 1900;
}
$zone += 3600 if defined $zone && $dst;
$ss += "0.$frac" if $frac;
# Reject inputs that produced only a timezone with no date/time components.
# A bare number like '1' or '+0500' gets consumed by the timezone regex,
# leaving no meaningful date or time information — these are not valid dates.
return unless defined $hh || defined $mm || defined $ss
|| defined $day || defined $month || defined $year;
return ($ss,$mm,$hh,$day,$month,$year,$zone,$century);
}
ESQ
our ($day_ref, $mon_ref, $suf_ref, $obj);
sub gen_parser
{
local($day_ref,$mon_ref,$suf_ref,$obj) = @_;
if($obj)
{
my $obj_strptime = $strptime;
substr($obj_strptime,index($strptime,"sub")+6,0) = <<'ESQ';
shift; # package
ESQ
my $sub = eval "$obj_strptime" or die $@;
return $sub;
}
eval "$strptime" or die $@;
}
*strptime = gen_parser(\%day,\%month,\@suf);
sub str2time
{
my $now = @_ > 2 ? splice(@_, 2, 1) : time;
my @t = strptime(@_);
return undef
unless @t;
my($ss,$mm,$hh,$day,$month,$year,$zone, $century) = @t;
my @lt = localtime($now);
$hh ||= 0;
$mm ||= 0;
$ss ||= 0;
my $frac = $ss - int($ss);
$ss = int $ss;
$month = $lt[4]
unless(defined $month);
$day = $lt[3]
unless(defined $day);
unless (defined $year) {
my $is_future = $month > $lt[4]
|| ($month == $lt[4] && $day > $lt[3]);
$year = $is_future ? ($lt[5] - 1) : $lt[5];
}
# we were given a 4 digit year, so let's keep using those
$year += 1900 if defined $century;
# Normalize two-digit years to 4-digit before passing to Time::Local.
# Time::Local's own windowing varies across versions, so we do it ourselves.
# Convention: 69-99 -> 1969-1999, 0-68 -> 2000-2068 (POSIX strptime behavior).
# Note: first-century dates (years 1-99 AD) are not representable through
# str2time — same limitation as POSIX strptime.
$year += ($year >= 69 ? 1900 : 2000) if $year < 100;
return undef
unless($month <= 11 && $day >= 1 && $day <= 31
&& $hh <= 23 && $mm <= 59 && $ss <= 59);
my $result;
if (defined $zone) {
$result = eval {
local $SIG{__DIE__} = sub {}; # Ick!
timegm($ss,$mm,$hh,$day,$month,$year);
};
return undef
if !defined $result
or $result == -1
&& join("",$ss,$mm,$hh,$day,$month,$year)
ne "595923311169";
# Detect integer overflow: post-1970 dates must produce a non-negative epoch
return undef if $result < 0 && $year >= 1970;
$result -= $zone;
}
else {
$result = eval {
local $SIG{__DIE__} = sub {}; # Ick!
timelocal($ss,$mm,$hh,$day,$month,$year);
};
return undef
if !defined $result
or $result == -1
&& join("",$ss,$mm,$hh,$day,$month,$year)
ne join("",(localtime(-1))[0..5]);
# Detect integer overflow: post-1970 dates must produce a non-negative epoch
# Use 1971 to avoid false positives from timezone offsets near epoch 0
return undef if $result < 0 && $year >= 1971;
}
return $result + $frac;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Date::Parse - Parse date strings into time values
=head1 VERSION
version 2.35
=head1 SYNOPSIS
use Date::Parse;
my $date = "Wed, 16 Jun 94 07:29:35 CST";
my $time = str2time($date);
my ($ss,$mm,$hh,$day,$month,$year,$zone) = strptime($date);
=head1 DESCRIPTION
C<Date::Parse> provides two routines for parsing date strings into time values.
=over 4
=item str2time(DATE [, ZONE [, EPOCH]])
C<str2time> parses C<DATE> and returns a unix time value, or undef upon failure.
C<ZONE>, if given, specifies the timezone to assume when parsing if the
date string does not specify a timezone.
C<EPOCH>, if given, is a unix epoch value used as the reference time when
filling in missing date components (month, day, or year). Defaults to
C<time()>. Useful when the current system clock cannot be trusted or when
parsing dates relative to a known reference point.
=item strptime(DATE [, ZONE])
C<strptime> takes the same arguments as str2time but returns an array of
values C<($ss,$mm,$hh,$day,$month,$year,$zone,$century)>. Elements are only
defined if they could be extracted from the date string. An empty array is
returned upon failure.
The return values follow the same conventions as Perl's built-in C<localtime>
and C<gmtime> functions:
=over 4
=item C<$month>
0-indexed: 0 = January, 1 = February, ..., 11 = December.
=item C<$year>
Years since 1900. For example, the year 2015 is returned as C<115>, and 1995
is returned as C<95>. To recover the full 4-digit year: C<$year + 1900>.
=item C<$zone>
Timezone offset in seconds from UTC, or C<undef> if no timezone was specified
in the input string.
=item C<$century>
Defined only when a 4-digit year was present in the input. Its value is
C<int($full_year / 100)> (e.g. C<20> for the year 2015). When C<$century> is
defined, C<$year + 1900> gives the original 4-digit year.
=back
For example, C<strptime("2015-01-24T09:08:17")> returns:
($ss, $mm, $hh, $day, $month, $year, $zone, $century)
( 17, 8, 9, 24, 0, 115, undef, 20 )
# ^--- January (0-indexed)
# ^--- 2015 - 1900
# ^--- not in input
# ^--- int(2015/100)
=back
=head1 NAME
Date::Parse - Parse date strings into time values
=head1 MULTI-LANGUAGE SUPPORT
Date::Parse is capable of parsing dates in several languages, these include
English, French, German and Italian.
$lang = Date::Language->new('German');
$lang->str2time("25 Jun 1996 21:09:55 +0100");
=head1 EXAMPLE DATES
Below is a sample list of dates that are known to be parsable with Date::Parse
1995-01-24T09:08:17.1823213 ISO-8601
Wed, 16 Jun 94 07:29:35 CST Comma and day name are optional
Thu, 13 Oct 94 10:13:13 -0700
Wed, 9 Nov 1994 09:50:32 -0500 (EST) Text in ()'s will be ignored.
21 dec 17:05 Will be parsed in the current time zone
21-dec 17:05
21/dec 17:05
21/dec/93 17:05
1999 10:02:18 "GMT"
16 Nov 94 22:28:20 PST
=head1 BUGS
When both the month and the date are specified in the date as numbers
they are always parsed assuming that the month number comes before the
date. This is the usual format used in American dates.
The reason why it is like this and not dynamic is that it must be
deterministic. Several people have suggested using the current locale,
but this will not work as the date being parsed may not be in the format
of the current locale.
My plans to address this, which will be in a future release, is to allow
the programmer to state what order they want these values parsed in.
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
=head1 COPYRIGHT
Copyright (c) 1995-2009 Graham Barr. This program is free
software; you can redistribute it and/or modify it under the same terms
as Perl itself.
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

373
OGP64/usr/share/perl5/vendor_perl/5.40/Encode/Locale.pm Normal file
View file

@ -0,0 +1,373 @@
package Encode::Locale;
use strict;
our $VERSION = "1.05";
use base 'Exporter';
our @EXPORT_OK = qw(
decode_argv env
$ENCODING_LOCALE $ENCODING_LOCALE_FS
$ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT
);
use Encode ();
use Encode::Alias ();
our $ENCODING_LOCALE;
our $ENCODING_LOCALE_FS;
our $ENCODING_CONSOLE_IN;
our $ENCODING_CONSOLE_OUT;
sub DEBUG () { 0 }
sub _init {
if ($^O eq "MSWin32") {
unless ($ENCODING_LOCALE) {
# Try to obtain what the Windows ANSI code page is
eval {
unless (defined &GetACP) {
require Win32;
eval { Win32::GetACP() };
*GetACP = sub { &Win32::GetACP } unless $@;
}
unless (defined &GetACP) {
require Win32::API;
Win32::API->Import('kernel32', 'int GetACP()');
}
if (defined &GetACP) {
my $cp = GetACP();
$ENCODING_LOCALE = "cp$cp" if $cp;
}
};
}
unless ($ENCODING_CONSOLE_IN) {
# only test one since set together
unless (defined &GetInputCP) {
eval {
require Win32;
eval { Win32::GetConsoleCP() };
# manually "import" it since Win32->import refuses
*GetInputCP = sub { &Win32::GetConsoleCP } unless $@;
*GetOutputCP = sub { &Win32::GetConsoleOutputCP } unless $@;
};
unless (defined &GetInputCP) {
eval {
# try Win32::Console module for codepage to use
require Win32::Console;
eval { Win32::Console::InputCP() };
*GetInputCP = sub { &Win32::Console::InputCP }
unless $@;
*GetOutputCP = sub { &Win32::Console::OutputCP }
unless $@;
};
}
unless (defined &GetInputCP) {
# final fallback
*GetInputCP = *GetOutputCP = sub {
# another fallback that could work is:
# reg query HKLM\System\CurrentControlSet\Control\Nls\CodePage /v ACP
((qx(chcp) || '') =~ /^Active code page: (\d+)/)
? $1 : ();
};
}
}
my $cp = GetInputCP();
$ENCODING_CONSOLE_IN = "cp$cp" if $cp;
$cp = GetOutputCP();
$ENCODING_CONSOLE_OUT = "cp$cp" if $cp;
}
}
unless ($ENCODING_LOCALE) {
eval {
require I18N::Langinfo;
$ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());
# Workaround of Encode < v2.25. The "646" encoding alias was
# introduced in Encode-2.25, but we don't want to require that version
# quite yet. Should avoid the CPAN testers failure reported from
# openbsd-4.7/perl-5.10.0 combo.
$ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646";
# https://rt.cpan.org/Ticket/Display.html?id=66373
$ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8";
};
$ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN;
}
if ($^O eq "darwin") {
$ENCODING_LOCALE_FS ||= "UTF-8";
}
# final fallback
$ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8";
$ENCODING_LOCALE_FS ||= $ENCODING_LOCALE;
$ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE;
$ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN;
unless (Encode::find_encoding($ENCODING_LOCALE)) {
my $foundit;
if (lc($ENCODING_LOCALE) eq "gb18030") {
eval {
require Encode::HanExtra;
};
if ($@) {
die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped";
}
$foundit++ if Encode::find_encoding($ENCODING_LOCALE);
}
die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped"
unless $foundit;
}
# use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT;
}
_init();
Encode::Alias::define_alias(sub {
no strict 'refs';
no warnings 'once';
return ${"ENCODING_" . uc(shift)};
}, "locale");
sub _flush_aliases {
no strict 'refs';
for my $a (keys %Encode::Alias::Alias) {
if (defined ${"ENCODING_" . uc($a)}) {
delete $Encode::Alias::Alias{$a};
warn "Flushed alias cache for $a" if DEBUG;
}
}
}
sub reinit {
$ENCODING_LOCALE = shift;
$ENCODING_LOCALE_FS = shift;
$ENCODING_CONSOLE_IN = $ENCODING_LOCALE;
$ENCODING_CONSOLE_OUT = $ENCODING_LOCALE;
_init();
_flush_aliases();
}
sub decode_argv {
die if defined wantarray;
for (@ARGV) {
$_ = Encode::decode(locale => $_, @_);
}
}
sub env {
my $k = Encode::encode(locale => shift);
my $old = $ENV{$k};
if (@_) {
my $v = shift;
if (defined $v) {
$ENV{$k} = Encode::encode(locale => $v);
}
else {
delete $ENV{$k};
}
}
return Encode::decode(locale => $old) if defined wantarray;
}
1;
__END__
=head1 NAME
Encode::Locale - Determine the locale encoding
=head1 SYNOPSIS
use Encode::Locale;
use Encode;
$string = decode(locale => $bytes);
$bytes = encode(locale => $string);
if (-t) {
binmode(STDIN, ":encoding(console_in)");
binmode(STDOUT, ":encoding(console_out)");
binmode(STDERR, ":encoding(console_out)");
}
# Processing file names passed in as arguments
my $uni_filename = decode(locale => $ARGV[0]);
open(my $fh, "<", encode(locale_fs => $uni_filename))
|| die "Can't open '$uni_filename': $!";
binmode($fh, ":encoding(locale)");
...
=head1 DESCRIPTION
In many applications it's wise to let Perl use Unicode for the strings it
processes. Most of the interfaces Perl has to the outside world are still byte
based. Programs therefore need to decode byte strings that enter the program
from the outside and encode them again on the way out.
The POSIX locale system is used to specify both the language conventions
requested by the user and the preferred character set to consume and
output. The C<Encode::Locale> module looks up the charset and encoding (called
a CODESET in the locale jargon) and arranges for the L<Encode> module to know
this encoding under the name "locale". It means bytes obtained from the
environment can be converted to Unicode strings by calling C<<
Encode::encode(locale => $bytes) >> and converted back again with C<<
Encode::decode(locale => $string) >>.
Where file systems interfaces pass file names in and out of the program we also
need care. The trend is for operating systems to use a fixed file encoding
that don't actually depend on the locale; and this module determines the most
appropriate encoding for file names. The L<Encode> module will know this
encoding under the name "locale_fs". For traditional Unix systems this will
be an alias to the same encoding as "locale".
For programs running in a terminal window (called a "Console" on some systems)
the "locale" encoding is usually a good choice for what to expect as input and
output. Some systems allows us to query the encoding set for the terminal and
C<Encode::Locale> will do that if available and make these encodings known
under the C<Encode> aliases "console_in" and "console_out". For systems where
we can't determine the terminal encoding these will be aliased as the same
encoding as "locale". The advice is to use "console_in" for input known to
come from the terminal and "console_out" for output to the terminal.
In addition to arranging for various Encode aliases the following functions and
variables are provided:
=over
=item decode_argv( )
=item decode_argv( Encode::FB_CROAK )
This will decode the command line arguments to perl (the C<@ARGV> array) in-place.
The function will by default replace characters that can't be decoded by
"\x{FFFD}", the Unicode replacement character.
Any argument provided is passed as CHECK to underlying Encode::decode() call.
Pass the value C<Encode::FB_CROAK> to have the decoding croak if not all the
command line arguments can be decoded. See L<Encode/"Handling Malformed Data">
for details on other options for CHECK.
=item env( $uni_key )
=item env( $uni_key => $uni_value )
Interface to get/set environment variables. Returns the current value as a
Unicode string. The $uni_key and $uni_value arguments are expected to be
Unicode strings as well. Passing C<undef> as $uni_value deletes the
environment variable named $uni_key.
The returned value will have the characters that can't be decoded replaced by
"\x{FFFD}", the Unicode replacement character.
There is no interface to request alternative CHECK behavior as for
decode_argv(). If you need that you need to call encode/decode yourself.
For example:
my $key = Encode::encode(locale => $uni_key, Encode::FB_CROAK);
my $uni_value = Encode::decode(locale => $ENV{$key}, Encode::FB_CROAK);
=item reinit( )
=item reinit( $encoding )
Reinitialize the encodings from the locale. You want to call this function if
you changed anything in the environment that might influence the locale.
This function will croak if the determined encoding isn't recognized by
the Encode module.
With argument force $ENCODING_... variables to set to the given value.
=item $ENCODING_LOCALE
The encoding name determined to be suitable for the current locale.
L<Encode> know this encoding as "locale".
=item $ENCODING_LOCALE_FS
The encoding name determined to be suitable for file system interfaces
involving file names.
L<Encode> know this encoding as "locale_fs".
=item $ENCODING_CONSOLE_IN
=item $ENCODING_CONSOLE_OUT
The encodings to be used for reading and writing output to the a console.
L<Encode> know these encodings as "console_in" and "console_out".
=back
=head1 NOTES
This table summarizes the mapping of the encodings set up
by the C<Encode::Locale> module:
Encode | | |
Alias | Windows | Mac OS X | POSIX
------------+---------+--------------+------------
locale | ANSI | nl_langinfo | nl_langinfo
locale_fs | ANSI | UTF-8 | nl_langinfo
console_in | OEM | nl_langinfo | nl_langinfo
console_out | OEM | nl_langinfo | nl_langinfo
=head2 Windows
Windows has basically 2 sets of APIs. A wide API (based on passing UTF-16
strings) and a byte based API based a character set called ANSI. The
regular Perl interfaces to the OS currently only uses the ANSI APIs.
Unfortunately ANSI is not a single character set.
The encoding that corresponds to ANSI varies between different editions of
Windows. For many western editions of Windows ANSI corresponds to CP-1252
which is a character set similar to ISO-8859-1. Conceptually the ANSI
character set is a similar concept to the POSIX locale CODESET so this module
figures out what the ANSI code page is and make this available as
$ENCODING_LOCALE and the "locale" Encoding alias.
Windows systems also operate with another byte based character set.
It's called the OEM code page. This is the encoding that the Console
takes as input and output. It's common for the OEM code page to
differ from the ANSI code page.
=head2 Mac OS X
On Mac OS X the file system encoding is always UTF-8 while the locale
can otherwise be set up as normal for POSIX systems.
File names on Mac OS X will at the OS-level be converted to
NFD-form. A file created by passing a NFC-filename will come
in NFD-form from readdir(). See L<Unicode::Normalize> for details
of NFD/NFC.
Actually, Apple does not follow the Unicode NFD standard since not all
character ranges are decomposed. The claim is that this avoids problems with
round trip conversions from old Mac text encodings. See L<Encode::UTF8Mac> for
details.
=head2 POSIX (Linux and other Unixes)
File systems might vary in what encoding is to be used for
filenames. Since this module has no way to actually figure out
what the is correct it goes with the best guess which is to
assume filenames are encoding according to the current locale.
Users are advised to always specify UTF-8 as the locale charset.
=head1 SEE ALSO
L<I18N::Langinfo>, L<Encode>, L<Term::Encoding>
=head1 AUTHOR
Copyright 2010 Gisle Aas <gisle@aas.no>.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

1196
OGP64/usr/share/perl5/vendor_perl/5.40/Error.pm Normal file
View file

File diff suppressed because it is too large Load diff

165
OGP64/usr/share/perl5/vendor_perl/5.40/Error/Simple.pm Normal file
View file

@ -0,0 +1,165 @@
# Error/Simple.pm
#
# Copyright (c) 2006 Shlomi Fish <shlomif@shlomifish.org>.
# This file is free software; you can redistribute it and/or
# modify it under the terms of the MIT/X11 license (whereas the licence
# of the Error distribution as a whole is the GPLv1+ and the Artistic
# licence).
package Error::Simple;
$Error::Simple::VERSION = '0.17030';
use strict;
use warnings;
use Error;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Error::Simple - the simple error sub-class of Error
=head1 VERSION
version 0.17030
=head1 SYNOPSIS
use base 'Error::Simple';
=head1 DESCRIPTION
The only purpose of this module is to allow one to say:
use base 'Error::Simple';
and the only thing it does is "use" Error.pm. Refer to the documentation
of L<Error> for more information about Error::Simple.
=head1 METHODS
=head2 Error::Simple->new($text [, $value])
Constructs an Error::Simple with the text C<$text> and the optional value
C<$value>.
=head2 $err->stringify()
Error::Simple overloads this method.
=head1 KNOWN BUGS
None.
=head1 AUTHORS
Shlomi Fish ( L<http://www.shlomifish.org/> )
=head1 SEE ALSO
L<Error>
=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Websites
The following websites have more information about this module, and may be of help to you. As always,
in addition to those websites please use your favorite search engine to discover more resources.
=over 4
=item *
MetaCPAN
A modern, open-source CPAN search engine, useful to view POD in HTML format.
L<https://metacpan.org/release/Error>
=item *
RT: CPAN's Bug Tracker
The RT ( Request Tracker ) website is the default bug/issue tracking system for CPAN.
L<https://rt.cpan.org/Public/Dist/Display.html?Name=Error>
=item *
CPANTS
The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution.
L<http://cpants.cpanauthors.org/dist/Error>
=item *
CPAN Testers
The CPAN Testers is a network of smoke testers who run automated tests on uploaded CPAN distributions.
L<http://www.cpantesters.org/distro/E/Error>
=item *
CPAN Testers Matrix
The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms.
L<http://matrix.cpantesters.org/?dist=Error>
=item *
CPAN Testers Dependencies
The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution.
L<http://deps.cpantesters.org/?module=Error>
=back
=head2 Bugs / Feature Requests
Please report any bugs or feature requests by email to C<bug-error at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/Public/Bug/Report.html?Queue=Error>. You will be automatically notified of any
progress on the request by the system.
=head2 Source Code
The code is open to the world, and available for you to hack on. Please feel free to browse it and play
with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull
from your repository :)
L<https://github.com/shlomif/perl-error.pm>
git clone git://github.com/shlomif/perl-error.pm.git
=head1 AUTHOR
Shlomi Fish ( http://www.shlomifish.org/ )
=head1 BUGS
Please report any bugs or feature requests on the bugtracker website
L<https://github.com/shlomif/perl-error.pm/issues>
When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2025 by Shlomi Fish ( http://www.shlomifish.org/ ).
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

660
OGP64/usr/share/perl5/vendor_perl/5.40/File/ShareDir.pm Normal file
View file

@ -0,0 +1,660 @@
package File::ShareDir;
=pod
=head1 NAME
File::ShareDir - Locate per-dist and per-module shared files
=begin html
<a href="https://travis-ci.org/perl5-utils/File-ShareDir"><img src="https://travis-ci.org/perl5-utils/File-ShareDir.svg?branch=master" alt="Travis CI"/></a>
<a href='https://coveralls.io/github/perl5-utils/File-ShareDir?branch=master'><img src='https://coveralls.io/repos/github/perl5-utils/File-ShareDir/badge.svg?branch=master' alt='Coverage Status' /></a>
<a href="https://saythanks.io/to/rehsack"><img src="https://img.shields.io/badge/Say%20Thanks-!-1EAEDB.svg" alt="Say Thanks" /></a>
=end html
=head1 SYNOPSIS
use File::ShareDir ':ALL';
# Where are distribution-level shared data files kept
$dir = dist_dir('File-ShareDir');
# Where are module-level shared data files kept
$dir = module_dir('File::ShareDir');
# Find a specific file in our dist/module shared dir
$file = dist_file( 'File-ShareDir', 'file/name.txt');
$file = module_file('File::ShareDir', 'file/name.txt');
# Like module_file, but search up the inheritance tree
$file = class_file( 'Foo::Bar', 'file/name.txt' );
=head1 DESCRIPTION
The intent of L<File::ShareDir> is to provide a companion to
L<Class::Inspector> and L<File::HomeDir>, modules that take a
process that is well-known by advanced Perl developers but gets a
little tricky, and make it more available to the larger Perl community.
Quite often you want or need your Perl module (CPAN or otherwise)
to have access to a large amount of read-only data that is stored
on the file-system at run-time.
On a linux-like system, this would be in a place such as /usr/share,
however Perl runs on a wide variety of different systems, and so
the use of any one location is unreliable.
Perl provides a little-known method for doing this, but almost
nobody is aware that it exists. As a result, module authors often
go through some very strange ways to make the data available to
their code.
The most common of these is to dump the data out to an enormous
Perl data structure and save it into the module itself. The
result are enormous multi-megabyte .pm files that chew up a
lot of memory needlessly.
Another method is to put the data "file" after the __DATA__ compiler
tag and limit yourself to access as a filehandle.
The problem to solve is really quite simple.
1. Write the data files to the system at install time.
2. Know where you put them at run-time.
Perl's install system creates an "auto" directory for both
every distribution and for every module file.
These are used by a couple of different auto-loading systems
to store code fragments generated at install time, and various
other modules written by the Perl "ancient masters".
But the same mechanism is available to any dist or module to
store any sort of data.
=head2 Using Data in your Module
C<File::ShareDir> forms one half of a two part solution.
Once the files have been installed to the correct directory,
you can use C<File::ShareDir> to find your files again after
the installation.
For the installation half of the solution, see L<File::ShareDir::Install>
and its C<install_share> directive.
Using L<File::ShareDir::Install> together with L<File::ShareDir>
allows one to rely on the files in appropriate C<dist_dir()>
or C<module_dir()> in development phase, too.
=head1 FUNCTIONS
C<File::ShareDir> provides four functions for locating files and
directories.
For greater maintainability, none of these are exported by default
and you are expected to name the ones you want at use-time, or provide
the C<':ALL'> tag. All of the following are equivalent.
# Load but don't import, and then call directly
use File::ShareDir;
$dir = File::ShareDir::dist_dir('My-Dist');
# Import a single function
use File::ShareDir 'dist_dir';
dist_dir('My-Dist');
# Import all the functions
use File::ShareDir ':ALL';
dist_dir('My-Dist');
All of the functions will check for you that the dir/file actually
exists, and that you have read permissions, or they will throw an
exception.
=cut
use 5.005;
use strict;
use warnings;
use base ('Exporter');
use constant IS_MACOS => !!($^O eq 'MacOS');
use constant IS_WIN32 => !!($^O eq 'MSWin32');
use Carp ();
use Exporter ();
use File::Spec ();
use Class::Inspector ();
our %DIST_SHARE;
our %MODULE_SHARE;
our @CARP_NOT;
our @EXPORT_OK = qw{
dist_dir
dist_file
module_dir
module_file
class_dir
class_file
};
our %EXPORT_TAGS = (
ALL => [@EXPORT_OK],
);
our $VERSION = '1.118';
#####################################################################
# Interface Functions
=pod
=head2 dist_dir
# Get a distribution's shared files directory
my $dir = dist_dir('My-Distribution');
The C<dist_dir> function takes a single parameter of the name of an
installed (CPAN or otherwise) distribution, and locates the shared
data directory created at install time for it.
Returns the directory path as a string, or dies if it cannot be
located or is not readable.
=cut
sub dist_dir
{
my $dist = _DIST(shift);
my $dir;
# Try the new version, then fall back to the legacy version
$dir = _dist_dir_new($dist) || _dist_dir_old($dist);
return $dir if defined $dir;
# Ran out of options
Carp::croak("Failed to find share dir for dist '$dist'");
}
sub _dist_dir_new
{
my $dist = shift;
return $DIST_SHARE{$dist} if exists $DIST_SHARE{$dist};
# Create the subpath
my $path = File::Spec->catdir('auto', 'share', 'dist', $dist);
# Find the full dir within @INC
return _search_inc_path($path);
}
sub _dist_dir_old
{
my $dist = shift;
# Create the subpath
my $path = File::Spec->catdir('auto', split(/-/, $dist),);
# Find the full dir within @INC
return _search_inc_path($path);
}
=pod
=head2 module_dir
# Get a module's shared files directory
my $dir = module_dir('My::Module');
The C<module_dir> function takes a single parameter of the name of an
installed (CPAN or otherwise) module, and locates the shared data
directory created at install time for it.
In order to find the directory, the module B<must> be loaded when
calling this function.
Returns the directory path as a string, or dies if it cannot be
located or is not readable.
=cut
sub module_dir
{
my $module = _MODULE(shift);
return $MODULE_SHARE{$module} if exists $MODULE_SHARE{$module};
# Try the new version first, then fall back to the legacy version
return _module_dir_new($module) || _module_dir_old($module);
}
sub _module_dir_new
{
my $module = shift;
# Create the subpath
my $path = File::Spec->catdir('auto', 'share', 'module', _module_subdir($module),);
# Find the full dir within @INC
return _search_inc_path($path);
}
sub _module_dir_old
{
my $module = shift;
my $short = Class::Inspector->filename($module);
my $long = Class::Inspector->loaded_filename($module);
$short =~ tr{/}{:} if IS_MACOS;
$short =~ tr{\\} {/} if IS_WIN32;
$long =~ tr{\\} {/} if IS_WIN32;
substr($short, -3, 3, '');
$long =~ m/^(.*)\Q$short\E\.pm\z/s or Carp::croak("Failed to find base dir");
my $dir = File::Spec->catdir("$1", 'auto', $short);
-d $dir or Carp::croak("Directory '$dir': No such directory");
-r $dir or Carp::croak("Directory '$dir': No read permission");
return $dir;
}
=pod
=head2 dist_file
# Find a file in our distribution shared dir
my $dir = dist_file('My-Distribution', 'file/name.txt');
The C<dist_file> function takes two parameters of the distribution name
and file name, locates the dist directory, and then finds the file within
it, verifying that the file actually exists, and that it is readable.
The filename should be a relative path in the format of your local
filesystem. It will simply added to the directory using L<File::Spec>'s
C<catfile> method.
Returns the file path as a string, or dies if the file or the dist's
directory cannot be located, or the file is not readable.
=cut
sub dist_file
{
my $dist = _DIST(shift);
my $file = _FILE(shift);
# Try the new version first, in doubt hand off to the legacy version
my $path = _dist_file_new($dist, $file) || _dist_file_old($dist, $file);
$path or Carp::croak("Failed to find shared file '$file' for dist '$dist'");
-f $path or Carp::croak("File '$path': No such file");
-r $path or Carp::croak("File '$path': No read permission");
return $path;
}
sub _dist_file_new
{
my $dist = shift;
my $file = shift;
# If it exists, what should the path be
my $dir = _dist_dir_new($dist);
return undef unless defined $dir;
my $path = File::Spec->catfile($dir, $file);
# Does the file exist
return undef unless -e $path;
return $path;
}
sub _dist_file_old
{
my $dist = shift;
my $file = shift;
# If it exists, what should the path be
my $dir = _dist_dir_old($dist);
return undef unless defined $dir;
my $path = File::Spec->catfile($dir, $file);
# Does the file exist
return undef unless -e $path;
return $path;
}
=pod
=head2 module_file
# Find a file in our module shared dir
my $dir = module_file('My::Module', 'file/name.txt');
The C<module_file> function takes two parameters of the module name
and file name. It locates the module directory, and then finds the file
within it, verifying that the file actually exists, and that it is readable.
In order to find the directory, the module B<must> be loaded when
calling this function.
The filename should be a relative path in the format of your local
filesystem. It will simply added to the directory using L<File::Spec>'s
C<catfile> method.
Returns the file path as a string, or dies if the file or the dist's
directory cannot be located, or the file is not readable.
=cut
sub module_file
{
my $module = _MODULE(shift);
my $file = _FILE(shift);
my $dir = module_dir($module);
my $path = File::Spec->catfile($dir, $file);
-e $path or Carp::croak("File '$path' does not exist in module dir");
-r $path or Carp::croak("File '$path': No read permission");
return $path;
}
=pod
=head2 class_file
# Find a file in our module shared dir, or in our parent class
my $dir = class_file('My::Module', 'file/name.txt');
The C<module_file> function takes two parameters of the module name
and file name. It locates the module directory, and then finds the file
within it, verifying that the file actually exists, and that it is readable.
In order to find the directory, the module B<must> be loaded when
calling this function.
The filename should be a relative path in the format of your local
filesystem. It will simply added to the directory using L<File::Spec>'s
C<catfile> method.
If the file is NOT found for that module, C<class_file> will scan up
the module's @ISA tree, looking for the file in all of the parent
classes.
This allows you to, in effect, "subclass" shared files.
Returns the file path as a string, or dies if the file or the dist's
directory cannot be located, or the file is not readable.
=cut
sub class_file
{
my $module = _MODULE(shift);
my $file = _FILE(shift);
# Get the super path ( not including UNIVERSAL )
# Rather than using Class::ISA, we'll use an inlined version
# that implements the same basic algorithm.
my @path = ();
my @queue = ($module);
my %seen = ($module => 1);
while (my $cl = shift @queue)
{
push @path, $cl;
no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
unshift @queue, grep { !$seen{$_}++ }
map { my $s = $_; $s =~ s/^::/main::/; $s =~ s/\'/::/g; $s } (@{"${cl}::ISA"});
}
# Search up the path
foreach my $class (@path)
{
my $dir = eval { module_dir($class); };
next if $@;
my $path = File::Spec->catfile($dir, $file);
-e $path or next;
-r $path or Carp::croak("File '$file' cannot be read, no read permissions");
return $path;
}
Carp::croak("File '$file' does not exist in class or parent shared files");
}
## no critic (BuiltinFunctions::ProhibitStringyEval)
if (eval "use List::MoreUtils 0.428; 1;")
{
List::MoreUtils->import("firstres");
}
else
{
## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
eval <<'END_OF_BORROWED_CODE';
sub firstres (&@)
{
my $test = shift;
foreach (@_)
{
my $testval = $test->();
$testval and return $testval;
}
return undef;
}
END_OF_BORROWED_CODE
}
#####################################################################
# Support Functions
sub _search_inc_path
{
my $path = shift;
# Find the full dir within @INC
my $dir = firstres(
sub {
my $d;
$d = File::Spec->catdir($_, $path) if defined _STRING($_);
defined $d and -d $d ? $d : 0;
},
@INC
) or return;
Carp::croak("Found directory '$dir', but no read permissions") unless -r $dir;
return $dir;
}
sub _module_subdir
{
my $module = shift;
$module =~ s/::/-/g;
return $module;
}
## no critic (BuiltinFunctions::ProhibitStringyEval)
if (eval "use Params::Util 1.07; 1;")
{
Params::Util->import("_CLASS", "_STRING");
}
else
{
## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
eval <<'END_OF_BORROWED_CODE';
# Inlined from Params::Util pure perl version
sub _CLASS ($)
{
return (defined $_[0] and !ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef;
}
sub _STRING ($)
{
(defined $_[0] and ! ref $_[0] and length($_[0])) ? $_[0] : undef;
}
END_OF_BORROWED_CODE
}
# Maintainer note: The following private functions are used by
# File::ShareDir::PAR. (It has to or else it would have to copy&fork)
# So if you significantly change or even remove them, please
# notify the File::ShareDir::PAR maintainer(s). Thank you!
# Matches a valid distribution name
### This is a total guess at this point
sub _DIST ## no critic (Subroutines::RequireArgUnpacking)
{
defined _STRING($_[0]) and $_[0] =~ /^[a-z0-9+_-]+$/is and return $_[0];
Carp::croak("Not a valid distribution name");
}
# A valid and loaded module name
sub _MODULE
{
my $module = _CLASS(shift) or Carp::croak("Not a valid module name");
Class::Inspector->loaded($module) and return $module;
Carp::croak("Module '$module' is not loaded");
}
# A valid file name
sub _FILE
{
my $file = shift;
_STRING($file) or Carp::croak("Did not pass a file name");
File::Spec->file_name_is_absolute($file) and Carp::croak("Cannot use absolute file name '$file'");
return $file;
}
1;
=pod
=head1 EXTENDING
=head2 Overriding Directory Resolution
C<File::ShareDir> has two convenience hashes for people who have advanced usage
requirements of C<File::ShareDir> such as using uninstalled C<share>
directories during development.
#
# Dist-Name => /absolute/path/for/DistName/share/dir
#
%File::ShareDir::DIST_SHARE
#
# Module::Name => /absolute/path/for/Module/Name/share/dir
#
%File::ShareDir::MODULE_SHARE
Setting these values any time before the corresponding calls
dist_dir('Dist-Name')
dist_file('Dist-Name','some/file');
module_dir('Module::Name');
module_file('Module::Name','some/file');
Will override the base directory for resolving those calls.
An example of where this would be useful is in a test for a module that
depends on files installed into a share directory, to enable the tests
to use the development copy without needing to install them first.
use File::ShareDir;
use Cwd qw( getcwd );
use File::Spec::Functions qw( rel2abs catdir );
$File::ShareDir::MODULE_SHARE{'Foo::Module'} = rel2abs(catfile(getcwd,'share'));
use Foo::Module;
# internal calls in Foo::Module to module_file('Foo::Module','bar') now resolves to
# the source trees share/ directory instead of something in @INC
=head1 SUPPORT
Bugs should always be submitted via the CPAN request tracker, see below.
You can find documentation for this module with the perldoc command.
perldoc File::ShareDir
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-ShareDir>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/File-ShareDir>
=item * CPAN Ratings
L<http://cpanratings.perl.org/s/File-ShareDir>
=item * CPAN Search
L<http://search.cpan.org/dist/File-ShareDir/>
=back
=head2 Where can I go for other help?
If you have a bug report, a patch or a suggestion, please open a new
report ticket at CPAN (but please check previous reports first in case
your issue has already been addressed).
Report tickets should contain a detailed description of the bug or
enhancement request and at least an easily verifiable way of
reproducing the issue or fix. Patches are always welcome, too.
=head2 Where can I go for help with a concrete version?
Bugs and feature requests are accepted against the latest version
only. To get patches for earlier versions, you need to get an
agreement with a developer of your choice - who may or not report the
issue and a suggested fix upstream (depends on the license you have
chosen).
=head2 Business support and maintenance
For business support you can contact the maintainer via his CPAN
email address. Please keep in mind that business support is neither
available for free nor are you eligible to receive any support
based on the license distributed with this package.
=head1 AUTHOR
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
=head2 MAINTAINER
Jens Rehsack E<lt>rehsack@cpan.orgE<gt>
=head1 SEE ALSO
L<File::ShareDir::Install>,
L<File::ConfigDir>, L<File::HomeDir>,
L<Module::Install>, L<Module::Install::Share>,
L<File::ShareDir::PAR>, L<Dist::Zilla::Plugin::ShareDir>
=head1 COPYRIGHT
Copyright 2005 - 2011 Adam Kennedy,
Copyright 2014 - 2018 Jens Rehsack.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
=cut

458
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Config.pm Normal file
View file

@ -0,0 +1,458 @@
package HTTP::Config;
use strict;
use warnings;
our $VERSION = '7.01';
use URI;
sub new {
my $class = shift;
return bless [], $class;
}
sub entries {
my $self = shift;
@$self;
}
sub empty {
my $self = shift;
not @$self;
}
sub add {
if (@_ == 2) {
my $self = shift;
push(@$self, shift);
return;
}
my($self, %spec) = @_;
push(@$self, \%spec);
return;
}
sub find2 {
my($self, %spec) = @_;
my @found;
my @rest;
ITEM:
for my $item (@$self) {
for my $k (keys %spec) {
no warnings 'uninitialized';
if (!exists $item->{$k} || $spec{$k} ne $item->{$k}) {
push(@rest, $item);
next ITEM;
}
}
push(@found, $item);
}
return \@found unless wantarray;
return \@found, \@rest;
}
sub find {
my $self = shift;
my $f = $self->find2(@_);
return @$f if wantarray;
return $f->[0];
}
sub remove {
my($self, %spec) = @_;
my($removed, $rest) = $self->find2(%spec);
@$self = @$rest if @$removed;
return @$removed;
}
my %MATCH = (
m_scheme => sub {
my($v, $uri) = @_;
return $uri->_scheme eq $v; # URI known to be canonical
},
m_secure => sub {
my($v, $uri) = @_;
my $secure = $uri->can("secure") ? $uri->secure : $uri->_scheme eq "https";
return $secure == !!$v;
},
m_host_port => sub {
my($v, $uri) = @_;
return unless $uri->can("host_port");
return $uri->host_port eq $v, 7;
},
m_host => sub {
my($v, $uri) = @_;
return unless $uri->can("host");
return $uri->host eq $v, 6;
},
m_port => sub {
my($v, $uri) = @_;
return unless $uri->can("port");
return $uri->port eq $v;
},
m_domain => sub {
my($v, $uri) = @_;
return unless $uri->can("host");
my $h = $uri->host;
$h = "$h.local" unless $h =~ /\./;
$v = ".$v" unless $v =~ /^\./;
return length($v), 5 if substr($h, -length($v)) eq $v;
return 0;
},
m_path => sub {
my($v, $uri) = @_;
return unless $uri->can("path");
return $uri->path eq $v, 4;
},
m_path_prefix => sub {
my($v, $uri) = @_;
return unless $uri->can("path");
my $path = $uri->path;
my $len = length($v);
return $len, 3 if $path eq $v;
return 0 if length($path) <= $len;
$v .= "/" unless $v =~ m,/\z,,;
return $len, 3 if substr($path, 0, length($v)) eq $v;
return 0;
},
m_path_match => sub {
my($v, $uri) = @_;
return unless $uri->can("path");
return $uri->path =~ $v;
},
m_uri__ => sub {
my($v, $k, $uri) = @_;
return unless $uri->can($k);
return 1 unless defined $v;
return $uri->$k eq $v;
},
m_method => sub {
my($v, $uri, $request) = @_;
return $request && $request->method eq $v;
},
m_proxy => sub {
my($v, $uri, $request) = @_;
return $request && ($request->{proxy} || "") eq $v;
},
m_code => sub {
my($v, $uri, $request, $response) = @_;
$v =~ s/xx\z//;
return unless $response;
return length($v), 2 if substr($response->code, 0, length($v)) eq $v;
},
m_media_type => sub { # for request too??
my($v, $uri, $request, $response) = @_;
return unless $response;
return 1, 1 if $v eq "*/*";
my $ct = $response->content_type;
return 2, 1 if $v =~ s,/\*\z,, && $ct =~ m,^\Q$v\E/,;
return 3, 1 if $v eq "html" && $response->content_is_html;
return 4, 1 if $v eq "xhtml" && $response->content_is_xhtml;
return 10, 1 if $v eq $ct;
return 0;
},
m_header__ => sub {
my($v, $k, $uri, $request, $response) = @_;
return unless $request;
my $req_header = $request->header($k);
return 1 if defined($req_header) && $req_header eq $v;
if ($response) {
my $res_header = $response->header($k);
return 1 if defined($res_header) && $res_header eq $v;
}
return 0;
},
m_response_attr__ => sub {
my($v, $k, $uri, $request, $response) = @_;
return unless $response;
return 1 if !defined($v) && exists $response->{$k};
return 0 unless exists $response->{$k};
return 1 if $response->{$k} eq $v;
return 0;
},
);
sub matching {
my $self = shift;
if (@_ == 1) {
if ($_[0]->can("request")) {
unshift(@_, $_[0]->request);
unshift(@_, undef) unless defined $_[0];
}
unshift(@_, $_[0]->uri_canonical) if $_[0] && $_[0]->can("uri_canonical");
}
my($uri, $request, $response) = @_;
$uri = URI->new($uri) unless ref($uri);
my @m;
ITEM:
for my $item (@$self) {
my $order;
for my $ikey (keys %$item) {
my $mkey = $ikey;
my $k;
$k = $1 if $mkey =~ s/__(.*)/__/;
if (my $m = $MATCH{$mkey}) {
#print "$ikey $mkey\n";
my($c, $o);
my @arg = (
defined($k) ? $k : (),
$uri, $request, $response
);
my $v = $item->{$ikey};
$v = [$v] unless ref($v) eq "ARRAY";
for (@$v) {
($c, $o) = $m->($_, @arg);
#print " - $_ ==> $c $o\n";
last if $c;
}
next ITEM unless $c;
$order->[$o || 0] += $c;
}
}
$order->[7] ||= 0;
$item->{_order} = join(".", reverse map sprintf("%03d", $_ || 0), @$order);
push(@m, $item);
}
@m = sort { $b->{_order} cmp $a->{_order} } @m;
delete $_->{_order} for @m;
return @m if wantarray;
return $m[0];
}
sub add_item {
my $self = shift;
my $item = shift;
return $self->add(item => $item, @_);
}
sub remove_items {
my $self = shift;
return map $_->{item}, $self->remove(@_);
}
sub matching_items {
my $self = shift;
return map $_->{item}, $self->matching(@_);
}
1;
=pod
=encoding UTF-8
=head1 NAME
HTTP::Config - Configuration for request and response objects
=head1 VERSION
version 7.01
=head1 SYNOPSIS
use HTTP::Config;
my $c = HTTP::Config->new;
$c->add(m_domain => ".example.com", m_scheme => "http", verbose => 1);
use HTTP::Request;
my $request = HTTP::Request->new(GET => "http://www.example.com");
if (my @m = $c->matching($request)) {
print "Yadayada\n" if $m[0]->{verbose};
}
=head1 DESCRIPTION
An C<HTTP::Config> object is a list of entries that
can be matched against request or request/response pairs. Its
purpose is to hold configuration data that can be looked up given a
request or response object.
Each configuration entry is a hash. Some keys specify matching to
occur against attributes of request/response objects. Other keys can
be used to hold user data.
The following methods are provided:
=over 4
=item $conf = HTTP::Config->new
Constructs a new empty C<HTTP::Config> object and returns it.
=item $conf->entries
Returns the list of entries in the configuration object.
In scalar context returns the number of entries.
=item $conf->empty
Return true if there are no entries in the configuration object.
This is just a shorthand for C<< not $conf->entries >>.
=item $conf->add( %matchspec, %other )
=item $conf->add( \%entry )
Adds a new entry to the configuration.
You can either pass separate key/value pairs or a hash reference.
=item $conf->remove( %spec )
Removes (and returns) the entries that have matches for all the key/value pairs in %spec.
If %spec is empty this will match all entries; so it will empty the configuration object.
=item $conf->matching( $uri, $request, $response )
=item $conf->matching( $uri )
=item $conf->matching( $request )
=item $conf->matching( $response )
Returns the entries that match the given $uri, $request and $response triplet.
If called with a single $request object then the $uri is obtained by calling its 'uri_canonical' method.
If called with a single $response object, then the request object is obtained by calling its 'request' method;
and then the $uri is obtained as if a single $request was provided.
The entries are returned with the most specific matches first.
In scalar context returns the most specific match or C<undef> in none match.
=item $conf->add_item( $item, %matchspec )
=item $conf->remove_items( %spec )
=item $conf->matching_items( $uri, $request, $response )
Wrappers that hides the entries themselves.
=back
=head2 Matching
The following keys on a configuration entry specify matching. For all
of these you can provide an array of values instead of a single value.
The entry matches if at least one of the values in the array matches.
Entries that require match against a response object attribute will never match
unless a response object was provided.
=over
=item m_scheme => $scheme
Matches if the URI uses the specified scheme; e.g. "http".
=item m_secure => $bool
If $bool is TRUE; matches if the URI uses a secure scheme. If $bool
is FALSE; matches if the URI does not use a secure scheme. An example
of a secure scheme is "https".
=item m_host_port => "$hostname:$port"
Matches if the URI's host_port method return the specified value.
=item m_host => $hostname
Matches if the URI's host method returns the specified value.
=item m_port => $port
Matches if the URI's port method returns the specified value.
=item m_domain => ".$domain"
Matches if the URI's host method return a value that within the given
domain. The hostname "www.example.com" will for instance match the
domain ".com".
=item m_path => $path
Matches if the URI's path method returns the specified value.
=item m_path_prefix => $path
Matches if the URI's path is the specified path or has the specified
path as prefix.
=item m_path_match => $Regexp
Matches if the regular expression matches the URI's path. Eg. qr/\.html$/.
=item m_method => $method
Matches if the request method matches the specified value. Eg. "GET" or "POST".
=item m_code => $digit
=item m_code => $status_code
Matches if the response status code matches. If a single digit is
specified; matches for all response status codes beginning with that digit.
=item m_proxy => $url
Matches if the request is to be sent to the given Proxy server.
=item m_media_type => "*/*"
=item m_media_type => "text/*"
=item m_media_type => "html"
=item m_media_type => "xhtml"
=item m_media_type => "text/html"
Matches if the response media type matches.
With a value of "html" matches if $response->content_is_html returns TRUE.
With a value of "xhtml" matches if $response->content_is_xhtml returns TRUE.
=item m_uri__I<$method> => undef
Matches if the URI object provides the method.
=item m_uri__I<$method> => $string
Matches if the URI's $method method returns the given value.
=item m_header__I<$field> => $string
Matches if either the request or the response have a header $field with the given value.
=item m_response_attr__I<$key> => undef
=item m_response_attr__I<$key> => $string
Matches if the response object has that key, or the entry has the given value.
=back
=head1 SEE ALSO
L<URI>, L<HTTP::Request>, L<HTTP::Response>
=head1 AUTHOR
Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1994 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
#ABSTRACT: Configuration for request and response objects

1210
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Daemon.pm Normal file
View file

File diff suppressed because it is too large Load diff

419
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Date.pm Normal file
View file

@ -0,0 +1,419 @@
package HTTP::Date;
use strict;
our $VERSION = '6.06';
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(time2str str2time);
our @EXPORT_OK = qw(parse_date time2iso time2isoz);
require Time::Local;
our ( @DoW, @MoY, %MoY );
@DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@MoY{@MoY} = ( 1 .. 12 );
my %GMT_ZONE = ( GMT => 1, UTC => 1, UT => 1, Z => 1 );
sub time2str (;$) {
my $time = shift;
$time = time unless defined $time;
my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = gmtime($time);
sprintf(
"%s, %02d %s %04d %02d:%02d:%02d GMT",
$DoW[$wday],
$mday, $MoY[$mon], $year + 1900,
$hour, $min, $sec
);
}
sub str2time ($;$) {
my $str = shift;
return undef unless defined $str;
# fast exit for strictly conforming string
if ( $str
=~ /^[SMTWF][a-z][a-z], (\d\d) ([JFMAJSOND][a-z][a-z]) (\d\d\d\d) (\d\d):(\d\d):(\d\d) GMT$/
) {
return eval {
my $t = Time::Local::timegm( $6, $5, $4, $1, $MoY{$2} - 1, $3 );
$t < 0 ? undef : $t;
};
}
my @d = parse_date($str);
return undef unless @d;
$d[1]--; # month
my $tz = pop(@d);
unless ( defined $tz ) {
unless ( defined( $tz = shift ) ) {
return eval {
my $frac = $d[-1];
$frac -= ( $d[-1] = int($frac) );
my $t = Time::Local::timelocal( reverse @d ) + $frac;
$t < 0 ? undef : $t;
};
}
}
my $offset = 0;
if ( $GMT_ZONE{ uc $tz } ) {
# offset already zero
}
elsif ( $tz =~ /^([-+])?(\d\d?):?(\d\d)?$/ ) {
$offset = 3600 * $2;
$offset += 60 * $3 if $3;
$offset *= -1 if $1 && $1 eq '-';
}
else {
eval { require Time::Zone } || return undef;
$offset = Time::Zone::tz_offset($tz);
return undef unless defined $offset;
}
return eval {
my $frac = $d[-1];
$frac -= ( $d[-1] = int($frac) );
my $t = Time::Local::timegm( reverse @d ) + $frac;
$t < 0 ? undef : $t - $offset;
};
}
sub parse_date ($) {
local ($_) = shift;
return unless defined;
# More lax parsing below
s/^\s+//; # kill leading space
s/^(?:Sun|Mon|Tue|Wed|Thu|Fri|Sat)[a-z]*,?\s*//i; # Useless weekday
my ( $day, $mon, $yr, $hr, $min, $sec, $tz, $ampm );
# Then we are able to check for most of the formats with this regexp
(
( $day, $mon, $yr, $hr, $min, $sec, $tz )
= /^
(\d\d?) # day
(?:\s+|[-\/])
(\w+) # month
(?:\s+|[-\/])
(\d+) # year
(?:
(?:\s+|:) # separator before clock
(\d\d?):(\d\d) # hour:min
(?::(\d\d))? # optional seconds
)? # optional clock
\s*
([-+]?\d{2,4}|(?![APap][Mm]\b)[A-Za-z]+)? # timezone
\s*
(?:\(\w+\)|\w{3,})? # ASCII representation of timezone.
\s*$
/x
)
||
# Try the ctime and asctime format
(
( $mon, $day, $hr, $min, $sec, $tz, $yr )
= /^
(\w{1,3}) # month
\s+
(\d\d?) # day
\s+
(\d\d?):(\d\d) # hour:min
(?::(\d\d))? # optional seconds
\s+
(?:([A-Za-z]+)\s+)? # optional timezone
(\d+) # year
\s*$ # allow trailing whitespace
/x
)
||
# Then the Unix 'ls -l' date format
(
( $mon, $day, $yr, $hr, $min, $sec )
= /^
(\w{3}) # month
\s+
(\d\d?) # day
\s+
(?:
(\d\d\d\d) | # year
(\d{1,2}):(\d{2}) # hour:min
(?::(\d\d))? # optional seconds
)
\s*$
/x
)
||
# ISO 8601 format '1996-02-29 12:00:00 -0100' and variants
(
( $yr, $mon, $day, $hr, $min, $sec, $tz )
= /^
(\d{4}) # year
[-\/]?
(\d\d?) # numerical month
[-\/]?
(\d\d?) # day
(?:
(?:\s+|[-:Tt]) # separator before clock
(\d\d?):?(\d\d) # hour:min
(?::?(\d\d(?:\.\d*)?))? # optional seconds (and fractional)
)? # optional clock
\s*
([-+]?\d\d?:?(:?\d\d)?
|Z|z)? # timezone (Z is "zero meridian", i.e. GMT)
\s*$
/x
)
||
# Windows 'dir': '11-12-96 03:52PM' and four-digit year variant
(
( $mon, $day, $yr, $hr, $min, $ampm )
= /^
(\d{2}) # numerical month
-
(\d{2}) # day
-
(\d{2,4}) # year
\s+
(\d\d?):(\d\d)([APap][Mm]) # hour:min AM or PM
\s*$
/x
)
|| return; # unrecognized format
# Translate month name to number
$mon
= $MoY{$mon}
|| $MoY{"\u\L$mon"}
|| ( $mon =~ /^\d\d?$/ && $mon >= 1 && $mon <= 12 && int($mon) )
|| return;
# If the year is missing, we assume first date before the current,
# because of the formats we support such dates are mostly present
# on "ls -l" listings.
unless ( defined $yr ) {
my $cur_mon;
( $cur_mon, $yr ) = (localtime)[ 4, 5 ];
$yr += 1900;
$cur_mon++;
$yr-- if $mon > $cur_mon;
}
elsif ( length($yr) < 3 ) {
# Find "obvious" year
my $cur_yr = (localtime)[5] + 1900;
my $m = $cur_yr % 100;
my $tmp = $yr;
$yr += $cur_yr - $m;
$m -= $tmp;
$yr += ( $m > 0 ) ? 100 : -100
if abs($m) > 50;
}
# Make sure clock elements are defined
$hr = 0 unless defined($hr);
$min = 0 unless defined($min);
$sec = 0 unless defined($sec);
# Compensate for AM/PM
if ($ampm) {
$ampm = uc $ampm;
$hr = 0 if $hr == 12 && $ampm eq 'AM';
$hr += 12 if $ampm eq 'PM' && $hr != 12;
}
return ( $yr, $mon, $day, $hr, $min, $sec, $tz )
if wantarray;
if ( defined $tz ) {
$tz = "Z" if $tz =~ /^(GMT|UTC?|[-+]?0+)$/;
}
else {
$tz = "";
}
return sprintf(
"%04d-%02d-%02d %02d:%02d:%02d%s",
$yr, $mon, $day, $hr, $min, $sec, $tz
);
}
sub time2iso (;$) {
my $time = shift;
$time = time unless defined $time;
my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime($time);
sprintf(
"%04d-%02d-%02d %02d:%02d:%02d",
$year + 1900, $mon + 1, $mday, $hour, $min, $sec
);
}
sub time2isoz (;$) {
my $time = shift;
$time = time unless defined $time;
my ( $sec, $min, $hour, $mday, $mon, $year ) = gmtime($time);
sprintf(
"%04d-%02d-%02d %02d:%02d:%02dZ",
$year + 1900, $mon + 1, $mday, $hour, $min, $sec
);
}
1;
# ABSTRACT: HTTP::Date - date conversion routines
#
__END__
=pod
=encoding UTF-8
=head1 NAME
HTTP::Date - HTTP::Date - date conversion routines
=head1 VERSION
version 6.06
=head1 SYNOPSIS
use HTTP::Date;
$string = time2str($time); # Format as GMT ASCII time
$time = str2time($string); # convert ASCII date to machine time
=head1 DESCRIPTION
This module provides functions that deal the date formats used by the
HTTP protocol (and then some more). Only the first two functions,
time2str() and str2time(), are exported by default.
=over 4
=item time2str( [$time] )
The time2str() function converts a machine time (seconds since epoch)
to a string. If the function is called without an argument or with an
undefined argument, it will use the current time.
The string returned is in the format preferred for the HTTP protocol.
This is a fixed length subset of the format defined by RFC 1123,
represented in Universal Time (GMT). An example of a time stamp
in this format is:
Sun, 06 Nov 1994 08:49:37 GMT
=item str2time( $str [, $zone] )
The str2time() function converts a string to machine time. It returns
C<undef> if the format of $str is unrecognized, otherwise whatever the
C<Time::Local> functions can make out of the parsed time. Dates
before the system's epoch may not work on all operating systems. The
time formats recognized are the same as for parse_date().
The function also takes an optional second argument that specifies the
default time zone to use when converting the date. This parameter is
ignored if the zone is found in the date string itself. If this
parameter is missing, and the date string format does not contain any
zone specification, then the local time zone is assumed.
If the zone is not "C<GMT>" or numerical (like "C<-0800>" or
"C<+0100>"), then the C<Time::Zone> module must be installed in order
to get the date recognized.
=item parse_date( $str )
This function will try to parse a date string, and then return it as a
list of numerical values followed by a (possible undefined) time zone
specifier; ($year, $month, $day, $hour, $min, $sec, $tz). The $year
will be the full 4-digit year, and $month numbers start with 1 (for January).
In scalar context the numbers are interpolated in a string of the
"YYYY-MM-DD hh:mm:ss TZ"-format and returned.
If the date is unrecognized, then the empty list is returned (C<undef> in
scalar context).
The function is able to parse the following formats:
"Wed, 09 Feb 1994 22:23:32 GMT" -- HTTP format
"Thu Feb 3 17:03:55 GMT 1994" -- ctime(3) format
"Thu Feb 3 00:00:00 1994", -- ANSI C asctime() format
"Tuesday, 08-Feb-94 14:15:29 GMT" -- old rfc850 HTTP format
"Tuesday, 08-Feb-1994 14:15:29 GMT" -- broken rfc850 HTTP format
"03/Feb/1994:17:03:55 -0700" -- common logfile format
"09 Feb 1994 22:23:32 GMT" -- HTTP format (no weekday)
"08-Feb-94 14:15:29 GMT" -- rfc850 format (no weekday)
"08-Feb-1994 14:15:29 GMT" -- broken rfc850 format (no weekday)
"1994-02-03 14:15:29 -0100" -- ISO 8601 format
"1994-02-03 14:15:29" -- zone is optional
"1994-02-03" -- only date
"1994-02-03T14:15:29" -- Use T as separator
"19940203T141529Z" -- ISO 8601 compact format
"19940203" -- only date
"08-Feb-94" -- old rfc850 HTTP format (no weekday, no time)
"08-Feb-1994" -- broken rfc850 HTTP format (no weekday, no time)
"09 Feb 1994" -- proposed new HTTP format (no weekday, no time)
"03/Feb/1994" -- common logfile format (no time, no offset)
"Feb 3 1994" -- Unix 'ls -l' format
"Feb 3 17:03" -- Unix 'ls -l' format
"11-15-96 03:52PM" -- Windows 'dir' format
"11-15-1996 03:52PM" -- Windows 'dir' format with four-digit year
The parser ignores leading and trailing whitespace. It also allow the
seconds to be missing and the month to be numerical in most formats.
If the year is missing, then we assume that the date is the first
matching date I<before> current month. If the year is given with only
2 digits, then parse_date() will select the century that makes the
year closest to the current date.
=item time2iso( [$time] )
Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ss"-formatted
string representing time in the local time zone.
=item time2isoz( [$time] )
Same as time2str(), but returns a "YYYY-MM-DD hh:mm:ssZ"-formatted
string representing Universal Time.
=back
=head1 SEE ALSO
L<perlfunc/time>, L<Time::Zone>
=head1 AUTHOR
Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1995 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

879
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Headers.pm Normal file
View file

@ -0,0 +1,879 @@
package HTTP::Headers;
use strict;
use warnings;
our $VERSION = '7.01';
use Clone qw(clone);
use Carp ();
# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
# as a replacement for '-' in header field names.
our $TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
# "Good Practice" order of HTTP message headers:
# - General-Headers
# - Request-Headers
# - Response-Headers
# - Entity-Headers
my @general_headers = qw(
Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
Via Warning
);
my @request_headers = qw(
Accept Accept-Charset Accept-Encoding Accept-Language
Authorization Expect From Host
If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
Max-Forwards Proxy-Authorization Range Referer TE User-Agent
);
my @response_headers = qw(
Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
Vary WWW-Authenticate
);
my @entity_headers = qw(
Allow Content-Encoding Content-Language Content-Length Content-Location
Content-MD5 Content-Range Content-Type Expires Last-Modified
);
my %entity_header = map { lc($_) => 1 } @entity_headers;
my @header_order = (
@general_headers,
@request_headers,
@response_headers,
@entity_headers,
);
# Make alternative representations of @header_order. This is used
# for sorting and case matching.
my %header_order;
my %standard_case;
{
my $i = 0;
for (@header_order) {
my $lc = lc $_;
$header_order{$lc} = ++$i;
$standard_case{$lc} = $_;
}
}
sub new
{
my($class) = shift;
my $self = bless {}, $class;
$self->header(@_) if @_; # set up initial headers
$self;
}
sub header
{
my $self = shift;
Carp::croak('Usage: $h->header($field, ...)') unless @_;
my(@old);
my %seen;
while (@_) {
my $field = shift;
my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
@old = $self->_header($field, shift, $op);
}
return @old if wantarray;
return $old[0] if @old <= 1;
join(", ", @old);
}
sub clear
{
my $self = shift;
%$self = ();
}
sub push_header
{
my $self = shift;
return $self->_header(@_, 'PUSH_H') if @_ == 2;
while (@_) {
$self->_header(splice(@_, 0, 2), 'PUSH_H');
}
}
sub init_header
{
Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
shift->_header(@_, 'INIT');
}
sub remove_header
{
my($self, @fields) = @_;
my $field;
my @values;
foreach $field (@fields) {
$field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
my $v = delete $self->{lc $field};
push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v;
}
return @values;
}
sub remove_content_headers
{
my $self = shift;
unless (defined(wantarray)) {
# fast branch that does not create return object
delete @$self{grep $entity_header{$_} || /^content-/, keys %$self};
return;
}
my $c = ref($self)->new;
for my $f (grep $entity_header{$_} || /^content-/, keys %$self) {
$c->{$f} = delete $self->{$f};
}
if (exists $self->{'::std_case'}) {
$c->{'::std_case'} = $self->{'::std_case'};
}
$c;
}
sub _header
{
my($self, $field, $val, $op) = @_;
Carp::croak("Illegal field name '$field'")
if rindex($field, ':') > 1 || !length($field);
unless ($field =~ /^:/) {
$field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
my $old = $field;
$field = lc $field;
unless($standard_case{$field} || $self->{'::std_case'}{$field}) {
# generate a %std_case entry for this field
$old =~ s/\b(\w)/\u$1/g;
$self->{'::std_case'}{$field} = $old;
}
}
$op ||= defined($val) ? 'SET' : 'GET';
if ($op eq 'PUSH_H') {
# Like PUSH but where we don't care about the return value
if (exists $self->{$field}) {
my $h = $self->{$field};
if (ref($h) eq 'ARRAY') {
push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
}
else {
$self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
}
return;
}
$self->{$field} = $val;
return;
}
my $h = $self->{$field};
my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
if (defined($val)) {
my @new = ($op eq 'PUSH') ? @old : ();
if (ref($val) ne 'ARRAY') {
push(@new, $val);
}
else {
push(@new, @$val);
}
$self->{$field} = @new > 1 ? \@new : $new[0];
}
elsif ($op ne 'PUSH') {
delete $self->{$field};
}
}
@old;
}
sub _sorted_field_names
{
my $self = shift;
return [ sort {
($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
$a cmp $b
} grep !/^::/, keys %$self ];
}
sub header_field_names {
my $self = shift;
return map $standard_case{$_} || $self->{'::std_case'}{$_} || $_, @{ $self->_sorted_field_names },
if wantarray;
return grep !/^::/, keys %$self;
}
sub scan
{
my($self, $sub) = @_;
my $key;
for $key (@{ $self->_sorted_field_names }) {
my $vals = $self->{$key};
if (ref($vals) eq 'ARRAY') {
my $val;
for $val (@$vals) {
$sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $val);
}
}
else {
$sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $vals);
}
}
}
sub flatten {
my($self)=@_;
(
map {
my $k = $_;
map {
( $k => $_ )
} $self->header($_);
} $self->header_field_names
);
}
sub as_string
{
my($self, $endl) = @_;
$endl = "\n" unless defined $endl;
my @result = ();
for my $key (@{ $self->_sorted_field_names }) {
next if index($key, '_') == 0;
my $vals = $self->{$key};
if ( ref($vals) eq 'ARRAY' ) {
for my $val (@$vals) {
$val = '' if not defined $val;
my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
$field =~ s/^://;
if ( index($val, "\n") >= 0 ) {
$val = _process_newline($val, $endl);
}
push @result, $field . ': ' . $val;
}
}
else {
$vals = '' if not defined $vals;
my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
$field =~ s/^://;
if ( index($vals, "\n") >= 0 ) {
$vals = _process_newline($vals, $endl);
}
push @result, $field . ': ' . $vals;
}
}
join($endl, @result, '');
}
sub _process_newline {
local $_ = shift;
my $endl = shift;
# must handle header values with embedded newlines with care
s/\s+$//; # trailing newlines and space must go
s/\n(\x0d?\n)+/\n/g; # no empty lines
s/\n([^\040\t])/\n $1/g; # initial space for continuation
s/\n/$endl/g; # substitute with requested line ending
$_;
}
sub _date_header
{
require HTTP::Date;
my($self, $header, $time) = @_;
my($old) = $self->_header($header);
if (defined $time) {
$self->_header($header, HTTP::Date::time2str($time));
}
$old =~ s/;.*// if defined($old);
HTTP::Date::str2time($old);
}
sub date { shift->_date_header('Date', @_); }
sub expires { shift->_date_header('Expires', @_); }
sub if_modified_since { shift->_date_header('If-Modified-Since', @_); }
sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
sub last_modified { shift->_date_header('Last-Modified', @_); }
# This is used as a private LWP extension. The Client-Date header is
# added as a timestamp to a response when it has been received.
sub client_date { shift->_date_header('Client-Date', @_); }
# The retry_after field is dual format (can also be a expressed as
# number of seconds from now), so we don't provide an easy way to
# access it until we have know how both these interfaces can be
# addressed. One possibility is to return a negative value for
# relative seconds and a positive value for epoch based time values.
#sub retry_after { shift->_date_header('Retry-After', @_); }
sub content_type {
my $self = shift;
my $ct = $self->{'content-type'};
$self->{'content-type'} = shift if @_;
$ct = $ct->[0] if ref($ct) eq 'ARRAY';
return '' unless defined($ct) && length($ct);
my @ct = split(/;\s*/, $ct, 2);
for ($ct[0]) {
s/\s+//g;
$_ = lc($_);
}
wantarray ? @ct : $ct[0];
}
sub content_type_charset {
my $self = shift;
require HTTP::Headers::Util;
my $h = $self->{'content-type'};
$h = $h->[0] if ref($h);
$h = "" unless defined $h;
my @v = HTTP::Headers::Util::split_header_words($h);
if (@v) {
my($ct, undef, %ct_param) = @{$v[0]};
my $charset = $ct_param{charset};
if ($ct) {
$ct = lc($ct);
$ct =~ s/\s+//;
}
if ($charset) {
$charset = uc($charset);
$charset =~ s/^\s+//; $charset =~ s/\s+\z//;
undef($charset) if $charset eq "";
}
return $ct, $charset if wantarray;
return $charset;
}
return undef, undef if wantarray;
return undef;
}
sub content_is_text {
my $self = shift;
return $self->content_type =~ m,^text/,;
}
sub content_is_html {
my $self = shift;
return $self->content_type eq 'text/html' || $self->content_is_xhtml;
}
sub content_is_xhtml {
my $ct = shift->content_type;
return $ct eq "application/xhtml+xml" ||
$ct eq "application/vnd.wap.xhtml+xml";
}
sub content_is_xml {
my $ct = shift->content_type;
return 1 if $ct eq "text/xml";
return 1 if $ct eq "application/xml";
return 1 if $ct =~ /\+xml$/;
return 0;
}
sub referer {
my $self = shift;
if (@_ && $_[0] =~ /#/) {
# Strip fragment per RFC 2616, section 14.36.
my $uri = shift;
if (ref($uri)) {
$uri = $uri->clone;
$uri->fragment(undef);
}
else {
$uri =~ s/\#.*//;
}
unshift @_, $uri;
}
($self->_header('Referer', @_))[0];
}
*referrer = \&referer; # on tchrist's request
sub title { (shift->_header('Title', @_))[0] }
sub content_encoding { (shift->_header('Content-Encoding', @_))[0] }
sub content_language { (shift->_header('Content-Language', @_))[0] }
sub content_length { (shift->_header('Content-Length', @_))[0] }
sub user_agent { (shift->_header('User-Agent', @_))[0] }
sub server { (shift->_header('Server', @_))[0] }
sub from { (shift->_header('From', @_))[0] }
sub warning { (shift->_header('Warning', @_))[0] }
sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] }
sub authorization { (shift->_header('Authorization', @_))[0] }
sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] }
sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
sub authorization_basic { shift->_basic_auth("Authorization", @_) }
sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
sub _basic_auth {
require MIME::Base64;
my($self, $h, $user, $passwd) = @_;
my($old) = $self->_header($h);
if (defined $user) {
Carp::croak("Basic authorization user name can't contain ':'")
if $user =~ /:/;
$passwd = '' unless defined $passwd;
$self->_header($h => 'Basic ' .
MIME::Base64::encode("$user:$passwd", ''));
}
if (defined $old && $old =~ s/^\s*Basic\s+//) {
my $val = MIME::Base64::decode($old);
return $val unless wantarray;
return split(/:/, $val, 2);
}
return;
}
1;
=pod
=encoding UTF-8
=head1 NAME
HTTP::Headers - Class encapsulating HTTP Message headers
=head1 VERSION
version 7.01
=head1 SYNOPSIS
require HTTP::Headers;
$h = HTTP::Headers->new;
$h->header('Content-Type' => 'text/plain'); # set
$ct = $h->header('Content-Type'); # get
$h->remove_header('Content-Type'); # delete
=head1 DESCRIPTION
The C<HTTP::Headers> class encapsulates HTTP-style message headers.
The headers consist of attribute-value pairs also called fields, which
may be repeated, and which are printed in a particular order. The
field names are cases insensitive.
Instances of this class are usually created as member variables of the
C<HTTP::Request> and C<HTTP::Response> classes, internal to the
library.
The following methods are available:
=over 4
=item $h = HTTP::Headers->new
Constructs a new C<HTTP::Headers> object. You might pass some initial
attribute-value pairs as parameters to the constructor. I<E.g.>:
$h = HTTP::Headers->new(
Date => 'Thu, 03 Feb 1994 00:00:00 GMT',
Content_Type => 'text/html; version=3.2',
Content_Base => 'http://www.perl.org/');
The constructor arguments are passed to the C<header> method which is
described below.
=item $h->clone
Returns a copy of this C<HTTP::Headers> object.
=item $h->header( $field )
=item $h->header( $field => $value )
=item $h->header( $f1 => $v1, $f2 => $v2, ... )
Get or set the value of one or more header fields. The header field
name ($field) is not case sensitive. To make the life easier for perl
users who wants to avoid quoting before the => operator, you can use
'_' as a replacement for '-' in header names.
The header() method accepts multiple ($field => $value) pairs, which
means that you can update several fields with a single invocation.
The $value argument may be a plain string or a reference to an array
of strings for a multi-valued field. If the $value is provided as
C<undef> then the field is removed. If the $value is not given, then
that header field will remain unchanged. In addition to being a string,
$value may be something that stringifies.
The old value (or values) of the last of the header fields is returned.
If no such field exists C<undef> will be returned.
A multi-valued field will be returned as separate values in list
context and will be concatenated with ", " as separator in scalar
context. The HTTP spec (RFC 2616) promises that joining multiple
values in this way will not change the semantic of a header field, but
in practice there are cases like old-style Netscape cookies (see
L<HTTP::Cookies>) where "," is used as part of the syntax of a single
field value.
Examples:
$header->header(MIME_Version => '1.0',
User_Agent => 'My-Web-Client/0.01');
$header->header(Accept => "text/html, text/plain, image/*");
$header->header(Accept => [qw(text/html text/plain image/*)]);
@accepts = $header->header('Accept'); # get multiple values
$accepts = $header->header('Accept'); # get values as a single string
=item $h->push_header( $field => $value )
=item $h->push_header( $f1 => $v1, $f2 => $v2, ... )
Add a new field value for the specified header field. Previous values
for the same field are retained.
As for the header() method, the field name ($field) is not case
sensitive and '_' can be used as a replacement for '-'.
The $value argument may be a scalar or a reference to a list of
scalars.
$header->push_header(Accept => 'image/jpeg');
$header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);
=item $h->init_header( $field => $value )
Set the specified header to the given value, but only if no previous
value for that field is set.
The header field name ($field) is not case sensitive and '_'
can be used as a replacement for '-'.
The $value argument may be a scalar or a reference to a list of
scalars.
=item $h->remove_header( $field, ... )
This function removes the header fields with the specified names.
The header field names ($field) are not case sensitive and '_'
can be used as a replacement for '-'.
The return value is the values of the fields removed. In scalar
context the number of fields removed is returned.
Note that if you pass in multiple field names then it is generally not
possible to tell which of the returned values belonged to which field.
=item $h->remove_content_headers
This will remove all the header fields used to describe the content of
a message. All header field names prefixed with C<Content-> fall
into this category, as well as C<Allow>, C<Expires> and
C<Last-Modified>. RFC 2616 denotes these fields as I<Entity Header
Fields>.
The return value is a new C<HTTP::Headers> object that contains the
removed headers only.
=item $h->clear
This will remove all header fields.
=item $h->header_field_names
Returns the list of distinct names for the fields present in the
header. The field names have case as suggested by HTTP spec, and the
names are returned in the recommended "Good Practice" order.
In scalar context return the number of distinct field names.
=item $h->scan( \&process_header_field )
Apply a subroutine to each header field in turn. The callback routine
is called with two parameters; the name of the field and a single
value (a string). If a header field is multi-valued, then the
routine is called once for each value. The field name passed to the
callback routine has case as suggested by HTTP spec, and the headers
will be visited in the recommended "Good Practice" order.
Any return values of the callback routine are ignored. The loop can
be broken by raising an exception (C<die>), but the caller of scan()
would have to trap the exception itself.
=item $h->flatten()
Returns the list of pairs of keys and values.
=item $h->as_string
=item $h->as_string( $eol )
Return the header fields as a formatted MIME header. Since it
internally uses the C<scan> method to build the string, the result
will use case as suggested by HTTP spec, and it will follow
recommended "Good Practice" of ordering the header fields. Long header
values are not folded.
The optional $eol parameter specifies the line ending sequence to
use. The default is "\n". Embedded "\n" characters in header field
values will be substituted with this line ending sequence.
=back
=head1 CONVENIENCE METHODS
The most frequently used headers can also be accessed through the
following convenience methods. Most of these methods can both be used to read
and to set the value of a header. The header value is set if you pass
an argument to the method. The old header value is always returned.
If the given header did not exist then C<undef> is returned.
Methods that deal with dates/times always convert their value to system
time (seconds since Jan 1, 1970) and they also expect this kind of
value when the header value is set.
=over 4
=item $h->date
This header represents the date and time at which the message was
originated. I<E.g.>:
$h->date(time); # set current date
=item $h->expires
This header gives the date and time after which the entity should be
considered stale.
=item $h->if_modified_since
=item $h->if_unmodified_since
These header fields are used to make a request conditional. If the requested
resource has (or has not) been modified since the time specified in this field,
then the server will return a C<304 Not Modified> response instead of
the document itself.
=item $h->last_modified
This header indicates the date and time at which the resource was last
modified. I<E.g.>:
# check if document is more than 1 hour old
if (my $last_mod = $h->last_modified) {
if ($last_mod < time - 60*60) {
...
}
}
=item $h->content_type
The Content-Type header field indicates the media type of the message
content. I<E.g.>:
$h->content_type('text/html');
The value returned will be converted to lower case, and potential
parameters will be chopped off and returned as a separate value if in
an array context. If there is no such header field, then the empty
string is returned. This makes it safe to do the following:
if ($h->content_type eq 'text/html') {
# we enter this place even if the real header value happens to
# be 'TEXT/HTML; version=3.0'
...
}
=item $h->content_type_charset
Returns the upper-cased charset specified in the Content-Type header. In list
context return the lower-cased bare content type followed by the upper-cased
charset. Both values will be C<undef> if not specified in the header.
=item $h->content_is_text
Returns TRUE if the Content-Type header field indicate that the
content is textual.
=item $h->content_is_html
Returns TRUE if the Content-Type header field indicate that the
content is some kind of HTML (including XHTML). This method can't be
used to set Content-Type.
=item $h->content_is_xhtml
Returns TRUE if the Content-Type header field indicate that the
content is XHTML. This method can't be used to set Content-Type.
=item $h->content_is_xml
Returns TRUE if the Content-Type header field indicate that the
content is XML. This method can't be used to set Content-Type.
=item $h->content_encoding
The Content-Encoding header field is used as a modifier to the
media type. When present, its value indicates what additional
encoding mechanism has been applied to the resource.
=item $h->content_length
A decimal number indicating the size in bytes of the message content.
=item $h->content_language
The natural language(s) of the intended audience for the message
content. The value is one or more language tags as defined by RFC
1766. Eg. "no" for some kind of Norwegian and "en-US" for English the
way it is written in the US.
=item $h->title
The title of the document. In libwww-perl this header will be
initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element
of HTML documents. I<This header is no longer part of the HTTP
standard.>
=item $h->user_agent
This header field is used in request messages and contains information
about the user agent originating the request. I<E.g.>:
$h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)');
=item $h->server
The server header field contains information about the software being
used by the originating server program handling the request.
=item $h->from
This header should contain an Internet e-mail address for the human
user who controls the requesting user agent. The address should be
machine-usable, as defined by RFC822. E.g.:
$h->from('King Kong <king@kong.com>');
I<This header is no longer part of the HTTP standard.>
=item $h->referer
Used to specify the address (URI) of the document from which the
requested resource address was obtained.
The "Free On-line Dictionary of Computing" as this to say about the
word I<referer>:
<World-Wide Web> A misspelling of "referrer" which
somehow made it into the {HTTP} standard. A given {web
page}'s referer (sic) is the {URL} of whatever web page
contains the link that the user followed to the current
page. Most browsers pass this information as part of a
request.
(1998-10-19)
By popular demand C<referrer> exists as an alias for this method so you
can avoid this misspelling in your programs and still send the right
thing on the wire.
When setting the referrer, this method removes the fragment from the
given URI if it is present, as mandated by RFC2616. Note that
the removal does I<not> happen automatically if using the header(),
push_header() or init_header() methods to set the referrer.
=item $h->www_authenticate
This header must be included as part of a C<401 Unauthorized> response.
The field value consist of a challenge that indicates the
authentication scheme and parameters applicable to the requested URI.
=item $h->proxy_authenticate
This header must be included in a C<407 Proxy Authentication Required>
response.
=item $h->authorization
=item $h->proxy_authorization
A user agent that wishes to authenticate itself with a server or a
proxy, may do so by including these headers.
=item $h->authorization_basic
This method is used to get or set an authorization header that use the
"Basic Authentication Scheme". In array context it will return two
values; the user name and the password. In scalar context it will
return I<"uname:password"> as a single string value.
When used to set the header value, it expects two arguments. I<E.g.>:
$h->authorization_basic($uname, $password);
The method will croak if the $uname contains a colon ':'.
=item $h->proxy_authorization_basic
Same as authorization_basic() but will set the "Proxy-Authorization"
header instead.
=back
=head1 NON-CANONICALIZED FIELD NAMES
The header field name spelling is normally canonicalized including the
'_' to '-' translation. There are some application where this is not
appropriate. Prefixing field names with ':' allow you to force a
specific spelling. For example if you really want a header field name
to show up as C<foo_bar> instead of "Foo-Bar", you might set it like
this:
$h->header(":foo_bar" => 1);
These field names are returned with the ':' intact for
$h->header_field_names and the $h->scan callback, but the colons do
not show in $h->as_string.
=head1 AUTHOR
Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1994 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
#ABSTRACT: Class encapsulating HTTP Message headers

127
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Headers/Auth.pm Normal file
View file

@ -0,0 +1,127 @@
package HTTP::Headers::Auth;
use strict;
use warnings;
our $VERSION = '7.01';
use HTTP::Headers;
package
HTTP::Headers;
BEGIN {
# we provide a new (and better) implementations below
undef(&www_authenticate);
undef(&proxy_authenticate);
}
require HTTP::Headers::Util;
sub _parse_authenticate
{
my @ret;
for (HTTP::Headers::Util::split_header_words(@_)) {
if (!defined($_->[1])) {
# this is a new auth scheme
push(@ret, shift(@$_) => {});
shift @$_;
}
if (@ret) {
# this a new parameter pair for the last auth scheme
while (@$_) {
my $k = shift @$_;
my $v = shift @$_;
$ret[-1]{$k} = $v;
}
}
else {
# something wrong, parameter pair without any scheme seen
# IGNORE
}
}
@ret;
}
sub _authenticate
{
my $self = shift;
my $header = shift;
my @old = $self->_header($header);
if (@_) {
$self->remove_header($header);
my @new = @_;
while (@new) {
my $a_scheme = shift(@new);
if ($a_scheme =~ /\s/) {
# assume complete valid value, pass it through
$self->push_header($header, $a_scheme);
}
else {
my @param;
if (@new) {
my $p = $new[0];
if (ref($p) eq "ARRAY") {
@param = @$p;
shift(@new);
}
elsif (ref($p) eq "HASH") {
@param = %$p;
shift(@new);
}
}
my $val = ucfirst(lc($a_scheme));
if (@param) {
my $sep = " ";
while (@param) {
my $k = shift @param;
my $v = shift @param;
if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") {
# must quote the value
$v =~ s,([\\\"]),\\$1,g;
$v = qq("$v");
}
$val .= "$sep$k=$v";
$sep = ", ";
}
}
$self->push_header($header, $val);
}
}
}
return unless defined wantarray;
wantarray ? _parse_authenticate(@old) : join(", ", @old);
}
sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) }
sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
HTTP::Headers::Auth
=head1 VERSION
version 7.01
=head1 AUTHOR
Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1994 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

123
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Headers/ETag.pm Normal file
View file

@ -0,0 +1,123 @@
package HTTP::Headers::ETag;
use strict;
use warnings;
our $VERSION = '7.01';
require HTTP::Date;
require HTTP::Headers;
package
HTTP::Headers;
sub _etags
{
my $self = shift;
my $header = shift;
my @old = _split_etag_list($self->_header($header));
if (@_) {
$self->_header($header => join(", ", _split_etag_list(@_)));
}
wantarray ? @old : join(", ", @old);
}
sub etag { shift->_etags("ETag", @_); }
sub if_match { shift->_etags("If-Match", @_); }
sub if_none_match { shift->_etags("If-None-Match", @_); }
sub if_range {
# Either a date or an entity-tag
my $self = shift;
my @old = $self->_header("If-Range");
if (@_) {
my $new = shift;
if (!defined $new) {
$self->remove_header("If-Range");
}
elsif ($new =~ /^\d+$/) {
$self->_date_header("If-Range", $new);
}
else {
$self->_etags("If-Range", $new);
}
}
return unless defined(wantarray);
for (@old) {
my $t = HTTP::Date::str2time($_);
$_ = $t if $t;
}
wantarray ? @old : join(", ", @old);
}
# Split a list of entity tag values. The return value is a list
# consisting of one element per entity tag. Suitable for parsing
# headers like C<If-Match>, C<If-None-Match>. You might even want to
# use it on C<ETag> and C<If-Range> entity tag values, because it will
# normalize them to the common form.
#
# entity-tag = [ weak ] opaque-tag
# weak = "W/"
# opaque-tag = quoted-string
sub _split_etag_list
{
my(@val) = @_;
my @res;
for (@val) {
while (length) {
my $weak = "";
$weak = "W/" if s,^\s*[wW]/,,;
my $etag = "";
if (s/^\s*(\"[^\"\\]*(?:\\.[^\"\\]*)*\")//) {
push(@res, "$weak$1");
}
elsif (s/^\s*,//) {
push(@res, qq(W/"")) if $weak;
}
elsif (s/^\s*([^,\s]+)//) {
$etag = $1;
$etag =~ s/([\"\\])/\\$1/g;
push(@res, qq($weak"$etag"));
}
elsif (s/^\s+// || !length) {
push(@res, qq(W/"")) if $weak;
}
else {
die "This should not happen: '$_'";
}
}
}
@res;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
HTTP::Headers::ETag
=head1 VERSION
version 7.01
=head1 AUTHOR
Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1994 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

213
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Headers/Util.pm Normal file
View file

@ -0,0 +1,213 @@
package HTTP::Headers::Util;
use strict;
use warnings;
our $VERSION = '7.01';
use Exporter 5.57 'import';
our @EXPORT_OK=qw(split_header_words _split_header_words join_header_words);
sub split_header_words {
my @res = &_split_header_words;
for my $arr (@res) {
for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
$arr->[$i] = lc($arr->[$i]);
}
}
return @res;
}
sub _split_header_words
{
my(@val) = @_;
my @res;
for (@val) {
my @cur;
while (length) {
if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute'
push(@cur, $1);
# a quoted value
if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
my $val = $1;
$val =~ s/\\(.)/$1/g;
push(@cur, $val);
# some unquoted value
}
elsif (s/^\s*=\s*([^;,\s]*)//) {
my $val = $1;
$val =~ s/\s+$//;
push(@cur, $val);
# no value, a lone token
}
else {
push(@cur, undef);
}
}
elsif (s/^\s*,//) {
push(@res, [@cur]) if @cur;
@cur = ();
}
elsif (s/^\s*;// || s/^\s+// || s/^=//) {
# continue
}
else {
die "This should not happen: '$_'";
}
}
push(@res, \@cur) if @cur;
}
@res;
}
sub join_header_words
{
@_ = ([@_]) if @_ && !ref($_[0]);
my @res;
for (@_) {
my @cur = @$_;
my @attr;
while (@cur) {
my $k = shift @cur;
my $v = shift @cur;
if (defined $v) {
if ($v =~ /[\x00-\x20()<>@,;:\\\"\/\[\]?={}\x7F-\xFF]/ || !length($v)) {
$v =~ s/([\"\\])/\\$1/g; # escape " and \
$k .= qq(="$v");
}
else {
# token
$k .= "=$v";
}
}
push(@attr, $k);
}
push(@res, join("; ", @attr)) if @attr;
}
join(", ", @res);
}
1;
=pod
=encoding UTF-8
=head1 NAME
HTTP::Headers::Util - Header value parsing utility functions
=head1 VERSION
version 7.01
=head1 SYNOPSIS
use HTTP::Headers::Util qw(split_header_words);
@values = split_header_words($h->header("Content-Type"));
=head1 DESCRIPTION
This module provides a few functions that helps parsing and
construction of valid HTTP header values. None of the functions are
exported by default.
The following functions are available:
=over 4
=item split_header_words( @header_values )
This function will parse the header values given as argument into a
list of anonymous arrays containing key/value pairs. The function
knows how to deal with ",", ";" and "=" as well as quoted values after
"=". A list of space separated tokens are parsed as if they were
separated by ";".
If the @header_values passed as argument contains multiple values,
then they are treated as if they were a single value separated by
comma ",".
This means that this function is useful for parsing header fields that
follow this syntax (BNF as from the HTTP/1.1 specification, but we relax
the requirement for tokens).
headers = #header
header = (token | parameter) *( [";"] (token | parameter))
token = 1*<any CHAR except CTLs or separators>
separators = "(" | ")" | "<" | ">" | "@"
| "," | ";" | ":" | "\" | <">
| "/" | "[" | "]" | "?" | "="
| "{" | "}" | SP | HT
quoted-string = ( <"> *(qdtext | quoted-pair ) <"> )
qdtext = <any TEXT except <">>
quoted-pair = "\" CHAR
parameter = attribute "=" value
attribute = token
value = token | quoted-string
Each I<header> is represented by an anonymous array of key/value
pairs. The keys will be all be forced to lower case.
The value for a simple token (not part of a parameter) is C<undef>.
Syntactically incorrect headers will not necessarily be parsed as you
would want.
This is easier to describe with some examples:
split_header_words('foo="bar"; port="80,81"; DISCARD, BAR=baz');
split_header_words('text/html; charset="iso-8859-1"');
split_header_words('Basic realm="\\"foo\\\\bar\\""');
will return
[foo=>'bar', port=>'80,81', discard=> undef], [bar=>'baz' ]
['text/html' => undef, charset => 'iso-8859-1']
[basic => undef, realm => "\"foo\\bar\""]
If you don't want the function to convert tokens and attribute keys to
lower case you can call it as C<_split_header_words> instead (with a
leading underscore).
=item join_header_words( @arrays )
This will do the opposite of the conversion done by split_header_words().
It takes a list of anonymous arrays as arguments (or a list of
key/value pairs) and produces a single header value. Attribute values
are quoted if needed.
Example:
join_header_words(["text/plain" => undef, charset => "iso-8859/1"]);
join_header_words("text/plain" => undef, charset => "iso-8859/1");
will both return the string:
text/plain; charset="iso-8859/1"
=back
=head1 AUTHOR
Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1994 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
#ABSTRACT: Header value parsing utility functions

1241
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Message.pm Normal file
View file

File diff suppressed because it is too large Load diff

352
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Request.pm Normal file
View file

@ -0,0 +1,352 @@
package HTTP::Request;
use strict;
use warnings;
our $VERSION = '7.01';
use parent 'HTTP::Message';
sub new
{
my($class, $method, $uri, $header, $content) = @_;
my $self = $class->SUPER::new($header, $content);
$self->method($method);
$self->uri($uri);
$self;
}
sub parse
{
my($class, $str) = @_;
Carp::carp('Undefined argument to parse()') if $^W && ! defined $str;
my $request_line;
if (defined $str && $str =~ s/^(.*)\n//) {
$request_line = $1;
}
else {
$request_line = $str;
$str = "";
}
my $self = $class->SUPER::parse($str);
if (defined $request_line) {
my($method, $uri, $protocol) = split(' ', $request_line);
$self->method($method);
$self->uri($uri) if defined($uri);
$self->protocol($protocol) if $protocol;
}
$self;
}
sub clone
{
my $self = shift;
my $clone = bless $self->SUPER::clone, ref($self);
$clone->method($self->method);
$clone->uri($self->uri);
$clone;
}
sub method
{
shift->_elem('_method', @_);
}
sub uri
{
my $self = shift;
my $old = $self->{'_uri'};
if (@_) {
my $uri = shift;
if (!defined $uri) {
# that's ok
}
elsif (ref $uri) {
Carp::croak("A URI can't be a " . ref($uri) . " reference")
if ref($uri) eq 'HASH' or ref($uri) eq 'ARRAY';
Carp::croak("Can't use a " . ref($uri) . " object as a URI")
unless $uri->can('scheme') && $uri->can('canonical');
$uri = $uri->clone;
unless ($HTTP::URI_CLASS eq "URI") {
# Argh!! Hate this... old LWP legacy!
eval { local $SIG{__DIE__}; $uri = $uri->abs; };
die $@ if $@ && $@ !~ /Missing base argument/;
}
}
else {
$uri = $HTTP::URI_CLASS->new($uri);
}
$self->{'_uri'} = $uri;
delete $self->{'_uri_canonical'};
}
$old;
}
*url = \&uri; # legacy
sub uri_canonical
{
my $self = shift;
my $uri = $self->{_uri};
if (defined (my $canon = $self->{_uri_canonical})) {
# early bailout if these are the exact same string;
# rely on stringification of the URI objects
return $canon if $canon eq $uri;
}
# otherwise we need to refresh the memoized value
$self->{_uri_canonical} = $uri->canonical;
}
sub accept_decodable
{
my $self = shift;
$self->header("Accept-Encoding", scalar($self->decodable));
}
sub as_string
{
my $self = shift;
my($eol) = @_;
$eol = "\n" unless defined $eol;
my $req_line = $self->method || "-";
my $uri = $self->uri;
$uri = (defined $uri) ? $uri->as_string : "-";
$req_line .= " $uri";
my $proto = $self->protocol;
$req_line .= " $proto" if $proto;
return join($eol, $req_line, $self->SUPER::as_string($eol));
}
sub dump
{
my $self = shift;
my @pre = ($self->method || "-", $self->uri || "-");
if (my $prot = $self->protocol) {
push(@pre, $prot);
}
return $self->SUPER::dump(
preheader => join(" ", @pre),
@_,
);
}
1;
=pod
=encoding UTF-8
=head1 NAME
HTTP::Request - HTTP style request message
=head1 VERSION
version 7.01
=head1 SYNOPSIS
require HTTP::Request;
$request = HTTP::Request->new(GET => 'http://www.example.com/');
and usually used like this:
$ua = LWP::UserAgent->new;
$response = $ua->request($request);
=head1 DESCRIPTION
C<HTTP::Request> is a class encapsulating HTTP style requests,
consisting of a request line, some headers, and a content body. Note
that the LWP library uses HTTP style requests even for non-HTTP
protocols. Instances of this class are usually passed to the
request() method of an C<LWP::UserAgent> object.
C<HTTP::Request> is a subclass of C<HTTP::Message> and therefore
inherits its methods. The following additional methods are available:
=over 4
=item $r = HTTP::Request->new( $method, $uri )
=item $r = HTTP::Request->new( $method, $uri, $header )
=item $r = HTTP::Request->new( $method, $uri, $header, $content )
Constructs a new C<HTTP::Request> object describing a request on the
object $uri using method $method. The $method argument must be a
string. The $uri argument can be either a string, or a reference to a
C<URI> object. The optional $header argument should be a reference to
an C<HTTP::Headers> object or a plain array reference of key/value
pairs. The optional $content argument should be a string of bytes.
=item $r = HTTP::Request->parse( $str )
This constructs a new request object by parsing the given string.
=item $r->method
=item $r->method( $val )
This is used to get/set the method attribute. The method should be a
short string like "GET", "HEAD", "PUT", "PATCH" or "POST".
=item $r->uri
=item $r->uri( $val )
This is used to get/set the uri attribute. The $val can be a
reference to a URI object or a plain string. If a string is given,
then it should be parsable as an absolute URI.
=item $r->header( $field )
=item $r->header( $field => $value )
This is used to get/set header values and it is inherited from
C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
details and other similar methods that can be used to access the
headers.
=item $r->accept_decodable
This will set the C<Accept-Encoding> header to the list of encodings
that decoded_content() can decode.
=item $r->content
=item $r->content( $bytes )
This is used to get/set the content and it is inherited from the
C<HTTP::Message> base class. See L<HTTP::Message> for details and
other methods that can be used to access the content.
Note that the content should be a string of bytes. Strings in perl
can contain characters outside the range of a byte. The C<Encode>
module can be used to turn such strings into a string of bytes.
=item $r->as_string
=item $r->as_string( $eol )
Method returning a textual representation of the request.
=back
=head1 EXAMPLES
Creating requests to be sent with L<LWP::UserAgent> or others can be easy. Here
are a few examples.
=head2 Simple POST
Here, we'll create a simple POST request that could be used to send JSON data
to an endpoint.
#!/usr/bin/env perl
use strict;
use warnings;
use HTTP::Request ();
use JSON::MaybeXS qw(encode_json);
my $url = 'https://www.example.com/api/user/123';
my $header = ['Content-Type' => 'application/json; charset=UTF-8'];
my $data = {foo => 'bar', baz => 'quux'};
my $encoded_data = encode_json($data);
my $r = HTTP::Request->new('POST', $url, $header, $encoded_data);
# at this point, we could send it via LWP::UserAgent
# my $ua = LWP::UserAgent->new();
# my $res = $ua->request($r);
=head2 Batch POST Request
Some services, like Google, allow multiple requests to be sent in one batch.
L<https://developers.google.com/drive/v3/web/batch> for example. Using the
C<add_part> method from L<HTTP::Message> makes this simple.
#!/usr/bin/env perl
use strict;
use warnings;
use HTTP::Request ();
use JSON::MaybeXS qw(encode_json);
my $auth_token = 'auth_token';
my $batch_url = 'https://www.googleapis.com/batch';
my $url = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id';
my $url_no_email = 'https://www.googleapis.com/drive/v3/files/fileId/permissions?fields=id&sendNotificationEmail=false';
# generate a JSON post request for one of the batch entries
my $req1 = build_json_request($url, {
emailAddress => 'example@appsrocks.com',
role => "writer",
type => "user",
});
# generate a JSON post request for one of the batch entries
my $req2 = build_json_request($url_no_email, {
domain => "appsrocks.com",
role => "reader",
type => "domain",
});
# generate a multipart request to send all of the other requests
my $r = HTTP::Request->new('POST', $batch_url, [
'Accept-Encoding' => 'gzip',
# if we don't provide a boundary here, HTTP::Message will generate
# one for us. We could use UUID::uuid() here if we wanted.
'Content-Type' => 'multipart/mixed; boundary=END_OF_PART'
]);
# add the two POST requests to the main request
$r->add_part($req1, $req2);
# at this point, we could send it via LWP::UserAgent
# my $ua = LWP::UserAgent->new();
# my $res = $ua->request($r);
exit();
sub build_json_request {
my ($url, $href) = @_;
my $header = ['Authorization' => "Bearer $auth_token", 'Content-Type' => 'application/json; charset=UTF-8'];
return HTTP::Request->new('POST', $url, $header, encode_json($href));
}
=head1 SEE ALSO
L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Request::Common>,
L<HTTP::Response>
=head1 AUTHOR
Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1994 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
#ABSTRACT: HTTP style request message

577
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Request/Common.pm Normal file
View file

@ -0,0 +1,577 @@
package HTTP::Request::Common;
use strict;
use warnings;
our $VERSION = '7.01';
our $DYNAMIC_FILE_UPLOAD ||= 0; # make it defined (don't know why)
our $READ_BUFFER_SIZE = 8192;
use Exporter 5.57 'import';
our @EXPORT =qw(GET HEAD PUT PATCH POST OPTIONS);
our @EXPORT_OK = qw($DYNAMIC_FILE_UPLOAD DELETE);
require HTTP::Request;
use Carp();
use File::Spec;
my $CRLF = "\015\012"; # "\r\n" is not portable
sub GET { _simple_req('GET', @_); }
sub HEAD { _simple_req('HEAD', @_); }
sub DELETE { _simple_req('DELETE', @_); }
sub PATCH { request_type_with_data('PATCH', @_); }
sub POST { request_type_with_data('POST', @_); }
sub PUT { request_type_with_data('PUT', @_); }
sub OPTIONS { request_type_with_data('OPTIONS', @_); }
sub request_type_with_data
{
my $type = shift;
my $url = shift;
my $req = HTTP::Request->new($type => $url);
my $content;
$content = shift if @_ and ref $_[0];
my($k, $v);
while (($k,$v) = splice(@_, 0, 2)) {
if (lc($k) eq 'content') {
$content = $v;
}
else {
$req->push_header($k, $v);
}
}
my $ct = $req->header('Content-Type');
unless ($ct) {
$ct = 'application/x-www-form-urlencoded';
}
elsif ($ct eq 'form-data') {
$ct = 'multipart/form-data';
}
if (ref $content) {
if ($ct =~ m,^multipart/form-data\s*(;|$),i) {
require HTTP::Headers::Util;
my @v = HTTP::Headers::Util::split_header_words($ct);
Carp::carp("Multiple Content-Type headers") if @v > 1;
@v = @{$v[0]};
my $boundary;
my $boundary_index;
for (my @tmp = @v; @tmp;) {
my($k, $v) = splice(@tmp, 0, 2);
if ($k eq "boundary") {
$boundary = $v;
$boundary_index = @v - @tmp - 1;
last;
}
}
($content, $boundary) = form_data($content, $boundary, $req);
if ($boundary_index) {
$v[$boundary_index] = $boundary;
}
else {
push(@v, boundary => $boundary);
}
$ct = HTTP::Headers::Util::join_header_words(@v);
}
else {
# We use a temporary URI object to format
# the application/x-www-form-urlencoded content.
require URI;
my $url = URI->new('http:');
$url->query_form(ref($content) eq "HASH" ? %$content : @$content);
$content = $url->query;
}
}
$req->header('Content-Type' => $ct); # might be redundant
if (defined($content)) {
$req->header('Content-Length' =>
length($content)) unless ref($content);
$req->content($content);
}
else {
$req->header('Content-Length' => 0);
}
$req;
}
sub _simple_req
{
my($method, $url) = splice(@_, 0, 2);
my $req = HTTP::Request->new($method => $url);
my($k, $v);
my $content;
while (($k,$v) = splice(@_, 0, 2)) {
if (lc($k) eq 'content') {
$req->add_content($v);
$content++;
}
else {
$req->push_header($k, $v);
}
}
if ($content && !defined($req->header("Content-Length"))) {
$req->header("Content-Length", length(${$req->content_ref}));
}
$req;
}
sub form_data # RFC1867
{
my($data, $boundary, $req) = @_;
my @data = ref($data) eq "HASH" ? %$data : @$data; # copy
my $fhparts;
my @parts;
while (my ($k,$v) = splice(@data, 0, 2)) {
if (!ref($v)) {
$k =~ s/([\\\"])/\\$1/g; # escape quotes and backslashes
no warnings 'uninitialized';
push(@parts,
qq(Content-Disposition: form-data; name="$k"$CRLF$CRLF$v));
}
else {
my($file, $usename, @headers) = @$v;
unless (defined $usename) {
$usename = $file;
$usename = (File::Spec->splitpath($usename))[-1] if defined($usename);
}
$k =~ s/([\\\"])/\\$1/g;
my $disp = qq(form-data; name="$k");
if (defined($usename) and length($usename)) {
$usename =~ s/([\\\"])/\\$1/g;
$disp .= qq(; filename="$usename");
}
my $content = "";
my $h = HTTP::Headers->new(@headers);
if ($file) {
open(my $fh, "<", $file) or Carp::croak("Can't open file $file: $!");
binmode($fh);
if ($DYNAMIC_FILE_UPLOAD) {
# will read file later, close it now in order to
# not accumulate to many open file handles
close($fh);
$content = \$file;
}
else {
local($/) = undef; # slurp files
$content = <$fh>;
close($fh);
}
unless ($h->header("Content-Type")) {
require LWP::MediaTypes;
LWP::MediaTypes::guess_media_type($file, $h);
}
}
if ($h->header("Content-Disposition")) {
# just to get it sorted first
$disp = $h->header("Content-Disposition");
$h->remove_header("Content-Disposition");
}
if ($h->header("Content")) {
$content = $h->header("Content");
$h->remove_header("Content");
}
my $head = join($CRLF, "Content-Disposition: $disp",
$h->as_string($CRLF),
"");
if (ref $content) {
push(@parts, [$head, $$content]);
$fhparts++;
}
else {
push(@parts, $head . $content);
}
}
}
return ("", "none") unless @parts;
my $content;
if ($fhparts) {
$boundary = boundary(10) # hopefully enough randomness
unless $boundary;
# add the boundaries to the @parts array
for (1..@parts-1) {
splice(@parts, $_*2-1, 0, "$CRLF--$boundary$CRLF");
}
unshift(@parts, "--$boundary$CRLF");
push(@parts, "$CRLF--$boundary--$CRLF");
# See if we can generate Content-Length header
my $length = 0;
for (@parts) {
if (ref $_) {
my ($head, $f) = @$_;
my $file_size;
unless ( -f $f && ($file_size = -s _) ) {
# The file is either a dynamic file like /dev/audio
# or perhaps a file in the /proc file system where
# stat may return a 0 size even though reading it
# will produce data. So we cannot make
# a Content-Length header.
undef $length;
last;
}
$length += $file_size + length $head;
}
else {
$length += length;
}
}
$length && $req->header('Content-Length' => $length);
# set up a closure that will return content piecemeal
$content = sub {
for (;;) {
unless (@parts) {
defined $length && $length != 0 &&
Carp::croak "length of data sent did not match calculated Content-Length header. Probably because uploaded file changed in size during transfer.";
return;
}
my $p = shift @parts;
unless (ref $p) {
$p .= shift @parts while @parts && !ref($parts[0]);
defined $length && ($length -= length $p);
return $p;
}
my($buf, $fh) = @$p;
unless (ref($fh)) {
my $file = $fh;
undef($fh);
open($fh, "<", $file) || Carp::croak("Can't open file $file: $!");
binmode($fh);
}
my $buflength = length $buf;
my $n = read($fh, $buf, $READ_BUFFER_SIZE, $buflength);
if ($n) {
$buflength += $n;
unshift(@parts, ["", $fh]);
}
else {
close($fh);
}
if ($buflength) {
defined $length && ($length -= $buflength);
return $buf
}
}
};
}
else {
$boundary = boundary() unless $boundary;
my $bno = 0;
CHECK_BOUNDARY:
{
for (@parts) {
if (index($_, $boundary) >= 0) {
# must have a better boundary
$boundary = boundary(++$bno);
redo CHECK_BOUNDARY;
}
}
last;
}
$content = "--$boundary$CRLF" .
join("$CRLF--$boundary$CRLF", @parts) .
"$CRLF--$boundary--$CRLF";
}
wantarray ? ($content, $boundary) : $content;
}
sub boundary
{
my $size = shift || return "xYzZY";
require MIME::Base64;
my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
$b =~ s/[\W]/X/g; # ensure alnum only
$b;
}
1;
=pod
=encoding UTF-8
=head1 NAME
HTTP::Request::Common - Construct common HTTP::Request objects
=head1 VERSION
version 7.01
=head1 SYNOPSIS
use HTTP::Request::Common;
$ua = LWP::UserAgent->new;
$ua->request(GET 'http://www.sn.no/');
$ua->request(POST 'http://somewhere/foo', foo => bar, bar => foo);
$ua->request(PATCH 'http://somewhere/foo', foo => bar, bar => foo);
$ua->request(PUT 'http://somewhere/foo', foo => bar, bar => foo);
$ua->request(OPTIONS 'http://somewhere/foo', foo => bar, bar => foo);
=head1 DESCRIPTION
This module provides functions that return newly created C<HTTP::Request>
objects. These functions are usually more convenient to use than the
standard C<HTTP::Request> constructor for the most common requests.
Note that L<LWP::UserAgent> has several convenience methods, including
C<get>, C<head>, C<delete>, C<post> and C<put>.
The following functions are provided:
=over 4
=item GET $url
=item GET $url, Header => Value,...
The C<GET> function returns an L<HTTP::Request> object initialized with
the "GET" method and the specified URL. It is roughly equivalent to the
following call
HTTP::Request->new(
GET => $url,
HTTP::Headers->new(Header => Value,...),
)
but is less cluttered. What is different is that a header named
C<Content> will initialize the content part of the request instead of
setting a header field. Note that GET requests should normally not
have a content, so this hack makes more sense for the C<PUT>, C<PATCH>
and C<POST> functions described below.
The C<get(...)> method of L<LWP::UserAgent> exists as a shortcut for
C<< $ua->request(GET ...) >>.
=item HEAD $url
=item HEAD $url, Header => Value,...
Like GET() but the method in the request is "HEAD".
The C<head(...)> method of L<LWP::UserAgent> exists as a shortcut for
C<< $ua->request(HEAD ...) >>.
=item DELETE $url
=item DELETE $url, Header => Value,...
Like C<GET> but the method in the request is C<DELETE>. This function
is not exported by default.
=item PATCH $url
=item PATCH $url, Header => Value,...
=item PATCH $url, $form_ref, Header => Value,...
=item PATCH $url, Header => Value,..., Content => $form_ref
=item PATCH $url, Header => Value,..., Content => $content
The same as C<POST> below, but the method in the request is C<PATCH>.
=item PUT $url
=item PUT $url, Header => Value,...
=item PUT $url, $form_ref, Header => Value,...
=item PUT $url, Header => Value,..., Content => $form_ref
=item PUT $url, Header => Value,..., Content => $content
The same as C<POST> below, but the method in the request is C<PUT>
=item OPTIONS $url
=item OPTIONS $url, Header => Value,...
=item OPTIONS $url, $form_ref, Header => Value,...
=item OPTIONS $url, Header => Value,..., Content => $form_ref
=item OPTIONS $url, Header => Value,..., Content => $content
The same as C<POST> below, but the method in the request is C<OPTIONS>
This was added in version 6.21, so you should require that in your code:
use HTTP::Request::Common 6.21;
=item POST $url
=item POST $url, Header => Value,...
=item POST $url, $form_ref, Header => Value,...
=item POST $url, Header => Value,..., Content => $form_ref
=item POST $url, Header => Value,..., Content => $content
C<POST>, C<PATCH> and C<PUT> all work with the same parameters.
%data = ( title => 'something', body => something else' );
$ua = LWP::UserAgent->new();
$request = HTTP::Request::Common::POST( $url, [ %data ] );
$response = $ua->request($request);
They take a second optional array or hash reference
parameter C<$form_ref>. The content can also be specified
directly using the C<Content> pseudo-header, and you may also provide
the C<$form_ref> this way.
The C<Content> pseudo-header steals a bit of the header field namespace as
there is no way to directly specify a header that is actually called
"Content". If you really need this you must update the request
returned in a separate statement.
The C<$form_ref> argument can be used to pass key/value pairs for the
form content. By default we will initialize a request using the
C<application/x-www-form-urlencoded> content type. This means that
you can emulate an HTML E<lt>form> POSTing like this:
POST 'http://www.perl.org/survey.cgi',
[ name => 'Gisle Aas',
email => 'gisle@aas.no',
gender => 'M',
born => '1964',
perc => '3%',
];
This will create an L<HTTP::Request> object that looks like this:
POST http://www.perl.org/survey.cgi
Content-Length: 66
Content-Type: application/x-www-form-urlencoded
name=Gisle%20Aas&email=gisle%40aas.no&gender=M&born=1964&perc=3%25
Multivalued form fields can be specified by either repeating the field
name or by passing the value as an array reference.
The POST method also supports the C<multipart/form-data> content used
for I<Form-based File Upload> as specified in RFC 1867. You trigger
this content format by specifying a content type of C<'form-data'> as
one of the request headers. If one of the values in the C<$form_ref> is
an array reference, then it is treated as a file part specification
with the following interpretation:
[ $file, $filename, Header => Value... ]
[ undef, $filename, Header => Value,..., Content => $content ]
The first value in the array ($file) is the name of a file to open.
This file will be read and its content placed in the request. The
routine will croak if the file can't be opened. Use an C<undef> as
$file value if you want to specify the content directly with a
C<Content> header. The $filename is the filename to report in the
request. If this value is undefined, then the basename of the $file
will be used. You can specify an empty string as $filename if you
want to suppress sending the filename when you provide a $file value.
If a $file is provided by no C<Content-Type> header, then C<Content-Type>
and C<Content-Encoding> will be filled in automatically with the values
returned by C<LWP::MediaTypes::guess_media_type()>
Sending my F<~/.profile> to the survey used as example above can be
achieved by this:
POST 'http://www.perl.org/survey.cgi',
Content_Type => 'form-data',
Content => [ name => 'Gisle Aas',
email => 'gisle@aas.no',
gender => 'M',
born => '1964',
init => ["$ENV{HOME}/.profile"],
]
This will create an L<HTTP::Request> object that almost looks this (the
boundary and the content of your F<~/.profile> is likely to be
different):
POST http://www.perl.org/survey.cgi
Content-Length: 388
Content-Type: multipart/form-data; boundary="6G+f"
--6G+f
Content-Disposition: form-data; name="name"
Gisle Aas
--6G+f
Content-Disposition: form-data; name="email"
gisle@aas.no
--6G+f
Content-Disposition: form-data; name="gender"
M
--6G+f
Content-Disposition: form-data; name="born"
1964
--6G+f
Content-Disposition: form-data; name="init"; filename=".profile"
Content-Type: text/plain
PATH=/local/perl/bin:$PATH
export PATH
--6G+f--
If you set the C<$DYNAMIC_FILE_UPLOAD> variable (exportable) to some TRUE
value, then you get back a request object with a subroutine closure as
the content attribute. This subroutine will read the content of any
files on demand and return it in suitable chunks. This allow you to
upload arbitrary big files without using lots of memory. You can even
upload infinite files like F</dev/audio> if you wish; however, if
the file is not a plain file, there will be no C<Content-Length> header
defined for the request. Not all servers (or server
applications) like this. Also, if the file(s) change in size between
the time the C<Content-Length> is calculated and the time that the last
chunk is delivered, the subroutine will C<Croak>.
The C<post(...)> method of L<LWP::UserAgent> exists as a shortcut for
C<< $ua->request(POST ...) >>.
=back
=head1 SEE ALSO
L<HTTP::Request>, L<LWP::UserAgent>
Also, there are some examples in L<HTTP::Request/"EXAMPLES"> that you might
find useful. For example, batch requests are explained there.
=head1 AUTHOR
Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1994 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
#ABSTRACT: Construct common HTTP::Request objects

671
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Response.pm Normal file
View file

@ -0,0 +1,671 @@
package HTTP::Response;
use strict;
use warnings;
our $VERSION = '7.01';
use parent 'HTTP::Message';
use HTTP::Status ();
sub new
{
my($class, $rc, $msg, $header, $content) = @_;
my $self = $class->SUPER::new($header, $content);
$self->code($rc);
$self->message($msg);
$self;
}
sub parse
{
my($class, $str) = @_;
Carp::carp('Undefined argument to parse()') if $^W && ! defined $str;
my $status_line;
if (defined $str && $str =~ s/^(.*)\n//) {
$status_line = $1;
}
else {
$status_line = $str;
$str = "";
}
$status_line =~ s/\r\z// if defined $status_line;
my $self = $class->SUPER::parse($str);
if (defined $status_line) {
my($protocol, $code, $message);
if ($status_line =~ /^\d{3} /) {
# Looks like a response created by HTTP::Response->new
($code, $message) = split(' ', $status_line, 2);
} else {
($protocol, $code, $message) = split(' ', $status_line, 3);
}
$self->protocol($protocol) if $protocol;
$self->code($code) if defined($code);
$self->message($message) if defined($message);
}
$self;
}
sub clone
{
my $self = shift;
my $clone = bless $self->SUPER::clone, ref($self);
$clone->code($self->code);
$clone->message($self->message);
$clone->request($self->request->clone) if $self->request;
# we don't clone previous
$clone;
}
sub code { shift->_elem('_rc', @_); }
sub message { shift->_elem('_msg', @_); }
sub previous { shift->_elem('_previous',@_); }
sub request { shift->_elem('_request', @_); }
sub status_line
{
my $self = shift;
my $code = $self->{'_rc'} || "000";
my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
return "$code $mess";
}
sub base
{
my $self = shift;
my $base = (
$self->header('Content-Base'), # used to be HTTP/1.1
$self->header('Base'), # HTTP/1.0
)[0];
if ($base && $base =~ /^$URI::scheme_re:/o) {
# already absolute
return $HTTP::URI_CLASS->new($base);
}
my $req = $self->request;
if ($req) {
# if $base is undef here, the return value is effectively
# just a copy of $self->request->uri.
return $HTTP::URI_CLASS->new_abs($base, $req->uri);
}
# can't find an absolute base
return undef;
}
sub redirects {
my $self = shift;
my @r;
my $r = $self;
while (my $p = $r->previous) {
push(@r, $p);
$r = $p;
}
return @r unless wantarray;
return reverse @r;
}
sub filename
{
my $self = shift;
my $file;
my $cd = $self->header('Content-Disposition');
if ($cd) {
require HTTP::Headers::Util;
if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
my ($disposition, undef, %cd_param) = @{$cd[-1]};
$file = $cd_param{filename};
# RFC 2047 encoded?
if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
my $charset = $1;
my $encoding = uc($2);
my $encfile = $3;
if ($encoding eq 'Q' || $encoding eq 'B') {
local($SIG{__DIE__});
eval {
if ($encoding eq 'Q') {
$encfile =~ s/_/ /g;
require MIME::QuotedPrint;
$encfile = MIME::QuotedPrint::decode($encfile);
}
else { # $encoding eq 'B'
require MIME::Base64;
$encfile = MIME::Base64::decode($encfile);
}
require Encode;
require Encode::Locale;
Encode::from_to($encfile, $charset, "locale_fs");
};
$file = $encfile unless $@;
}
}
}
}
unless (defined($file) && length($file)) {
my $uri;
if (my $cl = $self->header('Content-Location')) {
$uri = URI->new($cl);
}
elsif (my $request = $self->request) {
$uri = $request->uri;
}
if ($uri) {
$file = ($uri->path_segments)[-1];
}
}
if ($file) {
$file =~ s,.*[\\/],,; # basename
}
if ($file && !length($file)) {
$file = undef;
}
$file;
}
sub as_string
{
my $self = shift;
my($eol) = @_;
$eol = "\n" unless defined $eol;
my $status_line = $self->status_line;
my $proto = $self->protocol;
$status_line = "$proto $status_line" if $proto;
return join($eol, $status_line, $self->SUPER::as_string($eol));
}
sub dump
{
my $self = shift;
my $status_line = $self->status_line;
my $proto = $self->protocol;
$status_line = "$proto $status_line" if $proto;
return $self->SUPER::dump(
preheader => $status_line,
@_,
);
}
sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }
sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
sub is_client_error { HTTP::Status::is_client_error (shift->{'_rc'}); }
sub is_server_error { HTTP::Status::is_server_error (shift->{'_rc'}); }
sub error_as_HTML
{
my $self = shift;
my $title = 'An Error Occurred';
my $body = $self->status_line;
$body =~ s/&/&amp;/g;
$body =~ s/</&lt;/g;
return <<EOM;
<html>
<head><title>$title</title></head>
<body>
<h1>$title</h1>
<p>$body</p>
</body>
</html>
EOM
}
sub current_age
{
my $self = shift;
my $time = shift;
# Implementation of RFC 2616 section 13.2.3
# (age calculations)
my $response_time = $self->client_date;
my $date = $self->date;
my $age = 0;
if ($response_time && $date) {
$age = $response_time - $date; # apparent_age
$age = 0 if $age < 0;
}
my $age_v = $self->header('Age');
if ($age_v && $age_v > $age) {
$age = $age_v; # corrected_received_age
}
if ($response_time) {
my $request = $self->request;
if ($request) {
my $request_time = $request->date;
if ($request_time && $request_time < $response_time) {
# Add response_delay to age to get 'corrected_initial_age'
$age += $response_time - $request_time;
}
}
$age += ($time || time) - $response_time;
}
return $age;
}
sub freshness_lifetime
{
my($self, %opt) = @_;
# First look for the Cache-Control: max-age=n header
for my $cc ($self->header('Cache-Control')) {
for my $cc_dir (split(/\s*,\s*/, $cc)) {
return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
}
}
# Next possibility is to look at the "Expires" header
my $date = $self->date || $self->client_date || $opt{time} || time;
if (my $expires = $self->expires) {
return $expires - $date;
}
# Must apply heuristic expiration
return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
# Default heuristic expiration parameters
$opt{h_min} ||= 60;
$opt{h_max} ||= 24 * 3600;
$opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
$opt{h_default} ||= 3600;
# Should give a warning if more than 24 hours according to
# RFC 2616 section 13.2.4. Here we just make this the default
# maximum value.
if (my $last_modified = $self->last_modified) {
my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
return $opt{h_min} if $h_exp < $opt{h_min};
return $opt{h_max} if $h_exp > $opt{h_max};
return $h_exp;
}
# default when all else fails
return $opt{h_min} if $opt{h_min} > $opt{h_default};
return $opt{h_default};
}
sub is_fresh
{
my($self, %opt) = @_;
$opt{time} ||= time;
my $f = $self->freshness_lifetime(%opt);
return undef unless defined($f);
return $f > $self->current_age($opt{time});
}
sub fresh_until
{
my($self, %opt) = @_;
$opt{time} ||= time;
my $f = $self->freshness_lifetime(%opt);
return undef unless defined($f);
return $f - $self->current_age($opt{time}) + $opt{time};
}
1;
=pod
=encoding UTF-8
=head1 NAME
HTTP::Response - HTTP style response message
=head1 VERSION
version 7.01
=head1 SYNOPSIS
Response objects are returned by the request() method of the C<LWP::UserAgent>:
# ...
$response = $ua->request($request);
if ($response->is_success) {
print $response->decoded_content;
}
else {
print STDERR $response->status_line, "\n";
}
=head1 DESCRIPTION
The C<HTTP::Response> class encapsulates HTTP style responses. A
response consists of a response line, some headers, and a content
body. Note that the LWP library uses HTTP style responses even for
non-HTTP protocol schemes. Instances of this class are usually
created and returned by the request() method of an C<LWP::UserAgent>
object.
C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
inherits its methods. The following additional methods are available:
=over 4
=item $r = HTTP::Response->new( $code )
=item $r = HTTP::Response->new( $code, $msg )
=item $r = HTTP::Response->new( $code, $msg, $header )
=item $r = HTTP::Response->new( $code, $msg, $header, $content )
Constructs a new C<HTTP::Response> object describing a response with
response code $code and optional message $msg. The optional $header
argument should be a reference to an C<HTTP::Headers> object or a
plain array reference of key/value pairs. The optional $content
argument should be a string of bytes. The meanings of these arguments are
described below.
=item $r = HTTP::Response->parse( $str )
This constructs a new response object by parsing the given string.
=item $r->code
=item $r->code( $code )
This is used to get/set the code attribute. The code is a 3 digit
number that encode the overall outcome of an HTTP response. The
C<HTTP::Status> module provide constants that provide mnemonic names
for the code attribute.
=item $r->message
=item $r->message( $message )
This is used to get/set the message attribute. The message is a short
human readable single line string that explains the response code.
=item $r->header( $field )
=item $r->header( $field => $value )
This is used to get/set header values and it is inherited from
C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
details and other similar methods that can be used to access the
headers.
=item $r->content
=item $r->content( $bytes )
This is used to get/set the raw content and it is inherited from the
C<HTTP::Message> base class. See L<HTTP::Message> for details and
other methods that can be used to access the content.
=item $r->decoded_content( %options )
This will return the content after any C<Content-Encoding> and
charsets have been decoded. See L<HTTP::Message> for details.
=item $r->request
=item $r->request( $request )
This is used to get/set the request attribute. The request attribute
is a reference to the request that caused this response. It does
not have to be the same request passed to the $ua->request() method,
because there might have been redirects and authorization retries in
between.
=item $r->previous
=item $r->previous( $response )
This is used to get/set the previous attribute. The previous
attribute is used to link together chains of responses. You get
chains of responses if the first response is redirect or unauthorized.
The value is C<undef> if this is the first response in a chain.
Note that the method $r->redirects is provided as a more convenient
way to access the response chain.
=item $r->status_line
Returns the string "E<lt>code> E<lt>message>". If the message attribute
is not set then the official name of E<lt>code> (see L<HTTP::Status>)
is substituted.
=item $r->base
Returns the base URI for this response. The return value will be a
reference to a URI object.
The base URI is obtained from one the following sources (in priority
order):
=over 4
=item 1.
Embedded in the document content, for instance <BASE HREF="...">
in HTML documents.
=item 2.
A "Content-Base:" header in the response.
For backwards compatibility with older HTTP implementations we will
also look for the "Base:" header.
=item 3.
The URI used to request this response. This might not be the original
URI that was passed to $ua->request() method, because we might have
received some redirect responses first.
=back
If none of these sources provide an absolute URI, undef is returned.
B<Note>: previous versions of HTTP::Response would also consider
a "Content-Location:" header,
as L<RFC 2616|https://www.rfc-editor.org/rfc/rfc2616> said it should be.
But this was never widely implemented by browsers,
and now L<RFC 7231|https://www.rfc-editor.org/rfc/rfc7231>
says it should no longer be considered.
When the LWP protocol modules produce the HTTP::Response object, then any base
URI embedded in the document (step 1) will already have initialized the
"Content-Base:" header. (See L<LWP::UserAgent/parse_head>). This means that
this method only performs the last 2 steps (the content is not always available
either).
=item $r->filename
Returns a filename for this response. Note that doing sanity checks
on the returned filename (eg. removing characters that cannot be used
on the target filesystem where the filename would be used, and
laundering it for security purposes) are the caller's responsibility;
the only related thing done by this method is that it makes a simple
attempt to return a plain filename with no preceding path segments.
The filename is obtained from one the following sources (in priority
order):
=over 4
=item 1.
A "Content-Disposition:" header in the response. Proper decoding of
RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.
=item 2.
A "Content-Location:" header in the response.
=item 3.
The URI used to request this response. This might not be the original
URI that was passed to $ua->request() method, because we might have
received some redirect responses first.
=back
If a filename cannot be derived from any of these sources, undef is
returned.
=item $r->as_string
=item $r->as_string( $eol )
Returns a textual representation of the response.
=item $r->is_info
=item $r->is_success
=item $r->is_redirect
=item $r->is_error
=item $r->is_client_error
=item $r->is_server_error
These methods indicate if the response was informational, successful, a
redirection, or an error. See L<HTTP::Status> for the meaning of these.
=item $r->error_as_HTML
Returns a string containing a complete HTML document indicating what
error occurred. This method should only be called when $r->is_error
is TRUE.
=item $r->redirects
Returns the list of redirect responses that lead up to this response
by following the $r->previous chain. The list order is oldest first.
In scalar context return the number of redirect responses leading up
to this one.
=item $r->current_age
Calculates the "current age" of the response as specified by RFC 2616
section 13.2.3. The age of a response is the time since it was sent
by the origin server. The returned value is a number representing the
age in seconds.
=item $r->freshness_lifetime( %opt )
Calculates the "freshness lifetime" of the response as specified by
RFC 2616 section 13.2.4. The "freshness lifetime" is the length of
time between the generation of a response and its expiration time.
The returned value is the number of seconds until expiry.
If the response does not contain an "Expires" or a "Cache-Control"
header, then this function will apply some simple heuristic based on
the "Last-Modified" header to determine a suitable lifetime. The
following options might be passed to control the heuristics:
=over
=item heuristic_expiry => $bool
If passed as a FALSE value, don't apply heuristics and just return
C<undef> when "Expires" or "Cache-Control" is lacking.
=item h_lastmod_fraction => $num
This number represent the fraction of the difference since the
"Last-Modified" timestamp to make the expiry time. The default is
C<0.10>, the suggested typical setting of 10% in RFC 2616.
=item h_min => $sec
This is the lower limit of the heuristic expiry age to use. The
default is C<60> (1 minute).
=item h_max => $sec
This is the upper limit of the heuristic expiry age to use. The
default is C<86400> (24 hours).
=item h_default => $sec
This is the expiry age to use when nothing else applies. The default
is C<3600> (1 hour) or "h_min" if greater.
=back
=item $r->is_fresh( %opt )
Returns TRUE if the response is fresh, based on the values of
freshness_lifetime() and current_age(). If the response is no longer
fresh, then it has to be re-fetched or re-validated by the origin
server.
Options might be passed to control expiry heuristics, see the
description of freshness_lifetime().
=item $r->fresh_until( %opt )
Returns the time (seconds since epoch) when this entity is no longer fresh.
Options might be passed to control expiry heuristics, see the
description of freshness_lifetime().
=back
=head1 SEE ALSO
L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>
=head1 AUTHOR
Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1994 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
#ABSTRACT: HTTP style response message

389
OGP64/usr/share/perl5/vendor_perl/5.40/HTTP/Status.pm Normal file
View file

@ -0,0 +1,389 @@
package HTTP::Status;
use strict;
use warnings;
our $VERSION = '7.01';
use Exporter 5.57 'import';
our @EXPORT = qw(is_info is_success is_redirect is_error status_message);
our @EXPORT_OK = qw(is_client_error is_server_error is_cacheable_by_default status_constant_name status_codes);
# Note also addition of mnemonics to @EXPORT below
# Unmarked codes are from RFC 7231 (2017-12-20)
# See also:
# https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml
my %StatusCode = (
100 => 'Continue',
101 => 'Switching Protocols',
102 => 'Processing', # RFC 2518: WebDAV
103 => 'Early Hints', # RFC 8297: Indicating Hints
# 104 .. 199
200 => 'OK',
201 => 'Created',
202 => 'Accepted',
203 => 'Non-Authoritative Information',
204 => 'No Content',
205 => 'Reset Content',
206 => 'Partial Content', # RFC 7233: Range Requests
207 => 'Multi-Status', # RFC 4918: WebDAV
208 => 'Already Reported', # RFC 5842: WebDAV bindings
# 209 .. 225
226 => 'IM Used', # RFC 3229: Delta encoding
# 227 .. 299
300 => 'Multiple Choices',
301 => 'Moved Permanently',
302 => 'Found',
303 => 'See Other',
304 => 'Not Modified', # RFC 7232: Conditional Request
305 => 'Use Proxy',
306 => '(Unused)', # RFC 9110: Previously used and reserved
307 => 'Temporary Redirect',
308 => 'Permanent Redirect', # RFC 7528: Permanent Redirect
# 309 .. 399
400 => 'Bad Request',
401 => 'Unauthorized', # RFC 7235: Authentication
402 => 'Payment Required',
403 => 'Forbidden',
404 => 'Not Found',
405 => 'Method Not Allowed',
406 => 'Not Acceptable',
407 => 'Proxy Authentication Required', # RFC 7235: Authentication
408 => 'Request Timeout',
409 => 'Conflict',
410 => 'Gone',
411 => 'Length Required',
412 => 'Precondition Failed', # RFC 7232: Conditional Request
413 => 'Content Too Large',
414 => 'URI Too Long',
415 => 'Unsupported Media Type',
416 => 'Range Not Satisfiable', # RFC 7233: Range Requests
417 => 'Expectation Failed',
418 => "I'm a teapot", # RFC 2324: RFC9110 reserved it
# 419 .. 420
421 => 'Misdirected Request', # RFC 7540: HTTP/2
422 => 'Unprocessable Content', # RFC 9110: WebDAV
423 => 'Locked', # RFC 4918: WebDAV
424 => 'Failed Dependency', # RFC 4918: WebDAV
425 => 'Too Early', # RFC 8470: Using Early Data in HTTP
426 => 'Upgrade Required',
# 427
428 => 'Precondition Required', # RFC 6585: Additional Codes
429 => 'Too Many Requests', # RFC 6585: Additional Codes
# 430
431 => 'Request Header Fields Too Large', # RFC 6585: Additional Codes
# 432 .. 450
451 => 'Unavailable For Legal Reasons', # RFC 7725: Legal Obstacles
# 452 .. 499
500 => 'Internal Server Error',
501 => 'Not Implemented',
502 => 'Bad Gateway',
503 => 'Service Unavailable',
504 => 'Gateway Timeout',
505 => 'HTTP Version Not Supported',
506 => 'Variant Also Negotiates', # RFC 2295: Transparent Ngttn
507 => 'Insufficient Storage', # RFC 4918: WebDAV
508 => 'Loop Detected', # RFC 5842: WebDAV bindings
# 509
510 => 'Not Extended', # RFC 2774: Extension Framework
511 => 'Network Authentication Required', # RFC 6585: Additional Codes
# Keep some unofficial codes that used to be in this distribution
449 => 'Retry with', # microsoft
509 => 'Bandwidth Limit Exceeded', # Apache / cPanel
);
my %StatusCodeName;
my $mnemonicCode = '';
my ($code, $message);
while (($code, $message) = each %StatusCode) {
next if $message eq '(Unused)';
# create mnemonic subroutines
$message =~ s/I'm/I am/;
$message =~ tr/a-z \-/A-Z__/;
my $constant_name = "HTTP_".$message;
$mnemonicCode .= "sub $constant_name () { $code }\n";
$mnemonicCode .= "*RC_$message = \\&HTTP_$message;\n"; # legacy
$mnemonicCode .= "push(\@EXPORT_OK, 'HTTP_$message');\n";
$mnemonicCode .= "push(\@EXPORT, 'RC_$message');\n";
$StatusCodeName{$code} = $constant_name
}
eval $mnemonicCode; # only one eval for speed
die if $@;
# backwards compatibility
*RC_MOVED_TEMPORARILY = \&RC_FOUND; # 302 was renamed in the standard
push(@EXPORT, "RC_MOVED_TEMPORARILY");
my %compat = (
UNPROCESSABLE_ENTITY => \&HTTP_UNPROCESSABLE_CONTENT,
PAYLOAD_TOO_LARGE => \&HTTP_CONTENT_TOO_LARGE,
REQUEST_ENTITY_TOO_LARGE => \&HTTP_CONTENT_TOO_LARGE,
REQUEST_URI_TOO_LARGE => \&HTTP_URI_TOO_LONG,
REQUEST_RANGE_NOT_SATISFIABLE => \&HTTP_RANGE_NOT_SATISFIABLE,
NO_CODE => \&HTTP_TOO_EARLY,
UNORDERED_COLLECTION => \&HTTP_TOO_EARLY,
);
foreach my $name (keys %compat) {
push(@EXPORT, "RC_$name");
push(@EXPORT_OK, "HTTP_$name");
no strict 'refs';
*{"RC_$name"} = $compat{$name};
*{"HTTP_$name"} = $compat{$name};
}
our %EXPORT_TAGS = (
constants => [grep /^HTTP_/, @EXPORT_OK],
is => [grep /^is_/, @EXPORT, @EXPORT_OK],
);
sub status_message ($) { $StatusCode{$_[0]}; }
sub status_constant_name ($) {
exists($StatusCodeName{$_[0]}) ? $StatusCodeName{$_[0]} : undef;
}
sub is_info ($) { $_[0] && $_[0] >= 100 && $_[0] < 200; }
sub is_success ($) { $_[0] && $_[0] >= 200 && $_[0] < 300; }
sub is_redirect ($) { $_[0] && $_[0] >= 300 && $_[0] < 400; }
sub is_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 600; }
sub is_client_error ($) { $_[0] && $_[0] >= 400 && $_[0] < 500; }
sub is_server_error ($) { $_[0] && $_[0] >= 500 && $_[0] < 600; }
sub is_cacheable_by_default ($) { $_[0] && ( $_[0] == 200 # OK
|| $_[0] == 203 # Non-Authoritative Information
|| $_[0] == 204 # No Content
|| $_[0] == 206 # Not Acceptable
|| $_[0] == 300 # Multiple Choices
|| $_[0] == 301 # Moved Permanently
|| $_[0] == 308 # Permanent Redirect
|| $_[0] == 404 # Not Found
|| $_[0] == 405 # Method Not Allowed
|| $_[0] == 410 # Gone
|| $_[0] == 414 # Request-URI Too Large
|| $_[0] == 451 # Unavailable For Legal Reasons
|| $_[0] == 501 # Not Implemented
);
}
sub status_codes { %StatusCode; }
1;
=pod
=encoding UTF-8
=head1 NAME
HTTP::Status - HTTP Status code processing
=head1 VERSION
version 7.01
=head1 SYNOPSIS
use HTTP::Status qw(:constants :is status_message);
if ($rc != HTTP_OK) {
print status_message($rc), "\n";
}
if (is_success($rc)) { ... }
if (is_error($rc)) { ... }
if (is_redirect($rc)) { ... }
=head1 DESCRIPTION
I<HTTP::Status> is a library of routines for defining and
classifying HTTP status codes for libwww-perl. Status codes are
used to encode the overall outcome of an HTTP response message. Codes
correspond to those defined in RFC 2616 and RFC 2518.
=head1 CONSTANTS
The following constant functions can be used as mnemonic status code
names. None of these are exported by default. Use the C<:constants>
tag to import them all.
HTTP_CONTINUE (100)
HTTP_SWITCHING_PROTOCOLS (101)
HTTP_PROCESSING (102)
HTTP_EARLY_HINTS (103)
HTTP_OK (200)
HTTP_CREATED (201)
HTTP_ACCEPTED (202)
HTTP_NON_AUTHORITATIVE_INFORMATION (203)
HTTP_NO_CONTENT (204)
HTTP_RESET_CONTENT (205)
HTTP_PARTIAL_CONTENT (206)
HTTP_MULTI_STATUS (207)
HTTP_ALREADY_REPORTED (208)
HTTP_IM_USED (226)
HTTP_MULTIPLE_CHOICES (300)
HTTP_MOVED_PERMANENTLY (301)
HTTP_FOUND (302)
HTTP_SEE_OTHER (303)
HTTP_NOT_MODIFIED (304)
HTTP_USE_PROXY (305)
HTTP_TEMPORARY_REDIRECT (307)
HTTP_PERMANENT_REDIRECT (308)
HTTP_BAD_REQUEST (400)
HTTP_UNAUTHORIZED (401)
HTTP_PAYMENT_REQUIRED (402)
HTTP_FORBIDDEN (403)
HTTP_NOT_FOUND (404)
HTTP_METHOD_NOT_ALLOWED (405)
HTTP_NOT_ACCEPTABLE (406)
HTTP_PROXY_AUTHENTICATION_REQUIRED (407)
HTTP_REQUEST_TIMEOUT (408)
HTTP_CONFLICT (409)
HTTP_GONE (410)
HTTP_LENGTH_REQUIRED (411)
HTTP_PRECONDITION_FAILED (412)
HTTP_CONTENT_TOO_LARGE (413)
HTTP_URI_TOO_LONG (414)
HTTP_UNSUPPORTED_MEDIA_TYPE (415)
HTTP_RANGE_NOT_SATISFIABLE (416)
HTTP_EXPECTATION_FAILED (417)
HTTP_MISDIRECTED REQUEST (421)
HTTP_UNPROCESSABLE_CONTENT (422)
HTTP_LOCKED (423)
HTTP_FAILED_DEPENDENCY (424)
HTTP_TOO_EARLY (425)
HTTP_UPGRADE_REQUIRED (426)
HTTP_PRECONDITION_REQUIRED (428)
HTTP_TOO_MANY_REQUESTS (429)
HTTP_REQUEST_HEADER_FIELDS_TOO_LARGE (431)
HTTP_UNAVAILABLE_FOR_LEGAL_REASONS (451)
HTTP_INTERNAL_SERVER_ERROR (500)
HTTP_NOT_IMPLEMENTED (501)
HTTP_BAD_GATEWAY (502)
HTTP_SERVICE_UNAVAILABLE (503)
HTTP_GATEWAY_TIMEOUT (504)
HTTP_HTTP_VERSION_NOT_SUPPORTED (505)
HTTP_VARIANT_ALSO_NEGOTIATES (506)
HTTP_INSUFFICIENT_STORAGE (507)
HTTP_LOOP_DETECTED (508)
HTTP_NOT_EXTENDED (510)
HTTP_NETWORK_AUTHENTICATION_REQUIRED (511)
=head1 FUNCTIONS
The following additional functions are provided. Most of them are
exported by default. The C<:is> import tag can be used to import all
the classification functions.
=over 4
=item status_message( $code )
The status_message() function will translate status codes to human
readable strings. The string is the same as found in the constant
names above.
For example, C<status_message(303)> will return C<"Not Found">.
If the $code is not registered in the L<list of IANA HTTP Status
Codes|https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml>
then C<undef> is returned.
=item status_constant_name( $code )
The status_constant_name() function will translate a status code
to a string which has the name of the constant for that status code.
For example, C<status_constant_name(404)> will return C<"HTTP_NOT_FOUND">.
If the C<$code> is not registered in the L<list of IANA HTTP Status
Codes|https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml>
then C<undef> is returned.
=item is_info( $code )
Return TRUE if C<$code> is an I<Informational> status code (1xx). This
class of status code indicates a provisional response which can't have
any content.
=item is_success( $code )
Return TRUE if C<$code> is a I<Successful> status code (2xx).
=item is_redirect( $code )
Return TRUE if C<$code> is a I<Redirection> status code (3xx). This class of
status code indicates that further action needs to be taken by the
user agent in order to fulfill the request.
=item is_error( $code )
Return TRUE if C<$code> is an I<Error> status code (4xx or 5xx). The function
returns TRUE for both client and server error status codes.
=item is_client_error( $code )
Return TRUE if C<$code> is a I<Client Error> status code (4xx). This class
of status code is intended for cases in which the client seems to have
erred.
This function is B<not> exported by default.
=item is_server_error( $code )
Return TRUE if C<$code> is a I<Server Error> status code (5xx). This class
of status codes is intended for cases in which the server is aware
that it has erred or is incapable of performing the request.
This function is B<not> exported by default.
=item is_cacheable_by_default( $code )
Return TRUE if C<$code> indicates that a response is cacheable by default, and
it can be reused by a cache with heuristic expiration. All other status codes
are not cacheable by default. See L<RFC 7231 - HTTP/1.1 Semantics and Content,
Section 6.1. Overview of Status Codes|https://tools.ietf.org/html/rfc7231#section-6.1>.
This function is B<not> exported by default.
=item status_codes
Returns a hash mapping numerical HTTP status code (e.g. 200) to text status messages (e.g. "OK")
This function is B<not> exported by default.
=back
=head1 SEE ALSO
L<IANA HTTP Status Codes|https://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml>
=head1 BUGS
For legacy reasons all the C<HTTP_> constants are exported by default
with the prefix C<RC_>. It's recommended to use explicit imports and
the C<:constants> tag instead of relying on this.
=head1 AUTHOR
Gisle Aas <gisle@activestate.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1994 by Gisle Aas.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
#ABSTRACT: HTTP Status code processing

629
OGP64/usr/share/perl5/vendor_perl/5.40/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

292
OGP64/usr/share/perl5/vendor_perl/5.40/LWP/MediaTypes.pm Normal file
View file

@ -0,0 +1,292 @@
package LWP::MediaTypes;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(guess_media_type media_suffix);
@EXPORT_OK = qw(add_type add_encoding read_media_types);
our $VERSION = '6.04';
use strict;
use Scalar::Util qw(blessed);
use Carp qw(croak);
# note: These hashes will also be filled with the entries found in
# the 'media.types' file.
my %suffixType = (
'txt' => 'text/plain',
'html' => 'text/html',
'gif' => 'image/gif',
'jpg' => 'image/jpeg',
'xml' => 'text/xml',
);
my %suffixExt = (
'text/plain' => 'txt',
'text/html' => 'html',
'image/gif' => 'gif',
'image/jpeg' => 'jpg',
'text/xml' => 'xml',
);
#XXX: there should be some way to define this in the media.types files.
my %suffixEncoding = (
'Z' => 'compress',
'gz' => 'gzip',
'hqx' => 'x-hqx',
'uu' => 'x-uuencode',
'z' => 'x-pack',
'bz2' => 'x-bzip2',
);
read_media_types();
sub guess_media_type
{
my($file, $header) = @_;
return undef unless defined $file;
my $fullname;
if (ref $file) {
croak("Unable to determine filetype on unblessed refs") unless blessed($file);
if ($file->can('path')) {
$file = $file->path;
}
elsif ($file->can('filename')) {
$fullname = $file->filename;
}
else {
$fullname = "" . $file;
}
}
else {
$fullname = $file; # enable peek at actual file
}
my @encoding = ();
my $ct = undef;
for (file_exts($file)) {
# first check this dot part as encoding spec
if (exists $suffixEncoding{$_}) {
unshift(@encoding, $suffixEncoding{$_});
next;
}
if (exists $suffixEncoding{lc $_}) {
unshift(@encoding, $suffixEncoding{lc $_});
next;
}
# check content-type
if (exists $suffixType{$_}) {
$ct = $suffixType{$_};
last;
}
if (exists $suffixType{lc $_}) {
$ct = $suffixType{lc $_};
last;
}
# don't know nothing about this dot part, bail out
last;
}
unless (defined $ct) {
# Take a look at the file
if (defined $fullname) {
$ct = (-T $fullname) ? "text/plain" : "application/octet-stream";
}
else {
$ct = "application/octet-stream";
}
}
if ($header) {
$header->header('Content-Type' => $ct);
$header->header('Content-Encoding' => \@encoding) if @encoding;
}
wantarray ? ($ct, @encoding) : $ct;
}
sub media_suffix {
if (!wantarray && @_ == 1 && $_[0] !~ /\*/) {
return $suffixExt{lc $_[0]};
}
my(@type) = @_;
my(@suffix, $ext, $type);
foreach (@type) {
if (s/\*/.*/) {
while(($ext,$type) = each(%suffixType)) {
push(@suffix, $ext) if $type =~ /^$_$/i;
}
}
else {
my $ltype = lc $_;
while(($ext,$type) = each(%suffixType)) {
push(@suffix, $ext) if lc $type eq $ltype;
}
}
}
wantarray ? @suffix : $suffix[0];
}
sub file_exts
{
require File::Basename;
my @parts = reverse split(/\./, File::Basename::basename($_[0]));
pop(@parts); # never consider first part
@parts;
}
sub add_type
{
my($type, @exts) = @_;
for my $ext (@exts) {
$ext =~ s/^\.//;
$suffixType{$ext} = $type;
}
$suffixExt{lc $type} = $exts[0] if @exts;
}
sub add_encoding
{
my($type, @exts) = @_;
for my $ext (@exts) {
$ext =~ s/^\.//;
$suffixEncoding{$ext} = $type;
}
}
sub read_media_types
{
my(@files) = @_;
local($/, $_) = ("\n", undef); # ensure correct $INPUT_RECORD_SEPARATOR
my @priv_files = ();
push(@priv_files, "$ENV{HOME}/.media.types", "$ENV{HOME}/.mime.types")
if defined $ENV{HOME}; # Some doesn't have a home (for instance Win32)
# Try to locate "media.types" file, and initialize %suffixType from it
my $typefile;
unless (@files) {
@files = map {"$_/LWP/media.types"} @INC;
push @files, @priv_files;
}
for $typefile (@files) {
local(*TYPE);
open(TYPE, $typefile) || next;
while (<TYPE>) {
next if /^\s*#/; # comment line
next if /^\s*$/; # blank line
s/#.*//; # remove end-of-line comments
my($type, @exts) = split(' ', $_);
add_type($type, @exts);
}
close(TYPE);
}
}
1;
__END__
=head1 NAME
LWP::MediaTypes - guess media type for a file or a URL
=head1 SYNOPSIS
use LWP::MediaTypes qw(guess_media_type);
$type = guess_media_type("/tmp/foo.gif");
=head1 DESCRIPTION
This module provides functions for handling media (also known as
MIME) types and encodings. The mapping from file extensions to media
types is defined by the F<media.types> file. If the F<~/.media.types>
file exists it is used instead.
For backwards compatibility we will also look for F<~/.mime.types>.
The following functions are exported by default:
=over 4
=item guess_media_type( $filename )
=item guess_media_type( $uri )
=item guess_media_type( $filename_or_object, $header_to_modify )
This function tries to guess media type and encoding for a file or objects that
support the a C<path> or C<filename> method, eg, L<URI> or L<File::Temp> objects.
When an object does not support either method, it will be stringified to
determine the filename.
It returns the content type, which is a string like C<"text/html">.
In array context it also returns any content encodings applied (in the
order used to encode the file). You can pass a URI object
reference, instead of the file name.
If the type can not be deduced from looking at the file name,
then guess_media_type() will let the C<-T> Perl operator take a look.
If this works (and C<-T> returns a TRUE value) then we return
I<text/plain> as the type, otherwise we return
I<application/octet-stream> as the type.
The optional second argument should be a reference to a HTTP::Headers
object or any object that implements the $obj->header method in a
similar way. When it is present the values of the
'Content-Type' and 'Content-Encoding' will be set for this header.
=item media_suffix( $type, ... )
This function will return all suffixes that can be used to denote the
specified media type(s). Wildcard types can be used. In a scalar
context it will return the first suffix found. Examples:
@suffixes = media_suffix('image/*', 'audio/basic');
$suffix = media_suffix('text/html');
=back
The following functions are only exported by explicit request:
=over 4
=item add_type( $type, @exts )
Associate a list of file extensions with the given media type.
Example:
add_type("x-world/x-vrml" => qw(wrl vrml));
=item add_encoding( $type, @ext )
Associate a list of file extensions with an encoding type.
Example:
add_encoding("x-gzip" => "gz");
=item read_media_types( @files )
Parse media types files and add the type mappings found there.
Example:
read_media_types("conf/mime.types");
=back
=head1 COPYRIGHT
Copyright 1995-1999 Gisle Aas.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

1479
OGP64/usr/share/perl5/vendor_perl/5.40/LWP/media.types Normal file
View file

File diff suppressed because it is too large Load diff

229
OGP64/usr/share/perl5/vendor_perl/5.40/MIME/Base32.pm Normal file
View file

@ -0,0 +1,229 @@
package MIME::Base32;
use 5.008001;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(encode_base32 decode_base32);
our @EXPORT_OK = qw(
encode_rfc3548 decode_rfc3548 encode_09AV decode_09AV
encode_base32hex decode_base32hex
);
our $VERSION = "1.303";
$VERSION = eval $VERSION;
sub encode { return encode_base32(@_) }
sub encode_rfc3548 { return encode_base32(@_) }
sub encode_base32 {
my $arg = shift;
return '' unless defined($arg); # mimic MIME::Base64
$arg = unpack('B*', $arg);
$arg =~ s/(.....)/000$1/g;
my $l = length($arg);
if ($l & 7) {
my $e = substr($arg, $l & ~7);
$arg = substr($arg, 0, $l & ~7);
$arg .= "000$e" . '0' x (5 - length $e);
}
$arg = pack('B*', $arg);
$arg =~ tr|\0-\37|A-Z2-7|;
return $arg;
}
sub decode { return decode_base32(@_) }
sub decode_rfc3548 { return decode_base32(@_) }
sub decode_base32 {
my $arg = uc(shift || ''); # mimic MIME::Base64
$arg =~ tr|A-Z2-7|\0-\37|;
$arg = unpack('B*', $arg);
$arg =~ s/000(.....)/$1/g;
my $l = length $arg;
$arg = substr($arg, 0, $l & ~7) if $l & 7;
$arg = pack('B*', $arg);
return $arg;
}
sub encode_09AV { return encode_base32hex(@_) }
sub encode_base32hex {
my $arg = shift;
return '' unless defined($arg); # mimic MIME::Base64
$arg = unpack('B*', $arg);
$arg =~ s/(.....)/000$1/g;
my $l = length($arg);
if ($l & 7) {
my $e = substr($arg, $l & ~7);
$arg = substr($arg, 0, $l & ~7);
$arg .= "000$e" . '0' x (5 - length $e);
}
$arg = pack('B*', $arg);
$arg =~ tr|\0-\37|0-9A-V|;
return $arg;
}
sub decode_09AV { return decode_base32hex(@_) }
sub decode_base32hex {
my $arg = uc(shift || ''); # mimic MIME::Base64
$arg =~ tr|0-9A-V|\0-\37|;
$arg = unpack('B*', $arg);
$arg =~ s/000(.....)/$1/g;
my $l = length($arg);
$arg = substr($arg, 0, $l & ~7) if $l & 7;
$arg = pack('B*', $arg);
return $arg;
}
1;
=encoding utf8
=head1 NAME
MIME::Base32 - Base32 encoder and decoder
=head1 SYNOPSIS
#!/usr/bin/env perl
use strict;
use warnings;
use MIME::Base32;
my $encoded = encode_base32('Aladdin: open sesame');
my $decoded = decode_base32($encoded);
=head1 DESCRIPTION
This module is for encoding/decoding data much the way that L<MIME::Base64> does.
Prior to version 1.0, L<MIME::Base32> used the C<base32hex> (or C<[0-9A-V]>) encoding and
decoding methods by default. If you need to maintain that behavior, please call
C<encode_base32hex> or C<decode_base32hex> functions directly.
Now, in accordance with L<RFC-3548, Section 5|https://tools.ietf.org/html/rfc3548#section-5>,
L<MIME::Base32> uses the C<encode_base32> and C<decode_base32> functions by default.
=head1 FUNCTIONS
The following primary functions are provided:
=head2 decode
Synonym for C<decode_base32>
=head2 decode_rfc3548
Synonym for C<decode_base32>
=head2 decode_base32
my $string = decode_base32($encoded_data);
Decode some encoded data back into a string of text or binary data.
=head2 decode_09AV
Synonym for C<decode_base32hex>
=head2 decode_base32hex
my $string_or_binary_data = MIME::Base32::decode_base32hex($encoded_data);
Decode some encoded data back into a string of text or binary data.
=head2 encode
Synonym for C<encode_base32>
=head2 encode_rfc3548
Synonym for C<encode_base32>
=head2 encode_base32
my $encoded = encode_base32("some string");
Encode a string of text or binary data.
=head2 encode_09AV
Synonym for C<encode_base32hex>
=head2 encode_base32hex
my $encoded = MIME::Base32::encode_base32hex("some string");
Encode a string of text or binary data. This uses the C<hex> (or C<[0-9A-V]>) method.
=head1 AUTHORS
Jens Rehsack - <rehsack@cpan.org> - Current maintainer
Chase Whitener
Daniel Peder - sponsored by Infoset s.r.o., Czech Republic
- <Daniel.Peder@InfoSet.COM> http://www.infoset.com - Original author
=head1 BUGS
Before reporting any new issue, bug or alike, please check
L<https://rt.cpan.org/Dist/Display.html?Queue=MIME-Base32>,
L<https://github.com/perl5-utils/MIME-Base32/issues> or
L<https://github.com/perl5-utils/MIME-Base32/pulls>, respectively, whether
the issue is already reported.
Please report any bugs or feature requests to
C<bug-mime-base32 at rt.cpan.org>, or through the web interface at
L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=MIME-Base32>.
I will be notified, and then you'll automatically be notified of progress
on your bug as I make changes.
Any and all criticism, bug reports, enhancements, fixes, etc. are appreciated.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc MIME::Base32
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<https://rt.cpan.org/Dist/Display.html?Name=MIME-Base32>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/MIME-Base32>
=item * MetaCPAN
L<https://metacpan.org/release/MIME-Base32>
=back
=head1 COPYRIGHT AND LICENSE INFORMATION
Copyright (c) 2003-2010 Daniel Peder. All rights reserved.
Copyright (c) 2015-2016 Chase Whitener. All rights reserved.
Copyright (c) 2016 Jens Rehsack. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<MIME::Base64>, L<RFC-3548|https://tools.ietf.org/html/rfc3548#section-5>
=cut

198
OGP64/usr/share/perl5/vendor_perl/5.40/Path/Class.pm Normal file
View file

@ -0,0 +1,198 @@
use strict;
package Path::Class;
{
$Path::Class::VERSION = '0.37';
}
{
## no critic
no strict 'vars';
@ISA = qw(Exporter);
@EXPORT = qw(file dir);
@EXPORT_OK = qw(file dir foreign_file foreign_dir tempdir);
}
use Exporter;
use Path::Class::File;
use Path::Class::Dir;
use File::Temp ();
sub file { Path::Class::File->new(@_) }
sub dir { Path::Class::Dir ->new(@_) }
sub foreign_file { Path::Class::File->new_foreign(@_) }
sub foreign_dir { Path::Class::Dir ->new_foreign(@_) }
sub tempdir { Path::Class::Dir->new(File::Temp::tempdir(@_)) }
1;
__END__
=head1 NAME
Path::Class - Cross-platform path specification manipulation
=head1 VERSION
version 0.37
=head1 SYNOPSIS
use Path::Class;
my $dir = dir('foo', 'bar'); # Path::Class::Dir object
my $file = file('bob', 'file.txt'); # Path::Class::File object
# Stringifies to 'foo/bar' on Unix, 'foo\bar' on Windows, etc.
print "dir: $dir\n";
# Stringifies to 'bob/file.txt' on Unix, 'bob\file.txt' on Windows
print "file: $file\n";
my $subdir = $dir->subdir('baz'); # foo/bar/baz
my $parent = $subdir->parent; # foo/bar
my $parent2 = $parent->parent; # foo
my $dir2 = $file->dir; # bob
# Work with foreign paths
use Path::Class qw(foreign_file foreign_dir);
my $file = foreign_file('Mac', ':foo:file.txt');
print $file->dir; # :foo:
print $file->as_foreign('Win32'); # foo\file.txt
# Interact with the underlying filesystem:
# $dir_handle is an IO::Dir object
my $dir_handle = $dir->open or die "Can't read $dir: $!";
# $file_handle is an IO::File object
my $file_handle = $file->open($mode) or die "Can't read $file: $!";
=head1 DESCRIPTION
C<Path::Class> is a module for manipulation of file and directory
specifications (strings describing their locations, like
C<'/home/ken/foo.txt'> or C<'C:\Windows\Foo.txt'>) in a cross-platform
manner. It supports pretty much every platform Perl runs on,
including Unix, Windows, Mac, VMS, Epoc, Cygwin, OS/2, and NetWare.
The well-known module L<File::Spec> also provides this service, but
it's sort of awkward to use well, so people sometimes avoid it, or use
it in a way that won't actually work properly on platforms
significantly different than the ones they've tested their code on.
In fact, C<Path::Class> uses C<File::Spec> internally, wrapping all
the unsightly details so you can concentrate on your application code.
Whereas C<File::Spec> provides functions for some common path
manipulations, C<Path::Class> provides an object-oriented model of the
world of path specifications and their underlying semantics.
C<File::Spec> doesn't create any objects, and its classes represent
the different ways in which paths must be manipulated on various
platforms (not a very intuitive concept). C<Path::Class> creates
objects representing files and directories, and provides methods that
relate them to each other. For instance, the following C<File::Spec>
code:
my $absolute = File::Spec->file_name_is_absolute(
File::Spec->catfile( @dirs, $file )
);
can be written using C<Path::Class> as
my $absolute = Path::Class::File->new( @dirs, $file )->is_absolute;
or even as
my $absolute = file( @dirs, $file )->is_absolute;
Similar readability improvements should happen all over the place when
using C<Path::Class>.
Using C<Path::Class> can help solve real problems in your code too -
for instance, how many people actually take the "volume" (like C<C:>
on Windows) into account when writing C<File::Spec>-using code? I
thought not. But if you use C<Path::Class>, your file and directory objects
will know what volumes they refer to and do the right thing.
The guts of the C<Path::Class> code live in the L<Path::Class::File>
and L<Path::Class::Dir> modules, so please see those
modules' documentation for more details about how to use them.
=head2 EXPORT
The following functions are exported by default.
=over 4
=item file
A synonym for C<< Path::Class::File->new >>.
=item dir
A synonym for C<< Path::Class::Dir->new >>.
=back
If you would like to prevent their export, you may explicitly pass an
empty list to perl's C<use>, i.e. C<use Path::Class ()>.
The following are exported only on demand.
=over 4
=item foreign_file
A synonym for C<< Path::Class::File->new_foreign >>.
=item foreign_dir
A synonym for C<< Path::Class::Dir->new_foreign >>.
=item tempdir
Create a new Path::Class::Dir instance pointed to temporary directory.
my $temp = Path::Class::tempdir(CLEANUP => 1);
A synonym for C<< Path::Class::Dir->new(File::Temp::tempdir(@_)) >>.
=back
=head1 Notes on Cross-Platform Compatibility
Although it is much easier to write cross-platform-friendly code with
this module than with C<File::Spec>, there are still some issues to be
aware of.
=over 4
=item *
On some platforms, notably VMS and some older versions of DOS (I think),
all filenames must have an extension. Thus if you create a file
called F<foo/bar> and then ask for a list of files in the directory
F<foo>, you may find a file called F<bar.> instead of the F<bar> you
were expecting. Thus it might be a good idea to use an extension in
the first place.
=back
=head1 AUTHOR
Ken Williams, KWILLIAMS@cpan.org
=head1 COPYRIGHT
Copyright (c) Ken Williams. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<Path::Class::Dir>, L<Path::Class::File>, L<File::Spec>
=cut

847
OGP64/usr/share/perl5/vendor_perl/5.40/Path/Class/Dir.pm Normal file
View file

@ -0,0 +1,847 @@
use strict;
package Path::Class::Dir;
{
$Path::Class::Dir::VERSION = '0.37';
}
use Path::Class::File;
use Carp();
use parent qw(Path::Class::Entity);
use IO::Dir ();
use File::Path ();
use File::Temp ();
use Scalar::Util ();
# updir & curdir on the local machine, for screening them out in
# children(). Note that they don't respect 'foreign' semantics.
my $Updir = __PACKAGE__->_spec->updir;
my $Curdir = __PACKAGE__->_spec->curdir;
sub new {
my $self = shift->SUPER::new();
# If the only arg is undef, it's probably a mistake. Without this
# special case here, we'd return the root directory, which is a
# lousy thing to do to someone when they made a mistake. Return
# undef instead.
return if @_==1 && !defined($_[0]);
my $s = $self->_spec;
my $first = (@_ == 0 ? $s->curdir :
!ref($_[0]) && $_[0] eq '' ? (shift, $s->rootdir) :
shift()
);
$self->{dirs} = [];
if ( Scalar::Util::blessed($first) && $first->isa("Path::Class::Dir") ) {
$self->{volume} = $first->{volume};
push @{$self->{dirs}}, @{$first->{dirs}};
}
else {
($self->{volume}, my $dirs) = $s->splitpath( $s->canonpath("$first") , 1);
push @{$self->{dirs}}, $dirs eq $s->rootdir ? "" : $s->splitdir($dirs);
}
push @{$self->{dirs}}, map {
Scalar::Util::blessed($_) && $_->isa("Path::Class::Dir")
? @{$_->{dirs}}
: $s->splitdir( $s->canonpath($_) )
} @_;
return $self;
}
sub file_class { "Path::Class::File" }
sub is_dir { 1 }
sub as_foreign {
my ($self, $type) = @_;
my $foreign = do {
local $self->{file_spec_class} = $self->_spec_class($type);
$self->SUPER::new;
};
# Clone internal structure
$foreign->{volume} = $self->{volume};
my ($u, $fu) = ($self->_spec->updir, $foreign->_spec->updir);
$foreign->{dirs} = [ map {$_ eq $u ? $fu : $_} @{$self->{dirs}}];
return $foreign;
}
sub stringify {
my $self = shift;
my $s = $self->_spec;
return $s->catpath($self->{volume},
$s->catdir(@{$self->{dirs}}),
'');
}
sub volume { shift()->{volume} }
sub file {
local $Path::Class::Foreign = $_[0]->{file_spec_class} if $_[0]->{file_spec_class};
return $_[0]->file_class->new(@_);
}
sub basename { shift()->{dirs}[-1] }
sub dir_list {
my $self = shift;
my $d = $self->{dirs};
return @$d unless @_;
my $offset = shift;
if ($offset < 0) { $offset = $#$d + $offset + 1 }
return wantarray ? @$d[$offset .. $#$d] : $d->[$offset] unless @_;
my $length = shift;
if ($length < 0) { $length = $#$d + $length + 1 - $offset }
return @$d[$offset .. $length + $offset - 1];
}
sub components {
my $self = shift;
return $self->dir_list(@_);
}
sub subdir {
my $self = shift;
return $self->new($self, @_);
}
sub parent {
my $self = shift;
my $dirs = $self->{dirs};
my ($curdir, $updir) = ($self->_spec->curdir, $self->_spec->updir);
if ($self->is_absolute) {
my $parent = $self->new($self);
pop @{$parent->{dirs}} if @$dirs > 1;
return $parent;
} elsif ($self eq $curdir) {
return $self->new($updir);
} elsif (!grep {$_ ne $updir} @$dirs) { # All updirs
return $self->new($self, $updir); # Add one more
} elsif (@$dirs == 1) {
return $self->new($curdir);
} else {
my $parent = $self->new($self);
pop @{$parent->{dirs}};
return $parent;
}
}
sub relative {
# File::Spec->abs2rel before version 3.13 returned the empty string
# when the two paths were equal - work around it here.
my $self = shift;
my $rel = $self->_spec->abs2rel($self->stringify, @_);
return $self->new( length $rel ? $rel : $self->_spec->curdir );
}
sub open { IO::Dir->new(@_) }
sub mkpath { File::Path::mkpath(shift()->stringify, @_) }
sub rmtree { File::Path::rmtree(shift()->stringify, @_) }
sub remove {
rmdir( shift() );
}
sub traverse {
my $self = shift;
my ($callback, @args) = @_;
my @children = $self->children;
return $self->$callback(
sub {
my @inner_args = @_;
return map { $_->traverse($callback, @inner_args) } @children;
},
@args
);
}
sub traverse_if {
my $self = shift;
my ($callback, $condition, @args) = @_;
my @children = grep { $condition->($_) } $self->children;
return $self->$callback(
sub {
my @inner_args = @_;
return map { $_->traverse_if($callback, $condition, @inner_args) } @children;
},
@args
);
}
sub recurse {
my $self = shift;
my %opts = (preorder => 1, depthfirst => 0, @_);
my $callback = $opts{callback}
or Carp::croak( "Must provide a 'callback' parameter to recurse()" );
my @queue = ($self);
my $visit_entry;
my $visit_dir =
$opts{depthfirst} && $opts{preorder}
? sub {
my $dir = shift;
my $ret = $callback->($dir);
unless( ($ret||'') eq $self->PRUNE ) {
unshift @queue, $dir->children;
}
}
: $opts{preorder}
? sub {
my $dir = shift;
my $ret = $callback->($dir);
unless( ($ret||'') eq $self->PRUNE ) {
push @queue, $dir->children;
}
}
: sub {
my $dir = shift;
$visit_entry->($_) foreach $dir->children;
$callback->($dir);
};
$visit_entry = sub {
my $entry = shift;
if ($entry->is_dir) { $visit_dir->($entry) } # Will call $callback
else { $callback->($entry) }
};
while (@queue) {
$visit_entry->( shift @queue );
}
}
sub children {
my ($self, %opts) = @_;
my $dh = $self->open or Carp::croak( "Can't open directory $self: $!" );
my @out;
while (defined(my $entry = $dh->read)) {
next if !$opts{all} && $self->_is_local_dot_dir($entry);
next if ($opts{no_hidden} && $entry =~ /^\./);
push @out, $self->file($entry);
$out[-1] = $self->subdir($entry) if -d $out[-1];
}
return @out;
}
sub _is_local_dot_dir {
my $self = shift;
my $dir = shift;
return ($dir eq $Updir or $dir eq $Curdir);
}
sub next {
my $self = shift;
unless ($self->{dh}) {
$self->{dh} = $self->open or Carp::croak( "Can't open directory $self: $!" );
}
my $next = $self->{dh}->read;
unless (defined $next) {
delete $self->{dh};
## no critic
return undef;
}
# Figure out whether it's a file or directory
my $file = $self->file($next);
$file = $self->subdir($next) if -d $file;
return $file;
}
sub subsumes {
Carp::croak "Too many arguments given to subsumes()" if $#_ > 2;
my ($self, $other) = @_;
Carp::croak( "No second entity given to subsumes()" ) unless defined $other;
$other = $self->new($other) unless eval{$other->isa( "Path::Class::Entity")};
$other = $other->dir unless $other->is_dir;
if ($self->is_absolute) {
$other = $other->absolute;
} elsif ($other->is_absolute) {
$self = $self->absolute;
}
$self = $self->cleanup;
$other = $other->cleanup;
if ($self->volume || $other->volume) {
return 0 unless $other->volume eq $self->volume;
}
# The root dir subsumes everything (but ignore the volume because
# we've already checked that)
return 1 if "@{$self->{dirs}}" eq "@{$self->new('')->{dirs}}";
# The current dir subsumes every relative path (unless starting with updir)
if ($self eq $self->_spec->curdir) {
return $other->{dirs}[0] ne $self->_spec->updir;
}
my $i = 0;
while ($i <= $#{ $self->{dirs} }) {
return 0 if $i > $#{ $other->{dirs} };
return 0 if $self->{dirs}[$i] ne $other->{dirs}[$i];
$i++;
}
return 1;
}
sub contains {
Carp::croak "Too many arguments given to contains()" if $#_ > 2;
my ($self, $other) = @_;
Carp::croak "No second entity given to contains()" unless defined $other;
return unless -d $self and (-e $other or -l $other);
# We're going to resolve the path, and don't want side effects on the objects
# so clone them. This also handles strings passed as $other.
$self= $self->new($self)->resolve;
$other= $self->new($other)->resolve;
return $self->subsumes($other);
}
sub tempfile {
my $self = shift;
return File::Temp::tempfile(@_, DIR => $self->stringify);
}
1;
__END__
=head1 NAME
Path::Class::Dir - Objects representing directories
=head1 VERSION
version 0.37
=head1 SYNOPSIS
use Path::Class; # Exports dir() by default
my $dir = dir('foo', 'bar'); # Path::Class::Dir object
my $dir = Path::Class::Dir->new('foo', 'bar'); # Same thing
# Stringifies to 'foo/bar' on Unix, 'foo\bar' on Windows, etc.
print "dir: $dir\n";
if ($dir->is_absolute) { ... }
if ($dir->is_relative) { ... }
my $v = $dir->volume; # Could be 'C:' on Windows, empty string
# on Unix, 'Macintosh HD:' on Mac OS
$dir->cleanup; # Perform logical cleanup of pathname
$dir->resolve; # Perform physical cleanup of pathname
my $file = $dir->file('file.txt'); # A file in this directory
my $subdir = $dir->subdir('george'); # A subdirectory
my $parent = $dir->parent; # The parent directory, 'foo'
my $abs = $dir->absolute; # Transform to absolute path
my $rel = $abs->relative; # Transform to relative path
my $rel = $abs->relative('/foo'); # Relative to /foo
print $dir->as_foreign('Mac'); # :foo:bar:
print $dir->as_foreign('Win32'); # foo\bar
# Iterate with IO::Dir methods:
my $handle = $dir->open;
while (my $file = $handle->read) {
$file = $dir->file($file); # Turn into Path::Class::File object
...
}
# Iterate with Path::Class methods:
while (my $file = $dir->next) {
# $file is a Path::Class::File or Path::Class::Dir object
...
}
=head1 DESCRIPTION
The C<Path::Class::Dir> class contains functionality for manipulating
directory names in a cross-platform way.
=head1 METHODS
=over 4
=item $dir = Path::Class::Dir->new( <dir1>, <dir2>, ... )
=item $dir = dir( <dir1>, <dir2>, ... )
Creates a new C<Path::Class::Dir> object and returns it. The
arguments specify names of directories which will be joined to create
a single directory object. A volume may also be specified as the
first argument, or as part of the first argument. You can use
platform-neutral syntax:
my $dir = dir( 'foo', 'bar', 'baz' );
or platform-native syntax:
my $dir = dir( 'foo/bar/baz' );
or a mixture of the two:
my $dir = dir( 'foo/bar', 'baz' );
All three of the above examples create relative paths. To create an
absolute path, either use the platform native syntax for doing so:
my $dir = dir( '/var/tmp' );
or use an empty string as the first argument:
my $dir = dir( '', 'var', 'tmp' );
If the second form seems awkward, that's somewhat intentional - paths
like C</var/tmp> or C<\Windows> aren't cross-platform concepts in the
first place (many non-Unix platforms don't have a notion of a "root
directory"), so they probably shouldn't appear in your code if you're
trying to be cross-platform. The first form is perfectly natural,
because paths like this may come from config files, user input, or
whatever.
As a special case, since it doesn't otherwise mean anything useful and
it's convenient to define this way, C<< Path::Class::Dir->new() >> (or
C<dir()>) refers to the current directory (C<< File::Spec->curdir >>).
To get the current directory as an absolute path, do C<<
dir()->absolute >>.
Finally, as another special case C<dir(undef)> will return undef,
since that's usually an accident on the part of the caller, and
returning the root directory would be a nasty surprise just asking for
trouble a few lines later.
=item $dir->stringify
This method is called internally when a C<Path::Class::Dir> object is
used in a string context, so the following are equivalent:
$string = $dir->stringify;
$string = "$dir";
=item $dir->volume
Returns the volume (e.g. C<C:> on Windows, C<Macintosh HD:> on Mac OS,
etc.) of the directory object, if any. Otherwise, returns the empty
string.
=item $dir->basename
Returns the last directory name of the path as a string.
=item $dir->is_dir
Returns a boolean value indicating whether this object represents a
directory. Not surprisingly, L<Path::Class::File> objects always
return false, and C<Path::Class::Dir> objects always return true.
=item $dir->is_absolute
Returns true or false depending on whether the directory refers to an
absolute path specifier (like C</usr/local> or C<\Windows>).
=item $dir->is_relative
Returns true or false depending on whether the directory refers to a
relative path specifier (like C<lib/foo> or C<./dir>).
=item $dir->cleanup
Performs a logical cleanup of the file path. For instance:
my $dir = dir('/foo//baz/./foo')->cleanup;
# $dir now represents '/foo/baz/foo';
=item $dir->resolve
Performs a physical cleanup of the file path. For instance:
my $dir = dir('/foo//baz/../foo')->resolve;
# $dir now represents '/foo/foo', assuming no symlinks
This actually consults the filesystem to verify the validity of the
path.
=item $file = $dir->file( <dir1>, <dir2>, ..., <file> )
Returns a L<Path::Class::File> object representing an entry in C<$dir>
or one of its subdirectories. Internally, this just calls C<<
Path::Class::File->new( @_ ) >>.
=item $subdir = $dir->subdir( <dir1>, <dir2>, ... )
Returns a new C<Path::Class::Dir> object representing a subdirectory
of C<$dir>.
=item $parent = $dir->parent
Returns the parent directory of C<$dir>. Note that this is the
I<logical> parent, not necessarily the physical parent. It really
means we just chop off entries from the end of the directory list
until we cain't chop no more. If the directory is relative, we start
using the relative forms of parent directories.
The following code demonstrates the behavior on absolute and relative
directories:
$dir = dir('/foo/bar');
for (1..6) {
print "Absolute: $dir\n";
$dir = $dir->parent;
}
$dir = dir('foo/bar');
for (1..6) {
print "Relative: $dir\n";
$dir = $dir->parent;
}
########### Output on Unix ################
Absolute: /foo/bar
Absolute: /foo
Absolute: /
Absolute: /
Absolute: /
Absolute: /
Relative: foo/bar
Relative: foo
Relative: .
Relative: ..
Relative: ../..
Relative: ../../..
=item @list = $dir->children
Returns a list of L<Path::Class::File> and/or C<Path::Class::Dir>
objects listed in this directory, or in scalar context the number of
such objects. Obviously, it is necessary for C<$dir> to
exist and be readable in order to find its children.
Note that the children are returned as subdirectories of C<$dir>,
i.e. the children of F<foo> will be F<foo/bar> and F<foo/baz>, not
F<bar> and F<baz>.
Ordinarily C<children()> will not include the I<self> and I<parent>
entries C<.> and C<..> (or their equivalents on non-Unix systems),
because that's like I'm-my-own-grandpa business. If you do want all
directory entries including these special ones, pass a true value for
the C<all> parameter:
@c = $dir->children(); # Just the children
@c = $dir->children(all => 1); # All entries
In addition, there's a C<no_hidden> parameter that will exclude all
normally "hidden" entries - on Unix this means excluding all entries
that begin with a dot (C<.>):
@c = $dir->children(no_hidden => 1); # Just normally-visible entries
=item $abs = $dir->absolute
Returns a C<Path::Class::Dir> object representing C<$dir> as an
absolute path. An optional argument, given as either a string or a
C<Path::Class::Dir> object, specifies the directory to use as the base
of relativity - otherwise the current working directory will be used.
=item $rel = $dir->relative
Returns a C<Path::Class::Dir> object representing C<$dir> as a
relative path. An optional argument, given as either a string or a
C<Path::Class::Dir> object, specifies the directory to use as the base
of relativity - otherwise the current working directory will be used.
=item $boolean = $dir->subsumes($other)
Returns true if this directory spec subsumes the other spec, and false
otherwise. Think of "subsumes" as "contains", but we only look at the
I<specs>, not whether C<$dir> actually contains C<$other> on the
filesystem.
The C<$other> argument may be a C<Path::Class::Dir> object, a
L<Path::Class::File> object, or a string. In the latter case, we
assume it's a directory.
# Examples:
dir('foo/bar' )->subsumes(dir('foo/bar/baz')) # True
dir('/foo/bar')->subsumes(dir('/foo/bar/baz')) # True
dir('foo/..')->subsumes(dir('foo/../bar)) # True
dir('foo/bar' )->subsumes(dir('bar/baz')) # False
dir('/foo/bar')->subsumes(dir('foo/bar')) # False
dir('foo/..')->subsumes(dir('bar')) # False! Use C<contains> to resolve ".."
=item $boolean = $dir->contains($other)
Returns true if this directory actually contains C<$other> on the
filesystem. C<$other> doesn't have to be a direct child of C<$dir>,
it just has to be subsumed after both paths have been resolved.
=item $foreign = $dir->as_foreign($type)
Returns a C<Path::Class::Dir> object representing C<$dir> as it would
be specified on a system of type C<$type>. Known types include
C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which
there is a subclass of C<File::Spec>.
Any generated objects (subdirectories, files, parents, etc.) will also
retain this type.
=item $foreign = Path::Class::Dir->new_foreign($type, @args)
Returns a C<Path::Class::Dir> object representing C<$dir> as it would
be specified on a system of type C<$type>. Known types include
C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which
there is a subclass of C<File::Spec>.
The arguments in C<@args> are the same as they would be specified in
C<new()>.
=item @list = $dir->dir_list([OFFSET, [LENGTH]])
Returns the list of strings internally representing this directory
structure. Each successive member of the list is understood to be an
entry in its predecessor's directory list. By contract, C<<
Path::Class->new( $dir->dir_list ) >> should be equivalent to C<$dir>.
The semantics of this method are similar to Perl's C<splice> or
C<substr> functions; they return C<LENGTH> elements starting at
C<OFFSET>. If C<LENGTH> is omitted, returns all the elements starting
at C<OFFSET> up to the end of the list. If C<LENGTH> is negative,
returns the elements from C<OFFSET> onward except for C<-LENGTH>
elements at the end. If C<OFFSET> is negative, it counts backward
C<OFFSET> elements from the end of the list. If C<OFFSET> and
C<LENGTH> are both omitted, the entire list is returned.
In a scalar context, C<dir_list()> with no arguments returns the
number of entries in the directory list; C<dir_list(OFFSET)> returns
the single element at that offset; C<dir_list(OFFSET, LENGTH)> returns
the final element that would have been returned in a list context.
=item $dir->components
Identical to C<dir_list()>. It exists because there's an analogous
method C<dir_list()> in the C<Path::Class::File> class that also
returns the basename string, so this method lets someone call
C<components()> without caring whether the object is a file or a
directory.
=item $fh = $dir->open()
Passes C<$dir> to C<< IO::Dir->open >> and returns the result as an
L<IO::Dir> object. If the opening fails, C<undef> is returned and
C<$!> is set.
=item $dir->mkpath($verbose, $mode)
Passes all arguments, including C<$dir>, to C<< File::Path::mkpath()
>> and returns the result (a list of all directories created).
=item $dir->rmtree($verbose, $cautious)
Passes all arguments, including C<$dir>, to C<< File::Path::rmtree()
>> and returns the result (the number of files successfully deleted).
=item $dir->remove()
Removes the directory, which must be empty. Returns a boolean value
indicating whether or not the directory was successfully removed.
This method is mainly provided for consistency with
C<Path::Class::File>'s C<remove()> method.
=item $dir->tempfile(...)
An interface to L<File::Temp>'s C<tempfile()> function. Just like
that function, if you call this in a scalar context, the return value
is the filehandle and the file is C<unlink>ed as soon as possible
(which is immediately on Unix-like platforms). If called in a list
context, the return values are the filehandle and the filename.
The given directory is passed as the C<DIR> parameter.
Here's an example of pretty good usage which doesn't allow race
conditions, won't leave yucky tempfiles around on your filesystem,
etc.:
my $fh = $dir->tempfile;
print $fh "Here's some data...\n";
seek($fh, 0, 0);
while (<$fh>) { do something... }
Or in combination with a C<fork>:
my $fh = $dir->tempfile;
print $fh "Here's some more data...\n";
seek($fh, 0, 0);
if ($pid=fork()) {
wait;
} else {
something($_) while <$fh>;
}
=item $dir_or_file = $dir->next()
A convenient way to iterate through directory contents. The first
time C<next()> is called, it will C<open()> the directory and read the
first item from it, returning the result as a C<Path::Class::Dir> or
L<Path::Class::File> object (depending, of course, on its actual
type). Each subsequent call to C<next()> will simply iterate over the
directory's contents, until there are no more items in the directory,
and then the undefined value is returned. For example, to iterate
over all the regular files in a directory:
while (my $file = $dir->next) {
next unless -f $file;
my $fh = $file->open('r') or die "Can't read $file: $!";
...
}
If an error occurs when opening the directory (for instance, it
doesn't exist or isn't readable), C<next()> will throw an exception
with the value of C<$!>.
=item $dir->traverse( sub { ... }, @args )
Calls the given callback for the root, passing it a continuation
function which, when called, will call this recursively on each of its
children. The callback function should be of the form:
sub {
my ($child, $cont, @args) = @_;
# ...
}
For instance, to calculate the number of files in a directory, you
can do this:
my $nfiles = $dir->traverse(sub {
my ($child, $cont) = @_;
return sum($cont->(), ($child->is_dir ? 0 : 1));
});
or to calculate the maximum depth of a directory:
my $depth = $dir->traverse(sub {
my ($child, $cont, $depth) = @_;
return max($cont->($depth + 1), $depth);
}, 0);
You can also choose not to call the callback in certain situations:
$dir->traverse(sub {
my ($child, $cont) = @_;
return if -l $child; # don't follow symlinks
# do something with $child
return $cont->();
});
=item $dir->traverse_if( sub { ... }, sub { ... }, @args )
traverse with additional "should I visit this child" callback.
Particularly useful in case examined tree contains inaccessible
directories.
Canonical example:
$dir->traverse_if(
sub {
my ($child, $cont) = @_;
# do something with $child
return $cont->();
},
sub {
my ($child) = @_;
# Process only readable items
return -r $child;
});
Second callback gets single parameter: child. Only children for
which it returns true will be processed by the first callback.
Remaining parameters are interpreted as in traverse, in particular
C<traverse_if(callback, sub { 1 }, @args> is equivalent to
C<traverse(callback, @args)>.
=item $dir->recurse( callback => sub {...} )
Iterates through this directory and all of its children, and all of
its children's children, etc., calling the C<callback> subroutine for
each entry. This is a lot like what the L<File::Find> module does,
and of course C<File::Find> will work fine on L<Path::Class> objects,
but the advantage of the C<recurse()> method is that it will also feed
your callback routine C<Path::Class> objects rather than just pathname
strings.
The C<recurse()> method requires a C<callback> parameter specifying
the subroutine to invoke for each entry. It will be passed the
C<Path::Class> object as its first argument.
C<recurse()> also accepts two boolean parameters, C<depthfirst> and
C<preorder> that control the order of recursion. The default is a
preorder, breadth-first search, i.e. C<< depthfirst => 0, preorder => 1 >>.
At the time of this writing, all combinations of these two parameters
are supported I<except> C<< depthfirst => 0, preorder => 0 >>.
C<callback> is normally not required to return any value. If it
returns special constant C<Path::Class::Entity::PRUNE()> (more easily
available as C<< $item->PRUNE >>), no children of analyzed
item will be analyzed (mostly as if you set C<$File::Find::prune=1>). Of course
pruning is available only in C<preorder>, in postorder return value
has no effect.
=item $st = $file->stat()
Invokes C<< File::stat::stat() >> on this directory and returns a
C<File::stat> object representing the result.
=item $st = $file->lstat()
Same as C<stat()>, but if C<$file> is a symbolic link, C<lstat()>
stats the link instead of the directory the link points to.
=item $class = $file->file_class()
Returns the class which should be used to create file objects.
Generally overridden whenever this class is subclassed.
=back
=head1 AUTHOR
Ken Williams, kwilliams@cpan.org
=head1 SEE ALSO
L<Path::Class>, L<Path::Class::File>, L<File::Spec>
=cut

117
OGP64/usr/share/perl5/vendor_perl/5.40/Path/Class/Entity.pm Normal file
View file

@ -0,0 +1,117 @@
use strict;
package Path::Class::Entity;
{
$Path::Class::Entity::VERSION = '0.37';
}
use File::Spec 3.26;
use File::stat ();
use Cwd;
use Carp();
use overload
(
q[""] => 'stringify',
'bool' => 'boolify',
fallback => 1,
);
sub new {
my $from = shift;
my ($class, $fs_class) = (ref($from)
? (ref $from, $from->{file_spec_class})
: ($from, $Path::Class::Foreign));
return bless {file_spec_class => $fs_class}, $class;
}
sub is_dir { 0 }
sub _spec_class {
my ($class, $type) = @_;
die "Invalid system type '$type'" unless ($type) = $type =~ /^(\w+)$/; # Untaint
my $spec = "File::Spec::$type";
## no critic
eval "require $spec; 1" or die $@;
return $spec;
}
sub new_foreign {
my ($class, $type) = (shift, shift);
local $Path::Class::Foreign = $class->_spec_class($type);
return $class->new(@_);
}
sub _spec { (ref($_[0]) && $_[0]->{file_spec_class}) || 'File::Spec' }
sub boolify { 1 }
sub is_absolute {
# 5.6.0 has a bug with regexes and stringification that's ticked by
# file_name_is_absolute(). Help it along with an explicit stringify().
$_[0]->_spec->file_name_is_absolute($_[0]->stringify)
}
sub is_relative { ! $_[0]->is_absolute }
sub cleanup {
my $self = shift;
my $cleaned = $self->new( $self->_spec->canonpath("$self") );
%$self = %$cleaned;
return $self;
}
sub resolve {
my $self = shift;
Carp::croak($! . " $self") unless -e $self; # No such file or directory
my $cleaned = $self->new( scalar Cwd::realpath($self->stringify) );
# realpath() always returns absolute path, kind of annoying
$cleaned = $cleaned->relative if $self->is_relative;
%$self = %$cleaned;
return $self;
}
sub absolute {
my $self = shift;
return $self if $self->is_absolute;
return $self->new($self->_spec->rel2abs($self->stringify, @_));
}
sub relative {
my $self = shift;
return $self->new($self->_spec->abs2rel($self->stringify, @_));
}
sub stat { File::stat::stat("$_[0]") }
sub lstat { File::stat::lstat("$_[0]") }
sub PRUNE { return \&PRUNE; }
1;
__END__
=head1 NAME
Path::Class::Entity - Base class for files and directories
=head1 VERSION
version 0.37
=head1 DESCRIPTION
This class is the base class for C<Path::Class::File> and
C<Path::Class::Dir>, it is not used directly by callers.
=head1 AUTHOR
Ken Williams, kwilliams@cpan.org
=head1 SEE ALSO
Path::Class
=cut

545
OGP64/usr/share/perl5/vendor_perl/5.40/Path/Class/File.pm Normal file
View file

@ -0,0 +1,545 @@
use strict;
package Path::Class::File;
{
$Path::Class::File::VERSION = '0.37';
}
use Path::Class::Dir;
use parent qw(Path::Class::Entity);
use Carp;
use IO::File ();
sub new {
my $self = shift->SUPER::new;
my $file = pop();
my @dirs = @_;
my ($volume, $dirs, $base) = $self->_spec->splitpath($file);
if (length $dirs) {
push @dirs, $self->_spec->catpath($volume, $dirs, '');
}
$self->{dir} = @dirs ? $self->dir_class->new(@dirs) : undef;
$self->{file} = $base;
return $self;
}
sub dir_class { "Path::Class::Dir" }
sub as_foreign {
my ($self, $type) = @_;
local $Path::Class::Foreign = $self->_spec_class($type);
my $foreign = ref($self)->SUPER::new;
$foreign->{dir} = $self->{dir}->as_foreign($type) if defined $self->{dir};
$foreign->{file} = $self->{file};
return $foreign;
}
sub stringify {
my $self = shift;
return $self->{file} unless defined $self->{dir};
return $self->_spec->catfile($self->{dir}->stringify, $self->{file});
}
sub dir {
my $self = shift;
return $self->{dir} if defined $self->{dir};
return $self->dir_class->new($self->_spec->curdir);
}
BEGIN { *parent = \&dir; }
sub volume {
my $self = shift;
return '' unless defined $self->{dir};
return $self->{dir}->volume;
}
sub components {
my $self = shift;
croak "Arguments are not currently supported by File->components()" if @_;
return ($self->dir->components, $self->basename);
}
sub basename { shift->{file} }
sub open { IO::File->new(@_) }
sub openr { $_[0]->open('r') or croak "Can't read $_[0]: $!" }
sub openw { $_[0]->open('w') or croak "Can't write to $_[0]: $!" }
sub opena { $_[0]->open('a') or croak "Can't append to $_[0]: $!" }
sub touch {
my $self = shift;
if (-e $self) {
utime undef, undef, $self;
} else {
$self->openw;
}
}
sub slurp {
my ($self, %args) = @_;
my $iomode = $args{iomode} || 'r';
my $fh = $self->open($iomode) or croak "Can't read $self: $!";
if (wantarray) {
my @data = <$fh>;
chomp @data if $args{chomped} or $args{chomp};
if ( my $splitter = $args{split} ) {
@data = map { [ split $splitter, $_ ] } @data;
}
return @data;
}
croak "'split' argument can only be used in list context"
if $args{split};
if ($args{chomped} or $args{chomp}) {
chomp( my @data = <$fh> );
return join '', @data;
}
local $/;
return <$fh>;
}
sub spew {
my $self = shift;
my %args = splice( @_, 0, @_-1 );
my $iomode = $args{iomode} || 'w';
my $fh = $self->open( $iomode ) or croak "Can't write to $self: $!";
if (ref($_[0]) eq 'ARRAY') {
# Use old-school for loop to avoid copying.
for (my $i = 0; $i < @{ $_[0] }; $i++) {
print $fh $_[0]->[$i]
or croak "Can't write to $self: $!";
}
}
else {
print $fh $_[0]
or croak "Can't write to $self: $!";
}
close $fh
or croak "Can't write to $self: $!";
return;
}
sub spew_lines {
my $self = shift;
my %args = splice( @_, 0, @_-1 );
my $content = $_[0];
# If content is an array ref, appends $/ to each element of the array.
# Otherwise, if it is a simple scalar, just appends $/ to that scalar.
$content
= ref( $content ) eq 'ARRAY'
? [ map { $_, $/ } @$content ]
: "$content$/";
return $self->spew( %args, $content );
}
sub remove {
my $file = shift->stringify;
return unlink $file unless -e $file; # Sets $! correctly
1 while unlink $file;
return not -e $file;
}
sub copy_to {
my ($self, $dest) = @_;
if ( eval{ $dest->isa("Path::Class::File")} ) {
$dest = $dest->stringify;
croak "Can't copy to file $dest: it is a directory" if -d $dest;
} elsif ( eval{ $dest->isa("Path::Class::Dir") } ) {
$dest = $dest->stringify;
croak "Can't copy to directory $dest: it is a file" if -f $dest;
croak "Can't copy to directory $dest: no such directory" unless -d $dest;
} elsif ( ref $dest ) {
croak "Don't know how to copy files to objects of type '".ref($self)."'";
}
require Perl::OSType;
if ( !Perl::OSType::is_os_type('Unix') ) {
require File::Copy;
return unless File::Copy::cp($self->stringify, "${dest}");
} else {
return unless (system('cp', $self->stringify, "${dest}") == 0);
}
return $self->new($dest);
}
sub move_to {
my ($self, $dest) = @_;
require File::Copy;
if (File::Copy::move($self->stringify, "${dest}")) {
my $new = $self->new($dest);
$self->{$_} = $new->{$_} foreach (qw/ dir file /);
return $self;
} else {
return;
}
}
sub traverse {
my $self = shift;
my ($callback, @args) = @_;
return $self->$callback(sub { () }, @args);
}
sub traverse_if {
my $self = shift;
my ($callback, $condition, @args) = @_;
return $self->$callback(sub { () }, @args);
}
1;
__END__
=head1 NAME
Path::Class::File - Objects representing files
=head1 VERSION
version 0.37
=head1 SYNOPSIS
use Path::Class; # Exports file() by default
my $file = file('foo', 'bar.txt'); # Path::Class::File object
my $file = Path::Class::File->new('foo', 'bar.txt'); # Same thing
# Stringifies to 'foo/bar.txt' on Unix, 'foo\bar.txt' on Windows, etc.
print "file: $file\n";
if ($file->is_absolute) { ... }
if ($file->is_relative) { ... }
my $v = $file->volume; # Could be 'C:' on Windows, empty string
# on Unix, 'Macintosh HD:' on Mac OS
$file->cleanup; # Perform logical cleanup of pathname
$file->resolve; # Perform physical cleanup of pathname
my $dir = $file->dir; # A Path::Class::Dir object
my $abs = $file->absolute; # Transform to absolute path
my $rel = $file->relative; # Transform to relative path
=head1 DESCRIPTION
The C<Path::Class::File> class contains functionality for manipulating
file names in a cross-platform way.
=head1 METHODS
=over 4
=item $file = Path::Class::File->new( <dir1>, <dir2>, ..., <file> )
=item $file = file( <dir1>, <dir2>, ..., <file> )
Creates a new C<Path::Class::File> object and returns it. The
arguments specify the path to the file. Any volume may also be
specified as the first argument, or as part of the first argument.
You can use platform-neutral syntax:
my $file = file( 'foo', 'bar', 'baz.txt' );
or platform-native syntax:
my $file = file( 'foo/bar/baz.txt' );
or a mixture of the two:
my $file = file( 'foo/bar', 'baz.txt' );
All three of the above examples create relative paths. To create an
absolute path, either use the platform native syntax for doing so:
my $file = file( '/var/tmp/foo.txt' );
or use an empty string as the first argument:
my $file = file( '', 'var', 'tmp', 'foo.txt' );
If the second form seems awkward, that's somewhat intentional - paths
like C</var/tmp> or C<\Windows> aren't cross-platform concepts in the
first place, so they probably shouldn't appear in your code if you're
trying to be cross-platform. The first form is perfectly fine,
because paths like this may come from config files, user input, or
whatever.
=item $file->stringify
This method is called internally when a C<Path::Class::File> object is
used in a string context, so the following are equivalent:
$string = $file->stringify;
$string = "$file";
=item $file->volume
Returns the volume (e.g. C<C:> on Windows, C<Macintosh HD:> on Mac OS,
etc.) of the object, if any. Otherwise, returns the empty string.
=item $file->basename
Returns the name of the file as a string, without the directory
portion (if any).
=item $file->components
Returns a list of the directory components of this file, followed by
the basename.
Note: unlike C<< $dir->components >>, this method currently does not
accept any arguments to select which elements of the list will be
returned. It may do so in the future. Currently it throws an
exception if such arguments are present.
=item $file->is_dir
Returns a boolean value indicating whether this object represents a
directory. Not surprisingly, C<Path::Class::File> objects always
return false, and L<Path::Class::Dir> objects always return true.
=item $file->is_absolute
Returns true or false depending on whether the file refers to an
absolute path specifier (like C</usr/local/foo.txt> or C<\Windows\Foo.txt>).
=item $file->is_relative
Returns true or false depending on whether the file refers to a
relative path specifier (like C<lib/foo.txt> or C<.\Foo.txt>).
=item $file->cleanup
Performs a logical cleanup of the file path. For instance:
my $file = file('/foo//baz/./foo.txt')->cleanup;
# $file now represents '/foo/baz/foo.txt';
=item $dir->resolve
Performs a physical cleanup of the file path. For instance:
my $file = file('/foo/baz/../foo.txt')->resolve;
# $file now represents '/foo/foo.txt', assuming no symlinks
This actually consults the filesystem to verify the validity of the
path.
=item $dir = $file->dir
Returns a C<Path::Class::Dir> object representing the directory
containing this file.
=item $dir = $file->parent
A synonym for the C<dir()> method.
=item $abs = $file->absolute
Returns a C<Path::Class::File> object representing C<$file> as an
absolute path. An optional argument, given as either a string or a
L<Path::Class::Dir> object, specifies the directory to use as the base
of relativity - otherwise the current working directory will be used.
=item $rel = $file->relative
Returns a C<Path::Class::File> object representing C<$file> as a
relative path. An optional argument, given as either a string or a
C<Path::Class::Dir> object, specifies the directory to use as the base
of relativity - otherwise the current working directory will be used.
=item $foreign = $file->as_foreign($type)
Returns a C<Path::Class::File> object representing C<$file> as it would
be specified on a system of type C<$type>. Known types include
C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which
there is a subclass of C<File::Spec>.
Any generated objects (subdirectories, files, parents, etc.) will also
retain this type.
=item $foreign = Path::Class::File->new_foreign($type, @args)
Returns a C<Path::Class::File> object representing a file as it would
be specified on a system of type C<$type>. Known types include
C<Unix>, C<Win32>, C<Mac>, C<VMS>, and C<OS2>, i.e. anything for which
there is a subclass of C<File::Spec>.
The arguments in C<@args> are the same as they would be specified in
C<new()>.
=item $fh = $file->open($mode, $permissions)
Passes the given arguments, including C<$file>, to C<< IO::File->new >>
(which in turn calls C<< IO::File->open >> and returns the result
as an L<IO::File> object. If the opening
fails, C<undef> is returned and C<$!> is set.
=item $fh = $file->openr()
A shortcut for
$fh = $file->open('r') or croak "Can't read $file: $!";
=item $fh = $file->openw()
A shortcut for
$fh = $file->open('w') or croak "Can't write to $file: $!";
=item $fh = $file->opena()
A shortcut for
$fh = $file->open('a') or croak "Can't append to $file: $!";
=item $file->touch
Sets the modification and access time of the given file to right now,
if the file exists. If it doesn't exist, C<touch()> will I<make> it
exist, and - YES! - set its modification and access time to now.
=item $file->slurp()
In a scalar context, returns the contents of C<$file> in a string. In
a list context, returns the lines of C<$file> (according to how C<$/>
is set) as a list. If the file can't be read, this method will throw
an exception.
If you want C<chomp()> run on each line of the file, pass a true value
for the C<chomp> or C<chomped> parameters:
my @lines = $file->slurp(chomp => 1);
You may also use the C<iomode> parameter to pass in an IO mode to use
when opening the file, usually IO layers (though anything accepted by
the MODE argument of C<open()> is accepted here). Just make sure it's
a I<reading> mode.
my @lines = $file->slurp(iomode => ':crlf');
my $lines = $file->slurp(iomode => '<:encoding(UTF-8)');
The default C<iomode> is C<r>.
Lines can also be automatically split, mimicking the perl command-line
option C<-a> by using the C<split> parameter. If this parameter is used,
each line will be returned as an array ref.
my @lines = $file->slurp( chomp => 1, split => qr/\s*,\s*/ );
The C<split> parameter can only be used in a list context.
=item $file->spew( $content );
The opposite of L</slurp>, this takes a list of strings and prints them
to the file in write mode. If the file can't be written to, this method
will throw an exception.
The content to be written can be either an array ref or a plain scalar.
If the content is an array ref then each entry in the array will be
written to the file.
You may use the C<iomode> parameter to pass in an IO mode to use when
opening the file, just like L</slurp> supports.
$file->spew(iomode => '>:raw', $content);
The default C<iomode> is C<w>.
=item $file->spew_lines( $content );
Just like C<spew>, but, if $content is a plain scalar, appends $/
to it, or, if $content is an array ref, appends $/ to each element
of the array.
Can also take an C<iomode> parameter like C<spew>. Again, the
default C<iomode> is C<w>.
=item $file->traverse(sub { ... }, @args)
Calls the given callback on $file. This doesn't do much on its own,
but see the associated documentation in L<Path::Class::Dir>.
=item $file->remove()
This method will remove the file in a way that works well on all
platforms, and returns a boolean value indicating whether or not the
file was successfully removed.
C<remove()> is better than simply calling Perl's C<unlink()> function,
because on some platforms (notably VMS) you actually may need to call
C<unlink()> several times before all versions of the file are gone -
the C<remove()> method handles this process for you.
=item $st = $file->stat()
Invokes C<< File::stat::stat() >> on this file and returns a
L<File::stat> object representing the result.
=item $st = $file->lstat()
Same as C<stat()>, but if C<$file> is a symbolic link, C<lstat()>
stats the link instead of the file the link points to.
=item $class = $file->dir_class()
Returns the class which should be used to create directory objects.
Generally overridden whenever this class is subclassed.
=item $copy = $file->copy_to( $dest );
Copies the C<$file> to C<$dest>. It returns a L<Path::Class::File>
object when successful, C<undef> otherwise.
=item $moved = $file->move_to( $dest );
Moves the C<$file> to C<$dest>, and updates C<$file> accordingly.
It returns C<$file> is successful, C<undef> otherwise.
=back
=head1 AUTHOR
Ken Williams, kwilliams@cpan.org
=head1 SEE ALSO
L<Path::Class>, L<Path::Class::Dir>, L<File::Spec>
=cut

368
OGP64/usr/share/perl5/vendor_perl/5.40/Time/Zone.pm Normal file
View file

@ -0,0 +1,368 @@
package Time::Zone;
require 5.006;
require Exporter;
use Carp;
use strict;
use POSIX qw(tzset tzname);
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: miscellaneous timezone manipulations routines
our @ISA = qw(Exporter);
our @EXPORT = qw(tz2zone tz_local_offset tz_offset tz_name);
# Parts stolen from code by Paul Foley <paul@ascent.com>
my %tzn_cache;
sub tz2zone (;$$$)
{
my($TZ, $time, $isdst) = @_;
$TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : ''
unless $TZ;
# Hack to deal with 'PST8PDT' format of TZ
# Note that this can't deal with all the esoteric forms, but it
# does recognize the most common: [:]STDoff[DST[off][,rule]]
if (! defined $isdst) {
my $j;
$time = time() unless $time;
($j, $j, $j, $j, $j, $j, $j, $j, $isdst) = localtime($time);
}
if (defined $tzn_cache{$TZ}->[$isdst]) {
return $tzn_cache{$TZ}->[$isdst];
}
# Handle IANA timezone names (e.g., "America/Chicago", "Europe/Paris")
if ($TZ =~ m{/}) {
my ($std, $dst_name) = _iana_tzname($TZ);
$tzn_cache{$TZ} = [ $std, $dst_name ];
return $isdst ? $dst_name : $std;
}
if ($TZ =~ /^
( [^:\d+\-,] {3,} )
( [+-] ?
\d {1,2}
( : \d {1,2} ) {0,2}
)
( [^\d+\-,] {3,} )?
/x
) {
my $dsttz = defined($4) ? $4 : $1;
$TZ = $isdst ? $dsttz : $1;
$tzn_cache{$TZ} = [ $1, $dsttz ];
} else {
$tzn_cache{$TZ} = [ $TZ, $TZ ];
}
return $TZ;
}
my @tz_local;
sub tz_local_offset (;$)
{
my ($time) = @_;
$time = time() unless $time;
my (@l) = localtime($time);
my $isdst = $l[8];
if (defined($tz_local[$isdst])) {
return $tz_local[$isdst];
}
$tz_local[$isdst] = &calc_off($time);
return $tz_local[$isdst];
}
sub calc_off
{
my ($time) = @_;
my (@l) = localtime($time);
my (@g) = gmtime($time);
my $off;
$off = $l[0] - $g[0]
+ ($l[1] - $g[1]) * 60
+ ($l[2] - $g[2]) * 3600;
# subscript 7 is yday.
if ($l[7] == $g[7]) {
# done
} elsif ($l[7] == $g[7] + 1) {
$off += 86400;
} elsif ($l[7] == $g[7] - 1) {
$off -= 86400;
} elsif ($l[7] < $g[7]) {
# crossed over a year boundary!
# localtime is beginning of year, gmt is end
# therefore local is ahead
$off += 86400;
} else {
$off -= 86400;
}
return $off;
}
# Helper: temporarily set TZ to an IANA name, run a block, restore original TZ.
sub _with_iana_tz (&$) {
my ($code, $tz) = @_;
my $had_tz = exists $ENV{TZ};
my $saved = $ENV{TZ};
$ENV{TZ} = $tz;
tzset();
my @result = $code->();
if ($had_tz) { $ENV{TZ} = $saved } else { delete $ENV{TZ} }
tzset();
return @result;
}
# Return (std_name, dst_name) for an IANA timezone string.
sub _iana_tzname {
my ($tz) = @_;
my ($std, $dst) = _with_iana_tz { tzname() } $tz;
$dst = $std unless defined $dst;
return ($std, $dst);
}
# Return the UTC offset in seconds for an IANA timezone string at a given time.
sub _iana_offset {
my ($tz, $time) = @_;
$time = time() unless $time;
my ($off) = _with_iana_tz { calc_off($time) } $tz;
return $off;
}
# constants
my (%dstZone, %zoneOff, %dstZoneOff, %Zone);
CONFIG: {
my @dstZone = (
"ndt" => -2*3600-1800, # Newfoundland Daylight
"brst" => -2*3600, # Brazil Summer Time (East Daylight)
"adt" => -3*3600, # Atlantic Daylight
"edt" => -4*3600, # Eastern Daylight
"cdt" => -5*3600, # Central Daylight
"mdt" => -6*3600, # Mountain Daylight
"pdt" => -7*3600, # Pacific Daylight
"akdt" => -8*3600, # Alaska Daylight
"ydt" => -8*3600, # Yukon Daylight
"hdt" => -9*3600, # Hawaii Daylight
"bst" => +1*3600, # British Summer
"cest" => +2*3600, # Central European Summer (preferred)
"mest" => +2*3600, # Middle European Summer (alias, kept for compat)
"metdst" => +2*3600, # Middle European DST
"sst" => +2*3600, # Swedish Summer
"fst" => +2*3600, # French Summer
"eest" => +3*3600, # Eastern European Summer
"msd" => +4*3600, # Moscow Daylight (historical; Russia abolished DST permanently in Oct 2014)
"wadt" => +8*3600, # West Australian Daylight
"kdt" => +10*3600, # Korean Daylight
# "cadt" => +10*3600+1800, # Central Australian Daylight
"aedt" => +11*3600, # Eastern Australian Daylight
"eadt" => +11*3600, # Eastern Australian Daylight
"nzd" => +13*3600, # New Zealand Daylight
"nzdt" => +13*3600, # New Zealand Daylight
);
my @Zone = (
"gmt" => 0, # Greenwich Mean
"ut" => 0, # Universal (Coordinated)
"utc" => 0,
"wet" => 0, # Western European
"wat" => -1*3600, # West Africa
"at" => -2*3600, # Azores
"fnt" => -2*3600, # Brazil Time (Extreme East - Fernando Noronha)
"brt" => -3*3600, # Brazil Time (East Standard - Brasilia)
# For completeness. BST is also British Summer, and GST is also Guam Standard.
# "bst" => -3*3600, # Brazil Standard
# "gst" => -3*3600, # Greenland Standard
"nft" => -3*3600-1800,# Newfoundland
"nst" => -3*3600-1800,# Newfoundland Standard
"mnt" => -4*3600, # Brazil Time (West Standard - Manaus)
"ewt" => -4*3600, # U.S. Eastern War Time
"ast" => -4*3600, # Atlantic Standard
"est" => -5*3600, # Eastern Standard
"act" => -5*3600, # Brazil Time (Extreme West - Acre)
"cst" => -6*3600, # Central Standard
"mst" => -7*3600, # Mountain Standard
"pst" => -8*3600, # Pacific Standard
"akst" => -9*3600, # Alaska Standard
"yst" => -9*3600, # Yukon Standard
"hst" => -10*3600, # Hawaii Standard
"cat" => -10*3600, # Central Alaska
"ahst" => -10*3600, # Alaska-Hawaii Standard
"nt" => -11*3600, # Nome
"idlw" => -12*3600, # International Date Line West
"cet" => +1*3600, # Central European
"mez" => +1*3600, # Central European (German)
"ect" => +1*3600, # Central European (French)
"met" => +1*3600, # Middle European
"mewt" => +1*3600, # Middle European Winter
"swt" => +1*3600, # Swedish Winter
"set" => +1*3600, # Seychelles
"fwt" => +1*3600, # French Winter
"eet" => +2*3600, # Eastern Europe, USSR Zone 1
"ukr" => +2*3600, # Ukraine
"bt" => +3*3600, # Baghdad, USSR Zone 2
"msk" => +3*3600, # Moscow (UTC+3; was UTC+4 in 2011-2014 when Russia used permanent DST, reverted Oct 2014)
# "it" => +3*3600+1800,# Iran
"zp4" => +4*3600, # USSR Zone 3
"zp5" => +5*3600, # USSR Zone 4
"ist" => +5*3600+1800,# Indian Standard
"zp6" => +6*3600, # USSR Zone 5
# For completeness. NST is also Newfoundland Stanard, and SST is also Swedish Summer.
# "nst" => +6*3600+1800,# North Sumatra
# "sst" => +7*3600, # South Sumatra, USSR Zone 6
"ict" => +7*3600, # Indochina
# "jt" => +7*3600+1800,# Java (3pm in Cronusland!)
"ict" => +7*3600, # Indochina Time
"wst" => +8*3600, # West Australian Standard
"pht" => +8*3600, # Philippine
"hkt" => +8*3600, # Hong Kong
"pht" => +8*3600, # Philippine Time
"cct" => +8*3600, # China Coast, USSR Zone 7
"jst" => +9*3600, # Japan Standard, USSR Zone 8
"kst" => +9*3600, # Korean Standard
# "cast" => +9*3600+1800,# Central Australian Standard
"aest" => +10*3600, # Eastern Australian Standard
"east" => +10*3600, # Eastern Australian Standard
"gst" => +10*3600, # Guam Standard, USSR Zone 9
"nzt" => +12*3600, # New Zealand
"nzst" => +12*3600, # New Zealand Standard
"idle" => +12*3600, # International Date Line East
);
%Zone = @Zone;
%dstZone = @dstZone;
%zoneOff = reverse(@Zone);
%dstZoneOff = reverse(@dstZone);
}
sub tz_offset (;$$)
{
my ($zone, $time) = @_;
return &tz_local_offset($time) unless($zone);
$time = time() unless $time;
my(@l) = localtime($time);
my $dst = $l[8];
# Handle IANA timezone names (e.g., "America/Chicago") before lowercasing
if ($zone =~ m{/}) {
return _iana_offset($zone, $time);
}
$zone = lc $zone;
if($zone =~ /^(([\-\+])\d\d?)(\d\d)$/) {
my $v = $2 . $3;
return $1 * 3600 + $v * 60;
} elsif (exists $dstZone{$zone} && ($dst || !exists $Zone{$zone})) {
return $dstZone{$zone};
} elsif(exists $Zone{$zone}) {
return $Zone{$zone};
}
undef;
}
sub tz_name (;$$)
{
my ($off, $dst) = @_;
$off = tz_offset()
unless(defined $off);
$dst = (localtime(time))[8]
unless(defined $dst);
if (exists $dstZoneOff{$off} && ($dst || !exists $zoneOff{$off})) {
return $dstZoneOff{$off};
} elsif (exists $zoneOff{$off}) {
return $zoneOff{$off};
}
# $off is in seconds; format as +HHMM / -HHMM.
# Using abs() for the minutes component handles negative fractional-hour
# offsets correctly (e.g. -9000s = -2h30m → "-0230", not "-02-30").
sprintf("%+03d%02d", int($off / 3600), abs(int($off / 60)) % 60);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Time::Zone - miscellaneous timezone manipulations routines
=head1 VERSION
version 2.35
=head1 SYNOPSIS
use Time::Zone;
print tz2zone();
print tz2zone($ENV{'TZ'});
print tz2zone($ENV{'TZ'}, time());
my $isdst = 0;
print tz2zone($ENV{'TZ'}, undef, $isdst);
my $offset = tz_local_offset();
my $TZ = "EST";
$offset = tz_offset($TZ);
=head1 DESCRIPTION
This is a collection of miscellaneous timezone manipulation routines.
C<tz2zone()> parses the TZ environment variable and returns a timezone
string suitable for inclusion in L<date(1)>-like output. It optionally takes
a timezone string, a time, and a is-dst flag.
C<tz_local_offset()> determines the offset from GMT time in seconds. It
only does the calculation once.
C<tz_offset()> determines the offset from GMT in seconds of a specified
timezone.
C<tz_name()> determines the name of the timezone based on its offset
=head1 NAME
Time::Zone -- miscellaneous timezone manipulations routines
=head1 AUTHORS
Graham Barr <gbarr@pobox.com>
David Muir Sharnoff <muir@idiom.com>
Paul Foley <paul@ascent.com>
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

83
OGP64/usr/share/perl5/vendor_perl/5.40/TimeDate.pm Normal file
View file

@ -0,0 +1,83 @@
package TimeDate;
our $VERSION = '2.35'; # VERSION: generated
# ABSTRACT: Date and time formatting subroutines
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
TimeDate - Date and time formatting subroutines
=head1 VERSION
version 2.35
=head1 SYNOPSIS
use Date::Format;
use Date::Parse;
# Formatting
print time2str("%Y-%m-%d %T", time); # 2024-01-15 14:30:00
print time2str("%a %b %e %T %Y\n", time); # Mon Jan 15 14:30:00 2024
# Parsing
my $time = str2time("Wed, 16 Jun 94 07:29:35 CST");
my ($ss,$mm,$hh,$day,$month,$year,$zone) = strptime("2024-01-15T14:30:00Z");
# Multi-language support
use Date::Language;
my $lang = Date::Language->new('German');
print $lang->time2str("%a %b %e %T %Y\n", time);
=head1 DESCRIPTION
The TimeDate distribution provides date parsing, formatting, and timezone
handling for Perl.
=over 4
=item L<Date::Parse>
Parse date strings in a wide variety of formats into Unix timestamps
or component values.
=item L<Date::Format>
Format Unix timestamps or localtime arrays into strings using
C<strftime>-style conversion specifications.
=item L<Date::Language>
Format and parse dates in over 30 languages including French, German,
Spanish, Chinese, Russian, Arabic, and many more.
=item L<Time::Zone>
Timezone offset lookups and conversions for named timezones.
=back
=head1 SEE ALSO
L<Date::Format>, L<Date::Parse>, L<Date::Language>, L<Time::Zone>
=head1 AUTHOR
Graham <gbarr@pobox.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Graham Barr.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

1398
OGP64/usr/share/perl5/vendor_perl/5.40/URI.pm Normal file
View file

File diff suppressed because it is too large Load diff

248
OGP64/usr/share/perl5/vendor_perl/5.40/URI/Escape.pm Normal file
View file

@ -0,0 +1,248 @@
package URI::Escape;
use strict;
use warnings;
=head1 NAME
URI::Escape - Percent-encode and percent-decode unsafe characters
=head1 SYNOPSIS
use URI::Escape;
$safe = uri_escape("10% is enough\n");
$verysafe = uri_escape("foo", "\0-\377");
$str = uri_unescape($safe);
=head1 DESCRIPTION
This module provides functions to percent-encode and percent-decode URI strings as
defined by RFC 3986. Percent-encoding URI's is informally called "URI escaping".
This is the terminology used by this module, which predates the formalization of the
terms by the RFC by several years.
A URI consists of a restricted set of characters. The restricted set
of characters consists of digits, letters, and a few graphic symbols
chosen from those common to most of the character encodings and input
facilities available to Internet users. They are made up of the
"unreserved" and "reserved" character sets as defined in RFC 3986.
unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"
reserved = ":" / "/" / "?" / "#" / "[" / "]" / "@"
"!" / "$" / "&" / "'" / "(" / ")"
/ "*" / "+" / "," / ";" / "="
In addition, any byte (octet) can be represented in a URI by an escape
sequence: a triplet consisting of the character "%" followed by two
hexadecimal digits. A byte can also be represented directly by a
character, using the US-ASCII character for that octet.
Some of the characters are I<reserved> for use as delimiters or as
part of certain URI components. These must be escaped if they are to
be treated as ordinary data. Read RFC 3986 for further details.
The functions provided (and exported by default) from this module are:
=over 4
=item uri_escape( $string )
=item uri_escape( $string, $unsafe )
Replaces each unsafe character in the $string with the corresponding
escape sequence and returns the result. The $string argument should
be a string of bytes. The uri_escape() function will croak if given a
characters with code above 255. Use uri_escape_utf8() if you know you
have such chars or/and want chars in the 128 .. 255 range treated as
UTF-8.
The uri_escape() function takes an optional second argument that
overrides the set of characters that are to be escaped. The set is
specified as a string that can be used in a regular expression
character class (between [ ]). E.g.:
"\x00-\x1f\x7f-\xff" # all control and hi-bit characters
"a-z" # all lower case characters
"^A-Za-z" # everything not a letter
The default set of characters to be escaped is all those which are
I<not> part of the C<unreserved> character class shown above as well
as the reserved characters. I.e. the default is:
"^A-Za-z0-9\-\._~"
The second argument can also be specified as a regular expression object:
qr/[^A-Za-z]/
Any strings matched by this regular expression will have all of their
characters escaped.
=item uri_escape_utf8( $string )
=item uri_escape_utf8( $string, $unsafe )
Works like uri_escape(), but will encode chars as UTF-8 before
escaping them. This makes this function able to deal with characters
with code above 255 in $string. Note that chars in the 128 .. 255
range will be escaped differently by this function compared to what
uri_escape() would. For chars in the 0 .. 127 range there is no
difference.
Equivalent to:
utf8::encode($string);
my $uri = uri_escape($string);
Note: JavaScript has a function called escape() that produces the
sequence "%uXXXX" for chars in the 256 .. 65535 range. This function
has really nothing to do with URI escaping but some folks got confused
since it "does the right thing" in the 0 .. 255 range. Because of
this you sometimes see "URIs" with these kind of escapes. The
JavaScript encodeURIComponent() function is similar to uri_escape_utf8().
=item uri_unescape($string,...)
Returns a string with each %XX sequence replaced with the actual byte
(octet).
This does the same as:
$string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
but does not modify the string in-place as this RE would. Using the
uri_unescape() function instead of the RE might make the code look
cleaner and is a few characters less to type.
In a simple benchmark test I did,
calling the function (instead of the inline RE above) if a few chars
were unescaped was something like 40% slower, and something like 700% slower if none were. If
you are going to unescape a lot of times it might be a good idea to
inline the RE.
If the uri_unescape() function is passed multiple strings, then each
one is returned unescaped.
=back
The module can also export the C<%escapes> hash, which contains the
mapping from all 256 bytes to the corresponding escape codes. Lookup
in this hash is faster than evaluating C<sprintf("%%%02X", ord($byte))>
each time.
=head1 SEE ALSO
L<URI>
=head1 COPYRIGHT
Copyright 1995-2004 Gisle Aas.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
use Exporter 5.57 'import';
our %escapes;
our @EXPORT = qw(uri_escape uri_unescape uri_escape_utf8);
our @EXPORT_OK = qw(%escapes);
our $VERSION = '5.34';
use Carp ();
# Build a char->hex map
for (0..255) {
$escapes{chr($_)} = sprintf("%%%02X", $_);
}
my %subst; # compiled patterns
my %Unsafe = (
RFC2732 => qr/[^A-Za-z0-9\-_.!~*'()]/,
RFC3986 => qr/[^A-Za-z0-9\-\._~]/,
);
sub uri_escape {
my($text, $patn) = @_;
return undef unless defined $text;
my $re;
if (defined $patn){
if (ref $patn eq 'Regexp') {
$text =~ s{($patn)}{
join('', map +($escapes{$_} || _fail_hi($_)), split //, "$1")
}ge;
return $text;
}
$re = $subst{$patn};
if (!defined $re) {
$re = $patn;
# we need to escape the [] characters, except for those used in
# posix classes. if they are prefixed by a backslash, allow them
# through unmodified.
$re =~ s{(\[:\w+:\])|(\\)?([\[\]]|\\\z)}{
defined $1 ? $1 : defined $2 ? "$2$3" : "\\$3"
}ge;
eval {
# disable the warnings here, since they will trigger later
# when used, and we only want them to appear once per call,
# but every time the same pattern is used.
no warnings 'regexp';
$re = $subst{$patn} = qr{[$re]};
1;
} or Carp::croak("uri_escape: $@");
}
}
else {
$re = $Unsafe{RFC3986};
}
$text =~ s/($re)/$escapes{$1} || _fail_hi($1)/ge;
$text;
}
sub _fail_hi {
my $chr = shift;
Carp::croak(sprintf "Can't escape \\x{%04X}, try uri_escape_utf8() instead", ord($chr));
}
sub uri_escape_utf8 {
my $text = shift;
return undef unless defined $text;
utf8::encode($text);
return uri_escape($text, @_);
}
sub uri_unescape {
# Note from RFC1630: "Sequences which start with a percent sign
# but are not followed by two hexadecimal characters are reserved
# for future extension"
my $str = shift;
if (@_ && wantarray) {
# not executed for the common case of a single argument
my @str = ($str, @_); # need to copy
for (@str) {
s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
}
return @str;
}
$str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str;
$str;
}
# XXX FIXME escape_char is buggy as it assigns meaning to the string's storage format.
sub escape_char {
# Old versions of utf8::is_utf8() didn't properly handle magical vars (e.g. $1).
# The following forces a fetch to occur beforehand.
my $dummy = substr($_[0], 0, 0);
if (utf8::is_utf8($_[0])) {
my $s = shift;
utf8::encode($s);
unshift(@_, $s);
}
return join '', @URI::Escape::escapes{split //, $_[0]};
}
1;

258
OGP64/usr/share/perl5/vendor_perl/5.40/URI/Heuristic.pm Normal file
View file

@ -0,0 +1,258 @@
package URI::Heuristic;
=head1 NAME
URI::Heuristic - Expand URI using heuristics
=head1 SYNOPSIS
use URI::Heuristic qw(uf_uristr);
$u = uf_uristr("example"); # http://www.example.com
$u = uf_uristr("www.sol.no/sol"); # http://www.sol.no/sol
$u = uf_uristr("aas"); # http://www.aas.no
$u = uf_uristr("ftp.funet.fi"); # ftp://ftp.funet.fi
$u = uf_uristr("/etc/passwd"); # file:/etc/passwd
=head1 DESCRIPTION
This module provides functions that expand strings into real absolute
URIs using some built-in heuristics. Strings that already represent
absolute URIs (i.e. that start with a C<scheme:> part) are never modified
and are returned unchanged. The main use of these functions is to
allow abbreviated URIs similar to what many web browsers allow for URIs
typed in by the user.
The following functions are provided:
=over 4
=item uf_uristr($str)
Tries to make the argument string
into a proper absolute URI string. The "uf_" prefix stands for "User
Friendly". Under MacOS, it assumes that any string with a common URL
scheme (http, ftp, etc.) is a URL rather than a local path. So don't name
your volumes after common URL schemes and expect uf_uristr() to construct
valid file: URL's on those volumes for you, because it won't.
=item uf_uri($str)
Works the same way as uf_uristr() but
returns a C<URI> object.
=back
=head1 ENVIRONMENT
If the hostname portion of a URI does not contain any dots, then
certain qualified guesses are made. These guesses are governed by
the following environment variables:
=over 10
=item COUNTRY
The two-letter country code (ISO 3166) for your location. If
the domain name of your host ends with two letters, then it is taken
to be the default country. See also L<Locale::Country>.
=item HTTP_ACCEPT_LANGUAGE, LC_ALL, LANG
If COUNTRY is not set, these standard environment variables are
examined and country (not language) information possibly found in them
is used as the default country.
=item URL_GUESS_PATTERN
Contains a space-separated list of URL patterns to try. The string
"ACME" is for some reason used as a placeholder for the host name in
the URL provided. Example:
URL_GUESS_PATTERN="www.ACME.no www.ACME.se www.ACME.com"
export URL_GUESS_PATTERN
Specifying URL_GUESS_PATTERN disables any guessing rules based on
country. An empty URL_GUESS_PATTERN disables any guessing that
involves host name lookups.
=back
=head1 COPYRIGHT
Copyright 1997-1998, Gisle Aas
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
use strict;
use warnings;
use Exporter 5.57 'import';
our @EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr);
our $VERSION = '5.34';
our ($MY_COUNTRY, $DEBUG);
sub MY_COUNTRY() {
for ($MY_COUNTRY) {
return $_ if defined;
# First try the environment.
$_ = $ENV{COUNTRY};
return $_ if defined;
# Try the country part of LC_ALL and LANG from environment
my @srcs = ($ENV{LC_ALL}, $ENV{LANG});
# ...and HTTP_ACCEPT_LANGUAGE before those if present
if (my $httplang = $ENV{HTTP_ACCEPT_LANGUAGE}) {
# TODO: q-value processing/ordering
for $httplang (split(/\s*,\s*/, $httplang)) {
if ($httplang =~ /^\s*([a-zA-Z]+)[_-]([a-zA-Z]{2})\s*$/) {
unshift(@srcs, "${1}_${2}");
last;
}
}
}
for (@srcs) {
next unless defined;
return lc($1) if /^[a-zA-Z]+_([a-zA-Z]{2})(?:[.@]|$)/;
}
# Last bit of domain name. This may access the network.
require Net::Domain;
my $fqdn = Net::Domain::hostfqdn();
$_ = lc($1) if $fqdn =~ /\.([a-zA-Z]{2})$/;
return $_ if defined;
# Give up. Defined but false.
return ($_ = 0);
}
}
our %LOCAL_GUESSING =
(
'us' => [qw(www.ACME.gov www.ACME.mil)],
'gb' => [qw(www.ACME.co.uk www.ACME.org.uk www.ACME.ac.uk)],
'au' => [qw(www.ACME.com.au www.ACME.org.au www.ACME.edu.au)],
'il' => [qw(www.ACME.co.il www.ACME.org.il www.ACME.net.il)],
# send corrections and new entries to <gisle@aas.no>
);
# Backwards compatibility; uk != United Kingdom in ISO 3166
$LOCAL_GUESSING{uk} = $LOCAL_GUESSING{gb};
sub uf_uristr ($)
{
local($_) = @_;
print STDERR "uf_uristr: resolving $_\n" if $DEBUG;
return unless defined;
s/^\s+//;
s/\s+$//;
if (/^(www|web|home)[a-z0-9-]*(?:\.|$)/i) {
$_ = "http://$_";
} elsif (/^(ftp|gopher|news|wais|https|http)[a-z0-9-]*(?:\.|$)/i) {
$_ = lc($1) . "://$_";
} elsif (
m,^//, || m,^[\\][\\],) # UNC-like file name
{
s{[\\]}{/}g;
$_ = "smb:$_";
} elsif ($^O ne "MacOS" &&
(m,^/, || # absolute file name
m,^\.\.?/, || # relative file name
m,^[a-zA-Z]:[/\\],) # dosish file name
)
{
$_ = "file:$_";
} elsif ($^O eq "MacOS" && m/:/) {
# potential MacOS file name
unless (m/^(ftp|gopher|news|wais|http|https|mailto):/) {
require URI::file;
my $a = URI::file->new($_)->as_string;
$_ = ($a =~ m/^file:/) ? $a : "file:$a";
}
} elsif (/^\w+([\.\-]\w+)*\@(\w+\.)+\w{2,3}$/) {
$_ = "mailto:$_";
} elsif (!/^[a-zA-Z][a-zA-Z0-9.+\-]*:/) { # no scheme specified
if (s/^([-\w]+(?:\.[-\w]+)*)([\/:\?\#]|$)/$2/) {
my $host = $1;
my $scheme = "http";
if (/^:(\d+)\b/) {
# Some more or less well known ports
if ($1 =~ /^[56789]?443$/) {
$scheme = "https";
} elsif ($1 eq "21") {
$scheme = "ftp";
}
}
if ($host !~ /\./ && $host ne "localhost") {
my @guess;
if (exists $ENV{URL_GUESS_PATTERN}) {
@guess = map { s/\bACME\b/$host/; $_ }
split(' ', $ENV{URL_GUESS_PATTERN});
} else {
if (MY_COUNTRY()) {
my $special = $LOCAL_GUESSING{MY_COUNTRY()};
if ($special) {
my @special = @$special;
push(@guess, map { s/\bACME\b/$host/; $_ }
@special);
} else {
push(@guess, "www.$host." . MY_COUNTRY());
}
}
push(@guess, map "www.$host.$_",
"com", "org", "net", "edu", "int");
}
my $guess;
for $guess (@guess) {
print STDERR "uf_uristr: gethostbyname('$guess.')..."
if $DEBUG;
if (gethostbyname("$guess.")) {
print STDERR "yes\n" if $DEBUG;
$host = $guess;
last;
}
print STDERR "no\n" if $DEBUG;
}
}
$_ = "$scheme://$host$_";
} else {
# pure junk, just return it unchanged...
}
}
print STDERR "uf_uristr: ==> $_\n" if $DEBUG;
$_;
}
sub uf_uri ($)
{
require URI;
URI->new(uf_uristr($_[0]));
}
# legacy
*uf_urlstr = \*uf_uristr;
sub uf_url ($)
{
require URI::URL;
URI::URL->new(uf_uristr($_[0]));
}
1;

47
OGP64/usr/share/perl5/vendor_perl/5.40/URI/IRI.pm Normal file
View file

@ -0,0 +1,47 @@
package URI::IRI;
# Experimental
use strict;
use warnings;
use URI ();
use overload '""' => sub { shift->as_string };
our $VERSION = '5.34';
sub new {
my($class, $uri, $scheme) = @_;
utf8::upgrade($uri);
return bless {
uri => URI->new($uri, $scheme),
}, $class;
}
sub clone {
my $self = shift;
return bless {
uri => $self->{uri}->clone,
}, ref($self);
}
sub as_string {
my $self = shift;
return $self->{uri}->as_iri;
}
our $AUTOLOAD;
sub AUTOLOAD
{
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
# We create the function here so that it will not need to be
# autoloaded the next time.
no strict 'refs';
*$method = sub { shift->{uri}->$method(@_) };
goto &$method;
}
sub DESTROY {} # avoid AUTOLOADing it
1;

33
OGP64/usr/share/perl5/vendor_perl/5.40/URI/QueryParam.pm Normal file
View file

@ -0,0 +1,33 @@
package URI::QueryParam;
use strict;
use warnings;
our $VERSION = '5.34';
1;
__END__
=head1 NAME
URI::QueryParam - Additional query methods for URIs
=head1 SYNOPSIS
use URI;
=head1 DESCRIPTION
C<URI::QueryParam> used to provide the
L<< query_form_hash|URI/$hashref = $u->query_form_hash >>,
L<< query_param|URI/@keys = $u->query_param >>
L<< query_param_append|URI/$u->query_param_append($key, $value,...) >>, and
L<< query_param_delete|URI/ @values = $u->query_param_delete($key) >> methods
on L<URI> objects. These methods have been merged into L<URI> itself, so this
module is now a no-op.
=head1 COPYRIGHT
Copyright 2002 Gisle Aas.
=cut

97
OGP64/usr/share/perl5/vendor_perl/5.40/URI/Split.pm Normal file
View file

@ -0,0 +1,97 @@
package URI::Split;
use strict;
use warnings;
our $VERSION = '5.34';
use Exporter 5.57 'import';
our @EXPORT_OK = qw(uri_split uri_join);
use URI::Escape ();
sub uri_split {
return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
}
sub uri_join {
my($scheme, $auth, $path, $query, $frag) = @_;
my $uri = defined($scheme) ? "$scheme:" : "";
$path = "" unless defined $path;
if (defined $auth) {
$auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
$uri .= "//$auth";
$path = "/$path" if length($path) && $path !~ m,^/,;
}
elsif ($path =~ m,^//,) {
$uri .= "//"; # XXX force empty auth
}
unless (length $uri) {
$path =~ s,(:), URI::Escape::escape_char($1),e while $path =~ m,^[^:/?\#]+:,;
}
$path =~ s,([?\#]), URI::Escape::escape_char($1),eg;
$uri .= $path;
if (defined $query) {
$query =~ s,(\#), URI::Escape::escape_char($1),eg;
$uri .= "?$query";
}
$uri .= "#$frag" if defined $frag;
$uri;
}
1;
__END__
=head1 NAME
URI::Split - Parse and compose URI strings
=head1 SYNOPSIS
use URI::Split qw(uri_split uri_join);
($scheme, $auth, $path, $query, $frag) = uri_split($uri);
$uri = uri_join($scheme, $auth, $path, $query, $frag);
=head1 DESCRIPTION
Provides functions to parse and compose URI
strings. The following functions are provided:
=over
=item ($scheme, $auth, $path, $query, $frag) = uri_split($uri)
Breaks up a URI string into its component
parts. An C<undef> value is returned for those parts that are not
present. The $path part is always present (but can be the empty
string) and is thus never returned as C<undef>.
No sensible value is returned if this function is called in a scalar
context.
=item $uri = uri_join($scheme, $auth, $path, $query, $frag)
Puts together a URI string from its parts.
Missing parts are signaled by passing C<undef> for the corresponding
argument.
Minimal escaping is applied to parts that contain reserved chars
that would confuse a parser. For instance, any occurrence of '?' or '#'
in $path is always escaped, as it would otherwise be parsed back
as a query or fragment.
=back
=head1 SEE ALSO
L<URI>, L<URI::Escape>
=head1 COPYRIGHT
Copyright 2003, Gisle Aas
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut

303
OGP64/usr/share/perl5/vendor_perl/5.40/URI/URL.pm Normal file
View file

@ -0,0 +1,303 @@
package URI::URL;
use strict;
use warnings;
use parent 'URI::WithBase';
our $VERSION = '5.34';
# Provide as much as possible of the old URI::URL interface for backwards
# compatibility...
use Exporter 5.57 'import';
our @EXPORT = qw(url);
# Easy to use constructor
sub url ($;$) { URI::URL->new(@_); }
use URI::Escape qw(uri_unescape);
sub new
{
my $class = shift;
my $self = $class->SUPER::new(@_);
$self->[0] = $self->[0]->canonical;
$self;
}
sub newlocal
{
my $class = shift;
require URI::file;
bless [URI::file->new_abs(shift)], $class;
}
{package URI::_foreign;
sub _init # hope it is not defined
{
my $class = shift;
die "Unknown URI::URL scheme $_[1]:" if $URI::URL::STRICT;
$class->SUPER::_init(@_);
}
}
sub strict
{
my $old = $URI::URL::STRICT;
$URI::URL::STRICT = shift if @_;
$old;
}
sub print_on
{
my $self = shift;
require Data::Dumper;
print STDERR Data::Dumper::Dumper($self);
}
sub _try
{
my $self = shift;
my $method = shift;
scalar(eval { $self->$method(@_) });
}
sub crack
{
# should be overridden by subclasses
my $self = shift;
(scalar($self->scheme),
$self->_try("user"),
$self->_try("password"),
$self->_try("host"),
$self->_try("port"),
$self->_try("path"),
$self->_try("params"),
$self->_try("query"),
scalar($self->fragment),
)
}
sub full_path
{
my $self = shift;
my $path = $self->path_query;
$path = "/" unless length $path;
$path;
}
sub netloc
{
shift->authority(@_);
}
sub epath
{
my $path = shift->SUPER::path(@_);
$path =~ s/;.*//;
$path;
}
sub eparams
{
my $self = shift;
my @p = $self->path_segments;
return undef unless ref($p[-1]);
@p = @{$p[-1]};
shift @p;
join(";", @p);
}
sub params { shift->eparams(@_); }
sub path {
my $self = shift;
my $old = $self->epath(@_);
return unless defined wantarray;
return '/' if !defined($old) || !length($old);
Carp::croak("Path components contain '/' (you must call epath)")
if $old =~ /%2[fF]/ and !@_;
$old = "/$old" if $old !~ m|^/| && defined $self->netloc;
return uri_unescape($old);
}
sub path_components {
shift->path_segments(@_);
}
sub query {
my $self = shift;
my $old = $self->equery(@_);
if (defined(wantarray) && defined($old)) {
if ($old =~ /%(?:26|2[bB]|3[dD])/) { # contains escaped '=' '&' or '+'
my $mess;
for ($old) {
$mess = "Query contains both '+' and '%2B'"
if /\+/ && /%2[bB]/;
$mess = "Form query contains escaped '=' or '&'"
if /=/ && /%(?:3[dD]|26)/;
}
if ($mess) {
Carp::croak("$mess (you must call equery)");
}
}
# Now it should be safe to unescape the string without losing
# information
return uri_unescape($old);
}
undef;
}
sub abs
{
my $self = shift;
my $base = shift;
my $allow_scheme = shift;
$allow_scheme = $URI::URL::ABS_ALLOW_RELATIVE_SCHEME
unless defined $allow_scheme;
local $URI::ABS_ALLOW_RELATIVE_SCHEME = $allow_scheme;
local $URI::ABS_REMOTE_LEADING_DOTS = $URI::URL::ABS_REMOTE_LEADING_DOTS;
$self->SUPER::abs($base);
}
sub frag { shift->fragment(@_); }
sub keywords { shift->query_keywords(@_); }
# file:
sub local_path { shift->file; }
sub unix_path { shift->file("unix"); }
sub dos_path { shift->file("dos"); }
sub mac_path { shift->file("mac"); }
sub vms_path { shift->file("vms"); }
# mailto:
sub address { shift->to(@_); }
sub encoded822addr { shift->to(@_); }
sub URI::mailto::authority { shift->to(@_); } # make 'netloc' method work
# news:
sub groupart { shift->_group(@_); }
sub article { shift->message(@_); }
1;
__END__
=head1 NAME
URI::URL - Uniform Resource Locators
=head1 SYNOPSIS
$u1 = URI::URL->new($str, $base);
$u2 = $u1->abs;
=head1 DESCRIPTION
This module is provided for backwards compatibility with modules that
depend on the interface provided by the C<URI::URL> class that used to
be distributed with the libwww-perl library.
The following differences exist compared to the C<URI> class interface:
=over 3
=item *
The URI::URL module exports the url() function as an alternate
constructor interface.
=item *
The constructor takes an optional $base argument. The C<URI::URL>
class is a subclass of C<URI::WithBase>.
=item *
The URI::URL->newlocal class method is the same as URI::file->new_abs.
=item *
URI::URL::strict(1)
=item *
$url->print_on method
=item *
$url->crack method
=item *
$url->full_path: same as ($uri->abs_path || "/")
=item *
$url->netloc: same as $uri->authority
=item *
$url->epath, $url->equery: same as $uri->path, $uri->query
=item *
$url->path and $url->query pass unescaped strings.
=item *
$url->path_components: same as $uri->path_segments (if you don't
consider path segment parameters)
=item *
$url->params and $url->eparams methods
=item *
$url->base method. See L<URI::WithBase>.
=item *
$url->abs and $url->rel have an optional $base argument. See
L<URI::WithBase>.
=item *
$url->frag: same as $uri->fragment
=item *
$url->keywords: same as $uri->query_keywords
=item *
$url->localpath and friends map to $uri->file.
=item *
$url->address and $url->encoded822addr: same as $uri->to for mailto URI
=item *
$url->groupart method for news URI
=item *
$url->article: same as $uri->message
=back
=head1 SEE ALSO
L<URI>, L<URI::WithBase>
=head1 COPYRIGHT
Copyright 1998-2000 Gisle Aas.
=cut

174
OGP64/usr/share/perl5/vendor_perl/5.40/URI/WithBase.pm Normal file
View file

@ -0,0 +1,174 @@
package URI::WithBase;
use strict;
use warnings;
use URI ();
use Scalar::Util qw(blessed);
our $VERSION = '5.34';
use overload '""' => "as_string", fallback => 1;
sub as_string; # help overload find it
sub new
{
my($class, $uri, $base) = @_;
my $ibase = $base;
if ($base && blessed($base) && $base->isa(__PACKAGE__)) {
$base = $base->abs;
$ibase = $base->[0];
}
bless [URI->new($uri, $ibase), $base], $class;
}
sub new_abs
{
my $class = shift;
my $self = $class->new(@_);
$self->abs;
}
sub _init
{
my $class = shift;
my($str, $scheme) = @_;
bless [URI->new($str, $scheme), undef], $class;
}
sub eq
{
my($self, $other) = @_;
$other = $other->[0] if blessed($other) and $other->isa(__PACKAGE__);
$self->[0]->eq($other);
}
our $AUTOLOAD;
sub AUTOLOAD
{
my $self = shift;
my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
return if $method eq "DESTROY";
$self->[0]->$method(@_);
}
sub can { # override UNIVERSAL::can
my $self = shift;
$self->SUPER::can(@_) || (
ref($self)
? $self->[0]->can(@_)
: undef
)
}
sub base {
my $self = shift;
my $base = $self->[1];
if (@_) { # set
my $new_base = shift;
# ensure absoluteness
$new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__);
$self->[1] = $new_base;
}
return unless defined wantarray;
# The base attribute supports 'lazy' conversion from URL strings
# to URL objects. Strings may be stored but when a string is
# fetched it will automatically be converted to a URL object.
# The main benefit is to make it much cheaper to say:
# URI::WithBase->new($random_url_string, 'http:')
if (defined($base) && !ref($base)) {
$base = ref($self)->new($base);
$self->[1] = $base unless @_;
}
$base;
}
sub clone
{
my $self = shift;
my $base = $self->[1];
$base = $base->clone if ref($base);
bless [$self->[0]->clone, $base], ref($self);
}
sub abs
{
my $self = shift;
my $base = shift || $self->base || return $self->clone;
$base = $base->as_string if ref($base);
bless [$self->[0]->abs($base, @_), $base], ref($self);
}
sub rel
{
my $self = shift;
my $base = shift || $self->base || return $self->clone;
$base = $base->as_string if ref($base);
bless [$self->[0]->rel($base, @_), $base], ref($self);
}
1;
__END__
=head1 NAME
URI::WithBase - URIs which remember their base
=head1 SYNOPSIS
$u1 = URI::WithBase->new($str, $base);
$u2 = $u1->abs;
$base = $u1->base;
$u1->base( $new_base )
=head1 DESCRIPTION
This module provides the C<URI::WithBase> class. Objects of this class
are like C<URI> objects, but can keep their base too. The base
represents the context where this URI was found and can be used to
absolutize or relativize the URI. All the methods described in L<URI>
are supported for C<URI::WithBase> objects.
The methods provided in addition to or modified from those of C<URI> are:
=over 4
=item $uri = URI::WithBase->new($str, [$base])
The constructor takes an optional base URI as the second argument.
If provided, this argument initializes the base attribute.
=item $uri->base( [$new_base] )
Can be used to get or set the value of the base attribute.
The return value, which is the old value, is a URI object or C<undef>.
=item $uri->abs( [$base_uri] )
The $base_uri argument is now made optional as the object carries its
base with it. A new object is returned even if $uri is already
absolute (while plain URI objects simply return themselves in
that case).
=item $uri->rel( [$base_uri] )
The $base_uri argument is now made optional as the object carries its
base with it. A new object is always returned.
=back
=head1 SEE ALSO
L<URI>
=head1 COPYRIGHT
Copyright 1998-2002 Gisle Aas.
=cut

70
OGP64/usr/share/perl5/vendor_perl/5.40/URI/_emailauth.pm Normal file
View file

@ -0,0 +1,70 @@
package URI::_emailauth;
use strict;
use warnings;
our $VERSION = '5.34';
use parent 'URI::_server';
use URI::Escape qw(uri_unescape);
# Common user/auth code used in email URL schemes, such as POP, SMTP, IMAP.
# <scheme>://<user>;auth=<auth>@<host>:<port>
sub user
{
my $self = shift;
my $old = $self->userinfo;
if (@_) {
my $new_info = $old;
$new_info = "" unless defined $new_info;
$new_info =~ s/^[^;]*//;
my $new = shift;
if (!defined($new) && !length($new_info)) {
$self->userinfo(undef);
} else {
$new = "" unless defined $new;
$new =~ s/%/%25/g;
$new =~ s/;/%3B/g;
$self->userinfo("$new$new_info");
}
}
return undef unless defined $old;
$old =~ s/;.*//;
return uri_unescape($old);
}
sub auth
{
my $self = shift;
my $old = $self->userinfo;
if (@_) {
my $new = $old;
$new = "" unless defined $new;
$new =~ s/(^[^;]*)//;
my $user = $1;
$new =~ s/;auth=[^;]*//i;
my $auth = shift;
if (defined $auth) {
$auth =~ s/%/%25/g;
$auth =~ s/;/%3B/g;
$new = ";AUTH=$auth$new";
}
$self->userinfo("$user$new");
}
return undef unless defined $old;
$old =~ s/^[^;]*//;
return uri_unescape($1) if $old =~ /;auth=(.*)/i;
return;
}
1;

10
OGP64/usr/share/perl5/vendor_perl/5.40/URI/_foreign.pm Normal file
View file

@ -0,0 +1,10 @@
package URI::_foreign;
use strict;
use warnings;
use parent 'URI::_generic';
our $VERSION = '5.34';
1;

283
OGP64/usr/share/perl5/vendor_perl/5.40/URI/_generic.pm Normal file
View file

@ -0,0 +1,283 @@
package URI::_generic;
use strict;
use warnings;
use parent qw(URI URI::_query);
use URI::Escape qw(uri_unescape);
use Carp ();
our $VERSION = '5.34';
my $ACHAR = URI::HAS_RESERVED_SQUARE_BRACKETS ? $URI::uric : $URI::uric4host; $ACHAR =~ s,\\[/?],,g;
my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g;
sub _no_scheme_ok { 1 }
our $IPv6_re;
sub _looks_like_raw_ip6_address {
my $addr = shift;
if ( !$IPv6_re ) { #-- lazy / runs once / use Regexp::IPv6 if installed
eval {
require Regexp::IPv6;
Regexp::IPv6->import( qw($IPv6_re) );
1;
} || do { $IPv6_re = qr/[:0-9a-f]{3,}/; }; #-- fallback: unambitious guess
}
return 0 unless $addr;
return 0 if $addr =~ tr/:/:/ < 2; #-- fallback must not create false positive for IPv4:Port = 0:0
return 1 if $addr =~ /^$IPv6_re$/i;
return 0;
}
sub authority
{
my $self = shift;
$$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die;
if (@_) {
my $auth = shift;
$$self = $1;
my $rest = $3;
if (defined $auth) {
$auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego;
if ( my ($user, $host) = $auth =~ /^(.*@)?([^@]+)$/ ) { #-- special escape userinfo part
$user ||= '';
$user =~ s/([^$URI::uric4user])/ URI::Escape::escape_char($1)/ego;
$user =~ s/%40$/\@/; # recover final '@'
$host = "[$host]" if _looks_like_raw_ip6_address( $host );
$auth = $user . $host;
}
utf8::downgrade($auth);
$$self .= "//$auth";
}
_check_path($rest, $$self);
$$self .= $rest;
}
$2;
}
sub path
{
my $self = shift;
$$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die;
if (@_) {
$$self = $1;
my $rest = $3;
my $new_path = shift;
$new_path = "" unless defined $new_path;
$new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego;
utf8::downgrade($new_path);
_check_path($new_path, $$self);
$$self .= $new_path . $rest;
}
$2;
}
sub path_query
{
my $self = shift;
$$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die;
if (@_) {
$$self = $1;
my $rest = $3;
my $new_path = shift;
$new_path = "" unless defined $new_path;
$new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
utf8::downgrade($new_path);
_check_path($new_path, $$self);
$$self .= $new_path . $rest;
}
$2;
}
sub _check_path
{
my($path, $pre) = @_;
my $prefix;
if ($pre =~ m,/,) { # authority present
$prefix = "/" if length($path) && $path !~ m,^[/?\#],;
}
else {
if ($path =~ m,^//,) {
Carp::carp("Path starting with double slash is confusing")
if $^W;
}
elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
Carp::carp("Path might look like scheme, './' prepended")
if $^W;
$prefix = "./";
}
}
substr($_[0], 0, 0) = $prefix if defined $prefix;
}
sub path_segments
{
my $self = shift;
my $path = $self->path;
if (@_) {
my @arg = @_; # make a copy
for (@arg) {
if (ref($_)) {
my @seg = @$_;
$seg[0] =~ s/%/%25/g;
for (@seg) { s/;/%3B/g; }
$_ = join(";", @seg);
}
else {
s/%/%25/g; s/;/%3B/g;
}
s,/,%2F,g;
}
$self->path(join("/", @arg));
}
return $path unless wantarray;
map {/;/ ? $self->_split_segment($_)
: uri_unescape($_) }
split('/', $path, -1);
}
sub _split_segment
{
my $self = shift;
require URI::_segment;
URI::_segment->new(@_);
}
sub abs
{
my $self = shift;
my $base = shift || Carp::croak("Missing base argument");
if (my $scheme = $self->scheme) {
return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
$base = URI->new($base) unless ref $base;
return $self unless $scheme eq $base->scheme;
}
$base = URI->new($base) unless ref $base;
my $abs = $self->clone;
$abs->scheme($base->scheme);
return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
$abs->authority($base->authority);
my $path = $self->path;
return $abs if $path =~ m,^/,;
if (!length($path)) {
my $abs = $base->clone;
my $query = $self->query;
$abs->query($query) if defined $query;
my $fragment = $self->fragment;
$abs->fragment($fragment) if defined $fragment;
return $abs;
}
my $p = $base->path;
$p =~ s,[^/]+$,,;
$p .= $path;
my @p = split('/', $p, -1);
shift(@p) if @p && !length($p[0]);
my $i = 1;
while ($i < @p) {
#print "$i ", join("/", @p), " ($p[$i])\n";
if ($p[$i-1] eq ".") {
splice(@p, $i-1, 1);
$i-- if $i > 1;
}
elsif ($p[$i] eq ".." && $p[$i-1] ne "..") {
splice(@p, $i-1, 2);
if ($i > 1) {
$i--;
push(@p, "") if $i == @p;
}
}
else {
$i++;
}
}
$p[-1] = "" if @p && $p[-1] eq "."; # trailing "/."
if ($URI::ABS_REMOTE_LEADING_DOTS) {
shift @p while @p && $p[0] =~ /^\.\.?$/;
}
$abs->path("/" . join("/", @p));
$abs;
}
# The opposite of $url->abs. Return a URI which is as relative as possible
sub rel {
my $self = shift;
my $base = shift || Carp::croak("Missing base argument");
my $rel = $self->clone;
$base = URI->new($base) unless ref $base;
#my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)};
my $scheme = $rel->scheme;
my $auth = $rel->canonical->authority;
my $path = $rel->path;
if (!defined($scheme) && !defined($auth)) {
# it is already relative
return $rel;
}
#my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)};
my $bscheme = $base->scheme;
my $bauth = $base->canonical->authority;
my $bpath = $base->path;
for ($bscheme, $bauth, $auth) {
$_ = '' unless defined
}
unless ($scheme eq $bscheme && $auth eq $bauth) {
# different location, can't make it relative
return $rel;
}
for ($path, $bpath) { $_ = "/$_" unless m,^/,; }
# Make it relative by eliminating scheme and authority
$rel->scheme(undef);
$rel->authority(undef);
# This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>.
# First we calculate common initial path components length ($li).
my $li = 1;
while (1) {
my $i = index($path, '/', $li);
last if $i < 0 ||
$i != index($bpath, '/', $li) ||
substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
$li=$i+1;
}
# then we nuke it from both paths
substr($path, 0,$li) = '';
substr($bpath,0,$li) = '';
if ($path eq $bpath &&
defined($rel->fragment) &&
!defined($rel->query)) {
$rel->path("");
}
else {
# Add one "../" for each path component left in the base path
$path = ('../' x $bpath =~ tr|/|/|) . $path;
$path = "./" if $path eq "";
$rel->path($path);
}
$rel;
}
1;

91
OGP64/usr/share/perl5/vendor_perl/5.40/URI/_idna.pm Normal file
View file

@ -0,0 +1,91 @@
package URI::_idna;
# This module implements the RFCs 3490 (IDNA) and 3491 (Nameprep)
# based on Python-2.6.4/Lib/encodings/idna.py
use strict;
use warnings;
use URI::_punycode qw(decode_punycode encode_punycode);
use Carp qw(croak);
our $VERSION = '5.34';
BEGIN {
*URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS = "$]" < 5.008_003
? sub () { 1 }
: sub () { 0 }
;
}
my $ASCII = qr/^[\x00-\x7F]*\z/;
sub encode {
my $idomain = shift;
my @labels = split(/\./, $idomain, -1);
my @last_empty;
push(@last_empty, pop @labels) if @labels > 1 && $labels[-1] eq "";
for (@labels) {
$_ = ToASCII($_);
}
return eval 'join(".", @labels, @last_empty)' if URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS;
return join(".", @labels, @last_empty);
}
sub decode {
my $domain = shift;
return join(".", map ToUnicode($_), split(/\./, $domain, -1))
}
sub nameprep { # XXX real implementation missing
my $label = shift;
$label = lc($label);
return $label;
}
sub check_size {
my $label = shift;
croak "Label empty" if $label eq "";
croak "Label too long" if length($label) > 63;
return $label;
}
sub ToASCII {
my $label = shift;
return check_size($label) if $label =~ $ASCII;
# Step 2: nameprep
$label = nameprep($label);
# Step 3: UseSTD3ASCIIRules is false
# Step 4: try ASCII again
return check_size($label) if $label =~ $ASCII;
# Step 5: Check ACE prefix
if ($label =~ /^xn--/) {
croak "Label starts with ACE prefix";
}
# Step 6: Encode with PUNYCODE
$label = encode_punycode($label);
# Step 7: Prepend ACE prefix
$label = "xn--$label";
# Step 8: Check size
return check_size($label);
}
sub ToUnicode {
my $label = shift;
$label = nameprep($label) unless $label =~ $ASCII;
return $label unless $label =~ /^xn--/;
my $result = decode_punycode(substr($label, 4));
my $label2 = ToASCII($result);
if (lc($label) ne $label2) {
croak "IDNA does not round-trip: '\L$label\E' vs '$label2'";
}
return $result;
}
1;

140
OGP64/usr/share/perl5/vendor_perl/5.40/URI/_ldap.pm Normal file
View file

@ -0,0 +1,140 @@
# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package URI::_ldap;
use strict;
use warnings;
our $VERSION = '5.34';
use URI::Escape qw(uri_unescape);
sub _ldap_elem {
my $self = shift;
my $elem = shift;
my $query = $self->query;
my @bits = (split(/\?/,defined($query) ? $query : ""),("")x4);
my $old = $bits[$elem];
if (@_) {
my $new = shift;
$new =~ s/\?/%3F/g;
$bits[$elem] = $new;
$query = join("?",@bits);
$query =~ s/\?+$//;
$query = undef unless length($query);
$self->query($query);
}
$old;
}
sub dn {
my $old = shift->path(@_);
$old =~ s:^/::;
uri_unescape($old);
}
sub attributes {
my $self = shift;
my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ());
return $old unless wantarray;
map { uri_unescape($_) } split(/,/,$old);
}
sub _scope {
my $self = shift;
my $old = _ldap_elem($self,1, @_);
return undef unless defined wantarray && defined $old;
uri_unescape($old);
}
sub scope {
my $old = &_scope;
$old = "base" unless length $old;
$old;
}
sub _filter {
my $self = shift;
my $old = _ldap_elem($self,2, @_);
return undef unless defined wantarray && defined $old;
uri_unescape($old); # || "(objectClass=*)";
}
sub filter {
my $old = &_filter;
$old = "(objectClass=*)" unless length $old;
$old;
}
sub extensions {
my $self = shift;
my @ext;
while (@_) {
my $key = shift;
my $value = shift;
push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value));
}
@ext = join(",", @ext) if @ext;
my $old = _ldap_elem($self,3, @ext);
return $old unless wantarray;
map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old);
}
sub canonical
{
my $self = shift;
my $other = $self->_nonldap_canonical;
# The stuff below is not as efficient as one might hope...
$other = $other->clone if $other == $self;
$other->dn(_normalize_dn($other->dn));
# Should really know about mixed case "postalAddress", etc...
$other->attributes(map lc, $other->attributes);
# Lowercase scope, remove default
my $old_scope = $other->scope;
my $new_scope = lc($old_scope);
$new_scope = "" if $new_scope eq "base";
$other->scope($new_scope) if $new_scope ne $old_scope;
# Remove filter if default
my $old_filter = $other->filter;
$other->filter("") if lc($old_filter) eq "(objectclass=*)" ||
lc($old_filter) eq "objectclass=*";
# Lowercase extensions types and deal with known extension values
my @ext = $other->extensions;
for (my $i = 0; $i < @ext; $i += 2) {
my $etype = $ext[$i] = lc($ext[$i]);
if ($etype =~ /^!?bindname$/) {
$ext[$i+1] = _normalize_dn($ext[$i+1]);
}
}
$other->extensions(@ext) if @ext;
$other;
}
sub _normalize_dn # RFC 2253
{
my $dn = shift;
return $dn;
# The code below will fail if the "+" or "," is embedding in a quoted
# string or simply escaped...
my @dn = split(/([+,])/, $dn);
for (@dn) {
s/^([a-zA-Z]+=)/lc($1)/e;
}
join("", @dn);
}
1;

13
OGP64/usr/share/perl5/vendor_perl/5.40/URI/_login.pm Normal file
View file

@ -0,0 +1,13 @@
package URI::_login;
use strict;
use warnings;
use parent qw(URI::_server URI::_userpass);
our $VERSION = '5.34';
# Generic terminal logins. This is used as a base class for 'telnet',
# 'tn3270', and 'rlogin' URL schemes.
1;

217
OGP64/usr/share/perl5/vendor_perl/5.40/URI/_punycode.pm Normal file
View file

@ -0,0 +1,217 @@
package URI::_punycode;
use strict;
use warnings;
our $VERSION = '5.34';
use Exporter 'import';
our @EXPORT = qw(encode_punycode decode_punycode);
use integer;
our $DEBUG = 0;
use constant BASE => 36;
use constant TMIN => 1;
use constant TMAX => 26;
use constant SKEW => 38;
use constant DAMP => 700;
use constant INITIAL_BIAS => 72;
use constant INITIAL_N => 128;
my $Delimiter = chr 0x2D;
my $BasicRE = qr/[\x00-\x7f]/;
sub _croak { require Carp; Carp::croak(@_); }
sub _digit_value {
my $code = shift;
return ord($code) - ord("A") if $code =~ /[A-Z]/;
return ord($code) - ord("a") if $code =~ /[a-z]/;
return ord($code) - ord("0") + 26 if $code =~ /[0-9]/;
return;
}
sub _code_point {
my $digit = shift;
return $digit + ord('a') if 0 <= $digit && $digit <= 25;
return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36;
die 'NOT COME HERE';
}
sub _adapt {
my($delta, $numpoints, $firsttime) = @_;
$delta = $firsttime ? $delta / DAMP : $delta / 2;
$delta += $delta / $numpoints;
my $k = 0;
while ($delta > ((BASE - TMIN) * TMAX) / 2) {
$delta /= BASE - TMIN;
$k += BASE;
}
return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW));
}
sub decode_punycode {
my $code = shift;
my $n = INITIAL_N;
my $i = 0;
my $bias = INITIAL_BIAS;
my @output;
if ($code =~ s/(.*)$Delimiter//o) {
push @output, map ord, split //, $1;
return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o;
}
while ($code) {
my $oldi = $i;
my $w = 1;
LOOP:
for (my $k = BASE; 1; $k += BASE) {
my $cp = substr($code, 0, 1, '');
my $digit = _digit_value($cp);
defined $digit or return _croak("invalid punycode input");
$i += $digit * $w;
my $t = ($k <= $bias) ? TMIN
: ($k >= $bias + TMAX) ? TMAX : $k - $bias;
last LOOP if $digit < $t;
$w *= (BASE - $t);
}
$bias = _adapt($i - $oldi, @output + 1, $oldi == 0);
warn "bias becomes $bias" if $DEBUG;
$n += $i / (@output + 1);
$i = $i % (@output + 1);
splice(@output, $i, 0, $n);
warn join " ", map sprintf('%04x', $_), @output if $DEBUG;
$i++;
}
return join '', map chr, @output;
}
sub encode_punycode {
my $input = shift;
my @input = split //, $input;
my $n = INITIAL_N;
my $delta = 0;
my $bias = INITIAL_BIAS;
my @output;
my @basic = grep /$BasicRE/, @input;
my $h = my $b = @basic;
push @output, @basic;
push @output, $Delimiter if $b && $h < @input;
warn "basic codepoints: (@output)" if $DEBUG;
while ($h < @input) {
my $m = _min(grep { $_ >= $n } map ord, @input);
warn sprintf "next code point to insert is %04x", $m if $DEBUG;
$delta += ($m - $n) * ($h + 1);
$n = $m;
for my $i (@input) {
my $c = ord($i);
$delta++ if $c < $n;
if ($c == $n) {
my $q = $delta;
LOOP:
for (my $k = BASE; 1; $k += BASE) {
my $t = ($k <= $bias) ? TMIN :
($k >= $bias + TMAX) ? TMAX : $k - $bias;
last LOOP if $q < $t;
my $cp = _code_point($t + (($q - $t) % (BASE - $t)));
push @output, chr($cp);
$q = ($q - $t) / (BASE - $t);
}
push @output, chr(_code_point($q));
$bias = _adapt($delta, $h + 1, $h == $b);
warn "bias becomes $bias" if $DEBUG;
$delta = 0;
$h++;
}
}
$delta++;
$n++;
}
return join '', @output;
}
sub _min {
my $min = shift;
for (@_) { $min = $_ if $_ <= $min }
return $min;
}
1;
__END__
=encoding utf8
=head1 NAME
URI::_punycode - encodes Unicode string in Punycode
=head1 SYNOPSIS
use strict;
use warnings;
use utf8;
use URI::_punycode qw(encode_punycode decode_punycode);
# encode a unicode string
my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g
$punycode = encode_punycode('bücher'); # bcher-kva
$punycode = encode_punycode('他们为什么不说中文'); # ihqwcrb4cv8a8dqg056pqjye
# decode a punycode string back into a unicode string
my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net
$unicode = decode_punycode('bcher-kva'); # bücher
$unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文
=head1 DESCRIPTION
L<URI::_punycode> is a module to encode / decode Unicode strings into
L<Punycode|https://tools.ietf.org/html/rfc3492>, an efficient
encoding of Unicode for use with L<IDNA|https://tools.ietf.org/html/rfc5890>.
=head1 FUNCTIONS
All functions throw exceptions on failure. You can C<catch> them with
L<Syntax::Keyword::Try> or L<Try::Tiny>. The following functions are exported
by default.
=head2 encode_punycode
my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g
$punycode = encode_punycode('bücher'); # bcher-kva
$punycode = encode_punycode('他们为什么不说中文') # ihqwcrb4cv8a8dqg056pqjye
Takes a Unicode string (UTF8-flagged variable) and returns a Punycode
encoding for it.
=head2 decode_punycode
my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net
$unicode = decode_punycode('bcher-kva'); # bücher
$unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文
Takes a Punycode encoding and returns original Unicode string.
=head1 AUTHOR
Tatsuhiko Miyagawa <F<miyagawa@bulknews.net>> is the author of
L<IDNA::Punycode> which was the basis for this module.
=head1 SEE ALSO
L<IDNA::Punycode>, L<RFC 3492|https://tools.ietf.org/html/rfc3492>,
L<RFC 5891|https://tools.ietf.org/html/rfc5891>
=head1 COPYRIGHT AND LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut

194
OGP64/usr/share/perl5/vendor_perl/5.40/URI/_query.pm Normal file
View file

@ -0,0 +1,194 @@
package URI::_query;
use strict;
use warnings;
use URI ();
use URI::Escape qw(uri_unescape);
use Scalar::Util ();
our $VERSION = '5.34';
sub query
{
my $self = shift;
$$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die;
if (@_) {
my $q = shift;
$$self = $1;
if (defined $q) {
$q =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
utf8::downgrade($q);
$$self .= "?$q";
}
$$self .= $3;
}
$2;
}
# Handle ...?foo=bar&bar=foo type of query
sub query_form {
my $self = shift;
my $old = $self->query;
if (@_) {
# Try to set query string
my $delim;
my $r = $_[0];
if (_is_array($r)) {
$delim = $_[1];
@_ = @$r;
}
elsif (ref($r) eq "HASH") {
$delim = $_[1];
@_ = map { $_ => $r->{$_} } sort keys %$r;
}
$delim = pop if @_ % 2;
my @query;
while (my($key,$vals) = splice(@_, 0, 2)) {
$key = '' unless defined $key;
$key =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
$key =~ s/ /+/g;
$vals = [_is_array($vals) ? @$vals : $vals];
for my $val (@$vals) {
if (defined $val) {
$val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
$val =~ s/ /+/g;
push(@query, "$key=$val");
}
else {
push(@query, $key);
}
}
}
if (@query) {
unless ($delim) {
$delim = $1 if $old && $old =~ /([&;])/;
$delim ||= $URI::DEFAULT_QUERY_FORM_DELIMITER || "&";
}
$self->query(join($delim, @query));
}
else {
$self->query(undef);
}
}
return if !defined($old) || !length($old) || !defined(wantarray);
return unless $old =~ /=/; # not a form
map { ( defined ) ? do { s/\+/ /g; uri_unescape($_) } : undef }
map { /=/ ? split(/=/, $_, 2) : ($_ => undef)} split(/[&;]/, $old);
}
# Handle ...?dog+bones type of query
sub query_keywords
{
my $self = shift;
my $old = $self->query;
if (@_) {
# Try to set query string
my @copy = @_;
@copy = @{$copy[0]} if @copy == 1 && _is_array($copy[0]);
for (@copy) { s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; }
$self->query(@copy ? join('+', @copy) : undef);
}
return if !defined($old) || !defined(wantarray);
return if $old =~ /=/; # not keywords, but a form
map { uri_unescape($_) } split(/\+/, $old, -1);
}
# Some URI::URL compatibility stuff
sub equery { goto &query }
sub query_param {
my $self = shift;
my @old = $self->query_form;
if (@_ == 0) {
# get keys
my (%seen, $i);
return grep !($i++ % 2 || $seen{$_}++), @old;
}
my $key = shift;
my @i = grep $_ % 2 == 0 && $old[$_] eq $key, 0 .. $#old;
if (@_) {
my @new = @old;
my @new_i = @i;
my @vals = map { _is_array($_) ? @$_ : $_ } @_;
while (@new_i > @vals) {
splice @new, pop @new_i, 2;
}
if (@vals > @new_i) {
my $i = @new_i ? $new_i[-1] + 2 : @new;
my @splice = splice @vals, @new_i, @vals - @new_i;
splice @new, $i, 0, map { $key => $_ } @splice;
}
if (@vals) {
#print "SET $new_i[0]\n";
@new[ map $_ + 1, @new_i ] = @vals;
}
$self->query_form(\@new);
}
return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef;
}
sub query_param_append {
my $self = shift;
my $key = shift;
my @vals = map { _is_array($_) ? @$_ : $_ } @_;
$self->query_form($self->query_form, $key => \@vals); # XXX
return;
}
sub query_param_delete {
my $self = shift;
my $key = shift;
my @old = $self->query_form;
my @vals;
for (my $i = @old - 2; $i >= 0; $i -= 2) {
next if $old[$i] ne $key;
push(@vals, (splice(@old, $i, 2))[1]);
}
$self->query_form(\@old) if @vals;
return wantarray ? reverse @vals : $vals[-1];
}
sub query_form_hash {
my $self = shift;
my @old = $self->query_form;
if (@_) {
$self->query_form(@_ == 1 ? %{shift(@_)} : @_);
}
my %hash;
while (my($k, $v) = splice(@old, 0, 2)) {
if (exists $hash{$k}) {
for ($hash{$k}) {
$_ = [$_] unless _is_array($_);
push(@$_, $v);
}
}
else {
$hash{$k} = $v;
}
}
return \%hash;
}
sub _is_array {
return(
defined($_[0]) &&
( Scalar::Util::reftype($_[0]) || '' ) eq "ARRAY" &&
!(
Scalar::Util::blessed( $_[0] ) &&
overload::Method( $_[0], '""' )
)
);
}
1;

24
OGP64/usr/share/perl5/vendor_perl/5.40/URI/_segment.pm Normal file
View file

@ -0,0 +1,24 @@
package URI::_segment;
# Represents a generic path_segment so that it can be treated as
# a string too.
use strict;
use warnings;
use URI::Escape qw(uri_unescape);
use overload '""' => sub { $_[0]->[0] },
fallback => 1;
our $VERSION = '5.34';
sub new
{
my $class = shift;
my @segment = split(';', shift, -1);
$segment[0] = uri_unescape($segment[0]);
bless \@segment, $class;
}
1;

167
OGP64/usr/share/perl5/vendor_perl/5.40/URI/_server.pm Normal file
View file

@ -0,0 +1,167 @@
package URI::_server;
use strict;
use warnings;
use parent 'URI::_generic';
use URI::Escape qw(uri_unescape);
our $VERSION = '5.34';
sub _uric_escape {
my($class, $str) = @_;
if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
my($scheme, $host, $rest) = ($1, $2, $3);
my $ui = $host =~ s/(.*@)// ? $1 : "";
my $port = $host =~ s/(:\d+)\z// ? $1 : "";
if (_host_escape($host)) {
$str = "$scheme//$ui$host$port$rest";
}
}
return $class->SUPER::_uric_escape($str);
}
sub _host_escape {
return if URI::HAS_RESERVED_SQUARE_BRACKETS and $_[0] !~ /[^$URI::uric]/;
return if !URI::HAS_RESERVED_SQUARE_BRACKETS and $_[0] !~ /[^$URI::uric4host]/;
eval {
require URI::_idna;
$_[0] = URI::_idna::encode($_[0]);
};
return 0 if $@;
return 1;
}
sub as_iri {
my $self = shift;
my $str = $self->SUPER::as_iri;
if ($str =~ /\bxn--/) {
if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
my($scheme, $host, $rest) = ($1, $2, $3);
my $ui = $host =~ s/(.*@)// ? $1 : "";
my $port = $host =~ s/(:\d+)\z// ? $1 : "";
require URI::_idna;
$host = URI::_idna::decode($host);
$str = "$scheme//$ui$host$port$rest";
}
}
return $str;
}
sub userinfo
{
my $self = shift;
my $old = $self->authority;
if (@_) {
my $new = $old;
$new = "" unless defined $new;
$new =~ s/.*@//; # remove old stuff
my $ui = shift;
if (defined $ui) {
$ui =~ s/([^$URI::uric4user])/ URI::Escape::escape_char($1)/ego;
$new = "$ui\@$new";
}
$self->authority($new);
}
return undef if !defined($old) || $old !~ /(.*)@/;
return $1;
}
sub host
{
my $self = shift;
my $old = $self->authority;
if (@_) {
my $tmp = $old;
$tmp = "" unless defined $tmp;
my $ui = ($tmp =~ /(.*@)/) ? $1 : "";
my $port = ($tmp =~ /(:\d+)$/) ? $1 : "";
my $new = shift;
$new = "" unless defined $new;
if (length $new) {
$new =~ s/[@]/%40/g; # protect @
if ($new =~ /^[^:]*:\d*\z/ || $new =~ /]:\d*\z/) {
$new =~ s/(:\d*)\z// || die "Assert";
$port = $1;
}
$new = "[$new]" if $new =~ /:/ && $new !~ /^\[/; # IPv6 address
_host_escape($new);
}
$self->authority("$ui$new$port");
}
return undef unless defined $old;
$old =~ s/.*@//;
$old =~ s/:\d+$//; # remove the port
$old =~ s{^\[(.*)\]$}{$1}; # remove brackets around IPv6 (RFC 3986 3.2.2)
return uri_unescape($old);
}
sub ihost
{
my $self = shift;
my $old = $self->host(@_);
if ($old =~ /(^|\.)xn--/) {
require URI::_idna;
$old = URI::_idna::decode($old);
}
return $old;
}
sub _port
{
my $self = shift;
my $old = $self->authority;
if (@_) {
my $new = $old;
$new =~ s/:\d*$//;
my $port = shift;
$new .= ":$port" if defined $port;
$self->authority($new);
}
return $1 if defined($old) && $old =~ /:(\d*)$/;
return;
}
sub port
{
my $self = shift;
my $port = $self->_port(@_);
$port = $self->default_port if !defined($port) || $port eq "";
$port;
}
sub host_port
{
my $self = shift;
my $old = $self->authority;
$self->host(shift) if @_;
return undef unless defined $old;
$old =~ s/.*@//; # zap userinfo
$old =~ s/:$//; # empty port should be treated the same a no port
$old .= ":" . $self->port unless $old =~ /:\d+$/;
$old;
}
sub default_port { undef }
sub canonical
{
my $self = shift;
my $other = $self->SUPER::canonical;
my $host = $other->host || "";
my $port = $other->_port;
my $uc_host = $host =~ /[A-Z]/;
my $def_port = defined($port) && ($port eq "" ||
$port == $self->default_port);
if ($uc_host || $def_port) {
$other = $other->clone if $other == $self;
$other->host(lc $host) if $uc_host;
$other->port(undef) if $def_port;
}
$other;
}
1;

Some files were not shown because too many files have changed in this diff Show more