made the pack completely portable and wrote relevent bat files to go with it
This commit is contained in:
Draqoken
129
gitportable/usr/share/perl5/vendor_perl/Authen/SASL.pm
Normal file
129
gitportable/usr/share/perl5/vendor_perl/Authen/SASL.pm
Normal file
@@ -0,0 +1,129 @@
|
||||
# Copyright (c) 2004-2006 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 Authen::SASL;
|
||||
$Authen::SASL::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars qw(@Plugins);
|
||||
use Carp;
|
||||
|
||||
|
||||
@Plugins = qw(
|
||||
Authen::SASL::XS
|
||||
Authen::SASL::Perl
|
||||
);
|
||||
|
||||
|
||||
sub import {
|
||||
shift;
|
||||
return unless @_;
|
||||
|
||||
local $SIG{__DIE__};
|
||||
@Plugins = grep { /^[:\w]+$/ and eval "require $_" } map { /::/ ? $_ : "Authen::SASL::$_" } @_
|
||||
or croak "no valid Authen::SASL plugins found";
|
||||
}
|
||||
|
||||
|
||||
sub new {
|
||||
my $pkg = shift;
|
||||
my %opt = ((@_ % 2 ? 'mechanism' : ()), @_);
|
||||
|
||||
my $self = bless {
|
||||
mechanism => $opt{mechanism} || $opt{mech},
|
||||
callback => {},
|
||||
debug => $opt{debug},
|
||||
}, $pkg;
|
||||
|
||||
$self->callback(%{$opt{callback}}) if ref($opt{callback}) eq 'HASH';
|
||||
|
||||
# Compat
|
||||
$self->callback(user => ($self->{user} = $opt{user})) if exists $opt{user};
|
||||
$self->callback(pass => $opt{password}) if exists $opt{password};
|
||||
$self->callback(pass => $opt{response}) if exists $opt{response};
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub mechanism {
|
||||
my $self = shift;
|
||||
@_ ? $self->{mechanism} = shift
|
||||
: $self->{mechanism};
|
||||
}
|
||||
|
||||
sub callback {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{callback}{$_[0]} if @_ == 1;
|
||||
|
||||
my %new = @_;
|
||||
@{$self->{callback}}{keys %new} = values %new;
|
||||
|
||||
$self->{callback};
|
||||
}
|
||||
|
||||
# The list of packages should not really be hardcoded here
|
||||
# We need some way to discover what plugins are installed
|
||||
|
||||
sub client_new { # $self, $service, $host, $secflags
|
||||
my $self = shift;
|
||||
|
||||
my $err;
|
||||
foreach my $pkg (@Plugins) {
|
||||
if (eval "require $pkg" and $pkg->can("client_new")) {
|
||||
if ($self->{conn} = eval { $pkg->client_new($self, @_) }) {
|
||||
return $self->{conn};
|
||||
}
|
||||
$err = $@;
|
||||
}
|
||||
}
|
||||
|
||||
croak $err || "Cannot find a SASL Connection library";
|
||||
}
|
||||
|
||||
sub server_new { # $self, $service, $host, $secflags
|
||||
my $self = shift;
|
||||
|
||||
my $err;
|
||||
foreach my $pkg (@Plugins) {
|
||||
if (eval "require $pkg" and $pkg->can("server_new")) {
|
||||
if ($self->{conn} = eval { $pkg->server_new($self, @_) } ) {
|
||||
return $self->{conn};
|
||||
}
|
||||
$err = $@;
|
||||
}
|
||||
}
|
||||
croak $err || "Cannot find a SASL Connection library for server-side authentication";
|
||||
}
|
||||
|
||||
sub error {
|
||||
my $self = shift;
|
||||
$self->{conn} && $self->{conn}->error;
|
||||
}
|
||||
|
||||
# Compat.
|
||||
sub user {
|
||||
my $self = shift;
|
||||
my $user = $self->{callback}{user};
|
||||
$self->{callback}{user} = shift if @_;
|
||||
$user;
|
||||
}
|
||||
|
||||
sub challenge {
|
||||
my $self = shift;
|
||||
$self->{conn}->client_step(@_);
|
||||
}
|
||||
|
||||
sub initial {
|
||||
my $self = shift;
|
||||
$self->client_new($self)->client_start;
|
||||
}
|
||||
|
||||
sub name {
|
||||
my $self = shift;
|
||||
$self->{conn} ? $self->{conn}->mechanism : (($self->{mechanism} || '') =~ /(\S+)/)[0];
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,17 @@
|
||||
# Copyright (c) 2002 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 Authen::SASL::CRAM_MD5;
|
||||
$Authen::SASL::CRAM_MD5::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
|
||||
sub new {
|
||||
shift;
|
||||
Authen::SASL->new(@_, mechanism => 'CRAM-MD5');
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,17 @@
|
||||
# Copyright (c) 2002 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 Authen::SASL::EXTERNAL;
|
||||
$Authen::SASL::EXTERNAL::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
|
||||
sub new {
|
||||
shift;
|
||||
Authen::SASL->new(@_, mechanism => 'EXTERNAL');
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
345
gitportable/usr/share/perl5/vendor_perl/Authen/SASL/Perl.pm
Normal file
345
gitportable/usr/share/perl5/vendor_perl/Authen/SASL/Perl.pm
Normal file
@@ -0,0 +1,345 @@
|
||||
# Copyright (c) 2002 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 Authen::SASL::Perl;
|
||||
$Authen::SASL::Perl::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
|
||||
my %secflags = (
|
||||
noplaintext => 1,
|
||||
noanonymous => 1,
|
||||
nodictionary => 1,
|
||||
);
|
||||
my %have;
|
||||
|
||||
sub server_new {
|
||||
my ($pkg, $parent, $service, $host, $options) = @_;
|
||||
|
||||
my $self = {
|
||||
callback => { %{$parent->callback} },
|
||||
service => $service || '',
|
||||
host => $host || '',
|
||||
debug => $parent->{debug} || 0,
|
||||
need_step => 1,
|
||||
};
|
||||
|
||||
my $mechanism = $parent->mechanism
|
||||
or croak "No server mechanism specified";
|
||||
$mechanism =~ s/^\s*\b(.*)\b\s*$/$1/g;
|
||||
$mechanism =~ s/-/_/g;
|
||||
$mechanism = uc $mechanism;
|
||||
my $mpkg = __PACKAGE__ . "::$mechanism";
|
||||
eval "require $mpkg;"
|
||||
or croak "Cannot use $mpkg for " . $parent->mechanism;
|
||||
my $server = $mpkg->_init($self);
|
||||
$server->_init_server($options);
|
||||
return $server;
|
||||
}
|
||||
|
||||
sub client_new {
|
||||
my ($pkg, $parent, $service, $host, $secflags) = @_;
|
||||
|
||||
my @sec = grep { $secflags{$_} } split /\W+/, lc($secflags || '');
|
||||
|
||||
my $self = {
|
||||
callback => { %{$parent->callback} },
|
||||
service => $service || '',
|
||||
host => $host || '',
|
||||
debug => $parent->{debug} || 0,
|
||||
need_step => 1,
|
||||
};
|
||||
|
||||
my @mpkg = sort {
|
||||
$b->_order <=> $a->_order
|
||||
} grep {
|
||||
my $have = $have{$_} ||= (eval "require $_;" and $_->can('_secflags')) ? 1 : -1;
|
||||
$have > 0 and $_->_secflags(@sec) == @sec
|
||||
} map {
|
||||
(my $mpkg = __PACKAGE__ . "::$_") =~ s/-/_/g;
|
||||
$mpkg;
|
||||
} split /[^-\w]+/, $parent->mechanism
|
||||
or croak "No SASL mechanism found\n";
|
||||
|
||||
$mpkg[0]->_init($self);
|
||||
}
|
||||
|
||||
sub _init_server {}
|
||||
|
||||
sub _order { 0 }
|
||||
sub code { defined(shift->{error}) || 0 }
|
||||
sub error { shift->{error} }
|
||||
sub service { shift->{service} }
|
||||
sub host { shift->{host} }
|
||||
|
||||
sub need_step {
|
||||
my $self = shift;
|
||||
return 0 if $self->{error};
|
||||
return $self->{need_step};
|
||||
}
|
||||
|
||||
## I think I need to rename that to end()?
|
||||
## It doesn't mean that SASL is successful, but that
|
||||
## that the negotiation is over, no more step necessary
|
||||
## at least for the client
|
||||
sub set_success {
|
||||
my $self = shift;
|
||||
$self->{need_step} = 0;
|
||||
}
|
||||
|
||||
sub is_success {
|
||||
my $self = shift;
|
||||
return !$self->code && !$self->need_step;
|
||||
}
|
||||
|
||||
sub set_error {
|
||||
my $self = shift;
|
||||
$self->{error} = shift;
|
||||
return;
|
||||
}
|
||||
|
||||
# set/get property
|
||||
sub property {
|
||||
my $self = shift;
|
||||
my $prop = $self->{property} ||= {};
|
||||
return $prop->{ $_[0] } if @_ == 1;
|
||||
my %new = @_;
|
||||
@{$prop}{keys %new} = values %new;
|
||||
1;
|
||||
}
|
||||
|
||||
sub callback {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{callback}{$_[0]} if @_ == 1;
|
||||
|
||||
my %new = @_;
|
||||
@{$self->{callback}}{keys %new} = values %new;
|
||||
|
||||
$self->{callback};
|
||||
}
|
||||
|
||||
# Should be defined in the mechanism sub-class
|
||||
sub mechanism { undef }
|
||||
sub client_step { undef }
|
||||
sub client_start { undef }
|
||||
sub server_step { undef }
|
||||
sub server_start { undef }
|
||||
|
||||
# Private methods used by Authen::SASL::Perl that
|
||||
# may be overridden in mechanism sub-classes
|
||||
|
||||
sub _init {
|
||||
my ($pkg, $href) = @_;
|
||||
|
||||
bless $href, $pkg;
|
||||
}
|
||||
|
||||
sub _call {
|
||||
my ($self, $name) = splice(@_,0,2);
|
||||
|
||||
my $cb = $self->{callback}{$name};
|
||||
|
||||
return undef unless defined $cb;
|
||||
|
||||
my $value;
|
||||
|
||||
if (ref($cb) eq 'ARRAY') {
|
||||
my @args = @$cb;
|
||||
$cb = shift @args;
|
||||
$value = $cb->($self, @args);
|
||||
}
|
||||
elsif (ref($cb) eq 'CODE') {
|
||||
$value = $cb->($self, @_);
|
||||
}
|
||||
else {
|
||||
$value = $cb;
|
||||
}
|
||||
|
||||
$self->{answer}{$name} = $value
|
||||
unless $name eq 'pass'; # Do not store password
|
||||
|
||||
return $value;
|
||||
}
|
||||
|
||||
# TODO: Need a better name than this
|
||||
sub answer {
|
||||
my ($self, $name) = @_;
|
||||
$self->{answer}{$name};
|
||||
}
|
||||
|
||||
sub _secflags { 0 }
|
||||
|
||||
sub securesocket {
|
||||
my $self = shift;
|
||||
return $_[0] unless (defined($self->property('ssf')) && $self->property('ssf') > 0);
|
||||
|
||||
local *GLOB; # avoid used only once warning
|
||||
my $glob = \do { local *GLOB; };
|
||||
tie(*$glob, 'Authen::SASL::Perl::Layer', $_[0], $self);
|
||||
$glob;
|
||||
}
|
||||
|
||||
{
|
||||
|
||||
#
|
||||
# Add SASL encoding/decoding to a filehandle
|
||||
#
|
||||
|
||||
package # private package; prevent detection by MetaCPAN
|
||||
Authen::SASL::Perl::Layer;
|
||||
|
||||
use bytes;
|
||||
|
||||
require Tie::Handle;
|
||||
our @ISA = qw(Tie::Handle);
|
||||
|
||||
sub TIEHANDLE {
|
||||
my ($class, $fh, $conn) = @_;
|
||||
my $self;
|
||||
|
||||
warn __PACKAGE__ . ': non-blocking handle may not work'
|
||||
if ($fh->can('blocking') and not $fh->blocking());
|
||||
|
||||
$self->{fh} = $fh;
|
||||
$self->{conn} = $conn;
|
||||
$self->{readbuflen} = 0;
|
||||
$self->{sndbufsz} = $conn->property('maxout');
|
||||
$self->{rcvbufsz} = $conn->property('maxbuf');
|
||||
|
||||
return bless($self, $class);
|
||||
}
|
||||
|
||||
sub CLOSE {
|
||||
my ($self) = @_;
|
||||
|
||||
# forward close to the inner handle
|
||||
close($self->{fh});
|
||||
delete $self->{fh};
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my ($self) = @_;
|
||||
delete $self->{fh};
|
||||
undef $self;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my ($self) = @_;
|
||||
return $self->{fh};
|
||||
}
|
||||
|
||||
sub FILENO {
|
||||
my ($self) = @_;
|
||||
return fileno($self->{fh});
|
||||
}
|
||||
|
||||
|
||||
sub READ {
|
||||
my ($self, $buf, $len, $offset) = @_;
|
||||
my $debug = $self->{conn}->{debug};
|
||||
|
||||
$buf = \$_[1];
|
||||
|
||||
my $avail = $self->{readbuflen};
|
||||
|
||||
print STDERR " [READ(len=$len,offset=$offset)] avail=$avail;\n"
|
||||
if ($debug & 4);
|
||||
|
||||
# Check if there's leftovers from a previous READ
|
||||
if ($avail <= 0) {
|
||||
$avail = $self->_getbuf();
|
||||
return undef unless ($avail > 0);
|
||||
}
|
||||
|
||||
# if there's more than we need right now, leave the rest for later
|
||||
if ($avail >= $len) {
|
||||
print STDERR " GOT ALL: avail=$avail; need=$len\n"
|
||||
if ($debug & 4);
|
||||
substr($$buf, $offset, $len) = substr($self->{readbuf}, 0, $len, '');
|
||||
$self->{readbuflen} -= $len;
|
||||
return ($len);
|
||||
}
|
||||
|
||||
# there's not enough; take all we have, read more on next call
|
||||
print STDERR " GOT PARTIAL: avail=$avail; need=$len\n"
|
||||
if ($debug & 4);
|
||||
substr($$buf, $offset || 0, $avail) = $self->{readbuf};
|
||||
$self->{readbuf} = '';
|
||||
$self->{readbuflen} = 0;
|
||||
|
||||
return ($avail);
|
||||
}
|
||||
|
||||
# retrieve and decode a buffer of cipher text in SASL format
|
||||
sub _getbuf {
|
||||
my ($self) = @_;
|
||||
my $debug = $self->{conn}->{debug};
|
||||
my $fh = $self->{fh};
|
||||
my $buf = '';
|
||||
|
||||
# first, read 4-octet buffer size
|
||||
my $n = 0;
|
||||
while ($n < 4) {
|
||||
my $rv = sysread($fh, $buf, 4 - $n, $n);
|
||||
print STDERR " [getbuf: sysread($fh,$buf,4-$n,$n)=$rv: $!\n"
|
||||
if ($debug & 4);
|
||||
return $rv unless $rv > 0;
|
||||
$n += $rv;
|
||||
}
|
||||
|
||||
# size is encoded in network byte order
|
||||
my ($bsz) = unpack('N', $buf);
|
||||
print STDERR " [getbuf: cipher buffer sz=$bsz]\n" if ($debug & 4);
|
||||
return undef unless ($bsz <= $self->{rcvbufsz});
|
||||
|
||||
# next, read actual cipher text
|
||||
$buf = '';
|
||||
$n = 0;
|
||||
while ($n < $bsz) {
|
||||
my $rv = sysread($fh, $buf, $bsz - $n, $n);
|
||||
print STDERR " [getbuf: got o=$n,n=", $bsz - $n, ",rv=$rv,bl=" . length($buf) . "]\n"
|
||||
if ($debug & 4);
|
||||
return $rv unless $rv > 0;
|
||||
$n += $rv;
|
||||
}
|
||||
|
||||
# call mechanism specific decoding routine
|
||||
$self->{readbuf} = $self->{conn}->decode($buf, $bsz);
|
||||
$n = length($self->{readbuf});
|
||||
print STDERR " [getbuf: clear text buffer sz=$n]\n" if ($debug & 4);
|
||||
$self->{readbuflen} = $n;
|
||||
}
|
||||
|
||||
|
||||
# Encrypting a write() to a filehandle is much easier than reading, because
|
||||
# all the data to be encrypted is immediately available
|
||||
sub WRITE {
|
||||
my ($self, $data, $len, $offset) = @_;
|
||||
my $debug = $self->{conn}->{debug};
|
||||
|
||||
my $fh = $self->{fh};
|
||||
$len = length($data) if $len > length($data); # RT 85294
|
||||
|
||||
# put on wire in peer-sized chunks
|
||||
my $bsz = $self->{sndbufsz};
|
||||
while ($len > 0) {
|
||||
print STDERR " [WRITE: chunk $bsz/$len]\n"
|
||||
if ($debug & 8);
|
||||
|
||||
# call mechanism specific encoding routine
|
||||
my $x = $self->{conn}->encode(substr($data, $offset || 0, $bsz));
|
||||
print $fh pack('N', length($x)), $x;
|
||||
$len -= $bsz;
|
||||
$offset += $bsz;
|
||||
}
|
||||
|
||||
return $_[2];
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,97 @@
|
||||
# Copyright (c) 2002 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 Authen::SASL::Perl::ANONYMOUS;
|
||||
$Authen::SASL::Perl::ANONYMOUS::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars qw(@ISA);
|
||||
|
||||
@ISA = qw(Authen::SASL::Perl);
|
||||
|
||||
my %secflags = (
|
||||
noplaintext => 1,
|
||||
);
|
||||
|
||||
sub _order { 0 }
|
||||
sub _secflags {
|
||||
shift;
|
||||
grep { $secflags{$_} } @_;
|
||||
}
|
||||
|
||||
sub mechanism { 'ANONYMOUS' }
|
||||
|
||||
sub client_start {
|
||||
shift->_call('authname')
|
||||
}
|
||||
|
||||
sub client_step {
|
||||
shift->_call('authname')
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Authen::SASL::Perl::ANONYMOUS - Anonymous Authentication class
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.1700
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Authen::SASL qw(Perl);
|
||||
|
||||
$sasl = Authen::SASL->new(
|
||||
mechanism => 'ANONYMOUS',
|
||||
callback => {
|
||||
authname => $mailaddress
|
||||
},
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This method implements the client part of the ANONYMOUS SASL algorithm,
|
||||
as described in RFC 2245 resp. in IETF Draft draft-ietf-sasl-anon-XX.txt.
|
||||
|
||||
=head2 CALLBACK
|
||||
|
||||
The callbacks used are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item authname
|
||||
|
||||
email address or UTF-8 encoded string to be used as
|
||||
trace information for the server
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Authen::SASL>,
|
||||
L<Authen::SASL::Perl>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Software written by Graham Barr <gbarr@pobox.com>,
|
||||
documentation written by Peter Marschall <peter@adpm.de>.
|
||||
|
||||
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
|
||||
<perl-ldap@perl.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2002-2004 Graham Barr.
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
Documentation Copyright (c) 2004 Peter Marschall.
|
||||
All rights reserved. This documentation is distributed,
|
||||
and may be redistributed, under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,109 @@
|
||||
# Copyright (c) 2002 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 Authen::SASL::Perl::CRAM_MD5;
|
||||
$Authen::SASL::Perl::CRAM_MD5::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars qw(@ISA);
|
||||
use Digest::HMAC_MD5 qw(hmac_md5_hex);
|
||||
|
||||
@ISA = qw(Authen::SASL::Perl);
|
||||
|
||||
my %secflags = (
|
||||
noplaintext => 1,
|
||||
noanonymous => 1,
|
||||
);
|
||||
|
||||
sub _order { 2 }
|
||||
sub _secflags {
|
||||
shift;
|
||||
scalar grep { $secflags{$_} } @_;
|
||||
}
|
||||
|
||||
sub mechanism { 'CRAM-MD5' }
|
||||
|
||||
sub client_start {
|
||||
'';
|
||||
}
|
||||
|
||||
sub client_step {
|
||||
my ($self, $string) = @_;
|
||||
my ($user, $pass) = map {
|
||||
my $v = $self->_call($_);
|
||||
defined($v) ? $v : ''
|
||||
} qw(user pass);
|
||||
|
||||
$user . " " . hmac_md5_hex($string,$pass);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Authen::SASL::Perl::CRAM_MD5 - CRAM MD5 Authentication class
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.1700
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Authen::SASL qw(Perl);
|
||||
|
||||
$sasl = Authen::SASL->new(
|
||||
mechanism => 'CRAM-MD5',
|
||||
callback => {
|
||||
user => $user,
|
||||
pass => $pass
|
||||
},
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This method implements the client part of the CRAM-MD5 SASL algorithm,
|
||||
as described in RFC 2195 resp. in IETF Draft draft-ietf-sasl-crammd5-XX.txt.
|
||||
|
||||
=head2 CALLBACK
|
||||
|
||||
The callbacks used are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item user
|
||||
|
||||
The username to be used for authentication
|
||||
|
||||
=item pass
|
||||
|
||||
The user's password to be used for authentication
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Authen::SASL>,
|
||||
L<Authen::SASL::Perl>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Software written by Graham Barr <gbarr@pobox.com>,
|
||||
documentation written by Peter Marschall <peter@adpm.de>.
|
||||
|
||||
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
|
||||
<perl-ldap@perl.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2002-2004 Graham Barr.
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
Documentation Copyright (c) 2004 Peter Marschall.
|
||||
All rights reserved. This documentation is distributed,
|
||||
and may be redistributed, under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,881 @@
|
||||
# Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian
|
||||
# Onions, Nexor and Yann Kerherve.
|
||||
# All rights reserved. This program is free software; you can redistribute
|
||||
# it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
# See http://www.ietf.org/rfc/rfc2831.txt for details
|
||||
|
||||
package Authen::SASL::Perl::DIGEST_MD5;
|
||||
$Authen::SASL::Perl::DIGEST_MD5::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars qw(@ISA $CNONCE $NONCE);
|
||||
use Digest::MD5 qw(md5_hex md5);
|
||||
use Digest::HMAC_MD5 qw(hmac_md5);
|
||||
|
||||
# TODO: complete qop support in server, should be configurable
|
||||
|
||||
@ISA = qw(Authen::SASL::Perl);
|
||||
|
||||
my %secflags = (
|
||||
noplaintext => 1,
|
||||
noanonymous => 1,
|
||||
);
|
||||
|
||||
# some have to be quoted - some don't - sigh!
|
||||
my (%cqdval, %sqdval);
|
||||
@cqdval{qw(
|
||||
username authzid realm nonce cnonce digest-uri
|
||||
)} = ();
|
||||
|
||||
## ...and server behaves different than client - double sigh!
|
||||
@sqdval{keys %cqdval, qw(qop cipher)} = ();
|
||||
# username authzid realm nonce cnonce digest-uri qop cipher
|
||||
#)} = ();
|
||||
|
||||
my %multi;
|
||||
@{$multi{server}}{qw(realm auth-param)} = ();
|
||||
@{$multi{client}}{qw()} = ();
|
||||
|
||||
my @server_required = qw(algorithm nonce);
|
||||
my @client_required = qw(username nonce cnonce nc qop response);
|
||||
|
||||
# available ciphers
|
||||
my @ourciphers = (
|
||||
{
|
||||
name => 'rc4',
|
||||
ssf => 128,
|
||||
bs => 1,
|
||||
ks => 16,
|
||||
pkg => 'Crypt::RC4',
|
||||
key => sub { $_[0] },
|
||||
iv => sub {},
|
||||
fixup => sub {
|
||||
# retrofit the Crypt::RC4 module with standard subs
|
||||
*Crypt::RC4::encrypt = *Crypt::RC4::decrypt =
|
||||
sub { goto &Crypt::RC4::RC4; };
|
||||
*Crypt::RC4::keysize = sub {128};
|
||||
*Crypt::RC4::blocksize = sub {1};
|
||||
}
|
||||
},
|
||||
{
|
||||
name => '3des',
|
||||
ssf => 112,
|
||||
bs => 8,
|
||||
ks => 16,
|
||||
pkg => 'Crypt::DES3',
|
||||
key => sub {
|
||||
pack('B8' x 16,
|
||||
map { $_ . '0' }
|
||||
map { unpack('a7' x 16, $_); }
|
||||
unpack('B*', substr($_[0], 0, 14)) );
|
||||
},
|
||||
iv => sub { substr($_[0], -8, 8) },
|
||||
},
|
||||
{
|
||||
name => 'des',
|
||||
ssf => 56,
|
||||
bs => 8,
|
||||
ks => 16,
|
||||
pkg => 'Crypt::DES',
|
||||
key => sub {
|
||||
pack('B8' x 8,
|
||||
map { $_ . '0' }
|
||||
map { unpack('a7' x 8, $_); }
|
||||
unpack('B*',substr($_[0], 0, 7)) );
|
||||
},
|
||||
iv => sub { substr($_[0], -8, 8) },
|
||||
},
|
||||
{
|
||||
name => 'rc4-56',
|
||||
ssf => 56,
|
||||
bs => 1,
|
||||
ks => 7,
|
||||
pkg => 'Crypt::RC4',
|
||||
key => sub { $_[0] },
|
||||
iv => sub {},
|
||||
fixup => sub {
|
||||
*Crypt::RC4::encrypt = *Crypt::RC4::decrypt =
|
||||
sub { goto &Crypt::RC4::RC4; };
|
||||
*Crypt::RC4::keysize = sub {56};
|
||||
*Crypt::RC4::blocksize = sub {1};
|
||||
}
|
||||
},
|
||||
{
|
||||
name => 'rc4-40',
|
||||
ssf => 40,
|
||||
bs => 1,
|
||||
ks => 5,
|
||||
pkg => 'Crypt::RC4',
|
||||
key => sub { $_[0] },
|
||||
iv => sub {},
|
||||
fixup => sub {
|
||||
*Crypt::RC4::encrypt = *Crypt::RC4::decrypt =
|
||||
sub { goto &Crypt::RC4::RC4; };
|
||||
*Crypt::RC4::keysize = sub {40};
|
||||
*Crypt::RC4::blocksize = sub {1};
|
||||
}
|
||||
},
|
||||
);
|
||||
|
||||
## The system we are on, might not be able to crypt the stream
|
||||
our $NO_CRYPT_AVAILABLE = 1;
|
||||
for (@ourciphers) {
|
||||
eval "require $_->{pkg}";
|
||||
unless ($@) {
|
||||
$NO_CRYPT_AVAILABLE = 0;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
sub _order { 3 }
|
||||
sub _secflags {
|
||||
shift;
|
||||
scalar grep { $secflags{$_} } @_;
|
||||
}
|
||||
|
||||
sub mechanism { 'DIGEST-MD5' }
|
||||
|
||||
sub _init {
|
||||
my ($pkg, $self) = @_;
|
||||
bless $self, $pkg;
|
||||
|
||||
# set default security properties
|
||||
$self->property('minssf', 0);
|
||||
$self->property('maxssf', int 2**31 - 1); # XXX - arbitrary "high" value
|
||||
$self->property('maxbuf', 0xFFFFFF); # maximum supported by GSSAPI mech
|
||||
$self->property('externalssf', 0);
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
sub _init_server {
|
||||
my $server = shift;
|
||||
my $options = shift || {};
|
||||
if (!ref $options or ref $options ne 'HASH') {
|
||||
warn "options for DIGEST_MD5 should be a hashref";
|
||||
$options = {};
|
||||
}
|
||||
|
||||
## new server, means new nonce_counts
|
||||
$server->{nonce_counts} = {};
|
||||
|
||||
## determine supported qop
|
||||
my @qop = ('auth');
|
||||
push @qop, 'auth-int' unless $options->{no_integrity};
|
||||
push @qop, 'auth-conf' unless $options->{no_integrity}
|
||||
or $options->{no_confidentiality}
|
||||
or $NO_CRYPT_AVAILABLE;
|
||||
|
||||
$server->{supported_qop} = { map { $_ => 1 } @qop };
|
||||
}
|
||||
|
||||
sub init_sec_layer {
|
||||
my $self = shift;
|
||||
$self->{cipher} = undef;
|
||||
$self->{khc} = undef;
|
||||
$self->{khs} = undef;
|
||||
$self->{sndseqnum} = 0;
|
||||
$self->{rcvseqnum} = 0;
|
||||
|
||||
# reset properties for new session
|
||||
$self->property(maxout => undef);
|
||||
$self->property(ssf => undef);
|
||||
}
|
||||
|
||||
# no initial value passed to the server
|
||||
sub client_start {
|
||||
my $self = shift;
|
||||
|
||||
$self->{need_step} = 1;
|
||||
$self->{error} = undef;
|
||||
$self->{state} = 0;
|
||||
$self->init_sec_layer;
|
||||
'';
|
||||
}
|
||||
|
||||
sub server_start {
|
||||
my $self = shift;
|
||||
my $challenge = shift;
|
||||
my $cb = shift || sub {};
|
||||
|
||||
$self->{need_step} = 1;
|
||||
$self->{error} = undef;
|
||||
$self->{nonce} = md5_hex($NONCE || join (":", $$, time, rand));
|
||||
|
||||
$self->init_sec_layer;
|
||||
|
||||
my $qop = [ sort keys %{$self->{supported_qop}} ];
|
||||
|
||||
## get the realm using callbacks but default to the host specified
|
||||
## during the instantiation of the SASL object
|
||||
my $realm = $self->_call('realm');
|
||||
$realm ||= $self->host;
|
||||
|
||||
my %response = (
|
||||
nonce => $self->{nonce},
|
||||
charset => 'utf-8',
|
||||
algorithm => 'md5-sess',
|
||||
realm => $realm,
|
||||
maxbuf => $self->property('maxbuf'),
|
||||
|
||||
## IN DRAFT ONLY:
|
||||
# If this directive is present multiple times the client MUST treat
|
||||
# it as if it received a single qop directive containing a comma
|
||||
# separated value from all instances. I.e.,
|
||||
# 'qop="auth",qop="auth-int"' is the same as 'qop="auth,auth-int"
|
||||
|
||||
'qop' => $qop,
|
||||
'cipher' => [ map { $_->{name} } @ourciphers ],
|
||||
);
|
||||
my $final_response = _response(\%response);
|
||||
$cb->($final_response);
|
||||
return;
|
||||
}
|
||||
|
||||
sub client_step { # $self, $server_sasl_credentials
|
||||
my ($self, $challenge) = @_;
|
||||
$self->{server_params} = \my %sparams;
|
||||
|
||||
# Parse response parameters
|
||||
$self->_parse_challenge(\$challenge, server => $self->{server_params})
|
||||
or return $self->set_error("Bad challenge: '$challenge'");
|
||||
|
||||
if ($self->{state} == 1) {
|
||||
# check server's `rspauth' response
|
||||
return $self->set_error("Server did not send rspauth in step 2")
|
||||
unless ($sparams{rspauth});
|
||||
return $self->set_error("Invalid rspauth in step 2")
|
||||
unless ($self->{rspauth} eq $sparams{rspauth});
|
||||
|
||||
# all is well
|
||||
$self->set_success;
|
||||
return '';
|
||||
}
|
||||
|
||||
# check required fields in server challenge
|
||||
if (my @missing = grep { !exists $sparams{$_} } @server_required) {
|
||||
return $self->set_error("Server did not provide required field(s): @missing")
|
||||
}
|
||||
|
||||
my %response = (
|
||||
nonce => $sparams{'nonce'},
|
||||
cnonce => md5_hex($CNONCE || join (":", $$, time, rand)),
|
||||
'digest-uri' => $self->service . '/' . $self->host,
|
||||
# calc how often the server nonce has been seen; server expects "00000001"
|
||||
nc => sprintf("%08d", ++$self->{nonce_counts}{$sparams{'nonce'}}),
|
||||
charset => $sparams{'charset'},
|
||||
);
|
||||
|
||||
return $self->set_error("Server qop too weak (qop = $sparams{'qop'})")
|
||||
unless ($self->_client_layer(\%sparams,\%response));
|
||||
|
||||
# let caller-provided fields override defaults: authorization ID, service name, realm
|
||||
|
||||
my $s_realm = $sparams{realm} || [];
|
||||
my $realm = $self->_call('realm', @$s_realm);
|
||||
unless (defined $realm) {
|
||||
# If the user does not pick a realm, use the first from the server
|
||||
$realm = $s_realm->[0];
|
||||
}
|
||||
if (defined $realm) {
|
||||
$response{realm} = $realm;
|
||||
}
|
||||
|
||||
my $authzid = $self->_call('authname');
|
||||
if (defined $authzid) {
|
||||
$response{authzid} = $authzid;
|
||||
}
|
||||
|
||||
my $serv_name = $self->_call('serv');
|
||||
if (defined $serv_name) {
|
||||
$response{'digest-uri'} .= '/' . $serv_name;
|
||||
}
|
||||
|
||||
my $user = $self->_call('user');
|
||||
return $self->set_error("Username is required")
|
||||
unless defined $user;
|
||||
$response{username} = $user;
|
||||
|
||||
my $password = $self->_call('pass');
|
||||
return $self->set_error("Password is required")
|
||||
unless defined $password;
|
||||
|
||||
$self->property('maxout', $sparams{maxbuf} || 65536);
|
||||
|
||||
# Generate the response value
|
||||
$self->{state} = 1;
|
||||
|
||||
my ($response, $rspauth)
|
||||
= $self->_compute_digests_and_set_keys($password, \%response);
|
||||
|
||||
$response{response} = $response;
|
||||
$self->{rspauth} = $rspauth;
|
||||
|
||||
# finally, return our response token
|
||||
return _response(\%response, "is_client");
|
||||
}
|
||||
|
||||
sub _compute_digests_and_set_keys {
|
||||
my $self = shift;
|
||||
my $password = shift;
|
||||
my $params = shift;
|
||||
|
||||
if (defined $params->{realm} and ref $params->{realm} eq 'ARRAY') {
|
||||
$params->{realm} = $params->{realm}[0];
|
||||
}
|
||||
|
||||
my $realm = $params->{realm};
|
||||
$realm = "" unless defined $realm;
|
||||
|
||||
my $A1 = join (":",
|
||||
md5(join (":", $params->{username}, $realm, $password)),
|
||||
@$params{defined($params->{authzid})
|
||||
? qw(nonce cnonce authzid)
|
||||
: qw(nonce cnonce)
|
||||
}
|
||||
);
|
||||
|
||||
# pre-compute MD5(A1) and HEX(MD5(A1)); these are used multiple times below
|
||||
my $hdA1 = unpack("H*", (my $dA1 = md5($A1)) );
|
||||
|
||||
# derive keys for layer encryption / integrity
|
||||
$self->{kic} = md5($dA1,
|
||||
'Digest session key to client-to-server signing key magic constant');
|
||||
|
||||
$self->{kis} = md5($dA1,
|
||||
'Digest session key to server-to-client signing key magic constant');
|
||||
|
||||
if (my $cipher = $self->{cipher}) {
|
||||
&{ $cipher->{fixup} || sub{} };
|
||||
|
||||
# compute keys for encryption
|
||||
my $ks = $cipher->{ks};
|
||||
$self->{kcc} = md5(substr($dA1,0,$ks),
|
||||
'Digest H(A1) to client-to-server sealing key magic constant');
|
||||
$self->{kcs} = md5(substr($dA1,0,$ks),
|
||||
'Digest H(A1) to server-to-client sealing key magic constant');
|
||||
|
||||
# get an encryption and decryption handle for the chosen cipher
|
||||
$self->{khc} = $cipher->{pkg}->new($cipher->{key}->($self->{kcc}));
|
||||
$self->{khs} = $cipher->{pkg}->new($cipher->{key}->($self->{kcs}));
|
||||
|
||||
# initialize IVs
|
||||
$self->{ivc} = $cipher->{iv}->($self->{kcc});
|
||||
$self->{ivs} = $cipher->{iv}->($self->{kcs});
|
||||
}
|
||||
|
||||
my $A2 = "AUTHENTICATE:" . $params->{'digest-uri'};
|
||||
$A2 .= ":00000000000000000000000000000000" if ($params->{qop} ne 'auth');
|
||||
|
||||
my $response = md5_hex(
|
||||
join (":", $hdA1, @$params{qw(nonce nc cnonce qop)}, md5_hex($A2))
|
||||
);
|
||||
|
||||
# calculate server `rspauth' response, so we can check in step 2
|
||||
# the only difference here is in the A2 string which from which
|
||||
# `AUTHENTICATE' is omitted in the calculation of `rspauth'
|
||||
$A2 = ":" . $params->{'digest-uri'};
|
||||
$A2 .= ":00000000000000000000000000000000" if ($params->{qop} ne 'auth');
|
||||
|
||||
my $rspauth = md5_hex(
|
||||
join (":", $hdA1, @$params{qw(nonce nc cnonce qop)}, md5_hex($A2))
|
||||
);
|
||||
|
||||
return ($response, $rspauth);
|
||||
}
|
||||
|
||||
sub server_step {
|
||||
my $self = shift;
|
||||
my $challenge = shift;
|
||||
my $cb = shift || sub {};
|
||||
|
||||
$self->{client_params} = \my %cparams;
|
||||
unless ( $self->_parse_challenge(\$challenge, client => $self->{client_params}) ) {
|
||||
$self->set_error("Bad challenge: '$challenge'");
|
||||
return $cb->();
|
||||
}
|
||||
|
||||
# check required fields in server challenge
|
||||
if (my @missing = grep { !exists $cparams{$_} } @client_required) {
|
||||
$self->set_error("Client did not provide required field(s): @missing");
|
||||
return $cb->();
|
||||
}
|
||||
|
||||
my $count = hex ($cparams{'nc'} || 0);
|
||||
unless ($count == ++$self->{nonce_counts}{$cparams{nonce}}) {
|
||||
$self->set_error("nonce-count doesn't match: $count");
|
||||
return $cb->();
|
||||
}
|
||||
|
||||
my $qop = $cparams{'qop'} || "auth";
|
||||
unless ($self->is_qop_supported($qop)) {
|
||||
$self->set_error("Client qop not supported (qop = '$qop')");
|
||||
return $cb->();
|
||||
}
|
||||
|
||||
my $username = $cparams{'username'};
|
||||
unless ($username) {
|
||||
$self->set_error("Client didn't provide a username");
|
||||
return $cb->();
|
||||
}
|
||||
|
||||
# "The authzid MUST NOT be an empty string."
|
||||
if (exists $cparams{authzid} && $cparams{authzid} eq '') {
|
||||
$self->set_error("authzid cannot be empty");
|
||||
return $cb->();
|
||||
}
|
||||
my $authzid = $cparams{authzid};
|
||||
|
||||
# digest-uri: "Servers SHOULD check that the supplied value is correct.
|
||||
# This will detect accidental connection to the incorrect server, as well as
|
||||
# some redirection attacks"
|
||||
my $digest_uri = $cparams{'digest-uri'};
|
||||
my ($cservice, $chost, $cservname) = split '/', $digest_uri, 3;
|
||||
if ($cservice ne $self->service or $chost ne $self->host) {
|
||||
# XXX deal with serv_name
|
||||
$self->set_error("Incorrect digest-uri");
|
||||
return $cb->();
|
||||
}
|
||||
|
||||
unless (defined $self->callback('getsecret')) {
|
||||
$self->set_error("a getsecret callback MUST be defined");
|
||||
$cb->();
|
||||
return;
|
||||
}
|
||||
|
||||
my $realm = $self->{client_params}->{'realm'};
|
||||
my $response_check = sub {
|
||||
my $password = shift;
|
||||
return $self->set_error("Cannot get the passord for $username")
|
||||
unless defined $password;
|
||||
|
||||
## configure the security layer
|
||||
$self->_server_layer($qop)
|
||||
or return $self->set_error("Cannot negociate the security layer");
|
||||
|
||||
my ($expected, $rspauth)
|
||||
= $self->_compute_digests_and_set_keys($password, $self->{client_params});
|
||||
|
||||
return $self->set_error("Incorrect response $self->{client_params}->{response} <> $expected")
|
||||
unless $expected eq $self->{client_params}->{response};
|
||||
|
||||
my %response = (
|
||||
rspauth => $rspauth,
|
||||
);
|
||||
|
||||
# I'm not entirely sure of what I am doing
|
||||
$self->{answer}{$_} = $self->{client_params}->{$_} for qw/username authzid realm serv/;
|
||||
|
||||
$self->set_success;
|
||||
return _response(\%response);
|
||||
};
|
||||
|
||||
$self->callback('getsecret')->(
|
||||
$self,
|
||||
{ user => $username, realm => $realm, authzid => $authzid },
|
||||
sub { $cb->( $response_check->( shift ) ) },
|
||||
);
|
||||
}
|
||||
|
||||
sub is_qop_supported {
|
||||
my $self = shift;
|
||||
my $qop = shift;
|
||||
return $self->{supported_qop}{$qop};
|
||||
}
|
||||
|
||||
sub _response {
|
||||
my $response = shift;
|
||||
my $is_client = shift;
|
||||
|
||||
my @out;
|
||||
for my $k (sort keys %$response) {
|
||||
my $is_array = ref $response->{$k} && ref $response->{$k} eq 'ARRAY';
|
||||
my @values = $is_array ? @{$response->{$k}} : ($response->{$k});
|
||||
# Per spec, one way of doing it: multiple k=v
|
||||
#push @out, [$k, $_] for @values;
|
||||
# other way: comma separated list
|
||||
push @out, [$k, join (',', @values)];
|
||||
}
|
||||
return join (",", map { _qdval($_->[0], $_->[1], $is_client) } @out);
|
||||
}
|
||||
|
||||
sub _parse_challenge {
|
||||
my $self = shift;
|
||||
my $challenge_ref = shift;
|
||||
my $type = shift;
|
||||
my $params = shift;
|
||||
|
||||
while($$challenge_ref =~
|
||||
s/^(?:\s*,)*\s* # remaining or crap
|
||||
([\w-]+) # key, eg: qop
|
||||
=
|
||||
("([^\\"]+|\\.)*"|[^,]+) # value, eg: auth-conf or "NoNcE"
|
||||
\s*(?:,\s*)* # remaining
|
||||
//x) {
|
||||
|
||||
my ($k, $v) = ($1,$2);
|
||||
if ($v =~ /^"(.*)"$/s) {
|
||||
($v = $1) =~ s/\\(.)/$1/g;
|
||||
}
|
||||
if (exists $multi{$type}{$k}) {
|
||||
my $aref = $params->{$k} ||= [];
|
||||
push @$aref, $v;
|
||||
}
|
||||
elsif (defined $params->{$k}) {
|
||||
return $self->set_error("Bad challenge: '$$challenge_ref'");
|
||||
}
|
||||
else {
|
||||
$params->{$k} = $v;
|
||||
}
|
||||
}
|
||||
return length $$challenge_ref ? 0 : 1;
|
||||
}
|
||||
|
||||
sub _qdval {
|
||||
my ($k, $v, $is_client) = @_;
|
||||
|
||||
my $qdval = $is_client ? \%cqdval : \%sqdval;
|
||||
|
||||
if (!defined $v) {
|
||||
return;
|
||||
}
|
||||
elsif (exists $qdval->{$k}) {
|
||||
$v =~ s/([\\"])/\\$1/g;
|
||||
return qq{$k="$v"};
|
||||
}
|
||||
|
||||
return "$k=$v";
|
||||
}
|
||||
|
||||
sub _server_layer {
|
||||
my ($self, $auth) = @_;
|
||||
|
||||
# XXX dupe
|
||||
# construct our qop mask
|
||||
my $maxssf = $self->property('maxssf') - $self->property('externalssf');
|
||||
$maxssf = 0 if ($maxssf < 0);
|
||||
my $minssf = $self->property('minssf') - $self->property('externalssf');
|
||||
$minssf = 0 if ($minssf < 0);
|
||||
|
||||
return undef if ($maxssf < $minssf); # sanity check
|
||||
|
||||
my $ciphers = [ map { $_->{name} } @ourciphers ];
|
||||
if (( $auth eq 'auth-conf')
|
||||
and $self->_select_cipher($minssf, $maxssf, $ciphers )) {
|
||||
$self->property('ssf', $self->{cipher}->{ssf});
|
||||
return 1;
|
||||
}
|
||||
if ($auth eq 'auth-int') {
|
||||
$self->property('ssf', 1);
|
||||
return 1;
|
||||
}
|
||||
if ($auth eq 'auth') {
|
||||
$self->property('ssf', 0);
|
||||
return 1;
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _client_layer {
|
||||
my ($self, $sparams, $response) = @_;
|
||||
|
||||
# construct server qop mask
|
||||
# qop in server challenge is optional: if not there "auth" is assumed
|
||||
my $smask = 0;
|
||||
map {
|
||||
m/^auth$/ and $smask |= 1;
|
||||
m/^auth-int$/ and $smask |= 2;
|
||||
m/^auth-conf$/ and $smask |= 4;
|
||||
} split(/,/, $sparams->{qop}||'auth'); # XXX I think we might have a bug here bc. of LWS
|
||||
|
||||
# construct our qop mask
|
||||
my $cmask = 0;
|
||||
my $maxssf = $self->property('maxssf') - $self->property('externalssf');
|
||||
$maxssf = 0 if ($maxssf < 0);
|
||||
my $minssf = $self->property('minssf') - $self->property('externalssf');
|
||||
$minssf = 0 if ($minssf < 0);
|
||||
|
||||
return undef if ($maxssf < $minssf); # sanity check
|
||||
|
||||
# ssf values > 1 mean integrity and confidentiality
|
||||
# ssf == 1 means integrity but no confidentiality
|
||||
# ssf < 1 means neither integrity nor confidentiality
|
||||
# no security layer can be had if buffer size is 0
|
||||
$cmask |= 1 if ($minssf < 1);
|
||||
$cmask |= 2 if ($minssf <= 1 and $maxssf >= 1);
|
||||
$cmask |= 4 if ($maxssf > 1);
|
||||
|
||||
# find common bits
|
||||
$cmask &= $smask;
|
||||
|
||||
# parse server cipher options
|
||||
my @sciphers = split(/,/, $sparams->{'cipher-opts'}||$sparams->{cipher}||'');
|
||||
|
||||
if (($cmask & 4) and $self->_select_cipher($minssf,$maxssf,\@sciphers)) {
|
||||
$response->{qop} = 'auth-conf';
|
||||
$response->{cipher} = $self->{cipher}->{name};
|
||||
$self->property('ssf', $self->{cipher}->{ssf});
|
||||
return 1;
|
||||
}
|
||||
if ($cmask & 2) {
|
||||
$response->{qop} = 'auth-int';
|
||||
$self->property('ssf', 1);
|
||||
return 1;
|
||||
}
|
||||
if ($cmask & 1) {
|
||||
$response->{qop} = 'auth';
|
||||
$self->property('ssf', 0);
|
||||
return 1;
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _select_cipher {
|
||||
my ($self, $minssf, $maxssf, $ciphers) = @_;
|
||||
|
||||
# compose a subset of candidate ciphers based on ssf and peer list
|
||||
my @a = map {
|
||||
my $c = $_;
|
||||
(grep { $c->{name} eq $_ } @$ciphers and
|
||||
$c->{ssf} >= $minssf and $c->{ssf} <= $maxssf) ? $_ : ()
|
||||
} @ourciphers;
|
||||
|
||||
# from these, select the first one we can create an instance of
|
||||
for (@a) {
|
||||
next unless eval "require $_->{pkg}";
|
||||
$self->{cipher} = $_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
use Digest::HMAC_MD5 qw(hmac_md5);
|
||||
|
||||
sub encode { # input: self, plaintext buffer,length (length not used here)
|
||||
my $self = shift;
|
||||
my $seqnum = pack('N', $self->{sndseqnum}++);
|
||||
my $mac = substr(hmac_md5($seqnum . $_[0], $self->{kic}), 0, 10);
|
||||
|
||||
# if integrity only, return concatenation of buffer, MAC, TYPE and SEQNUM
|
||||
return $_[0] . $mac.pack('n',1) . $seqnum unless ($self->{khc});
|
||||
|
||||
# must encrypt, block ciphers need padding bytes
|
||||
my $pad = '';
|
||||
my $bs = $self->{cipher}->{bs};
|
||||
if ($bs > 1) {
|
||||
# padding is added in between BUF and MAC
|
||||
my $n = $bs - ((length($_[0]) + 10) & ($bs - 1));
|
||||
$pad = chr($n) x $n;
|
||||
}
|
||||
|
||||
# XXX - for future AES cipher support, the currently used common _crypt()
|
||||
# function probably wont do; we might to switch to per-cipher routines
|
||||
# like so:
|
||||
# return $self->{khc}->encrypt($_[0] . $pad . $mac) . pack('n', 1) . $seqnum;
|
||||
return $self->_crypt(0, $_[0] . $pad . $mac) . pack('n', 1) . $seqnum;
|
||||
}
|
||||
|
||||
sub decode { # input: self, cipher buffer,length
|
||||
my ($self, $buf, $len) = @_;
|
||||
|
||||
return if ($len <= 16);
|
||||
|
||||
# extract TYPE/SEQNUM from end of buffer
|
||||
my ($type,$seqnum) = unpack('na[4]', substr($buf, -6, 6, ''));
|
||||
|
||||
# decrypt remaining buffer, if necessary
|
||||
if ($self->{khs}) {
|
||||
# XXX - see remark above in encode() #$buf = $self->{khs}->decrypt($buf);
|
||||
$buf = $self->_crypt(1, $buf);
|
||||
}
|
||||
return unless ($buf);
|
||||
|
||||
# extract 10-byte MAC from the end of (decrypted) buffer
|
||||
my ($mac) = unpack('a[10]', substr($buf, -10, 10, ''));
|
||||
|
||||
if ($self->{khs} and $self->{cipher}->{bs} > 1) {
|
||||
# remove padding
|
||||
my $n = ord(substr($buf, -1, 1));
|
||||
substr($buf, -$n, $n, '');
|
||||
}
|
||||
|
||||
# check the MAC
|
||||
my $check = substr(hmac_md5($seqnum . $buf, $self->{kis}), 0, 10);
|
||||
return if ($mac ne $check);
|
||||
return if (unpack('N', $seqnum) != $self->{rcvseqnum});
|
||||
$self->{rcvseqnum}++;
|
||||
|
||||
return $buf;
|
||||
}
|
||||
|
||||
sub _crypt { # input: op(decrypting=1/encrypting=0)), buffer
|
||||
my ($self,$d) = (shift,shift);
|
||||
my $bs = $self->{cipher}->{bs};
|
||||
|
||||
if ($bs <= 1) {
|
||||
# stream cipher
|
||||
return $d ? $self->{khs}->decrypt($_[0]) : $self->{khc}->encrypt($_[0])
|
||||
}
|
||||
|
||||
# the remainder of this sub is for block ciphers
|
||||
|
||||
# get current IV
|
||||
my $piv = \$self->{$d ? 'ivs' : 'ivc'};
|
||||
my $iv = $$piv;
|
||||
|
||||
my $result = join '', map {
|
||||
my $x = $d
|
||||
? $iv ^ $self->{khs}->decrypt($_)
|
||||
: $self->{khc}->encrypt($iv ^ $_);
|
||||
$iv = $d ? $_ : $x;
|
||||
$x;
|
||||
} unpack("a$bs "x(int(length($_[0])/$bs)), $_[0]);
|
||||
|
||||
# store current IV
|
||||
$$piv = $iv;
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Authen::SASL::Perl::DIGEST_MD5 - Digest MD5 Authentication class
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.1700
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Authen::SASL qw(Perl);
|
||||
|
||||
$sasl = Authen::SASL->new(
|
||||
mechanism => 'DIGEST-MD5',
|
||||
callback => {
|
||||
user => $user,
|
||||
pass => $pass,
|
||||
serv => $serv
|
||||
},
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This method implements the client and server parts of the DIGEST-MD5 SASL
|
||||
algorithm, as described in RFC 2831.
|
||||
|
||||
=head2 CALLBACK
|
||||
|
||||
The callbacks used are:
|
||||
|
||||
=head3 client
|
||||
|
||||
=over 4
|
||||
|
||||
=item authname
|
||||
|
||||
The authorization id to use after successful authentication
|
||||
|
||||
=item user
|
||||
|
||||
The username to be used in the response
|
||||
|
||||
=item pass
|
||||
|
||||
The password to be used to compute the response.
|
||||
|
||||
=item serv
|
||||
|
||||
The service name when authenticating to a replicated service
|
||||
|
||||
=item realm
|
||||
|
||||
The authentication realm when overriding the server-provided default.
|
||||
If not given the server-provided value is used.
|
||||
|
||||
The callback will be passed the list of realms that the server provided
|
||||
in the initial response.
|
||||
|
||||
=back
|
||||
|
||||
=head3 server
|
||||
|
||||
=over 4
|
||||
|
||||
=item realm
|
||||
|
||||
The default realm to provide to the client
|
||||
|
||||
=item getsecret(username, realm, authzid)
|
||||
|
||||
returns the password associated with C<username> and C<realm>
|
||||
|
||||
=back
|
||||
|
||||
=head2 PROPERTIES
|
||||
|
||||
The properties used are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item maxbuf
|
||||
|
||||
The maximum buffer size for receiving cipher text
|
||||
|
||||
=item minssf
|
||||
|
||||
The minimum SSF value that should be provided by the SASL security layer.
|
||||
The default is 0
|
||||
|
||||
=item maxssf
|
||||
|
||||
The maximum SSF value that should be provided by the SASL security layer.
|
||||
The default is 2**31
|
||||
|
||||
=item externalssf
|
||||
|
||||
The SSF value provided by an underlying external security layer.
|
||||
The default is 0
|
||||
|
||||
=item ssf
|
||||
|
||||
The actual SSF value provided by the SASL security layer after the SASL
|
||||
authentication phase has been completed. This value is read-only and set
|
||||
by the implementation after the SASL authentication phase has been completed.
|
||||
|
||||
=item maxout
|
||||
|
||||
The maximum plaintext buffer size for sending data to the peer.
|
||||
This value is set by the implementation after the SASL authentication
|
||||
phase has been completed and a SASL security layer is in effect.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Authen::SASL>,
|
||||
L<Authen::SASL::Perl>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Graham Barr, Djamel Boudjerda (NEXOR), Paul Connolly, Julian Onions (NEXOR),
|
||||
Yann Kerherve.
|
||||
|
||||
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
|
||||
<perl-ldap@perl.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly,
|
||||
Julian Onions, Nexor, Peter Marschall and Yann Kerherve.
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,101 @@
|
||||
# Copyright (c) 1998-2002 Graham Barr <gbarr@pobox.com> and 2001 Chris Ridd
|
||||
# <chris.ridd@isode.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 Authen::SASL::Perl::EXTERNAL;
|
||||
$Authen::SASL::Perl::EXTERNAL::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars qw(@ISA);
|
||||
|
||||
@ISA = qw(Authen::SASL::Perl);
|
||||
|
||||
my %secflags = (
|
||||
noplaintext => 1,
|
||||
nodictionary => 1,
|
||||
noanonymous => 1,
|
||||
);
|
||||
|
||||
sub _order { 2 }
|
||||
sub _secflags {
|
||||
shift;
|
||||
grep { $secflags{$_} } @_;
|
||||
}
|
||||
|
||||
sub mechanism { 'EXTERNAL' }
|
||||
|
||||
sub client_start {
|
||||
my $self = shift;
|
||||
my $v = $self->_call('user');
|
||||
defined($v) ? $v : ''
|
||||
}
|
||||
|
||||
#sub client_step {
|
||||
# shift->_call('user');
|
||||
#}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Authen::SASL::Perl::EXTERNAL - External Authentication class
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.1700
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Authen::SASL qw(Perl);
|
||||
|
||||
$sasl = Authen::SASL->new(
|
||||
mechanism => 'EXTERNAL',
|
||||
callback => {
|
||||
user => $user
|
||||
},
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This method implements the client part of the EXTERNAL SASL algorithm,
|
||||
as described in RFC 2222.
|
||||
|
||||
=head2 CALLBACK
|
||||
|
||||
The callbacks used are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item user
|
||||
|
||||
The username to be used for authentication
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Authen::SASL>,
|
||||
L<Authen::SASL::Perl>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Software written by Graham Barr <gbarr@pobox.com>,
|
||||
documentation written by Peter Marschall <peter@adpm.de>.
|
||||
|
||||
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
|
||||
<perl-ldap@perl.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1998-2004 Graham Barr.
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
Documentation Copyright (c) 2004 Peter Marschall.
|
||||
All rights reserved. This documentation is distributed,
|
||||
and may be redistributed, under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,380 @@
|
||||
# Copyright (c) 2006 Simon Wilkinson
|
||||
# All rights reserved. This program is free software; you can redistribute
|
||||
# it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
package Authen::SASL::Perl::GSSAPI;
|
||||
$Authen::SASL::Perl::GSSAPI::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use vars qw(@ISA);
|
||||
use GSSAPI;
|
||||
|
||||
@ISA = qw(Authen::SASL::Perl);
|
||||
|
||||
my %secflags = (
|
||||
noplaintext => 1,
|
||||
noanonymous => 1,
|
||||
);
|
||||
|
||||
sub _order { 4 }
|
||||
sub _secflags {
|
||||
shift;
|
||||
scalar grep { $secflags{$_} } @_;
|
||||
}
|
||||
|
||||
sub mechanism { 'GSSAPI' }
|
||||
|
||||
sub _init {
|
||||
my ($pkg, $self) = @_;
|
||||
bless $self, $pkg;
|
||||
|
||||
# set default security properties
|
||||
$self->property('minssf', 0);
|
||||
$self->property('maxssf', int 2**31 - 1); # XXX - arbitrary "high" value
|
||||
$self->property('maxbuf', 0xFFFFFF); # maximum supported by GSSAPI mech
|
||||
$self->property('externalssf', 0);
|
||||
# the cyrus sasl library allows only one bit to be set in the
|
||||
# layer selection mask in the client reply, we default to
|
||||
# compatibility with that bug
|
||||
$self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG', 1);
|
||||
$self;
|
||||
}
|
||||
|
||||
sub client_start {
|
||||
my $self = shift;
|
||||
my $status;
|
||||
my $principal = $self->service.'@'.$self->host;
|
||||
|
||||
# GSSAPI::Name->import is the *constructor*,
|
||||
# storing the new GSSAPI::Name into $target.
|
||||
# GSSAPI::Name->import is not the standard
|
||||
# import() method as used in Perl normally
|
||||
my $target;
|
||||
$status = GSSAPI::Name->import($target, $principal, gss_nt_service_name)
|
||||
or return $self->set_error("GSSAPI Error : ".$status);
|
||||
$self->{gss_name} = $target;
|
||||
$self->{gss_ctx} = new GSSAPI::Context;
|
||||
$self->{gss_state} = 0;
|
||||
$self->{gss_layer} = undef;
|
||||
my $cred = $self->_call('pass');
|
||||
$self->{gss_cred} = (ref($cred) && $cred->isa('GSSAPI::Cred')) ? $cred : GSS_C_NO_CREDENTIAL;
|
||||
$self->{gss_mech} = $self->_call('gssmech') || gss_mech_krb5;
|
||||
|
||||
# reset properties for new session
|
||||
$self->property(maxout => undef);
|
||||
$self->property(ssf => undef);
|
||||
|
||||
return $self->client_step('');
|
||||
}
|
||||
|
||||
sub client_step {
|
||||
my ($self, $challenge) = @_;
|
||||
my $debug = $self->{debug};
|
||||
|
||||
my $status;
|
||||
|
||||
if ($self->{gss_state} == 0) {
|
||||
my $outtok;
|
||||
my $inflags = GSS_C_INTEG_FLAG | GSS_C_MUTUAL_FLAG;#todo:set according to ssf props
|
||||
my $outflags;
|
||||
$status = $self->{gss_ctx}->init($self->{gss_cred}, $self->{gss_name},
|
||||
$self->{gss_mech},
|
||||
$inflags,
|
||||
0, GSS_C_NO_CHANNEL_BINDINGS, $challenge, undef,
|
||||
$outtok, $outflags, undef);
|
||||
|
||||
print STDERR "state(0): ".
|
||||
$status->generic_message.';'.$status->specific_message.
|
||||
"; output token sz: ".length($outtok)."\n"
|
||||
if ($debug & 1);
|
||||
|
||||
if (GSSAPI::Status::GSS_ERROR($status->major)) {
|
||||
return $self->set_error("GSSAPI Error (init): ".$status);
|
||||
}
|
||||
if ($status->major == GSS_S_COMPLETE) {
|
||||
$self->{gss_state} = 1;
|
||||
}
|
||||
return $outtok;
|
||||
}
|
||||
elsif ($self->{gss_state} == 1) {
|
||||
# If the server has an empty output token when it COMPLETEs, Cyrus SASL
|
||||
# kindly sends us that empty token. We need to ignore it, which introduces
|
||||
# another round into the process.
|
||||
print STDERR " state(1): challenge is EMPTY\n"
|
||||
if ($debug and $challenge eq '');
|
||||
return '' if ($challenge eq '');
|
||||
|
||||
my $unwrapped;
|
||||
$status = $self->{gss_ctx}->unwrap($challenge, $unwrapped, undef, undef)
|
||||
or return $self->set_error("GSSAPI Error (unwrap challenge): ".$status);
|
||||
|
||||
return $self->set_error("GSSAPI Error : invalid security layer token")
|
||||
if (length($unwrapped) != 4);
|
||||
|
||||
# the security layers the server supports: bitmask of
|
||||
# 1 = no security layer,
|
||||
# 2 = integrity protection,
|
||||
# 4 = confidentiality protection
|
||||
# which is encoded in the first octet of the response;
|
||||
# the remote maximum buffer size is encoded in the next three octets
|
||||
#
|
||||
my $layer = ord(substr($unwrapped, 0, 1, chr(0)));
|
||||
my ($rsz) = unpack('N',$unwrapped);
|
||||
|
||||
# get local receive buffer size
|
||||
my $lsz = $self->property('maxbuf');
|
||||
|
||||
# choose security layer
|
||||
my $choice = $self->_layer($layer,$rsz,$lsz);
|
||||
return $self->set_error("GSSAPI Error: security too weak") unless $choice;
|
||||
|
||||
$self->{gss_layer} = $choice;
|
||||
|
||||
if ($choice > 1) {
|
||||
# determine maximum plain text message size for peer's cipher buffer
|
||||
my $psz;
|
||||
$status = $self->{gss_ctx}->wrap_size_limit($choice & 4, 0, $rsz, $psz)
|
||||
or return $self->set_error("GSSAPI Error (wrap size): ".$status);
|
||||
return $self->set_error("GSSAPI wrap size = 0") unless ($psz);
|
||||
$self->property(maxout => $psz);
|
||||
# set SSF property; if we have just integrity protection SSF is set
|
||||
# to 1. If we have confidentiality, SSF would be an estimate of the
|
||||
# strength of the actual encryption ciphers in use which is not
|
||||
# available through the GSSAPI interface; for now just set it to
|
||||
# the lowest value that signifies confidentiality.
|
||||
$self->property(ssf => (($choice & 4) ? 2 : 1));
|
||||
} else {
|
||||
# our advertised buffer size should be 0 if no layer selected
|
||||
$lsz = 0;
|
||||
$self->property(ssf => 0);
|
||||
}
|
||||
|
||||
print STDERR "state(1): layermask $layer,rsz $rsz,lsz $lsz,choice $choice\n"
|
||||
if ($debug & 1);
|
||||
|
||||
my $message = pack('CCCC', $choice,
|
||||
($lsz >> 16)&0xff, ($lsz >> 8)&0xff, $lsz&0xff);
|
||||
|
||||
# append authorization identity if we have one
|
||||
my $authz = $self->_call('authname');
|
||||
$message .= $authz if ($authz);
|
||||
|
||||
my $outtok;
|
||||
$status = $self->{gss_ctx}->wrap(0, 0, $message, undef, $outtok)
|
||||
or return $self->set_error("GSSAPI Error (wrap token): ".$status);
|
||||
|
||||
$self->{gss_state} = 0;
|
||||
return $outtok;
|
||||
}
|
||||
}
|
||||
|
||||
# default layer selection
|
||||
sub _layer {
|
||||
my ($self, $theirmask, $rsz, $lsz) = @_;
|
||||
my $maxssf = $self->property('maxssf') - $self->property('externalssf');
|
||||
$maxssf = 0 if ($maxssf < 0);
|
||||
|
||||
my $minssf = $self->property('minssf') - $self->property('externalssf');
|
||||
$minssf = 0 if ($minssf < 0);
|
||||
|
||||
return undef if ($maxssf < $minssf); # sanity check
|
||||
|
||||
# ssf values > 1 mean integrity and confidentiality
|
||||
# ssf == 1 means integrity but no confidentiality
|
||||
# ssf < 1 means neither integrity nor confidentiality
|
||||
# no security layer can be had if buffer size is 0
|
||||
my $ourmask = 0;
|
||||
$ourmask |= 1 if ($minssf < 1);
|
||||
$ourmask |= 2 if ($minssf <= 1 and $maxssf >= 1);
|
||||
$ourmask |= 4 if ($maxssf > 1);
|
||||
$ourmask &= 1 unless ($rsz and $lsz);
|
||||
|
||||
# mask the bits they don't have
|
||||
$ourmask &= $theirmask;
|
||||
|
||||
return $ourmask unless $self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG');
|
||||
|
||||
# in cyrus sasl bug compat mode, select the highest bit set
|
||||
return 4 if ($ourmask & 4);
|
||||
return 2 if ($ourmask & 2);
|
||||
return 1 if ($ourmask & 1);
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub encode { # input: self, plaintext buffer,length (length not used here)
|
||||
my $self = shift;
|
||||
my $wrapped;
|
||||
my $status = $self->{gss_ctx}->wrap($self->{gss_layer} & 4, 0, $_[0], undef, $wrapped);
|
||||
$self->set_error("GSSAPI Error (encode): " . $status), return
|
||||
unless ($status);
|
||||
return $wrapped;
|
||||
}
|
||||
|
||||
sub decode { # input: self, cipher buffer,length (length not used here)
|
||||
my $self = shift;
|
||||
my $unwrapped;
|
||||
my $status = $self->{gss_ctx}->unwrap($_[0], $unwrapped, undef, undef);
|
||||
$self->set_error("GSSAPI Error (decode): " . $status), return
|
||||
unless ($status);
|
||||
return $unwrapped;
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Authen::SASL::Perl::GSSAPI - GSSAPI (Kerberosv5) Authentication class
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.1700
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Authen::SASL qw(Perl);
|
||||
|
||||
$sasl = Authen::SASL->new( mechanism => 'GSSAPI' );
|
||||
|
||||
$sasl = Authen::SASL->new( mechanism => 'GSSAPI',
|
||||
callback => { pass => $mycred });
|
||||
|
||||
$sasl->client_start( $service, $host );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This method implements the client part of the GSSAPI SASL algorithm,
|
||||
as described in RFC 2222 section 7.2.1 resp. draft-ietf-sasl-gssapi-XX.txt.
|
||||
|
||||
With a valid Kerberos 5 credentials cache (aka TGT) it allows
|
||||
to connect to I<service>@I<host> given as the first two parameters
|
||||
to Authen::SASL's client_start() method. Alternatively, a GSSAPI::Cred
|
||||
object can be passed in via the Authen::SASL callback hash using
|
||||
the `pass' key.
|
||||
|
||||
Please note that this module does not currently implement a SASL
|
||||
security layer following authentication. Unless the connection is
|
||||
protected by other means, such as TLS, it will be vulnerable to
|
||||
man-in-the-middle attacks. If security layers are required, then the
|
||||
L<Authen::SASL::XS> GSSAPI module should be used instead.
|
||||
|
||||
=head2 CALLBACK
|
||||
|
||||
The callbacks used are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item authname
|
||||
|
||||
The authorization identity to be used in SASL exchange
|
||||
|
||||
=item gssmech
|
||||
|
||||
The GSS mechanism to be used in the connection
|
||||
|
||||
=item pass
|
||||
|
||||
The GSS credentials to be used in the connection (optional)
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
#! /usr/bin/perl -w
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Net::LDAP 0.33;
|
||||
use Authen::SASL 2.10;
|
||||
|
||||
# -------- Adjust to your environment --------
|
||||
my $adhost = 'theserver.bla.net';
|
||||
my $ldap_base = 'dc=bla,dc=net';
|
||||
my $ldap_filter = '(&(sAMAccountName=BLAAGROL))';
|
||||
|
||||
my $sasl = Authen::SASL->new(mechanism => 'GSSAPI');
|
||||
my $ldap;
|
||||
|
||||
eval {
|
||||
$ldap = Net::LDAP->new($adhost,
|
||||
onerror => 'die')
|
||||
or die "Cannot connect to LDAP host '$adhost': '$@'";
|
||||
$ldap->bind(sasl => $sasl);
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
chomp $@;
|
||||
die "\nBind error : $@",
|
||||
"\nDetailed SASL error: ", $sasl->error,
|
||||
"\nTerminated";
|
||||
}
|
||||
|
||||
print "\nLDAP bind() succeeded, working in authenticated state";
|
||||
|
||||
my $mesg = $ldap->search(base => $ldap_base,
|
||||
filter => $ldap_filter);
|
||||
|
||||
# -------- evaluate $mesg
|
||||
|
||||
=head2 PROPERTIES
|
||||
|
||||
The properties used are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item maxbuf
|
||||
|
||||
The maximum buffer size for receiving cipher text
|
||||
|
||||
=item minssf
|
||||
|
||||
The minimum SSF value that should be provided by the SASL security layer.
|
||||
The default is 0
|
||||
|
||||
=item maxssf
|
||||
|
||||
The maximum SSF value that should be provided by the SASL security layer.
|
||||
The default is 2**31
|
||||
|
||||
=item externalssf
|
||||
|
||||
The SSF value provided by an underlying external security layer.
|
||||
The default is 0
|
||||
|
||||
=item ssf
|
||||
|
||||
The actual SSF value provided by the SASL security layer after the SASL
|
||||
authentication phase has been completed. This value is read-only and set
|
||||
by the implementation after the SASL authentication phase has been completed.
|
||||
|
||||
=item maxout
|
||||
|
||||
The maximum plaintext buffer size for sending data to the peer.
|
||||
This value is set by the implementation after the SASL authentication
|
||||
phase has been completed and a SASL security layer is in effect.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Authen::SASL>,
|
||||
L<Authen::SASL::Perl>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Written by Simon Wilkinson, with patches and extensions by Achim Grolms
|
||||
and Peter Marschall.
|
||||
|
||||
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
|
||||
<perl-ldap@perl.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2006 Simon Wilkinson, Achim Grolms and Peter Marschall.
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,220 @@
|
||||
# Copyright (c) 2002 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 Authen::SASL::Perl::LOGIN;
|
||||
$Authen::SASL::Perl::LOGIN::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars qw(@ISA);
|
||||
|
||||
@ISA = qw(Authen::SASL::Perl);
|
||||
|
||||
my %secflags = (
|
||||
noanonymous => 1,
|
||||
);
|
||||
|
||||
sub _order { 1 }
|
||||
sub _secflags {
|
||||
shift;
|
||||
scalar grep { $secflags{$_} } @_;
|
||||
}
|
||||
|
||||
sub mechanism { 'LOGIN' }
|
||||
|
||||
sub client_start {
|
||||
my $self = shift;
|
||||
$self->{stage} = 0;
|
||||
'';
|
||||
}
|
||||
|
||||
sub client_step {
|
||||
my ($self, $string) = @_;
|
||||
|
||||
# XXX technically this is wrong. I might want to change that.
|
||||
# spec say it's "staged" and that the content of the challenge doesn't
|
||||
# matter
|
||||
# actually, let's try
|
||||
my $stage = ++$self->{stage};
|
||||
if ($stage == 1) {
|
||||
return $self->_call('user');
|
||||
}
|
||||
elsif ($stage == 2) {
|
||||
return $self->_call('pass');
|
||||
}
|
||||
elsif ($stage == 3) {
|
||||
$self->set_success;
|
||||
return;
|
||||
}
|
||||
else {
|
||||
return $self->set_error("Invalid sequence");
|
||||
}
|
||||
}
|
||||
|
||||
sub server_start {
|
||||
my $self = shift;
|
||||
my $response = shift;
|
||||
my $user_cb = shift || sub {};
|
||||
|
||||
$self->{answer} = {};
|
||||
$self->{stage} = 0;
|
||||
$self->{need_step} = 1;
|
||||
$self->{error} = undef;
|
||||
$user_cb->('Username:');
|
||||
return;
|
||||
}
|
||||
|
||||
sub server_step {
|
||||
my $self = shift;
|
||||
my $response = shift;
|
||||
my $user_cb = shift || sub {};
|
||||
|
||||
my $stage = ++$self->{stage};
|
||||
|
||||
if ($stage == 1) {
|
||||
unless (defined $response) {
|
||||
$self->set_error("Invalid sequence (empty username)");
|
||||
return $user_cb->();
|
||||
}
|
||||
$self->{answer}{user} = $response;
|
||||
return $user_cb->("Password:");
|
||||
}
|
||||
elsif ($stage == 2) {
|
||||
unless (defined $response) {
|
||||
$self->set_error("Invalid sequence (empty pass)");
|
||||
return $user_cb->();
|
||||
}
|
||||
$self->{answer}{pass} = $response;
|
||||
}
|
||||
else {
|
||||
$self->set_error("Invalid sequence (end)");
|
||||
return $user_cb->();
|
||||
}
|
||||
my $error = "Credentials don't match";
|
||||
my $answers = { user => $self->{answer}{user}, pass => $self->{answer}{pass} };
|
||||
if (my $checkpass = $self->{callback}{checkpass}) {
|
||||
my $cb = sub {
|
||||
my $result = shift;
|
||||
unless ($result) {
|
||||
$self->set_error($error);
|
||||
}
|
||||
else {
|
||||
$self->set_success;
|
||||
}
|
||||
$user_cb->();
|
||||
};
|
||||
$checkpass->($self => $answers => $cb );
|
||||
return;
|
||||
}
|
||||
elsif (my $getsecret = $self->{callback}{getsecret}) {
|
||||
my $cb = sub {
|
||||
my $good_pass = shift;
|
||||
if ($good_pass && $good_pass eq ($self->{answer}{pass} || "")) {
|
||||
$self->set_success;
|
||||
}
|
||||
else {
|
||||
$self->set_error($error);
|
||||
}
|
||||
$user_cb->();
|
||||
};
|
||||
$getsecret->($self => $answers => $cb );
|
||||
return;
|
||||
}
|
||||
else {
|
||||
$self->set_error($error);
|
||||
$user_cb->();
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Authen::SASL::Perl::LOGIN - Login Authentication class
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.1700
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Authen::SASL qw(Perl);
|
||||
|
||||
$sasl = Authen::SASL->new(
|
||||
mechanism => 'LOGIN',
|
||||
callback => {
|
||||
user => $user,
|
||||
pass => $pass
|
||||
},
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This method implements the client and server part of the LOGIN SASL algorithm,
|
||||
as described in IETF Draft draft-murchison-sasl-login-XX.txt.
|
||||
|
||||
=head2 CALLBACK
|
||||
|
||||
The callbacks used are:
|
||||
|
||||
=head3 Client
|
||||
|
||||
=over 4
|
||||
|
||||
=item user
|
||||
|
||||
The username to be used for authentication
|
||||
|
||||
=item pass
|
||||
|
||||
The user's password to be used for authentication
|
||||
|
||||
=back
|
||||
|
||||
=head3 Server
|
||||
|
||||
=over 4
|
||||
|
||||
=item getsecret(username)
|
||||
|
||||
returns the password associated with C<username>
|
||||
|
||||
=item checkpass(username, password)
|
||||
|
||||
returns true and false depending on the validity of the credentials passed
|
||||
in arguments.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Authen::SASL>,
|
||||
L<Authen::SASL::Perl>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Software written by Graham Barr <gbarr@pobox.com>,
|
||||
documentation written by Peter Marschall <peter@adpm.de>.
|
||||
Server support by Yann Kerherve <yannk@cpan.org>
|
||||
|
||||
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
|
||||
<perl-ldap@perl.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2002-2004 Graham Barr.
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
Documentation Copyright (c) 2004 Peter Marschall.
|
||||
All rights reserved. This documentation is distributed,
|
||||
and may be redistributed, under the same terms as Perl itself.
|
||||
|
||||
Server support Copyright (c) 2009 Yann Kerherve.
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,186 @@
|
||||
# Copyright (c) 2002 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 Authen::SASL::Perl::PLAIN;
|
||||
$Authen::SASL::Perl::PLAIN::VERSION = '2.1700';
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars qw(@ISA);
|
||||
|
||||
@ISA = qw(Authen::SASL::Perl);
|
||||
|
||||
my %secflags = (
|
||||
noanonymous => 1,
|
||||
);
|
||||
|
||||
my @tokens = qw(authname user pass);
|
||||
|
||||
sub _order { 1 }
|
||||
sub _secflags {
|
||||
shift;
|
||||
grep { $secflags{$_} } @_;
|
||||
}
|
||||
|
||||
sub mechanism { 'PLAIN' }
|
||||
|
||||
sub client_start {
|
||||
my $self = shift;
|
||||
|
||||
$self->{error} = undef;
|
||||
$self->{need_step} = 0;
|
||||
|
||||
my @parts = map {
|
||||
my $v = $self->_call($_);
|
||||
defined($v) ? $v : ''
|
||||
} @tokens;
|
||||
|
||||
join("\0", @parts);
|
||||
}
|
||||
|
||||
sub server_start {
|
||||
my $self = shift;
|
||||
my $response = shift;
|
||||
my $user_cb = shift || sub {};
|
||||
|
||||
$self->{error} = undef;
|
||||
return $self->set_error("No response: Credentials don't match")
|
||||
unless defined $response;
|
||||
|
||||
my %parts;
|
||||
@parts{@tokens} = split "\0", $response, scalar @tokens;
|
||||
|
||||
|
||||
# I'm not entirely sure of what I am doing
|
||||
$self->{answer}{$_} = $parts{$_} for qw/authname user/;
|
||||
my $error = "Credentials don't match";
|
||||
|
||||
## checkpass
|
||||
if (my $checkpass = $self->callback('checkpass')) {
|
||||
my $cb = sub {
|
||||
my $result = shift;
|
||||
unless ($result) {
|
||||
$self->set_error($error);
|
||||
}
|
||||
else {
|
||||
$self->set_success;
|
||||
}
|
||||
$user_cb->();
|
||||
};
|
||||
$checkpass->($self => { %parts } => $cb );
|
||||
return;
|
||||
}
|
||||
|
||||
## getsecret
|
||||
elsif (my $getsecret = $self->callback('getsecret')) {
|
||||
my $cb = sub {
|
||||
my $good_pass = shift;
|
||||
if ($good_pass && $good_pass eq ($parts{pass} || "")) {
|
||||
$self->set_success;
|
||||
}
|
||||
else {
|
||||
$self->set_error($error);
|
||||
}
|
||||
$user_cb->();
|
||||
};
|
||||
$getsecret->( $self, { map { $_ => $parts{$_ } } qw/user authname/ }, $cb );
|
||||
return;
|
||||
}
|
||||
|
||||
## error by default
|
||||
else {
|
||||
$self->set_error($error);
|
||||
$user_cb->();
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Authen::SASL::Perl::PLAIN - Plain Login Authentication class
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.1700
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Authen::SASL qw(Perl);
|
||||
|
||||
$sasl = Authen::SASL->new(
|
||||
mechanism => 'PLAIN',
|
||||
callback => {
|
||||
user => $user,
|
||||
pass => $pass
|
||||
},
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This method implements the client and server part of the PLAIN SASL algorithm,
|
||||
as described in RFC 2595 resp. IETF Draft draft-ietf-sasl-plain-XX.txt
|
||||
|
||||
=head2 CALLBACK
|
||||
|
||||
The callbacks used are:
|
||||
|
||||
=head3 Client
|
||||
|
||||
=over 4
|
||||
|
||||
=item authname
|
||||
|
||||
The authorization id to use after successful authentication (client)
|
||||
|
||||
=item user
|
||||
|
||||
The username to be used for authentication (client)
|
||||
|
||||
=item pass
|
||||
|
||||
The user's password to be used for authentication.
|
||||
|
||||
=back
|
||||
|
||||
=head3 Server
|
||||
|
||||
=over 4
|
||||
|
||||
=item checkpass(username, password, realm)
|
||||
|
||||
returns true and false depending on the validity of the credentials passed
|
||||
in arguments.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Authen::SASL>,
|
||||
L<Authen::SASL::Perl>
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Software written by Graham Barr <gbarr@pobox.com>,
|
||||
documentation written by Peter Marschall <peter@adpm.de>.
|
||||
|
||||
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
|
||||
<perl-ldap@perl.org>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2002-2004 Graham Barr.
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
Documentation Copyright (c) 2004 Peter Marschall.
|
||||
All rights reserved. This documentation is distributed,
|
||||
and may be redistributed, under the same terms as Perl itself.
|
||||
|
||||
Server support Copyright (c) 2009 Yann Kerherve.
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
1711
gitportable/usr/share/perl5/vendor_perl/Convert/BinHex.pm
Normal file
1711
gitportable/usr/share/perl5/vendor_perl/Convert/BinHex.pm
Normal file
File diff suppressed because it is too large
Load Diff
403
gitportable/usr/share/perl5/vendor_perl/Date/Format.pm
Normal file
403
gitportable/usr/share/perl5/vendor_perl/Date/Format.pm
Normal file
@@ -0,0 +1,403 @@
|
||||
# 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;
|
||||
use vars qw(@EXPORT @ISA $VERSION);
|
||||
require Exporter;
|
||||
|
||||
$VERSION = "2.24";
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(time2str strftime ctime asctime);
|
||||
|
||||
sub time2str ($;$$)
|
||||
{
|
||||
Date::Format::Generic->time2str(@_);
|
||||
}
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
##
|
||||
##
|
||||
##
|
||||
|
||||
package Date::Format::Generic;
|
||||
|
||||
use vars qw($epoch $tzname);
|
||||
use Time::Zone;
|
||||
use Time::Local;
|
||||
|
||||
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 = timegm(@{$time}[0..5]);
|
||||
|
||||
@$me = gmtime($epoch + tz_offset($tzname) - tz_offset());
|
||||
}
|
||||
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 routins 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(timelocal(@{$_[0]}[0..5]));
|
||||
defined $tzname ? $tzname : uc tz_name($o, $_[0]->[8]);
|
||||
}
|
||||
|
||||
sub format_z {
|
||||
my $t = timelocal(@{$_[0]}[0..5]);
|
||||
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__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Date::Format - Date formating subroutines
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Date::Format;
|
||||
|
||||
@lt = localtime(time);
|
||||
|
||||
print time2str($template, time);
|
||||
print strftime($template, @lt);
|
||||
|
||||
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])
|
||||
|
||||
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.
|
||||
|
||||
|
||||
=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 MULTI-LANGUAGE SUPPORT
|
||||
|
||||
Date::Format is capable of formating into several languages by creating
|
||||
a language specific object and calling methods, see L<Date::Language>
|
||||
|
||||
my $lang = Date::Language->new('German');
|
||||
$lang->time2str("%a %b %e %T %Y\n", time);
|
||||
|
||||
I am open to suggestions on this.
|
||||
|
||||
=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.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
145
gitportable/usr/share/perl5/vendor_perl/Date/Language.pm
Normal file
145
gitportable/usr/share/perl5/vendor_perl/Date/Language.pm
Normal file
@@ -0,0 +1,145 @@
|
||||
|
||||
package Date::Language;
|
||||
|
||||
use strict;
|
||||
use Time::Local;
|
||||
use Carp;
|
||||
use vars qw($VERSION @ISA);
|
||||
require Date::Format;
|
||||
|
||||
$VERSION = "1.10";
|
||||
@ISA = qw(Date::Format::Generic);
|
||||
|
||||
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
|
||||
{
|
||||
use vars qw($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 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__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Date::Language - Language specific date formating and parsing
|
||||
|
||||
=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 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
|
||||
|
||||
@@ -0,0 +1,49 @@
|
||||
##
|
||||
## Afar tables
|
||||
##
|
||||
|
||||
package Date::Language::Afar;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "0.99";
|
||||
|
||||
@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);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,87 @@
|
||||
##
|
||||
## Amharic tables
|
||||
##
|
||||
|
||||
package Date::Language::Amharic;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.00";
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,36 @@
|
||||
##
|
||||
## Austrian tables
|
||||
##
|
||||
|
||||
package Date::Language::Austrian;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@MoY = qw(J<EFBFBD>nner Feber M<>rz April Mai Juni
|
||||
Juli August September Oktober November Dezember);
|
||||
@MoYs = qw(J<EFBFBD>n Feb M<>r Apr Mai Jun Jul Aug Sep Oct Nov Dez);
|
||||
@DoW = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
|
||||
@DoWs = qw(Son Mon Die Mit Don Fre Sam);
|
||||
|
||||
use Date::Language::English ();
|
||||
@AMPM = @{Date::Language::English::AMPM};
|
||||
@Dsuf = @{Date::Language::English::Dsuf};
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,35 @@
|
||||
##
|
||||
## Brazilian tables, contributed by Christian Tosta (tosta@cce.ufmg.br)
|
||||
##
|
||||
|
||||
package Date::Language::Brazilian;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@DoW = qw(Domingo Segunda Ter<65>a Quarta Quinta Sexta S<>bado);
|
||||
@MoY = qw(Janeiro Fevereiro Mar<61>o Abril Maio Junho
|
||||
Julho Agosto Setembro Outubro Novembro Dezembro);
|
||||
@DoWs = map { substr($_,0,3) } @DoW;
|
||||
@MoYs = map { substr($_,0,3) } @MoY;
|
||||
@AMPM = qw(AM PM);
|
||||
|
||||
@Dsuf = (qw(mo ro do ro to to to mo vo no)) x 3;
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,92 @@
|
||||
##
|
||||
## 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, $VERSION);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@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(ти ви);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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__
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Date::Language::Bulgarian - localization for Date::Format
|
||||
|
||||
=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 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 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.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
@@ -0,0 +1,36 @@
|
||||
##
|
||||
## English tables
|
||||
##
|
||||
|
||||
package Date::Language::Chinese;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.00";
|
||||
|
||||
@DoW = qw(星期日 星期一 星期二 星期三 星期四 星期五 星期六);
|
||||
@MoY = qw(一月 二月 三月 四月 五月 六月
|
||||
七月 八月 九月 十月 十一月 十二月);
|
||||
@DoWs = map { $_ } @DoW;
|
||||
@MoYs = map { $_ } @MoY;
|
||||
@AMPM = qw(上午 下午);
|
||||
|
||||
@Dsuf = (qw(日 日 日 日 日 日 日 日 日 日)) x 3;
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,36 @@
|
||||
##
|
||||
## English tables
|
||||
##
|
||||
|
||||
package Date::Language::Chinese_GB;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@DoW = qw(<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>һ <20><><EFBFBD>ڶ<EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>);
|
||||
@MoY = qw(һ<EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>
|
||||
<20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> ʮ<><CAAE> ʮһ<CAAE><D2BB> ʮ<><CAAE><EFBFBD><EFBFBD>);
|
||||
@DoWs = map { $_ } @DoW;
|
||||
@MoYs = map { $_ } @MoY;
|
||||
@AMPM = qw(<EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD>);
|
||||
|
||||
@Dsuf = (qw(<EFBFBD><EFBFBD> <20><> <20><> <20><> <20><> <20><> <20><> <20><> <20><> <20><>)) x 3;
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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],"<22><>") }
|
||||
1;
|
||||
@@ -0,0 +1,58 @@
|
||||
##
|
||||
## Czech tables
|
||||
##
|
||||
## Contributed by Honza Pazdziora
|
||||
|
||||
package Date::Language::Czech;
|
||||
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @MoY2 @AMPM %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language Date::Format::Generic);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@MoY = qw(leden <20>nor b<>ezen duben kv<6B>ten <20>erven <20>ervenec srpen z<><7A><EFBFBD>
|
||||
<20><>jen listopad prosinec);
|
||||
@MoYs = qw(led <20>nor b<>e dub kv<6B> <20>vn <20>ec srp z<><7A><EFBFBD> <20><>j lis pro);
|
||||
@MoY2 = @MoY;
|
||||
for (@MoY2)
|
||||
{ s!en$!na! or s!ec$!ce! or s!ad$!adu! or s!or$!ora!; }
|
||||
|
||||
@DoW = qw(ned<EFBFBD>le pond<6E>l<EFBFBD> <20>ter<65> st<73>eda <20>tvrtek p<>tek sobota);
|
||||
@DoWs = qw(Ne Po <20>t St <20>t P<> So);
|
||||
|
||||
@AMPM = qw(dop. odp.);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,36 @@
|
||||
##
|
||||
## Danish tables
|
||||
##
|
||||
|
||||
package Date::Language::Danish;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@MoY = qw(Januar Februar Marts April Maj Juni
|
||||
Juli August September Oktober November December);
|
||||
@MoYs = qw(Jan Feb Mar Apr Maj Jun Jul Aug Sep Okt Nov Dec);
|
||||
@DoW = qw(S<EFBFBD>ndag Mandag Tirsdag Onsdag Torsdag Fredag L<>rdag S<>ndag);
|
||||
@DoWs = qw(S<EFBFBD>n Man Tir Ons Tor Fre L<>r S<>n);
|
||||
|
||||
use Date::Language::English ();
|
||||
@AMPM = @{Date::Language::English::AMPM};
|
||||
@Dsuf = @{Date::Language::English::Dsuf};
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,40 @@
|
||||
##
|
||||
## Dutch tables
|
||||
## Contributed by Johannes la Poutre <jlpoutre@corp.nl.home.com>
|
||||
##
|
||||
|
||||
package Date::Language::Dutch;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.02";
|
||||
|
||||
@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;
|
||||
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,37 @@
|
||||
##
|
||||
## English tables
|
||||
##
|
||||
|
||||
package Date::Language::English;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@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);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,45 @@
|
||||
##
|
||||
## Finnish tables
|
||||
## Contributed by Matthew Musgrove <muskrat@mindless.com>
|
||||
## Corrected by roke
|
||||
##
|
||||
|
||||
package Date::Language::Finnish;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
# In Finnish, the names of the months and days are only capitalized at the beginning of sentences.
|
||||
@MoY = map($_ . "kuu", qw(tammi helmi maalis huhti touko kes<65> hein<69> elo syys loka marras joulu));
|
||||
@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:
|
||||
@MoYs = @MoY;
|
||||
@DoWs = @DoW;
|
||||
|
||||
# the short form of ordinals
|
||||
@Dsuf = ('.') x 31;
|
||||
|
||||
# doesn't look like this is normally used...
|
||||
@AMPM = qw(ap ip);
|
||||
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,37 @@
|
||||
##
|
||||
## French tables, contributed by Emmanuel Bataille (bem@residents.frmug.org)
|
||||
##
|
||||
|
||||
package Date::Language::French;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.04";
|
||||
|
||||
@DoW = qw(dimanche lundi mardi mercredi jeudi vendredi samedi);
|
||||
@MoY = qw(janvier f<>vrier mars avril mai juin
|
||||
juillet ao<61>t septembre octobre novembre d<>cembre);
|
||||
@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');
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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] }
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,51 @@
|
||||
##
|
||||
## Gedeo tables
|
||||
##
|
||||
|
||||
package Date::Language::Gedeo;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "0.99";
|
||||
|
||||
@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);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,37 @@
|
||||
##
|
||||
## German tables
|
||||
##
|
||||
|
||||
package Date::Language::German;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.02";
|
||||
|
||||
@MoY = qw(Januar Februar M<>rz April Mai Juni
|
||||
Juli August September Oktober November Dezember);
|
||||
@MoYs = qw(Jan Feb M<>r Apr Mai Jun Jul Aug Sep Okt Nov Dez);
|
||||
@DoW = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
|
||||
@DoWs = qw(Son Mon Die Mit Don Fre Sam);
|
||||
|
||||
use Date::Language::English ();
|
||||
@AMPM = @{Date::Language::English::AMPM};
|
||||
@Dsuf = @{Date::Language::English::Dsuf};
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,91 @@
|
||||
##
|
||||
## Greek tables
|
||||
##
|
||||
## Traditional date format is: DoW DD{eta} MoY Year (%A %o %B %Y)
|
||||
##
|
||||
## Matthew Musgrove <muskrat@mindless.com>
|
||||
## Translations gratiously 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 utf8;
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.00";
|
||||
|
||||
@DoW = (
|
||||
"\x{039a}\x{03c5}\x{03c1}\x{03b9}\x{03b1}\x{03ba}\x{03ae}",
|
||||
"\x{0394}\x{03b5}\x{03c5}\x{03c4}\x{03ad}\x{03c1}\x{03b1}",
|
||||
"\x{03a4}\x{03c1}\x{03af}\x{03c4}\x{03b7}",
|
||||
"\x{03a4}\x{03b5}\x{03c4}\x{03ac}\x{03c1}\x{03c4}\x{03b7}",
|
||||
"\x{03a0}\x{03ad}\x{03bc}\x{03c0}\x{03c4}\x{03b7}",
|
||||
"\x{03a0}\x{03b1}\x{03c1}\x{03b1}\x{03c3}\x{03ba}\x{03b5}\x{03c5}\x{03ae}",
|
||||
"\x{03a3}\x{03ac}\x{03b2}\x{03b2}\x{03b1}\x{03c4}\x{03bf}",
|
||||
);
|
||||
|
||||
@MoY = (
|
||||
"\x{0399}\x{03b1}\x{03bd}\x{03bf}\x{03c5}\x{03b1}\x{03c1}\x{03af}\x{03bf}\x{03c5}",
|
||||
"\x{03a6}\x{03b5}\x{03b2}\x{03c1}\x{03bf}\x{03c5}\x{03b1}\x{03c1}\x{03af}\x{03bf}\x{03c5}",
|
||||
"\x{039c}\x{03b1}\x{03c1}\x{03c4}\x{03af}\x{03bf}\x{03c5}",
|
||||
"\x{0391}\x{03c0}\x{03c1}\x{03b9}\x{03bb}\x{03af}\x{03c5}",
|
||||
"\x{039c}\x{03b1}\x{0390}\x{03bf}\x{03c5}",
|
||||
"\x{0399}\x{03bf}\x{03c5}\x{03bd}\x{03af}\x{03bf}\x{03c5}",
|
||||
"\x{0399}\x{03bf}\x{03c5}\x{03bb}\x{03af}\x{03bf}\x{03c5}",
|
||||
"\x{0391}\x{03c5}\x{03b3}\x{03bf}\x{03cd}\x{03c3}\x{03c4}\x{03bf}\x{03c5}",
|
||||
"\x{03a3}\x{03b5}\x{03c0}\x{03c4}\x{03b5}\x{03bc}\x{03c4}\x{03bf}\x{03c5}",
|
||||
"\x{039f}\x{03ba}\x{03c4}\x{03c9}\x{03b2}\x{03c1}\x{03af}\x{03bf}\x{03c5}",
|
||||
"\x{039d}\x{03bf}\x{03b5}\x{03bc}\x{03b2}\x{03c1}\x{03af}\x{03bf}\x{03c5}",
|
||||
"\x{0394}\x{03b5}\x{03ba}\x{03b5}\x{03bc}\x{03b2}\x{03c1}\x{03bf}\x{03c5}",
|
||||
);
|
||||
|
||||
@DoWs = (
|
||||
"\x{039a}\x{03c5}",
|
||||
"\x{0394}\x{03b5}",
|
||||
"\x{03a4}\x{03c1}",
|
||||
"\x{03a4}\x{03b5}",
|
||||
"\x{03a0}\x{03b5}",
|
||||
"\x{03a0}\x{03b1}",
|
||||
"\x{03a3}\x{03b1}",
|
||||
);
|
||||
@MoYs = (
|
||||
"\x{0399}\x{03b1}\x{03bd}",
|
||||
"\x{03a6}\x{03b5}",
|
||||
"\x{039c}\x{03b1}\x{03c1}",
|
||||
"\x{0391}\x{03c0}\x{03c1}",
|
||||
"\x{039c}\x{03b1}",
|
||||
"\x{0399}\x{03bf}\x{03c5}\x{03bd}",
|
||||
"\x{0399}\x{03bf}\x{03c5}\x{03bb}",
|
||||
"\x{0391}\x{03c5}\x{03b3}",
|
||||
"\x{03a3}\x{03b5}\x{03c0}",
|
||||
"\x{039f}\x{03ba}",
|
||||
"\x{039d}\x{03bf}",
|
||||
"\x{0394}\x{03b5}",
|
||||
);
|
||||
|
||||
@AMPM = ("\x{03c0}\x{03bc}", "\x{03bc}\x{03bc}");
|
||||
|
||||
@Dsuf = ("\x{03b7}" x 31);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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],"\x{03b7}") }
|
||||
sub format_p { $_[0]->[2] >= 12 ? $AMPM[1] : $AMPM[0] }
|
||||
|
||||
1;
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,88 @@
|
||||
##
|
||||
## 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 neeed.
|
||||
#
|
||||
|
||||
package Date::Language::Hungarian;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Date::Language::Hungarian - Magyar format for Date::Format
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $lang = Date::Language->new('Hungarian');
|
||||
print $lang->time2str("%a %b %e %T %Y", time);
|
||||
|
||||
@lt = localtime(time);
|
||||
print $lang->time2str($template, time);
|
||||
print $lang->strftime($template, @lt);
|
||||
|
||||
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 AUTHOR
|
||||
|
||||
Paula Goddard (paula -at- paulacska -dot- com)
|
||||
|
||||
=head1 LICENCE
|
||||
|
||||
Made available under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use base "Date::Language";
|
||||
use vars qw( @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@DoW = qw(Vas<EFBFBD>rnap H<>tf<74> Kedd Szerda Cs<43>t<EFBFBD>rt<72>k P<>ntek Szombat);
|
||||
@MoY = qw(Janu<EFBFBD>r Febru<72>r M<>rcius <20>prilis M<>jus J<>nius
|
||||
J<>lius Augusztus Szeptember Okt<6B>ber November December);
|
||||
@DoWs = map { substr($_,0,3) } @DoW;
|
||||
@MoYs = map { substr($_,0,3) } @MoY;
|
||||
@AMPM = qw(DE. DU.);
|
||||
|
||||
# There is no 'th or 'nd in Hungarian, just a dot
|
||||
@Dsuf = (".") x 31;
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,36 @@
|
||||
##
|
||||
## Icelandic tables
|
||||
##
|
||||
|
||||
package Date::Language::Icelandic;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@MoY = qw(Jan<EFBFBD>ar Febr<62>ar Mars Apr<70>l Ma<4D> J<>ni
|
||||
J<>li <20>g<EFBFBD>st September Okt<6B>ber N<>vember Desember);
|
||||
@MoYs = qw(Jan Feb Mar Apr Ma<4D> J<>n J<>l <20>g<EFBFBD> Sep Okt N<>v Des);
|
||||
@DoW = qw(Sunnudagur M<>nudagur <20>ri<72>judagur Mi<4D>vikudagur Fimmtudagur F<>studagur Laugardagur Sunnudagur);
|
||||
@DoWs = qw(Sun M<>n <20>ri Mi<4D> Fim F<>s Lau Sun);
|
||||
|
||||
use Date::Language::English ();
|
||||
@AMPM = @{Date::Language::English::AMPM};
|
||||
@Dsuf = @{Date::Language::English::Dsuf};
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,36 @@
|
||||
##
|
||||
## Italian tables
|
||||
##
|
||||
|
||||
package Date::Language::Italian;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@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};
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,36 @@
|
||||
##
|
||||
## Norwegian tables
|
||||
##
|
||||
|
||||
package Date::Language::Norwegian;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@MoY = qw(Januar Februar Mars April Mai Juni
|
||||
Juli August September Oktober November Desember);
|
||||
@MoYs = qw(Jan Feb Mar Apr Mai Jun Jul Aug Sep Okt Nov Des);
|
||||
@DoW = qw(S<EFBFBD>ndag Mandag Tirsdag Onsdag Torsdag Fredag L<>rdag S<>ndag);
|
||||
@DoWs = qw(S<EFBFBD>n Man Tir Ons Tor Fre L<>r S<>n);
|
||||
|
||||
use Date::Language::English ();
|
||||
@AMPM = @{Date::Language::English::AMPM};
|
||||
@Dsuf = @{Date::Language::English::Dsuf};
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,36 @@
|
||||
##
|
||||
## Occitan tables, contributed by Quentn PAGÈS
|
||||
##
|
||||
|
||||
package Date::Language::Occitan;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.04";
|
||||
|
||||
@DoW = qw(dimenge diluns dimars dimècres dijòus divendres dissabte);
|
||||
@MoY = qw(genièr febrièr mars abrial mai junh
|
||||
julhet agost 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');
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,37 @@
|
||||
##
|
||||
## Oromo tables
|
||||
##
|
||||
|
||||
package Date::Language::Oromo;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "0.99";
|
||||
|
||||
@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);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,37 @@
|
||||
##
|
||||
## Italian tables
|
||||
##
|
||||
|
||||
package Date::Language::Romanian;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@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;
|
||||
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,49 @@
|
||||
##
|
||||
## Russian tables
|
||||
##
|
||||
## Contributed by Danil Pismenny <dapi@mail.ru>
|
||||
|
||||
package Date::Language::Russian;
|
||||
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @MoY2 @AMPM %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language Date::Format::Generic);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@MoY = qw(<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>);
|
||||
@MoY2 = qw(<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>);
|
||||
@MoYs = qw(<EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD>);
|
||||
|
||||
@DoW = qw(<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>);
|
||||
@DoWs = qw(<EFBFBD><EFBFBD> <20><> <20><> <20><> <20><> <20><> <20><>);
|
||||
@DoWs2 = qw(<EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD>);
|
||||
|
||||
@AMPM = qw(<EFBFBD><EFBFBD> <20><>);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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+|^)<29><><EFBFBD>(\s+)/$1<><31><EFBFBD>$2/;
|
||||
return $self->SUPER::str2time($value);
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,39 @@
|
||||
##
|
||||
## Russian cp1251
|
||||
##
|
||||
|
||||
package Date::Language::Russian_cp1251;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@DoW = qw(<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>);
|
||||
@MoY = qw(<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD>
|
||||
<20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>);
|
||||
@DoWs = qw(<EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD>);
|
||||
#@DoWs = map { substr($_,0,3) } @DoW;
|
||||
@MoYs = map { substr($_,0,3) } @MoY;
|
||||
@AMPM = qw(AM PM);
|
||||
|
||||
@Dsuf = ('e') x 31;
|
||||
#@Dsuf[11,12,13] = qw(<28> <20> <20>);
|
||||
#@Dsuf[30,31] = qw(<28> <20>);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,39 @@
|
||||
##
|
||||
## Russian koi8r
|
||||
##
|
||||
|
||||
package Date::Language::Russian_koi8r;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@DoW = qw(<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>);
|
||||
@MoY = qw(<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD><EFBFBD>
|
||||
<20><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>);
|
||||
@DoWs = qw(<EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD> <20><><EFBFBD>);
|
||||
#@DoWs = map { substr($_,0,3) } @DoW;
|
||||
@MoYs = map { substr($_,0,3) } @MoY;
|
||||
@AMPM = qw(AM PM);
|
||||
|
||||
@Dsuf = ('e') x 31;
|
||||
#@Dsuf[11,12,13] = qw(<28> <20> <20>);
|
||||
#@Dsuf[30,31] = qw(<28> <20>);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,37 @@
|
||||
##
|
||||
## Sidama tables
|
||||
##
|
||||
|
||||
package Date::Language::Sidama;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "0.99";
|
||||
|
||||
@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);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,62 @@
|
||||
##
|
||||
## Somali tables
|
||||
##
|
||||
|
||||
package Date::Language::Somali;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "0.99";
|
||||
|
||||
@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);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,35 @@
|
||||
##
|
||||
## Spanish tables
|
||||
##
|
||||
|
||||
package Date::Language::Spanish;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.00";
|
||||
|
||||
@DoW = qw(domingo lunes martes mi<6D>rcoles jueves viernes s<>bado);
|
||||
@MoY = qw(enero febrero marzo abril mayo junio
|
||||
julio agosto septiembre octubre noviembre diciembre);
|
||||
@DoWs = map { substr($_,0,3) } @DoW;
|
||||
@MoYs = map { substr($_,0,3) } @MoY;
|
||||
@AMPM = qw(AM PM);
|
||||
|
||||
@Dsuf = ((qw(ro do ro to to to mo vo no mo)) x 3, 'ro');
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,41 @@
|
||||
##
|
||||
## Swedish tables
|
||||
## Contributed by Matthew Musgrove <muskrat@mindless.com>
|
||||
## Corrected by dempa
|
||||
##
|
||||
|
||||
package Date::Language::Swedish;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.01";
|
||||
|
||||
@MoY = qw(januari februari mars april maj juni juli augusti september oktober november december);
|
||||
@MoYs = map { substr($_,0,3) } @MoY;
|
||||
@DoW = map($_ . "dagen", qw(s<EFBFBD>n m<>n tis ons tors fre l<>r));
|
||||
@DoWs = map { substr($_,0,2) } @DoW;
|
||||
|
||||
# the ordinals are not typically used in modern times
|
||||
@Dsuf = ('a' x 2, 'e' x 29);
|
||||
|
||||
use Date::Language::English ();
|
||||
@AMPM = @{Date::Language::English::AMPM};
|
||||
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,58 @@
|
||||
##
|
||||
## Tigrinya tables
|
||||
##
|
||||
|
||||
package Date::Language::Tigrinya;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.00";
|
||||
|
||||
@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);
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,93 @@
|
||||
##
|
||||
## Tigrinya-Eritrean tables
|
||||
##
|
||||
|
||||
package Date::Language::TigrinyaEritrean;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.00";
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,93 @@
|
||||
##
|
||||
## Tigrinya-Ethiopian tables
|
||||
##
|
||||
|
||||
package Date::Language::TigrinyaEthiopian;
|
||||
|
||||
use Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.00";
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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;
|
||||
@@ -0,0 +1,59 @@
|
||||
#----------------------------------------------------#
|
||||
#
|
||||
# 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 Date::Language ();
|
||||
use vars qw(@ISA @DoW @DoWs @MoY @MoYs @AMPM @Dsuf %MoY %DoW $VERSION %DsufMAP);
|
||||
@ISA = qw(Date::Language);
|
||||
$VERSION = "1.0";
|
||||
|
||||
@DoW = qw(Pazar Pazartesi Sal<61> <20>ar<61>amba Per<65>embe Cuma Cumartesi);
|
||||
@MoY = qw(Ocak <20>ubat Mart Nisan May<61>s Haziran Temmuz A<>ustos Eyl<79>l Ekim Kas<61>m Aral<61>k);
|
||||
@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
|
||||
@MoYs = map { substr($_,0,3) } @MoY;
|
||||
@AMPM = ('',''); # no am-pm thingy
|
||||
|
||||
# not easy as in english... maybe we can just use a dot "." ? :)
|
||||
%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 {$_ => '<27>nc<6E>', $_+10 => '<27>nc<6E>', $_+20 => '<27>nc<6E>' } 3,4 ),
|
||||
(map {$_ => 'uncu', $_+10 => 'uncu', $_+20 => 'uncu' } 9 ),
|
||||
(map {$_ => 'nc<6E>', $_+10 => 'nc<6E>', $_+20 => 'nc<6E>' } 6 ),
|
||||
(map {$_ => 'uncu', } 10,30 ),
|
||||
20 => 'nci',
|
||||
31 => 'inci',
|
||||
);
|
||||
|
||||
@Dsuf = map{ $DsufMAP{$_} } sort {$a <=> $b} keys %DsufMAP;
|
||||
@MoY{@MoY} = (0 .. scalar(@MoY));
|
||||
@MoY{@MoYs} = (0 .. scalar(@MoYs));
|
||||
@DoW{@DoW} = (0 .. scalar(@DoW));
|
||||
@DoW{@DoWs} = (0 .. scalar(@DoWs));
|
||||
|
||||
# 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__
|
||||
388
gitportable/usr/share/perl5/vendor_perl/Date/Parse.pm
Normal file
388
gitportable/usr/share/perl5/vendor_perl/Date/Parse.pm
Normal file
@@ -0,0 +1,388 @@
|
||||
# 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 vars qw($VERSION @ISA @EXPORT);
|
||||
use Time::Local;
|
||||
use Carp;
|
||||
use Time::Zone;
|
||||
use Exporter;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(&strtotime &str2time &strptime);
|
||||
|
||||
$VERSION = "2.33";
|
||||
|
||||
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/,/ /g;
|
||||
$dtstr =~ s#($daypat)\s*(den\s)?\b# #o;
|
||||
# Time: 12:00 or 12:00:00 with optional am/pm
|
||||
|
||||
return unless $dtstr =~ /\S/;
|
||||
|
||||
if ($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);
|
||||
}
|
||||
|
||||
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,$day) = ($month{$1},$2);
|
||||
}
|
||||
elsif ($dtstr =~ s#($monpat)([\/-])(\d+)[\/-]# #o) {
|
||||
($month,$day) = ($month{$1},$3);
|
||||
}
|
||||
|
||||
# Date: 961212
|
||||
|
||||
elsif ($dtstr =~ s#\s(\d\d)(\d\d)(\d\d)\s# #o) {
|
||||
($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 > 1900) {
|
||||
$century = int($year / 100);
|
||||
$year -= 1900;
|
||||
}
|
||||
|
||||
$zone += 3600 if defined $zone && $dst;
|
||||
$ss += "0.$frac" if $frac;
|
||||
|
||||
return ($ss,$mm,$hh,$day,$month,$year,$zone,$century);
|
||||
}
|
||||
ESQ
|
||||
|
||||
use vars qw($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 @t = strptime(@_);
|
||||
|
||||
return undef
|
||||
unless @t;
|
||||
|
||||
my($ss,$mm,$hh,$day,$month,$year,$zone, $century) = @t;
|
||||
my @lt = localtime(time);
|
||||
|
||||
$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);
|
||||
|
||||
$year = ($month > $lt[4]) ? ($lt[5] - 1) : $lt[5]
|
||||
unless(defined $year);
|
||||
|
||||
# we were given a 4 digit year, so let's keep using those
|
||||
$year += 1900 if defined $century;
|
||||
|
||||
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";
|
||||
$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]);
|
||||
}
|
||||
|
||||
return $result + $frac;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Date::Parse - Parse date strings into time values
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Date::Parse;
|
||||
|
||||
$time = str2time($date);
|
||||
|
||||
($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])
|
||||
|
||||
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.
|
||||
|
||||
=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. The C<$zone> element
|
||||
is the timezone offset in seconds from GMT. An empty array is returned upon
|
||||
failure.
|
||||
|
||||
=back
|
||||
|
||||
=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
|
||||
1995-01-24T09:08:17.1823213
|
||||
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 LIMITATION
|
||||
|
||||
Date::Parse uses L<Time::Local> internally, so is limited to only parsing dates
|
||||
which result in valid values for Time::Local::timelocal. This generally means dates
|
||||
between 1901-12-17 00:00:00 GMT and 2038-01-16 23:59:59 GMT
|
||||
|
||||
=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.
|
||||
|
||||
=cut
|
||||
|
||||
373
gitportable/usr/share/perl5/vendor_perl/Encode/Locale.pm
Normal file
373
gitportable/usr/share/perl5/vendor_perl/Encode/Locale.pm
Normal 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
gitportable/usr/share/perl5/vendor_perl/Error.pm
Normal file
1196
gitportable/usr/share/perl5/vendor_perl/Error.pm
Normal file
File diff suppressed because it is too large
Load Diff
165
gitportable/usr/share/perl5/vendor_perl/Error/Simple.pm
Normal file
165
gitportable/usr/share/perl5/vendor_perl/Error/Simple.pm
Normal 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
|
||||
622
gitportable/usr/share/perl5/vendor_perl/File/Listing.pm
Normal file
622
gitportable/usr/share/perl5/vendor_perl/File/Listing.pm
Normal file
@@ -0,0 +1,622 @@
|
||||
package File::Listing;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp ();
|
||||
use HTTP::Date qw(str2time);
|
||||
use Exporter 5.57 qw( import );
|
||||
|
||||
# ABSTRACT: Parse directory listing
|
||||
our $VERSION = '6.16'; # VERSION
|
||||
|
||||
sub Version { $File::Listing::VERSION; }
|
||||
|
||||
our @EXPORT = qw(parse_dir);
|
||||
|
||||
sub parse_dir ($;$$$)
|
||||
{
|
||||
my($dir, $tz, $fstype, $error) = @_;
|
||||
|
||||
$fstype ||= 'unix';
|
||||
$fstype = "File::Listing::" . lc $fstype;
|
||||
|
||||
my @args = $_[0];
|
||||
push(@args, $tz) if(@_ >= 2);
|
||||
push(@args, $error) if(@_ >= 4);
|
||||
|
||||
$fstype->parse(@args);
|
||||
}
|
||||
|
||||
|
||||
sub line { Carp::croak("Not implemented yet"); }
|
||||
sub init { } # Dummy sub
|
||||
|
||||
|
||||
sub file_mode ($)
|
||||
{
|
||||
Carp::croak("Input to file_mode() must be a 10 character string.")
|
||||
unless length($_[0]) == 10;
|
||||
|
||||
# This routine was originally borrowed from Graham Barr's
|
||||
# Net::FTP package.
|
||||
|
||||
local $_ = shift;
|
||||
my $mode = 0;
|
||||
my($type);
|
||||
|
||||
s/^(.)// and $type = $1;
|
||||
|
||||
# When the set-group-ID bit (file mode bit 02000) is set, and the group
|
||||
# execution bit (file mode bit 00020) is unset, and it is a regular file,
|
||||
# some implementations of `ls' use the letter `S', others use `l' or `L'.
|
||||
# Convert this `S'.
|
||||
|
||||
s/[Ll](...)$/S$1/;
|
||||
|
||||
while (/(.)/g) {
|
||||
$mode <<= 1;
|
||||
$mode |= 1 if $1 ne "-" &&
|
||||
$1 ne "*" &&
|
||||
$1 ne 'S' &&
|
||||
$1 ne 'T';
|
||||
}
|
||||
|
||||
$mode |= 0004000 if /^..s....../i;
|
||||
$mode |= 0002000 if /^.....s.../i;
|
||||
$mode |= 0001000 if /^........t/i;
|
||||
|
||||
# De facto standard definitions. From 'stat.h' on Solaris 9.
|
||||
|
||||
$type eq "p" and $mode |= 0010000 or # fifo
|
||||
$type eq "c" and $mode |= 0020000 or # character special
|
||||
$type eq "d" and $mode |= 0040000 or # directory
|
||||
$type eq "b" and $mode |= 0060000 or # block special
|
||||
$type eq "-" and $mode |= 0100000 or # regular
|
||||
$type eq "l" and $mode |= 0120000 or # symbolic link
|
||||
$type eq "s" and $mode |= 0140000 or # socket
|
||||
$type eq "D" and $mode |= 0150000 or # door
|
||||
Carp::croak("Unknown file type: $type");
|
||||
|
||||
$mode;
|
||||
}
|
||||
|
||||
|
||||
sub parse
|
||||
{
|
||||
my($pkg, $dir, $tz, $error) = @_;
|
||||
|
||||
# First let's try to determine what kind of dir parameter we have
|
||||
# received. We allow both listings, reference to arrays and
|
||||
# file handles to read from.
|
||||
|
||||
if (ref($dir) eq 'ARRAY') {
|
||||
# Already split up
|
||||
}
|
||||
elsif (ref($dir) eq 'GLOB') {
|
||||
# A file handle
|
||||
}
|
||||
elsif (ref($dir)) {
|
||||
Carp::croak("Illegal argument to parse_dir()");
|
||||
}
|
||||
elsif ($dir =~ /^\*\w+(::\w+)+$/) {
|
||||
# This scalar looks like a file handle, so we assume it is
|
||||
}
|
||||
else {
|
||||
# A normal scalar listing
|
||||
$dir = [ split(/\n/, $dir) ];
|
||||
}
|
||||
|
||||
$pkg->init();
|
||||
|
||||
my @files = ();
|
||||
if (ref($dir) eq 'ARRAY') {
|
||||
for (@$dir) {
|
||||
push(@files, $pkg->line($_, $tz, $error));
|
||||
}
|
||||
}
|
||||
else {
|
||||
local($_);
|
||||
while (my $line = <$dir>) {
|
||||
chomp $line;
|
||||
push(@files, $pkg->line($line, $tz, $error));
|
||||
}
|
||||
}
|
||||
wantarray ? @files : \@files; ## no critic (Community::Wantarray)
|
||||
}
|
||||
|
||||
|
||||
|
||||
package File::Listing::unix;
|
||||
|
||||
use HTTP::Date qw(str2time);
|
||||
|
||||
our @ISA = qw(File::Listing);
|
||||
|
||||
# A place to remember current directory from last line parsed.
|
||||
our $curdir;
|
||||
|
||||
sub init
|
||||
{
|
||||
$curdir = '';
|
||||
}
|
||||
|
||||
|
||||
sub line
|
||||
{
|
||||
shift; # package name
|
||||
local($_) = shift;
|
||||
my($tz, $error) = @_;
|
||||
|
||||
s/\015//g;
|
||||
#study;
|
||||
|
||||
my ($kind, $size, $date, $name);
|
||||
if (($kind, $size, $date, $name) =
|
||||
/^([\-\*FlrwxsStTdD]{10}) # Type and permission bits
|
||||
.* # Graps
|
||||
\D(\d+) # File size
|
||||
\s+ # Some space
|
||||
(\w{3}\s+\d+\s+(?:\d{1,2}:\d{2}|\d{4})|\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2}) # Date
|
||||
\s+ # Some more space
|
||||
(.*)$ # File name
|
||||
/x )
|
||||
|
||||
{
|
||||
return if $name eq '.' || $name eq '..';
|
||||
$name = "$curdir/$name" if length $curdir;
|
||||
my $type = '?';
|
||||
if ($kind =~ /^l/ && $name =~ /(.*) -> (.*)/ ) {
|
||||
$name = $1;
|
||||
$type = "l $2";
|
||||
}
|
||||
elsif ($kind =~ /^[\-F]/) { # (hopefully) a regular file
|
||||
$type = 'f';
|
||||
}
|
||||
elsif ($kind =~ /^[dD]/) {
|
||||
$type = 'd';
|
||||
$size = undef; # Don't believe the reported size
|
||||
}
|
||||
return [$name, $type, $size, str2time($date, $tz),
|
||||
File::Listing::file_mode($kind)];
|
||||
|
||||
}
|
||||
elsif (/^(.+):$/ && !/^[dcbsp].*\s.*\s.*:$/ ) {
|
||||
my $dir = $1;
|
||||
return () if $dir eq '.';
|
||||
$curdir = $dir;
|
||||
return ();
|
||||
}
|
||||
elsif (/^[Tt]otal\s+(\d+)$/ || /^\s*$/) {
|
||||
return ();
|
||||
}
|
||||
elsif (/not found/ || # OSF1, HPUX, and SunOS return
|
||||
# "$file not found"
|
||||
/No such file/ || # IRIX returns
|
||||
# "UX:ls: ERROR: Cannot access $file: No such file or directory"
|
||||
# Solaris returns
|
||||
# "$file: No such file or directory"
|
||||
/cannot find/ # Windows NT returns
|
||||
# "The system cannot find the path specified."
|
||||
) {
|
||||
return () unless defined $error;
|
||||
&$error($_) if ref($error) eq 'CODE';
|
||||
warn "Error: $_\n" if $error eq 'warn';
|
||||
return ();
|
||||
}
|
||||
elsif ($_ eq '') { # AIX, and Linux return nothing
|
||||
return () unless defined $error;
|
||||
&$error("No such file or directory") if ref($error) eq 'CODE';
|
||||
warn "Warning: No such file or directory\n" if $error eq 'warn';
|
||||
return ();
|
||||
}
|
||||
else {
|
||||
# parse failed, check if the dosftp parse understands it
|
||||
File::Listing::dosftp->init();
|
||||
return(File::Listing::dosftp->line($_,$tz,$error));
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
package File::Listing::dosftp;
|
||||
|
||||
use HTTP::Date qw(str2time);
|
||||
|
||||
our @ISA = qw(File::Listing);
|
||||
|
||||
# A place to remember current directory from last line parsed.
|
||||
our $curdir;
|
||||
|
||||
|
||||
|
||||
sub init
|
||||
{
|
||||
$curdir = '';
|
||||
}
|
||||
|
||||
|
||||
sub line
|
||||
{
|
||||
shift; # package name
|
||||
local($_) = shift;
|
||||
my($tz, $error) = @_;
|
||||
|
||||
s/\015//g;
|
||||
|
||||
my ($date, $size_or_dir, $name, $size);
|
||||
|
||||
# usual format:
|
||||
# 02-05-96 10:48AM 1415 src.slf
|
||||
# 09-10-96 09:18AM <DIR> sl_util
|
||||
# alternative dos format with four-digit year:
|
||||
# 02-05-2022 10:48AM 1415 src.slf
|
||||
# 09-10-2022 09:18AM <DIR> sl_util
|
||||
if (($date, $size_or_dir, $name) =
|
||||
/^(\d\d-\d\d-\d{2,4}\s+\d\d:\d\d\wM) # Date and time info
|
||||
\s+ # Some space
|
||||
(<\w{3}>|\d+) # Dir or Size
|
||||
\s+ # Some more space
|
||||
(.+)$ # File name
|
||||
/x )
|
||||
{
|
||||
return if $name eq '.' || $name eq '..';
|
||||
$name = "$curdir/$name" if length $curdir;
|
||||
my $type = '?';
|
||||
if ($size_or_dir eq '<DIR>') {
|
||||
$type = "d";
|
||||
$size = ""; # directories have no size in the pc listing
|
||||
}
|
||||
else {
|
||||
$type = 'f';
|
||||
$size = $size_or_dir;
|
||||
}
|
||||
return [$name, $type, $size, str2time($date, $tz), undef];
|
||||
}
|
||||
else {
|
||||
return () unless defined $error;
|
||||
&$error($_) if ref($error) eq 'CODE';
|
||||
warn "Can't parse: $_\n" if $error eq 'warn';
|
||||
return ();
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
package File::Listing::vms;
|
||||
our @ISA = qw(File::Listing);
|
||||
|
||||
package File::Listing::netware;
|
||||
our @ISA = qw(File::Listing);
|
||||
|
||||
|
||||
|
||||
package File::Listing::apache;
|
||||
|
||||
our @ISA = qw(File::Listing);
|
||||
|
||||
|
||||
sub init { }
|
||||
|
||||
|
||||
sub line {
|
||||
shift; # package name
|
||||
local($_) = shift;
|
||||
my($tz, $error) = @_; # ignored for now...
|
||||
|
||||
s!</?t[rd][^>]*>! !g; # clean away various table stuff
|
||||
if (m!<A\s+HREF=\"([^?\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) {
|
||||
my($filename, $filesize) = ($1, $7);
|
||||
my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6);
|
||||
if ($m =~ /^\d+$/) {
|
||||
($d,$y) = ($y,$d) # iso date
|
||||
}
|
||||
else {
|
||||
$m = _monthabbrev_number($m);
|
||||
}
|
||||
|
||||
$filesize = 0 if $filesize eq '-';
|
||||
if ($filesize =~ s/k$//i) {
|
||||
$filesize *= 1024;
|
||||
}
|
||||
elsif ($filesize =~ s/M$//) {
|
||||
$filesize *= 1024*1024;
|
||||
}
|
||||
elsif ($filesize =~ s/G$//) {
|
||||
$filesize *= 1024*1024*1024;
|
||||
}
|
||||
$filesize = int $filesize;
|
||||
|
||||
require Time::Local;
|
||||
my $filetime = Time::Local::timelocal(0,$M,$H,$d,$m-1,_guess_year($y));
|
||||
my $filetype = ($filename =~ s|/$|| ? "d" : "f");
|
||||
return [$filename, $filetype, $filesize, $filetime, undef];
|
||||
}
|
||||
|
||||
# the default listing doesn't include timestamps or file sizes
|
||||
# but we don't want to grab navigation links, so we ignore links
|
||||
# that have a non-trailing slash / character or ?
|
||||
elsif(m!<A\s+HREF=\"([^?/\"]+/?)\">.*</A>!i) {
|
||||
my $filename = $1;
|
||||
my $filetype = ($filename =~ s|/$|| ? "d" : "f");
|
||||
return [$filename, $filetype, undef, undef, undef];
|
||||
}
|
||||
|
||||
return ();
|
||||
}
|
||||
|
||||
|
||||
sub _guess_year {
|
||||
my $y = shift;
|
||||
|
||||
# if the year is already four digit then we shouldn't do
|
||||
# anything to modify it.
|
||||
if ($y >= 1900) {
|
||||
# do nothing
|
||||
|
||||
# TODO: for hysterical er historical reasons we assume 9x is in the
|
||||
# 1990s we should probably not do that, but I don't have any examples
|
||||
# where apache provides two digit dates so I am leaving this as-is
|
||||
# for now. Possibly the right thing is to not handle two digit years.
|
||||
} elsif ($y >= 90) {
|
||||
$y = 1900+$y;
|
||||
}
|
||||
|
||||
# TODO: likewise assuming 00-89 are 20xx is long term probably wrong.
|
||||
elsif ($y < 100) {
|
||||
$y = 2000+$y;
|
||||
}
|
||||
$y;
|
||||
}
|
||||
|
||||
|
||||
sub _monthabbrev_number {
|
||||
my $mon = shift;
|
||||
+{'Jan' => 1,
|
||||
'Feb' => 2,
|
||||
'Mar' => 3,
|
||||
'Apr' => 4,
|
||||
'May' => 5,
|
||||
'Jun' => 6,
|
||||
'Jul' => 7,
|
||||
'Aug' => 8,
|
||||
'Sep' => 9,
|
||||
'Oct' => 10,
|
||||
'Nov' => 11,
|
||||
'Dec' => 12,
|
||||
}->{$mon};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Listing - Parse directory listing
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 6.16
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Listing qw(parse_dir);
|
||||
$ENV{LANG} = "C"; # dates in non-English locales not supported
|
||||
foreach my $file (parse_dir(`ls -l`)) {
|
||||
my ($name, $type, $size, $mtime, $mode) = @$file;
|
||||
next if $type ne 'f'; # plain file
|
||||
#...
|
||||
}
|
||||
|
||||
# directory listing can also be read from a file
|
||||
open my $listing, "zcat ls-lR.gz|";
|
||||
$dir = parse_dir($listing, '+0000');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module exports a single function called C<parse_dir>, which can be
|
||||
used to parse directory listings.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 parse_dir
|
||||
|
||||
my $dir = parse_dir( $listing );
|
||||
my $dir = parse_dir( $listing, $time_zone );
|
||||
my $dir = parse_dir( $listing, $time_zone, $type );
|
||||
my $dir = parse_dir( $listing, $time_zone, $type, $error );
|
||||
my @files = parse_dir( $listing );
|
||||
my @files = parse_dir( $listing, $time_zone );
|
||||
my @files = parse_dir( $listing, $time_zone, $type );
|
||||
my @files = parse_dir( $listing, $time_zone, $type, $error );
|
||||
|
||||
The first parameter (C<$listing>) is the directory listing to parse.
|
||||
It can be a scalar, a reference to an array of directory lines or a
|
||||
glob representing a filehandle to read the directory listing from.
|
||||
|
||||
The second parameter (C<$time_zone>) is the time zone to use when
|
||||
parsing time stamps in the listing. If this value is undefined,
|
||||
then the local time zone is assumed.
|
||||
|
||||
The third parameter (C<$type>) is the type of listing to assume.
|
||||
Currently supported formats are C<'unix'>, C<'apache'> and
|
||||
C<'dosftp'>. The default value is C<'unix'>. Ideally, the listing
|
||||
type should be determined automatically.
|
||||
|
||||
The fourth parameter (C<$error>) specifies how unparseable lines
|
||||
should be treated. Values can be C<'ignore'>, C<'warn'> or a code reference.
|
||||
Warn means that the perl warn() function will be called. If a code
|
||||
reference is passed, then this routine will be called and the return
|
||||
value from it will be incorporated in the listing. The default is
|
||||
C<'ignore'>.
|
||||
|
||||
Only the first parameter is mandatory.
|
||||
|
||||
# list context
|
||||
foreach my $file (parse_dir($listing)) {
|
||||
my($name, $type, $size, $mtime, $mode) = @$file;
|
||||
}
|
||||
|
||||
# scalar context
|
||||
my $dir = parse_dir($listing);
|
||||
foreach my $file (@$dir) {
|
||||
my($name, $type, $size, $mtime, $mode) = @$file;
|
||||
}
|
||||
|
||||
The return value from parse_dir() is a list of directory entries.
|
||||
In a scalar context the return value is a reference to the list.
|
||||
The directory entries are represented by an array consisting of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item name
|
||||
|
||||
The name of the file.
|
||||
|
||||
=item type
|
||||
|
||||
One of: C<f> file, C<d> directory, C<l> symlink, C<?> unknown.
|
||||
|
||||
=item size
|
||||
|
||||
The size of the file.
|
||||
|
||||
=item time
|
||||
|
||||
The number of seconds since January 1, 1970.
|
||||
|
||||
=item mode
|
||||
|
||||
Bitmask a la the mode returned by C<stat>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<File::Listing::Ftpcopy>
|
||||
|
||||
Provides the same interface but uses XS and the parser implementation from C<ftpcopy>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Original author: Gisle Aas
|
||||
|
||||
Current maintainer: Graham Ollis E<lt>plicease@cpan.orgE<gt>
|
||||
|
||||
Contributors:
|
||||
|
||||
Adam Kennedy
|
||||
|
||||
Adam Sjogren
|
||||
|
||||
Alex Kapranoff
|
||||
|
||||
Alexey Tourbin
|
||||
|
||||
Andreas J. Koenig
|
||||
|
||||
Bill Mann
|
||||
|
||||
Bron Gondwana
|
||||
|
||||
DAVIDRW
|
||||
|
||||
Daniel Hedlund
|
||||
|
||||
David E. Wheeler
|
||||
|
||||
David Steinbrunner
|
||||
|
||||
Erik Esterer
|
||||
|
||||
FWILES
|
||||
|
||||
Father Chrysostomos
|
||||
|
||||
Gavin Peters
|
||||
|
||||
Graeme Thompson
|
||||
|
||||
Grant Street Group
|
||||
|
||||
Hans-H. Froehlich
|
||||
|
||||
Ian Kilgore
|
||||
|
||||
Jacob J
|
||||
|
||||
Mark Stosberg
|
||||
|
||||
Mike Schilli
|
||||
|
||||
Ondrej Hanak
|
||||
|
||||
Peter John Acklam
|
||||
|
||||
Peter Rabbitson
|
||||
|
||||
Robert Stone
|
||||
|
||||
Rolf Grossmann
|
||||
|
||||
Sean M. Burke
|
||||
|
||||
Simon Legner
|
||||
|
||||
Slaven Rezic
|
||||
|
||||
Spiros Denaxas
|
||||
|
||||
Steve Hay
|
||||
|
||||
Todd Lipcon
|
||||
|
||||
Tom Hukins
|
||||
|
||||
Tony Finch
|
||||
|
||||
Toru Yamaguchi
|
||||
|
||||
Ville Skyttä
|
||||
|
||||
Yuri Karaban
|
||||
|
||||
Zefram
|
||||
|
||||
amire80
|
||||
|
||||
jefflee
|
||||
|
||||
john9art
|
||||
|
||||
mschilli
|
||||
|
||||
murphy
|
||||
|
||||
phrstbrn
|
||||
|
||||
ruff
|
||||
|
||||
sasao
|
||||
|
||||
uid39246
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 1996-2022 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
|
||||
463
gitportable/usr/share/perl5/vendor_perl/HTML/Tagset.pm
Normal file
463
gitportable/usr/share/perl5/vendor_perl/HTML/Tagset.pm
Normal file
@@ -0,0 +1,463 @@
|
||||
package HTML::Tagset;
|
||||
|
||||
use strict;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTML::Tagset - data tables useful in parsing HTML
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 3.24
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.24';
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use HTML::Tagset;
|
||||
# Then use any of the items in the HTML::Tagset package
|
||||
# as need arises
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module contains several data tables useful in various kinds of
|
||||
HTML parsing operations.
|
||||
|
||||
Note that all tag names used are lowercase.
|
||||
|
||||
In the following documentation, a "hashset" is a hash being used as a
|
||||
set -- the hash conveys that its keys are there, and the actual values
|
||||
associated with the keys are not significant. (But what values are
|
||||
there, are always true.)
|
||||
|
||||
=head1 VARIABLES
|
||||
|
||||
Note that none of these variables are exported.
|
||||
|
||||
=head2 hashset %HTML::Tagset::emptyElement
|
||||
|
||||
This hashset has as values the tag-names (GIs) of elements that cannot
|
||||
have content. (For example, "base", "br", "hr".) So
|
||||
C<$HTML::Tagset::emptyElement{'hr'}> exists and is true.
|
||||
C<$HTML::Tagset::emptyElement{'dl'}> does not exist, and so is not true.
|
||||
|
||||
=cut
|
||||
|
||||
our %emptyElement = map { $_ => 1 } qw(
|
||||
base link meta isindex
|
||||
img br hr wbr
|
||||
input area param
|
||||
embed bgsound spacer
|
||||
basefont col frame
|
||||
~comment ~literal
|
||||
~declaration ~pi
|
||||
);
|
||||
# The "~"-initial names are for pseudo-elements used by HTML::Entities
|
||||
# and TreeBuilder
|
||||
|
||||
=head2 hashset %HTML::Tagset::optionalEndTag
|
||||
|
||||
This hashset lists tag-names for elements that can have content, but whose
|
||||
end-tags are generally, "safely", omissible. Example:
|
||||
C<$HTML::Tagset::emptyElement{'li'}> exists and is true.
|
||||
|
||||
=cut
|
||||
|
||||
our %optionalEndTag = map { $_ => 1 } qw(
|
||||
p li dt dd
|
||||
); # option th tr td);
|
||||
|
||||
=head2 hash %HTML::Tagset::linkElements
|
||||
|
||||
Values in this hash are tagnames for elements that might contain
|
||||
links, and the value for each is a reference to an array of the names
|
||||
of attributes whose values can be links.
|
||||
|
||||
=cut
|
||||
|
||||
our %linkElements =
|
||||
(
|
||||
'a' => ['href'],
|
||||
'applet' => ['archive', 'codebase', 'code'],
|
||||
'area' => ['href'],
|
||||
'base' => ['href'],
|
||||
'bgsound' => ['src'],
|
||||
'blockquote' => ['cite'],
|
||||
'body' => ['background'],
|
||||
'del' => ['cite'],
|
||||
'embed' => ['pluginspage', 'src'],
|
||||
'form' => ['action'],
|
||||
'frame' => ['src', 'longdesc'],
|
||||
'iframe' => ['src', 'longdesc'],
|
||||
'ilayer' => ['background'],
|
||||
'img' => ['src', 'lowsrc', 'longdesc', 'usemap'],
|
||||
'input' => ['src', 'usemap'],
|
||||
'ins' => ['cite'],
|
||||
'isindex' => ['action'],
|
||||
'head' => ['profile'],
|
||||
'layer' => ['background', 'src'],
|
||||
'link' => ['href'],
|
||||
'object' => ['classid', 'codebase', 'data', 'archive', 'usemap'],
|
||||
'q' => ['cite'],
|
||||
'script' => ['src', 'for'],
|
||||
'table' => ['background'],
|
||||
'td' => ['background'],
|
||||
'th' => ['background'],
|
||||
'tr' => ['background'],
|
||||
'xmp' => ['href'],
|
||||
);
|
||||
|
||||
=head2 hash %HTML::Tagset::boolean_attr
|
||||
|
||||
This hash (not hashset) lists what attributes of what elements can be
|
||||
printed without showing the value (for example, the "noshade" attribute
|
||||
of "hr" elements). For elements with only one such attribute, its value
|
||||
is simply that attribute name. For elements with many such attributes,
|
||||
the value is a reference to a hashset containing all such attributes.
|
||||
|
||||
=cut
|
||||
|
||||
our %boolean_attr = (
|
||||
# TODO: make these all hashes
|
||||
'area' => 'nohref',
|
||||
'dir' => 'compact',
|
||||
'dl' => 'compact',
|
||||
'hr' => 'noshade',
|
||||
'img' => 'ismap',
|
||||
'input' => { 'checked' => 1, 'readonly' => 1, 'disabled' => 1 },
|
||||
'menu' => 'compact',
|
||||
'ol' => 'compact',
|
||||
'option' => 'selected',
|
||||
'select' => 'multiple',
|
||||
'td' => 'nowrap',
|
||||
'th' => 'nowrap',
|
||||
'ul' => 'compact',
|
||||
);
|
||||
|
||||
#==========================================================================
|
||||
# List of all elements from Extensible HTML version 1.0 Transitional DTD:
|
||||
#
|
||||
# a abbr acronym address applet area b base basefont bdo big
|
||||
# blockquote body br button caption center cite code col colgroup
|
||||
# dd del dfn dir div dl dt em fieldset font form h1 h2 h3 h4 h5 h6
|
||||
# head hr html i iframe img input ins isindex kbd label legend li
|
||||
# link map menu meta noframes noscript object ol optgroup option p
|
||||
# param pre q s samp script select small span strike strong style
|
||||
# sub sup table tbody td textarea tfoot th thead title tr tt u ul
|
||||
# var
|
||||
#
|
||||
# Varia from Mozilla source internal table of tags:
|
||||
# Implemented:
|
||||
# xmp listing wbr nobr frame frameset noframes ilayer
|
||||
# layer nolayer spacer embed multicol
|
||||
# But these are unimplemented:
|
||||
# sound?? keygen?? server??
|
||||
# Also seen here and there:
|
||||
# marquee?? app?? (both unimplemented)
|
||||
#==========================================================================
|
||||
|
||||
=head2 hashset %HTML::Tagset::isPhraseMarkup
|
||||
|
||||
This hashset contains all phrasal-level elements.
|
||||
|
||||
=cut
|
||||
|
||||
our %isPhraseMarkup = map { $_ => 1 } qw(
|
||||
span abbr acronym q sub sup
|
||||
cite code em kbd samp strong var dfn strike
|
||||
b i u s tt small big
|
||||
ins del
|
||||
a img br
|
||||
wbr nobr blink
|
||||
font basefont bdo
|
||||
spacer embed noembed
|
||||
); # had: center, hr, table
|
||||
|
||||
|
||||
=head2 hashset %HTML::Tagset::is_Possible_Strict_P_Content
|
||||
|
||||
This hashset contains all phrasal-level elements that be content of a
|
||||
P element, for a strict model of HTML.
|
||||
|
||||
=cut
|
||||
|
||||
our %isFormElement; # Forward declaration
|
||||
our %is_Possible_Strict_P_Content = (
|
||||
%isPhraseMarkup,
|
||||
%isFormElement,
|
||||
map {; $_ => 1} qw( object script map )
|
||||
# I've no idea why there's these latter exceptions.
|
||||
# I'm just following the HTML4.01 DTD.
|
||||
);
|
||||
|
||||
#from html4 strict:
|
||||
#<!ENTITY % fontstyle "TT | I | B | BIG | SMALL">
|
||||
#
|
||||
#<!ENTITY % phrase "EM | STRONG | DFN | CODE |
|
||||
# SAMP | KBD | VAR | CITE | ABBR | ACRONYM" >
|
||||
#
|
||||
#<!ENTITY % special
|
||||
# "A | IMG | OBJECT | BR | SCRIPT | MAP | Q | SUB | SUP | SPAN | BDO">
|
||||
#
|
||||
#<!ENTITY % formctrl "INPUT | SELECT | TEXTAREA | LABEL | BUTTON">
|
||||
#
|
||||
#<!-- %inline; covers inline or "text-level" elements -->
|
||||
#<!ENTITY % inline "#PCDATA | %fontstyle; | %phrase; | %special; | %formctrl;">
|
||||
|
||||
=head2 hashset %HTML::Tagset::isHeadElement
|
||||
|
||||
This hashset contains all elements that elements that should be
|
||||
present only in the 'head' element of an HTML document.
|
||||
|
||||
=cut
|
||||
|
||||
our %isHeadElement = map { $_ => 1 }
|
||||
qw(title base link meta isindex script style object bgsound);
|
||||
|
||||
=head2 hashset %HTML::Tagset::isList
|
||||
|
||||
This hashset contains all elements that can contain "li" elements.
|
||||
|
||||
=cut
|
||||
|
||||
our %isList = map { $_ => 1 } qw(
|
||||
ul ol dir menu
|
||||
);
|
||||
|
||||
=head2 hashset %HTML::Tagset::isTableElement
|
||||
|
||||
This hashset contains all elements that are to be found only in/under
|
||||
a "table" element.
|
||||
|
||||
=cut
|
||||
|
||||
our %isTableElement = map { $_ => 1 }
|
||||
qw(tr td th thead tbody tfoot caption col colgroup);
|
||||
|
||||
=head2 hashset %HTML::Tagset::isFormElement
|
||||
|
||||
This hashset contains all elements that are to be found only in/under
|
||||
a "form" element.
|
||||
|
||||
=cut
|
||||
|
||||
# Declared earlier in the file
|
||||
%isFormElement = map { $_ => 1 }
|
||||
qw(input select option optgroup textarea button label);
|
||||
|
||||
=head2 hashset %HTML::Tagset::isBodyElement
|
||||
|
||||
This hashset contains all elements that are to be found only in/under
|
||||
the "body" element of an HTML document.
|
||||
|
||||
=cut
|
||||
|
||||
our %isBodyElement = map { $_ => 1 } qw(
|
||||
h1 h2 h3 h4 h5 h6
|
||||
p div pre plaintext address blockquote
|
||||
xmp listing
|
||||
center
|
||||
|
||||
multicol
|
||||
iframe ilayer nolayer
|
||||
bgsound
|
||||
|
||||
hr
|
||||
ol ul dir menu li
|
||||
dl dt dd
|
||||
ins del
|
||||
|
||||
fieldset legend
|
||||
|
||||
map area
|
||||
applet param object
|
||||
isindex script noscript
|
||||
table
|
||||
center
|
||||
form
|
||||
),
|
||||
keys %isFormElement,
|
||||
keys %isPhraseMarkup, # And everything phrasal
|
||||
keys %isTableElement,
|
||||
;
|
||||
|
||||
|
||||
=head2 hashset %HTML::Tagset::isHeadOrBodyElement
|
||||
|
||||
This hashset includes all elements that I notice can fall either in
|
||||
the head or in the body.
|
||||
|
||||
=cut
|
||||
|
||||
our %isHeadOrBodyElement = map { $_ => 1 }
|
||||
qw(script isindex style object map area param noscript bgsound);
|
||||
# i.e., if we find 'script' in the 'body' or the 'head', don't freak out.
|
||||
|
||||
|
||||
=head2 hashset %HTML::Tagset::isKnown
|
||||
|
||||
This hashset lists all known HTML elements.
|
||||
|
||||
=cut
|
||||
|
||||
our %isKnown = (%isHeadElement, %isBodyElement,
|
||||
map{ $_ => 1 }
|
||||
qw( head body html
|
||||
frame frameset noframes
|
||||
~comment ~pi ~directive ~literal
|
||||
));
|
||||
# that should be all known tags ever ever
|
||||
|
||||
|
||||
=head2 hashset %HTML::Tagset::canTighten
|
||||
|
||||
This hashset lists elements that might have ignorable whitespace as
|
||||
children or siblings.
|
||||
|
||||
=cut
|
||||
|
||||
our %canTighten = %isKnown;
|
||||
delete @canTighten{
|
||||
keys(%isPhraseMarkup), 'input', 'select',
|
||||
'xmp', 'listing', 'plaintext', 'pre',
|
||||
};
|
||||
# xmp, listing, plaintext, and pre are untightenable, and
|
||||
# in a really special way.
|
||||
@canTighten{'hr','br'} = (1,1);
|
||||
# exceptional 'phrasal' things that ARE subject to tightening.
|
||||
|
||||
# The one case where I can think of my tightening rules failing is:
|
||||
# <p>foo bar<center> <em>baz quux</em> ...
|
||||
# ^-- that would get deleted.
|
||||
# But that's pretty gruesome code anyhow. You gets what you pays for.
|
||||
|
||||
#==========================================================================
|
||||
|
||||
=head2 array @HTML::Tagset::p_closure_barriers
|
||||
|
||||
This array has a meaning that I have only seen a need for in
|
||||
C<HTML::TreeBuilder>, but I include it here on the off chance that someone
|
||||
might find it of use:
|
||||
|
||||
When we see a "E<lt>pE<gt>" token, we go lookup up the lineage for a p
|
||||
element we might have to minimize. At first sight, we might say that
|
||||
if there's a p anywhere in the lineage of this new p, it should be
|
||||
closed. But that's wrong. Consider this document:
|
||||
|
||||
<html>
|
||||
<head>
|
||||
<title>foo</title>
|
||||
</head>
|
||||
<body>
|
||||
<p>foo
|
||||
<table>
|
||||
<tr>
|
||||
<td>
|
||||
foo
|
||||
<p>bar
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
</p>
|
||||
</body>
|
||||
</html>
|
||||
|
||||
The second p is quite legally inside a much higher p.
|
||||
|
||||
My formalization of the reason why this is legal, but this:
|
||||
|
||||
<p>foo<p>bar</p></p>
|
||||
|
||||
isn't, is that something about the table constitutes a "barrier" to
|
||||
the application of the rule about what p must minimize.
|
||||
|
||||
So C<@HTML::Tagset::p_closure_barriers> is the list of all such
|
||||
barrier-tags.
|
||||
|
||||
=cut
|
||||
|
||||
our @p_closure_barriers = qw(
|
||||
li blockquote
|
||||
ul ol menu dir
|
||||
dl dt dd
|
||||
td th tr table caption
|
||||
div
|
||||
);
|
||||
|
||||
# In an ideal world (i.e., XHTML) we wouldn't have to bother with any of this
|
||||
# monkey business of barriers to minimization!
|
||||
|
||||
=head2 hashset %isCDATA_Parent
|
||||
|
||||
This hashset includes all elements whose content is CDATA.
|
||||
|
||||
=cut
|
||||
|
||||
our %isCDATA_Parent = map { $_ => 1 }
|
||||
qw(script style xmp listing plaintext);
|
||||
|
||||
# TODO: there's nothing else that takes CDATA children, right?
|
||||
|
||||
# As the HTML3 DTD (Raggett 1995-04-24) noted:
|
||||
# The XMP, LISTING and PLAINTEXT tags are incompatible with SGML
|
||||
# and derive from very early versions of HTML. They require non-
|
||||
# standard parsers and will cause problems for processing
|
||||
# documents with standard SGML tools.
|
||||
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
You may find it useful to alter the behavior of modules (like
|
||||
C<HTML::Element> or C<HTML::TreeBuilder>) that use C<HTML::Tagset>'s
|
||||
data tables by altering the data tables themselves. You are welcome
|
||||
to try, but be careful; and be aware that different modules may or may
|
||||
react differently to the data tables being changed.
|
||||
|
||||
Note that it may be inappropriate to use these tables for I<producing>
|
||||
HTML -- for example, C<%isHeadOrBodyElement> lists the tagnames
|
||||
for all elements that can appear either in the head or in the body,
|
||||
such as "script". That doesn't mean that I am saying your code that
|
||||
produces HTML should feel free to put script elements in either place!
|
||||
If you are producing programs that spit out HTML, you should be
|
||||
I<intimately> familiar with the DTDs for HTML or XHTML (available at
|
||||
C<http://www.w3.org/>), and you should slavishly obey them, not
|
||||
the data tables in this document.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<HTML::Element>, L<HTML::TreeBuilder>, L<HTML::LinkExtor>
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright 1995-2000 Gisle Aas.
|
||||
|
||||
Copyright 2000-2005 Sean M. Burke.
|
||||
|
||||
Copyright 2005-2024 Andy Lester.
|
||||
|
||||
This library is free software; you can redistribute it and/or modify it
|
||||
under the terms of the Artistic License version 2.0.
|
||||
|
||||
=head1 ACKNOWLEDGEMENTS
|
||||
|
||||
Most of the code/data in this module was adapted from code written
|
||||
by Gisle Aas for C<HTML::Element>, C<HTML::TreeBuilder>, and
|
||||
C<HTML::LinkExtor>. Then it was maintained by Sean M. Burke.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Current maintainer: Andy Lester, C<< <andy at petdance.com> >>
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests to
|
||||
C<bug-html-tagset at rt.cpan.org>, or through the web interface at
|
||||
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=HTML-Tagset>. I will
|
||||
be notified, and then you'll automatically be notified of progress on
|
||||
your bug as I make changes.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
458
gitportable/usr/share/perl5/vendor_perl/HTTP/Config.pm
Normal file
458
gitportable/usr/share/perl5/vendor_perl/HTTP/Config.pm
Normal file
@@ -0,0 +1,458 @@
|
||||
package HTTP::Config;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '7.00';
|
||||
|
||||
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.00
|
||||
|
||||
=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
|
||||
|
||||
658
gitportable/usr/share/perl5/vendor_perl/HTTP/CookieJar.pm
Normal file
658
gitportable/usr/share/perl5/vendor_perl/HTTP/CookieJar.pm
Normal file
@@ -0,0 +1,658 @@
|
||||
use 5.008001;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package HTTP::CookieJar;
|
||||
# ABSTRACT: A minimalist HTTP user agent cookie jar
|
||||
our $VERSION = '0.014';
|
||||
|
||||
use Carp ();
|
||||
use HTTP::Date ();
|
||||
|
||||
my $HAS_MPS = eval { require Mozilla::PublicSuffix; 1 };
|
||||
|
||||
#pod =construct new
|
||||
#pod
|
||||
#pod my $jar = HTTP::CookieJar->new;
|
||||
#pod
|
||||
#pod Return a new, empty cookie jar
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
bless { store => {} }, $class;
|
||||
}
|
||||
|
||||
#pod =method add
|
||||
#pod
|
||||
#pod $jar->add(
|
||||
#pod "http://www.example.com/", "lang=en-US; Path=/; Domain=example.com"
|
||||
#pod );
|
||||
#pod
|
||||
#pod Given a request URL and a C<Set-Cookie> header string, attempts to adds the
|
||||
#pod cookie to the jar. If the cookie is expired, instead it deletes any matching
|
||||
#pod cookie from the jar. A C<Max-Age> attribute will be converted to an absolute
|
||||
#pod C<Expires> attribute.
|
||||
#pod
|
||||
#pod It will throw an exception if the request URL is missing or invalid. Returns true if
|
||||
#pod successful cookie processing or undef/empty-list on failure.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub add {
|
||||
my ( $self, $request, $cookie ) = @_;
|
||||
return unless defined $cookie and length $cookie;
|
||||
my ( $scheme, $host, $port, $request_path ) = eval { _split_url($request) };
|
||||
Carp::croak($@) if $@;
|
||||
|
||||
return unless my $parse = _parse_cookie($cookie);
|
||||
my $name = $parse->{name};
|
||||
|
||||
# check and normalize domain
|
||||
if ( exists $parse->{domain} ) {
|
||||
_normalize_domain( $host, $parse ) or return;
|
||||
}
|
||||
else {
|
||||
$parse->{domain} = $host;
|
||||
$parse->{hostonly} = 1;
|
||||
}
|
||||
my $domain = $parse->{domain};
|
||||
|
||||
# normalize path
|
||||
if ( !exists $parse->{path} || substr( $parse->{path}, 0, 1 ) ne "/" ) {
|
||||
$parse->{path} = _default_path($request_path);
|
||||
}
|
||||
my $path = $parse->{path};
|
||||
# set timestamps and normalize expires
|
||||
my $now = $parse->{creation_time} = $parse->{last_access_time} = time;
|
||||
if ( exists $parse->{'max-age'} ) {
|
||||
# "If delta-seconds is less than or equal to zero (0), let expiry-time
|
||||
# be the earliest representable date and time."
|
||||
$parse->{expires} = $parse->{'max-age'} <= 0
|
||||
? 0
|
||||
: $now + $parse->{'max-age'};
|
||||
delete $parse->{'max-age'};
|
||||
}
|
||||
# update creation time from old cookie, if exists
|
||||
if ( my $old = $self->{store}{$domain}{$path}{$name} ) {
|
||||
$parse->{creation_time} = $old->{creation_time};
|
||||
}
|
||||
# if cookie has expired, purge any old matching cookie, too
|
||||
if ( defined $parse->{expires} && $parse->{expires} < $now ) {
|
||||
delete $self->{store}{$domain}{$path}{$name};
|
||||
}
|
||||
else {
|
||||
$self->{store}{$domain}{$path}{$name} = $parse;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
#pod =method clear
|
||||
#pod
|
||||
#pod $jar->clear
|
||||
#pod
|
||||
#pod Empties the cookie jar.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub clear {
|
||||
my ($self) = @_;
|
||||
$self->{store} = {};
|
||||
return 1;
|
||||
}
|
||||
|
||||
#pod =method cookies_for
|
||||
#pod
|
||||
#pod my @cookies = $jar->cookies_for("http://www.example.com/foo/bar");
|
||||
#pod
|
||||
#pod Given a request URL, returns a list of hash references representing cookies
|
||||
#pod that should be sent. The hash references are copies -- changing values
|
||||
#pod will not change the cookies in the jar.
|
||||
#pod
|
||||
#pod Cookies set C<secure> will only be returned if the request scheme is C<https>.
|
||||
#pod Expired cookies will not be returned.
|
||||
#pod
|
||||
#pod Keys of a cookie hash reference might include:
|
||||
#pod
|
||||
#pod =for :list
|
||||
#pod * name -- the name of the cookie
|
||||
#pod * value -- the value of the cookie
|
||||
#pod * domain -- the domain name to which the cookie applies
|
||||
#pod * path -- the path to which the cookie applies
|
||||
#pod * expires -- if present, when the cookie expires in epoch seconds
|
||||
#pod * secure -- if present, the cookie was set C<Secure>
|
||||
#pod * httponly -- if present, the cookie was set C<HttpOnly>
|
||||
#pod * hostonly -- if present, the cookie may only be used with the domain as a host
|
||||
#pod * creation_time -- epoch time when the cookie was first stored
|
||||
#pod * last_access_time -- epoch time when the cookie was last accessed (i.e. "now")
|
||||
#pod
|
||||
#pod Keep in mind that C<httponly> means it should only be used in requests and not
|
||||
#pod made available via Javascript, etc. This is pretty meaningless for Perl user
|
||||
#pod agents.
|
||||
#pod
|
||||
#pod Generally, user agents should use the C<cookie_header> method instead.
|
||||
#pod
|
||||
#pod It will throw an exception if the request URL is missing or invalid.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub cookies_for {
|
||||
my ( $self, $request ) = @_;
|
||||
my @found = $self->_cookies_for($request);
|
||||
return map { {%$_} } @found;
|
||||
}
|
||||
|
||||
# _cookies_for returns originals, not copies, which helps in testing
|
||||
sub _cookies_for {
|
||||
my ( $self, $request ) = @_;
|
||||
my ( $scheme, $host, $port, $request_path ) = eval { _split_url($request) };
|
||||
Carp::croak($@) if $@;
|
||||
|
||||
my @found;
|
||||
my $now = time;
|
||||
for my $cookie ( $self->_all_cookies ) {
|
||||
next if $cookie->{hostonly} && $host ne $cookie->{domain};
|
||||
next if $cookie->{secure} && $scheme ne 'https';
|
||||
next if defined( $cookie->{expires} ) && $cookie->{expires} < $now;
|
||||
next unless _domain_match( $host, $cookie->{domain} );
|
||||
next unless _path_match( $request_path, $cookie->{path} );
|
||||
$cookie->{last_access_time} = time;
|
||||
push @found, $cookie;
|
||||
}
|
||||
@found = sort {
|
||||
length( $b->{path} ) <=> length( $a->{path} )
|
||||
|| $a->{creation_time} <=> $b->{creation_time}
|
||||
} @found;
|
||||
return @found;
|
||||
}
|
||||
|
||||
#pod =method cookie_header
|
||||
#pod
|
||||
#pod my $header = $jar->cookie_header("http://www.example.com/foo/bar");
|
||||
#pod
|
||||
#pod Given a request URL, returns a correctly-formatted string with all relevant
|
||||
#pod cookies for the request. This string is ready to be used in a C<Cookie> header
|
||||
#pod in an HTTP request. E.g.:
|
||||
#pod
|
||||
#pod SID=31d4d96e407aad42; lang=en-US
|
||||
#pod
|
||||
#pod It follows the same exclusion rules as C<cookies_for>.
|
||||
#pod
|
||||
#pod If the request is invalid or no cookies apply, it will return an empty string.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub cookie_header {
|
||||
my ( $self, $req ) = @_;
|
||||
return join( "; ", map { "$_->{name}=$_->{value}" } $self->cookies_for($req) );
|
||||
}
|
||||
|
||||
#pod =method dump_cookies
|
||||
#pod
|
||||
#pod my @list = $jar->dump_cookies;
|
||||
#pod my @list = $jar->dump_cookies( { persistent => 1 } );
|
||||
#pod
|
||||
#pod Returns a list of raw cookies in string form. The strings resemble what
|
||||
#pod would be received from C<Set-Cookie> headers, but with additional internal
|
||||
#pod fields. The list is only intended for use with C<load_cookies> to allow
|
||||
#pod cookie jar persistence.
|
||||
#pod
|
||||
#pod If a hash reference with a true C<persistent> key is given as an argument,
|
||||
#pod cookies without an C<Expires> time (i.e. "session cookies") will be omitted.
|
||||
#pod
|
||||
#pod Here is a trivial example of saving a cookie jar file with L<Path::Tiny>:
|
||||
#pod
|
||||
#pod path("jar.txt")->spew( join "\n", $jar->dump_cookies );
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub dump_cookies {
|
||||
my ( $self, $args ) = @_;
|
||||
my @list;
|
||||
for my $c ( $self->_all_cookies ) {
|
||||
my @parts = "$c->{name}=$c->{value}";
|
||||
if ( defined $c->{expires} ) {
|
||||
push @parts, 'Expires=' . HTTP::Date::time2str( $c->{expires} );
|
||||
}
|
||||
else {
|
||||
next if $args->{persistent};
|
||||
}
|
||||
for my $attr (qw/Domain Path Creation_Time Last_Access_Time/) {
|
||||
push @parts, "$attr=$c->{lc $attr}" if defined $c->{ lc $attr };
|
||||
}
|
||||
for my $attr (qw/Secure HttpOnly HostOnly/) {
|
||||
push @parts, $attr if $c->{ lc $attr };
|
||||
}
|
||||
push @list, join( "; ", @parts );
|
||||
}
|
||||
return @list;
|
||||
}
|
||||
|
||||
#pod =method load_cookies
|
||||
#pod
|
||||
#pod $jar->load_cookies( @cookies );
|
||||
#pod
|
||||
#pod Given a list of cookie strings from C<dump_cookies>, it adds them to
|
||||
#pod the cookie jar. Cookies added in this way will supersede any existing
|
||||
#pod cookies with similar domain, path and name.
|
||||
#pod
|
||||
#pod It returns the jar object for convenience when loading a new object:
|
||||
#pod
|
||||
#pod my $jar = HTTP::CookieJar->new->load_cookies( @cookies );
|
||||
#pod
|
||||
#pod Here is a trivial example of loading a cookie jar file with L<Path::Tiny>:
|
||||
#pod
|
||||
#pod my $jar = HTTP::CookieJar->new->load_cookies(
|
||||
#pod path("jar.txt")->lines
|
||||
#pod );
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub load_cookies {
|
||||
my ( $self, @cookies ) = @_;
|
||||
for my $cookie (@cookies) {
|
||||
my $p = _parse_cookie( $cookie, 1 );
|
||||
next unless exists $p->{domain} && exists $p->{path};
|
||||
$p->{$_} = time for grep { !defined $p->{$_} } qw/creation_time last_access_time/;
|
||||
$self->{store}{ $p->{domain} }{ $p->{path} }{ $p->{name} } = $p;
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# private methods
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
# return flattened list of all cookies
|
||||
sub _all_cookies {
|
||||
return map { values %$_ } map { values %$_ } values %{ $_[0]->{store} };
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# Helper subroutines
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
my $pub_re = qr/(?:domain|path|expires|max-age|httponly|secure)/;
|
||||
my $pvt_re = qr/(?:$pub_re|creation_time|last_access_time|hostonly)/;
|
||||
|
||||
sub _parse_cookie {
|
||||
my ( $cookie, $private ) = @_;
|
||||
$cookie = '' unless defined $cookie;
|
||||
my ( $kvp, @attrs ) = split /;/, $cookie;
|
||||
$kvp = '' unless defined $kvp;
|
||||
my ( $name, $value ) =
|
||||
map { s/^\s*//; s/\s*$//; $_ } split( /=/, $kvp, 2 ); ## no critic
|
||||
|
||||
return unless defined $name and length $name;
|
||||
$value = '' unless defined $value;
|
||||
my $parse = { name => $name, value => $value };
|
||||
for my $s (@attrs) {
|
||||
next unless defined $s && $s =~ /\S/;
|
||||
my ( $k, $v ) = map { s/^\s*//; s/\s*$//; $_ } split( /=/, $s, 2 ); ## no critic
|
||||
$k = lc $k;
|
||||
next unless $private ? ( $k =~ m/^$pvt_re$/ ) : ( $k =~ m/^$pub_re$/ );
|
||||
$v = 1 if $k =~ m/^(?:httponly|secure|hostonly)$/; # boolean flag if present
|
||||
$v = HTTP::Date::str2time($v) || 0 if $k eq 'expires'; # convert to epoch
|
||||
next unless length $v;
|
||||
$v =~ s{^\.}{} if $k eq 'domain'; # strip leading dot
|
||||
$v =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if $k eq 'path'; # unescape
|
||||
$parse->{$k} = $v;
|
||||
}
|
||||
return $parse;
|
||||
}
|
||||
|
||||
sub _domain_match {
|
||||
my ( $string, $dom_string ) = @_;
|
||||
return 1 if $dom_string eq $string;
|
||||
return unless $string =~ /[a-z]/i; # non-numeric
|
||||
if ( $string =~ s{\Q$dom_string\E$}{} ) {
|
||||
return substr( $string, -1, 1 ) eq '.'; # "foo."
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _normalize_domain {
|
||||
my ( $host, $parse ) = @_;
|
||||
|
||||
if ($HAS_MPS) {
|
||||
my $host_pub_suff = eval { Mozilla::PublicSuffix::public_suffix($host) };
|
||||
$host_pub_suff = '' unless defined $host_pub_suff;
|
||||
if ( _domain_match( $host_pub_suff, $parse->{domain} ) ) {
|
||||
if ( $parse->{domain} eq $host ) {
|
||||
return $parse->{hostonly} = 1;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ( $parse->{domain} !~ m{\.} && $parse->{domain} eq $host ) {
|
||||
return $parse->{hostonly} = 1;
|
||||
}
|
||||
|
||||
return _domain_match( $host, $parse->{domain} );
|
||||
}
|
||||
|
||||
sub _default_path {
|
||||
my ($path) = @_;
|
||||
return "/" if !length $path || substr( $path, 0, 1 ) ne "/";
|
||||
my ($default) = $path =~ m{^(.*)/}; # greedy to last /
|
||||
return length($default) ? $default : "/";
|
||||
}
|
||||
|
||||
sub _path_match {
|
||||
my ( $req_path, $cookie_path ) = @_;
|
||||
return 1 if $req_path eq $cookie_path;
|
||||
if ( $req_path =~ m{^\Q$cookie_path\E(.*)} ) {
|
||||
my $rest = $1;
|
||||
return 1 if substr( $cookie_path, -1, 1 ) eq '/';
|
||||
return 1 if substr( $rest, 0, 1 ) eq '/';
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _split_url {
|
||||
my $url = shift;
|
||||
die(qq/No URL provided\n/) unless defined $url and length $url;
|
||||
|
||||
# URI regex adapted from the URI module
|
||||
# XXX path_query here really chops at ? or # to get just the path and not the query
|
||||
my ( $scheme, $authority, $path_query ) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#?]*)>
|
||||
or die(qq/Cannot parse URL: '$url'\n/);
|
||||
|
||||
$scheme = lc $scheme;
|
||||
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
|
||||
$path_query =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
|
||||
|
||||
my $host = ( length($authority) ) ? lc $authority : 'localhost';
|
||||
$host =~ s/\A[^@]*@//; # userinfo
|
||||
my $port = do {
|
||||
$host =~ s/:([0-9]*)\z// && length $1
|
||||
? $1
|
||||
: ( $scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef );
|
||||
};
|
||||
|
||||
return ( $scheme, $host, $port, $path_query );
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
# vim: ts=4 sts=4 sw=4 et:
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTTP::CookieJar - A minimalist HTTP user agent cookie jar
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.014
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use HTTP::CookieJar;
|
||||
|
||||
my $jar = HTTP::CookieJar->new;
|
||||
|
||||
# add cookie received from a request
|
||||
$jar->add( "http://www.example.com/", "CUSTOMER=WILE_E_COYOTE; Path=/; Domain=example.com" );
|
||||
|
||||
# extract cookie header for a given request
|
||||
my $cookie = $jar->cookie_header( "http://www.example.com/" );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module implements a minimalist HTTP user agent cookie jar in
|
||||
conformance with L<RFC 6265|http://tools.ietf.org/html/rfc6265>.
|
||||
|
||||
Unlike the commonly used L<HTTP::Cookies> module, this module does
|
||||
not require use of L<HTTP::Request> and L<HTTP::Response> objects.
|
||||
An LWP-compatible adapter is available as L<HTTP::CookieJar::LWP>.
|
||||
|
||||
=head1 CONSTRUCTORS
|
||||
|
||||
=head2 new
|
||||
|
||||
my $jar = HTTP::CookieJar->new;
|
||||
|
||||
Return a new, empty cookie jar
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 add
|
||||
|
||||
$jar->add(
|
||||
"http://www.example.com/", "lang=en-US; Path=/; Domain=example.com"
|
||||
);
|
||||
|
||||
Given a request URL and a C<Set-Cookie> header string, attempts to adds the
|
||||
cookie to the jar. If the cookie is expired, instead it deletes any matching
|
||||
cookie from the jar. A C<Max-Age> attribute will be converted to an absolute
|
||||
C<Expires> attribute.
|
||||
|
||||
It will throw an exception if the request URL is missing or invalid. Returns true if
|
||||
successful cookie processing or undef/empty-list on failure.
|
||||
|
||||
=head2 clear
|
||||
|
||||
$jar->clear
|
||||
|
||||
Empties the cookie jar.
|
||||
|
||||
=head2 cookies_for
|
||||
|
||||
my @cookies = $jar->cookies_for("http://www.example.com/foo/bar");
|
||||
|
||||
Given a request URL, returns a list of hash references representing cookies
|
||||
that should be sent. The hash references are copies -- changing values
|
||||
will not change the cookies in the jar.
|
||||
|
||||
Cookies set C<secure> will only be returned if the request scheme is C<https>.
|
||||
Expired cookies will not be returned.
|
||||
|
||||
Keys of a cookie hash reference might include:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
name -- the name of the cookie
|
||||
|
||||
=item *
|
||||
|
||||
value -- the value of the cookie
|
||||
|
||||
=item *
|
||||
|
||||
domain -- the domain name to which the cookie applies
|
||||
|
||||
=item *
|
||||
|
||||
path -- the path to which the cookie applies
|
||||
|
||||
=item *
|
||||
|
||||
expires -- if present, when the cookie expires in epoch seconds
|
||||
|
||||
=item *
|
||||
|
||||
secure -- if present, the cookie was set C<Secure>
|
||||
|
||||
=item *
|
||||
|
||||
httponly -- if present, the cookie was set C<HttpOnly>
|
||||
|
||||
=item *
|
||||
|
||||
hostonly -- if present, the cookie may only be used with the domain as a host
|
||||
|
||||
=item *
|
||||
|
||||
creation_time -- epoch time when the cookie was first stored
|
||||
|
||||
=item *
|
||||
|
||||
last_access_time -- epoch time when the cookie was last accessed (i.e. "now")
|
||||
|
||||
=back
|
||||
|
||||
Keep in mind that C<httponly> means it should only be used in requests and not
|
||||
made available via Javascript, etc. This is pretty meaningless for Perl user
|
||||
agents.
|
||||
|
||||
Generally, user agents should use the C<cookie_header> method instead.
|
||||
|
||||
It will throw an exception if the request URL is missing or invalid.
|
||||
|
||||
=head2 cookie_header
|
||||
|
||||
my $header = $jar->cookie_header("http://www.example.com/foo/bar");
|
||||
|
||||
Given a request URL, returns a correctly-formatted string with all relevant
|
||||
cookies for the request. This string is ready to be used in a C<Cookie> header
|
||||
in an HTTP request. E.g.:
|
||||
|
||||
SID=31d4d96e407aad42; lang=en-US
|
||||
|
||||
It follows the same exclusion rules as C<cookies_for>.
|
||||
|
||||
If the request is invalid or no cookies apply, it will return an empty string.
|
||||
|
||||
=head2 dump_cookies
|
||||
|
||||
my @list = $jar->dump_cookies;
|
||||
my @list = $jar->dump_cookies( { persistent => 1 } );
|
||||
|
||||
Returns a list of raw cookies in string form. The strings resemble what
|
||||
would be received from C<Set-Cookie> headers, but with additional internal
|
||||
fields. The list is only intended for use with C<load_cookies> to allow
|
||||
cookie jar persistence.
|
||||
|
||||
If a hash reference with a true C<persistent> key is given as an argument,
|
||||
cookies without an C<Expires> time (i.e. "session cookies") will be omitted.
|
||||
|
||||
Here is a trivial example of saving a cookie jar file with L<Path::Tiny>:
|
||||
|
||||
path("jar.txt")->spew( join "\n", $jar->dump_cookies );
|
||||
|
||||
=head2 load_cookies
|
||||
|
||||
$jar->load_cookies( @cookies );
|
||||
|
||||
Given a list of cookie strings from C<dump_cookies>, it adds them to
|
||||
the cookie jar. Cookies added in this way will supersede any existing
|
||||
cookies with similar domain, path and name.
|
||||
|
||||
It returns the jar object for convenience when loading a new object:
|
||||
|
||||
my $jar = HTTP::CookieJar->new->load_cookies( @cookies );
|
||||
|
||||
Here is a trivial example of loading a cookie jar file with L<Path::Tiny>:
|
||||
|
||||
my $jar = HTTP::CookieJar->new->load_cookies(
|
||||
path("jar.txt")->lines
|
||||
);
|
||||
|
||||
=for Pod::Coverage method_names_here
|
||||
|
||||
=head1 LIMITATIONS AND CAVEATS
|
||||
|
||||
=head2 RFC 6265 vs prior standards
|
||||
|
||||
This modules adheres as closely as possible to the user-agent rules
|
||||
of RFC 6265. Therefore, it does not handle nor generate C<Set-Cookie2>
|
||||
and C<Cookie2> headers, implement C<.local> suffixes, or do path/domain
|
||||
matching in accord with prior RFC's.
|
||||
|
||||
=head2 Internationalized domain names
|
||||
|
||||
Internationalized domain names given in requests must be properly
|
||||
encoded in ASCII form.
|
||||
|
||||
=head2 Public suffixes
|
||||
|
||||
If L<Mozilla::PublicSuffix> is installed, cookie domains will be checked
|
||||
against the public suffix list. Public suffix cookies are only allowed
|
||||
as host-only cookies.
|
||||
|
||||
=head2 Third-party cookies
|
||||
|
||||
According to RFC 6265, a cookie may be accepted only if has no C<Domain>
|
||||
attribute (in which case it is "host-only") or if the C<Domain> attribute is a
|
||||
suffix of the request URL. This effectively prohibits Site A from setting a
|
||||
cookie for unrelated Site B, which is one potential third-party cookie vector.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
L<HTTP::Cookies>
|
||||
|
||||
=item *
|
||||
|
||||
L<Mojo::UserAgent::CookieJar>
|
||||
|
||||
=back
|
||||
|
||||
=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
=head2 Bugs / Feature Requests
|
||||
|
||||
Please report any bugs or feature requests through the issue tracker
|
||||
at L<https://github.com/dagolden/HTTP-CookieJar/issues>.
|
||||
You will be notified automatically of any progress on your issue.
|
||||
|
||||
=head2 Source Code
|
||||
|
||||
This is open source software. The code repository is available for
|
||||
public review and contribution under the terms of the license.
|
||||
|
||||
L<https://github.com/dagolden/HTTP-CookieJar>
|
||||
|
||||
git clone https://github.com/dagolden/HTTP-CookieJar.git
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
David Golden <dagolden@cpan.org>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
=for stopwords Dan Book David Golden jvolkening
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Dan Book <grinnz@grinnz.com>
|
||||
|
||||
=item *
|
||||
|
||||
David Golden <xdg@xdg.me>
|
||||
|
||||
=item *
|
||||
|
||||
jvolkening <jdv@base2bio.com>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2013 by David Golden.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Apache License, Version 2.0, January 2004
|
||||
|
||||
=cut
|
||||
126
gitportable/usr/share/perl5/vendor_perl/HTTP/CookieJar/LWP.pm
Normal file
126
gitportable/usr/share/perl5/vendor_perl/HTTP/CookieJar/LWP.pm
Normal file
@@ -0,0 +1,126 @@
|
||||
use 5.008001;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
package HTTP::CookieJar::LWP;
|
||||
# ABSTRACT: LWP adapter for HTTP::CookieJar
|
||||
our $VERSION = '0.014';
|
||||
|
||||
use parent 'HTTP::CookieJar';
|
||||
|
||||
sub add_cookie_header {
|
||||
my ( $self, $request ) = @_;
|
||||
|
||||
my $url = _get_url( $request, $request->uri );
|
||||
return unless ( $url->scheme =~ /^https?\z/ );
|
||||
|
||||
my $header = $self->cookie_header($url);
|
||||
$request->header( Cookie => $header );
|
||||
|
||||
return $request;
|
||||
}
|
||||
|
||||
sub extract_cookies {
|
||||
my ( $self, $response ) = @_;
|
||||
|
||||
my $request = $response->request
|
||||
or return;
|
||||
|
||||
my $url = _get_url( $request, $request->uri );
|
||||
|
||||
$self->add( $url, $_ ) for $response->_header("Set-Cookie");
|
||||
|
||||
return $response;
|
||||
}
|
||||
|
||||
#--------------------------------------------------------------------------#
|
||||
# helper subroutines
|
||||
#--------------------------------------------------------------------------#
|
||||
|
||||
sub _get_url {
|
||||
my ( $request, $url ) = @_;
|
||||
my $new_url = $url->clone;
|
||||
if ( my $h = $request->header("Host") ) {
|
||||
$h =~ s/:\d+$//; # might have a port as well
|
||||
$new_url->host($h);
|
||||
}
|
||||
return $new_url;
|
||||
}
|
||||
|
||||
sub _url_path {
|
||||
my $url = shift;
|
||||
my $path;
|
||||
if ( $url->can('epath') ) {
|
||||
$path = $url->epath; # URI::URL method
|
||||
}
|
||||
else {
|
||||
$path = $url->path; # URI::_generic method
|
||||
}
|
||||
$path = "/" unless length $path;
|
||||
$path;
|
||||
}
|
||||
|
||||
sub _normalize_path # so that plain string compare can be used
|
||||
{
|
||||
my $x;
|
||||
$_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
|
||||
$x = uc($1);
|
||||
$x eq "2F" || $x eq "25" ? "%$x" :
|
||||
pack("C", hex($x));
|
||||
/eg;
|
||||
$_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
# vim: ts=4 sts=4 sw=4 et:
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTTP::CookieJar::LWP - LWP adapter for HTTP::CookieJar
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.014
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use LWP::UserAgent;
|
||||
use HTTP::CookieJar::LWP;
|
||||
|
||||
my $ua = LWP::UserAgent->new(
|
||||
cookie_jar => HTTP::CookieJar::LWP->new
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is an experimental adapter to make L<HTTP::CookieJar> work with
|
||||
L<LWP>. It implements the two methods that C<LWP> calls from L<HTTP::Cookies>.
|
||||
|
||||
It is not a general-purpose drop-in replacement for C<HTTP::Cookies> in any
|
||||
other way.
|
||||
|
||||
=for Pod::Coverage method_names_here
|
||||
add_cookie_header
|
||||
extract_cookies
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
David Golden <dagolden@cpan.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2013 by David Golden.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Apache License, Version 2.0, January 2004
|
||||
|
||||
=cut
|
||||
900
gitportable/usr/share/perl5/vendor_perl/HTTP/Cookies.pm
Normal file
900
gitportable/usr/share/perl5/vendor_perl/HTTP/Cookies.pm
Normal file
@@ -0,0 +1,900 @@
|
||||
package HTTP::Cookies;
|
||||
|
||||
use strict;
|
||||
use HTTP::Date qw(str2time parse_date time2str);
|
||||
use HTTP::Headers::Util qw(_split_header_words join_header_words);
|
||||
|
||||
our $EPOCH_OFFSET;
|
||||
our $VERSION = '6.11';
|
||||
|
||||
# Legacy: because "use "HTTP::Cookies" used be the ONLY way
|
||||
# to load the class HTTP::Cookies::Netscape.
|
||||
require HTTP::Cookies::Netscape;
|
||||
|
||||
$EPOCH_OFFSET = 0; # difference from Unix epoch
|
||||
|
||||
# A HTTP::Cookies object is a hash. The main attribute is the
|
||||
# COOKIES 3 level hash: $self->{COOKIES}{$domain}{$path}{$key}.
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my $self = bless {
|
||||
COOKIES => {},
|
||||
}, $class;
|
||||
my %cnf = @_;
|
||||
for (keys %cnf) {
|
||||
$self->{lc($_)} = $cnf{$_};
|
||||
}
|
||||
$self->load;
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub add_cookie_header
|
||||
{
|
||||
my $self = shift;
|
||||
my $request = shift || return;
|
||||
my $url = $request->uri;
|
||||
my $scheme = $url->scheme;
|
||||
unless ($scheme =~ /^https?\z/) {
|
||||
return;
|
||||
}
|
||||
|
||||
my $domain = _host($request, $url);
|
||||
$domain = "$domain.local" unless $domain =~ /\./;
|
||||
my $secure_request = ($scheme eq "https");
|
||||
my $req_path = _url_path($url);
|
||||
my $req_port = $url->port;
|
||||
my $now = time();
|
||||
_normalize_path($req_path) if $req_path =~ /%/;
|
||||
|
||||
my @cval; # cookie values for the "Cookie" header
|
||||
my $set_ver;
|
||||
my $netscape_only = 0; # An exact domain match applies to any cookie
|
||||
|
||||
while ($domain =~ /\./) {
|
||||
# Checking $domain for cookies"
|
||||
my $cookies = $self->{COOKIES}{$domain};
|
||||
next unless $cookies;
|
||||
if ($self->{delayload} && defined($cookies->{'//+delayload'})) {
|
||||
my $cookie_data = $cookies->{'//+delayload'}{'cookie'};
|
||||
delete $self->{COOKIES}{$domain};
|
||||
$self->load_cookie($cookie_data->[1]);
|
||||
$cookies = $self->{COOKIES}{$domain};
|
||||
next unless $cookies; # should not really happen
|
||||
}
|
||||
|
||||
# Want to add cookies corresponding to the most specific paths
|
||||
# first (i.e. longest path first)
|
||||
my $path;
|
||||
for $path (sort {length($b) <=> length($a) } keys %$cookies) {
|
||||
if (index($req_path, $path) != 0) {
|
||||
next;
|
||||
}
|
||||
|
||||
my($key,$array);
|
||||
while (($key,$array) = each %{$cookies->{$path}}) {
|
||||
my($version,$val,$port,$path_spec,$secure,$expires) = @$array;
|
||||
if ($secure && !$secure_request) {
|
||||
next;
|
||||
}
|
||||
if ($expires && $expires < $now) {
|
||||
next;
|
||||
}
|
||||
if ($port) {
|
||||
my $found;
|
||||
if ($port =~ s/^_//) {
|
||||
# The corresponding Set-Cookie attribute was empty
|
||||
$found++ if $port eq $req_port;
|
||||
$port = "";
|
||||
}
|
||||
else {
|
||||
my $p;
|
||||
for $p (split(/,/, $port)) {
|
||||
$found++, last if $p eq $req_port;
|
||||
}
|
||||
}
|
||||
unless ($found) {
|
||||
next;
|
||||
}
|
||||
}
|
||||
if ($version > 0 && $netscape_only) {
|
||||
next;
|
||||
}
|
||||
|
||||
# set version number of cookie header.
|
||||
# XXX: What should it be if multiple matching
|
||||
# Set-Cookie headers have different versions themselves
|
||||
if (!$set_ver++) {
|
||||
if ($version >= 1) {
|
||||
push(@cval, "\$Version=$version");
|
||||
}
|
||||
elsif (!$self->{hide_cookie2}) {
|
||||
$request->header(Cookie2 => '$Version="1"');
|
||||
}
|
||||
}
|
||||
|
||||
# do we need to quote the value
|
||||
if ($val =~ /\W/ && $version) {
|
||||
$val =~ s/([\\\"])/\\$1/g;
|
||||
$val = qq("$val");
|
||||
}
|
||||
|
||||
# and finally remember this cookie
|
||||
push(@cval, "$key=$val");
|
||||
if ($version >= 1) {
|
||||
push(@cval, qq(\$Path="$path")) if $path_spec;
|
||||
push(@cval, qq(\$Domain="$domain")) if $domain =~ /^\./;
|
||||
if (defined $port) {
|
||||
my $p = '$Port';
|
||||
$p .= qq(="$port") if length $port;
|
||||
push(@cval, $p);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
} continue {
|
||||
# Try with a more general domain, alternately stripping
|
||||
# leading name components and leading dots. When this
|
||||
# results in a domain with no leading dot, it is for
|
||||
# Netscape cookie compatibility only:
|
||||
#
|
||||
# a.b.c.net Any cookie
|
||||
# .b.c.net Any cookie
|
||||
# b.c.net Netscape cookie only
|
||||
# .c.net Any cookie
|
||||
|
||||
if ($domain =~ s/^\.+//) {
|
||||
$netscape_only = 1;
|
||||
}
|
||||
else {
|
||||
$domain =~ s/[^.]*//;
|
||||
$netscape_only = 0;
|
||||
}
|
||||
}
|
||||
|
||||
if (@cval) {
|
||||
if (my $old = $request->header("Cookie")) {
|
||||
unshift(@cval, $old);
|
||||
}
|
||||
$request->header(Cookie => join("; ", @cval));
|
||||
if (my $hash = $request->{_http_cookies}) {
|
||||
%$hash = (map split(/=/, $_, 2), @cval);
|
||||
}
|
||||
}
|
||||
|
||||
$request;
|
||||
}
|
||||
|
||||
|
||||
sub get_cookies
|
||||
{
|
||||
my $self = shift;
|
||||
my $url = shift;
|
||||
$url = "https://$url" unless $url =~ m,^[a-zA-Z][a-zA-Z0-9.+\-]*:,;
|
||||
require HTTP::Request;
|
||||
my $req = HTTP::Request->new(GET => $url);
|
||||
my $cookies = $req->{_http_cookies} = {};
|
||||
$self->add_cookie_header($req);
|
||||
if (@_) {
|
||||
return map $cookies->{$_}, @_ if wantarray;
|
||||
return $cookies->{$_[0]};
|
||||
}
|
||||
return $cookies;
|
||||
}
|
||||
|
||||
|
||||
sub extract_cookies
|
||||
{
|
||||
my $self = shift;
|
||||
my $response = shift || return;
|
||||
|
||||
my @set = _split_header_words($response->_header("Set-Cookie2"));
|
||||
my @ns_set = $response->_header("Set-Cookie");
|
||||
|
||||
return $response unless @set || @ns_set; # quick exit
|
||||
|
||||
my $request = $response->request;
|
||||
my $url = $request->uri;
|
||||
my $req_host = _host($request, $url);
|
||||
$req_host = "$req_host.local" unless $req_host =~ /\./;
|
||||
my $req_port = $url->port;
|
||||
my $req_path = _url_path($url);
|
||||
_normalize_path($req_path) if $req_path =~ /%/;
|
||||
|
||||
if (@ns_set) {
|
||||
# The old Netscape cookie format for Set-Cookie
|
||||
# http://curl.haxx.se/rfc/cookie_spec.html
|
||||
# can for instance contain an unquoted "," in the expires
|
||||
# field, so we have to use this ad-hoc parser.
|
||||
my $now = time();
|
||||
|
||||
# Build a hash of cookies that was present in Set-Cookie2
|
||||
# headers. We need to skip them if we also find them in a
|
||||
# Set-Cookie header.
|
||||
my %in_set2;
|
||||
for (@set) {
|
||||
$in_set2{$_->[0]}++;
|
||||
}
|
||||
|
||||
my $set;
|
||||
for $set (@ns_set) {
|
||||
$set =~ s/^\s+//;
|
||||
my @cur;
|
||||
my $param;
|
||||
my $expires;
|
||||
my $first_param = 1;
|
||||
for $param (@{_split_text($set)}) {
|
||||
next unless length($param);
|
||||
my($k,$v) = split(/\s*=\s*/, $param, 2);
|
||||
if (defined $v) {
|
||||
$v =~ s/\s+$//;
|
||||
#print "$k => $v\n";
|
||||
}
|
||||
else {
|
||||
$k =~ s/\s+$//;
|
||||
#print "$k => undef";
|
||||
}
|
||||
if (!$first_param && lc($k) eq "expires") {
|
||||
my $etime = str2time($v);
|
||||
if (defined $etime) {
|
||||
push(@cur, "Max-Age" => $etime - $now);
|
||||
$expires++;
|
||||
}
|
||||
else {
|
||||
# parse_date can deal with years outside the range of time_t,
|
||||
my($year, $mon, $day, $hour, $min, $sec, $tz) = parse_date($v);
|
||||
if ($year) {
|
||||
my $thisyear = (gmtime)[5] + 1900;
|
||||
if ($year < $thisyear) {
|
||||
push(@cur, "Max-Age" => -1); # any negative value will do
|
||||
$expires++;
|
||||
}
|
||||
elsif ($year >= $thisyear + 10) {
|
||||
# the date is at least 10 years into the future, just replace
|
||||
# it with something approximate
|
||||
push(@cur, "Max-Age" => 10 * 365 * 24 * 60 * 60);
|
||||
$expires++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif (!$first_param && lc($k) eq 'max-age') {
|
||||
$expires++;
|
||||
}
|
||||
elsif (!$first_param && lc($k) =~ /^(?:version|discard|ns-cookie)/) {
|
||||
# ignore
|
||||
}
|
||||
else {
|
||||
push(@cur, $k => $v);
|
||||
}
|
||||
$first_param = 0;
|
||||
}
|
||||
next unless @cur;
|
||||
next if $in_set2{$cur[0]};
|
||||
|
||||
# push(@cur, "Port" => $req_port);
|
||||
push(@cur, "Discard" => undef) unless $expires;
|
||||
push(@cur, "Version" => 0);
|
||||
push(@cur, "ns-cookie" => 1);
|
||||
push(@set, \@cur);
|
||||
}
|
||||
}
|
||||
|
||||
SET_COOKIE:
|
||||
for my $set (@set) {
|
||||
next unless @$set >= 2;
|
||||
|
||||
my $key = shift @$set;
|
||||
my $val = shift @$set;
|
||||
|
||||
my %hash;
|
||||
while (@$set) {
|
||||
my $k = shift @$set;
|
||||
my $v = shift @$set;
|
||||
my $lc = lc($k);
|
||||
# don't loose case distinction for unknown fields
|
||||
$k = $lc if $lc =~ /^(?:discard|domain|max-age|
|
||||
path|port|secure|version)$/x;
|
||||
if ($k eq "discard" || $k eq "secure") {
|
||||
$v = 1 unless defined $v;
|
||||
}
|
||||
next if exists $hash{$k}; # only first value is significant
|
||||
$hash{$k} = $v;
|
||||
};
|
||||
|
||||
my %orig_hash = %hash;
|
||||
my $version = delete $hash{version};
|
||||
$version = 1 unless defined($version);
|
||||
my $discard = delete $hash{discard};
|
||||
my $secure = delete $hash{secure};
|
||||
my $maxage = delete $hash{'max-age'};
|
||||
my $ns_cookie = delete $hash{'ns-cookie'};
|
||||
|
||||
# Check domain
|
||||
my $domain = delete $hash{domain};
|
||||
$domain = lc($domain) if defined $domain;
|
||||
if (defined($domain)
|
||||
&& $domain ne $req_host && $domain ne ".$req_host") {
|
||||
if ($domain !~ /\./ && $domain ne "local") {
|
||||
next SET_COOKIE;
|
||||
}
|
||||
$domain = ".$domain" unless $domain =~ /^\./;
|
||||
if ($domain =~ /\.\d+$/) {
|
||||
next SET_COOKIE;
|
||||
}
|
||||
my $len = length($domain);
|
||||
unless (substr($req_host, -$len) eq $domain) {
|
||||
next SET_COOKIE;
|
||||
}
|
||||
my $hostpre = substr($req_host, 0, length($req_host) - $len);
|
||||
if ($hostpre =~ /\./ && !$ns_cookie) {
|
||||
next SET_COOKIE;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$domain = $req_host;
|
||||
}
|
||||
|
||||
my $path = delete $hash{path};
|
||||
my $path_spec;
|
||||
if (defined $path && $path ne '') {
|
||||
$path_spec++;
|
||||
_normalize_path($path) if $path =~ /%/;
|
||||
if (!$ns_cookie &&
|
||||
substr($req_path, 0, length($path)) ne $path) {
|
||||
next SET_COOKIE;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$path = $req_path;
|
||||
$path =~ s,/[^/]*$,,;
|
||||
$path = "/" unless length($path);
|
||||
}
|
||||
|
||||
my $port;
|
||||
if (exists $hash{port}) {
|
||||
$port = delete $hash{port};
|
||||
if (defined $port) {
|
||||
$port =~ s/\s+//g;
|
||||
my $found;
|
||||
for my $p (split(/,/, $port)) {
|
||||
unless ($p =~ /^\d+$/) {
|
||||
next SET_COOKIE;
|
||||
}
|
||||
$found++ if $p eq $req_port;
|
||||
}
|
||||
unless ($found) {
|
||||
next SET_COOKIE;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$port = "_$req_port";
|
||||
}
|
||||
}
|
||||
$self->set_cookie($version,$key,$val,$path,$domain,$port,$path_spec,$secure,$maxage,$discard, \%hash)
|
||||
if $self->set_cookie_ok(\%orig_hash);
|
||||
}
|
||||
|
||||
$response;
|
||||
}
|
||||
|
||||
sub set_cookie_ok
|
||||
{
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
sub set_cookie
|
||||
{
|
||||
my $self = shift;
|
||||
my($version,
|
||||
$key, $val, $path, $domain, $port,
|
||||
$path_spec, $secure, $maxage, $discard, $rest) = @_;
|
||||
|
||||
# path and key can not be empty (key can't start with '$')
|
||||
return $self if !defined($path) || $path !~ m,^/, ||
|
||||
!defined($key) || $key =~ m,^\$,;
|
||||
|
||||
# ensure legal port
|
||||
if (defined $port) {
|
||||
return $self unless $port =~ /^_?\d+(?:,\d+)*$/;
|
||||
}
|
||||
|
||||
my $expires;
|
||||
if (defined $maxage) {
|
||||
if ($maxage <= 0) {
|
||||
delete $self->{COOKIES}{$domain}{$path}{$key};
|
||||
return $self;
|
||||
}
|
||||
$expires = time() + $maxage;
|
||||
}
|
||||
$version = 0 unless defined $version;
|
||||
|
||||
my @array = ($version, $val,$port,
|
||||
$path_spec,
|
||||
$secure, $expires, $discard);
|
||||
push(@array, {%$rest}) if defined($rest) && %$rest;
|
||||
# trim off undefined values at end
|
||||
pop(@array) while !defined $array[-1];
|
||||
|
||||
$self->{COOKIES}{$domain}{$path}{$key} = \@array;
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub save
|
||||
{
|
||||
my $self = shift;
|
||||
my %args = (
|
||||
file => $self->{'file'},
|
||||
ignore_discard => $self->{'ignore_discard'},
|
||||
@_ == 1 ? ( file => $_[0] ) : @_
|
||||
);
|
||||
Carp::croak('Unexpected argument to save method') if keys %args > 2;
|
||||
my $file = $args{'file'} || return;
|
||||
open(my $fh, '>', $file) or die "Can't open $file: $!";
|
||||
print {$fh} "#LWP-Cookies-1.0\n";
|
||||
print {$fh} $self->as_string(!$args{'ignore_discard'});
|
||||
close $fh or die "Can't close $file: $!";
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
sub load
|
||||
{
|
||||
my $self = shift;
|
||||
my $file = shift || $self->{'file'} || return;
|
||||
|
||||
local $/ = "\n"; # make sure we got standard record separator
|
||||
open(my $fh, '<', $file) or return;
|
||||
|
||||
# check that we have the proper header
|
||||
my $magic = <$fh>;
|
||||
chomp $magic;
|
||||
unless ($magic =~ /^#LWP-Cookies-\d+\.\d+/) {
|
||||
warn "$file does not seem to contain cookies";
|
||||
return;
|
||||
}
|
||||
|
||||
# go through the file
|
||||
while (my $line = <$fh>) {
|
||||
chomp $line;
|
||||
next unless $line =~ s/^Set-Cookie3:\s*//;
|
||||
my $cookie;
|
||||
for $cookie (_split_header_words($line)) {
|
||||
my($key,$val) = splice(@$cookie, 0, 2);
|
||||
my %hash;
|
||||
while (@$cookie) {
|
||||
my $k = shift @$cookie;
|
||||
my $v = shift @$cookie;
|
||||
$hash{$k} = $v;
|
||||
}
|
||||
my $version = delete $hash{version};
|
||||
my $path = delete $hash{path};
|
||||
my $domain = delete $hash{domain};
|
||||
my $port = delete $hash{port};
|
||||
my $expires = str2time(delete $hash{expires});
|
||||
|
||||
my $path_spec = exists $hash{path_spec}; delete $hash{path_spec};
|
||||
my $secure = exists $hash{secure}; delete $hash{secure};
|
||||
my $discard = exists $hash{discard}; delete $hash{discard};
|
||||
|
||||
my @array = ($version, $val, $port, $path_spec, $secure, $expires,
|
||||
$discard);
|
||||
push(@array, \%hash) if %hash;
|
||||
$self->{COOKIES}{$domain}{$path}{$key} = \@array;
|
||||
}
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
sub revert
|
||||
{
|
||||
my $self = shift;
|
||||
$self->clear->load;
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub clear
|
||||
{
|
||||
my $self = shift;
|
||||
if (@_ == 0) {
|
||||
$self->{COOKIES} = {};
|
||||
}
|
||||
elsif (@_ == 1) {
|
||||
delete $self->{COOKIES}{$_[0]};
|
||||
}
|
||||
elsif (@_ == 2) {
|
||||
delete $self->{COOKIES}{$_[0]}{$_[1]};
|
||||
}
|
||||
elsif (@_ == 3) {
|
||||
delete $self->{COOKIES}{$_[0]}{$_[1]}{$_[2]};
|
||||
}
|
||||
else {
|
||||
require Carp;
|
||||
Carp::carp('Usage: $c->clear([domain [,path [,key]]])');
|
||||
}
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub clear_temporary_cookies
|
||||
{
|
||||
my($self) = @_;
|
||||
|
||||
$self->scan(sub {
|
||||
if($_[9] or # "Discard" flag set
|
||||
not $_[8]) { # No expire field?
|
||||
$_[8] = -1; # Set the expire/max_age field
|
||||
$self->set_cookie(@_); # Clear the cookie
|
||||
}
|
||||
});
|
||||
}
|
||||
|
||||
|
||||
sub DESTROY
|
||||
{
|
||||
my $self = shift;
|
||||
local($., $@, $!, $^E, $?);
|
||||
$self->save if $self->{'autosave'};
|
||||
}
|
||||
|
||||
|
||||
sub scan
|
||||
{
|
||||
my($self, $cb) = @_;
|
||||
my($domain,$path,$key);
|
||||
for $domain (sort keys %{$self->{COOKIES}}) {
|
||||
for $path (sort keys %{$self->{COOKIES}{$domain}}) {
|
||||
for $key (sort keys %{$self->{COOKIES}{$domain}{$path}}) {
|
||||
my($version,$val,$port,$path_spec,
|
||||
$secure,$expires,$discard,$rest) =
|
||||
@{$self->{COOKIES}{$domain}{$path}{$key}};
|
||||
$rest = {} unless defined($rest);
|
||||
&$cb($version,$key,$val,$path,$domain,$port,
|
||||
$path_spec,$secure,$expires,$discard,$rest);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub as_string
|
||||
{
|
||||
my($self, $skip_discard) = @_;
|
||||
my @res;
|
||||
$self->scan(sub {
|
||||
my($version,$key,$val,$path,$domain,$port,
|
||||
$path_spec,$secure,$expires,$discard,$rest) = @_;
|
||||
return if $discard && $skip_discard;
|
||||
my @h = ($key, $val);
|
||||
push(@h, "path", $path);
|
||||
push(@h, "domain" => $domain);
|
||||
push(@h, "port" => $port) if defined $port;
|
||||
push(@h, "path_spec" => undef) if $path_spec;
|
||||
push(@h, "secure" => undef) if $secure;
|
||||
push(@h, "expires" => HTTP::Date::time2isoz($expires)) if $expires;
|
||||
push(@h, "discard" => undef) if $discard;
|
||||
my $k;
|
||||
for $k (sort keys %$rest) {
|
||||
push(@h, $k, $rest->{$k});
|
||||
}
|
||||
push(@h, "version" => $version);
|
||||
push(@res, "Set-Cookie3: " . join_header_words(\@h));
|
||||
});
|
||||
join("\n", @res, "");
|
||||
}
|
||||
|
||||
sub _host
|
||||
{
|
||||
my($request, $url) = @_;
|
||||
if (my $h = $request->header("Host")) {
|
||||
$h =~ s/:\d+$//; # might have a port as well
|
||||
return lc($h);
|
||||
}
|
||||
return lc($url->host);
|
||||
}
|
||||
|
||||
sub _url_path
|
||||
{
|
||||
my $url = shift;
|
||||
my $path;
|
||||
if($url->can('epath')) {
|
||||
$path = $url->epath; # URI::URL method
|
||||
}
|
||||
else {
|
||||
$path = $url->path; # URI::_generic method
|
||||
}
|
||||
$path = "/" unless length $path;
|
||||
$path;
|
||||
}
|
||||
|
||||
sub _normalize_path # so that plain string compare can be used
|
||||
{
|
||||
my $x;
|
||||
$_[0] =~ s/%([0-9a-fA-F][0-9a-fA-F])/
|
||||
$x = uc($1);
|
||||
$x eq "2F" || $x eq "25" ? "%$x" :
|
||||
pack("C", hex($x));
|
||||
/eg;
|
||||
$_[0] =~ s/([\0-\x20\x7f-\xff])/sprintf("%%%02X",ord($1))/eg;
|
||||
}
|
||||
|
||||
# deals with splitting values by ; and the fact that they could
|
||||
# be in quotes which can also have escaping.
|
||||
sub _split_text {
|
||||
my $val = shift;
|
||||
my @vals = grep { $_ ne q{} } split(/([;\\"])/, $val);
|
||||
my @chunks;
|
||||
# divide it up into chunks to be processed.
|
||||
my $in_string = 0;
|
||||
my @current_string;
|
||||
for(my $i = 0; $i < @vals; $i++) {
|
||||
my $chunk = $vals[$i];
|
||||
if($in_string) {
|
||||
if($chunk eq q{\\}) {
|
||||
# don't care about next char probably.
|
||||
# having said that, probably need to be appending to the chunks
|
||||
# just dropping this.
|
||||
$i++;
|
||||
if($i < @vals) {
|
||||
push @current_string, $vals[$i];
|
||||
}
|
||||
} elsif($chunk eq q{"}) {
|
||||
$in_string = 0;
|
||||
}
|
||||
else {
|
||||
push @current_string, $chunk;
|
||||
}
|
||||
} else {
|
||||
if($chunk eq q{"}) {
|
||||
$in_string = 1;
|
||||
}
|
||||
elsif($chunk eq q{;}) {
|
||||
push @chunks, join(q{}, @current_string);
|
||||
@current_string = ();
|
||||
}
|
||||
else {
|
||||
push @current_string, $chunk;
|
||||
}
|
||||
}
|
||||
}
|
||||
push @chunks, join(q{}, @current_string) if @current_string;
|
||||
s/^\s+// for @chunks;
|
||||
return \@chunks;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTTP::Cookies - HTTP cookie jars
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 6.11
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use HTTP::Cookies;
|
||||
$cookie_jar = HTTP::Cookies->new(
|
||||
file => "$ENV{'HOME'}/lwp_cookies.dat",
|
||||
autosave => 1,
|
||||
);
|
||||
|
||||
use LWP;
|
||||
my $browser = LWP::UserAgent->new;
|
||||
$browser->cookie_jar($cookie_jar);
|
||||
|
||||
Or for an empty and temporary cookie jar:
|
||||
|
||||
use LWP;
|
||||
my $browser = LWP::UserAgent->new;
|
||||
$browser->cookie_jar( {} );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is for objects that represent a "cookie jar" -- that is, a
|
||||
database of all the HTTP cookies that a given LWP::UserAgent object
|
||||
knows about.
|
||||
|
||||
Cookies are a general mechanism which server side connections can use
|
||||
to both store and retrieve information on the client side of the
|
||||
connection. For more information about cookies refer to
|
||||
L<Cookie Spec|http://curl.haxx.se/rfc/cookie_spec.html> and
|
||||
L<Cookie Central|http://www.cookiecentral.com>. This module also implements the
|
||||
new style cookies described in L<RFC 2965|https://tools.ietf.org/html/rfc2965>.
|
||||
The two variants of cookies are supposed to be able to coexist happily.
|
||||
|
||||
Instances of the class I<HTTP::Cookies> are able to store a collection
|
||||
of Set-Cookie2: and Set-Cookie: headers and are able to use this
|
||||
information to initialize Cookie-headers in I<HTTP::Request> objects.
|
||||
The state of a I<HTTP::Cookies> object can be saved in and restored from
|
||||
files.
|
||||
|
||||
=head1 LIMITATIONS
|
||||
|
||||
This module does not support L<< Public Suffix|https://publicsuffix.org/
|
||||
>> encouraged by a more recent standard, L<< RFC
|
||||
6265|https://tools.ietf.org/html/rfc6265 >>.
|
||||
|
||||
This module's shortcomings mean that a malicious Web site can set
|
||||
cookies to track your user agent across all sites under a top level
|
||||
domain. See F<< t/publicsuffix.t >> in this module's distribution for
|
||||
details.
|
||||
|
||||
L<< HTTP::CookieJar::LWP >> supports Public Suffix, but only provides a
|
||||
limited subset of this module's functionality and L<< does not
|
||||
support|HTTP::CookieJar/LIMITATIONS-AND-CAVEATS >> standards older than
|
||||
I<RFC 6265>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
The following methods are provided:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $cookie_jar = HTTP::Cookies->new
|
||||
|
||||
The constructor takes hash style parameters. The following
|
||||
parameters are recognized:
|
||||
|
||||
file: name of the file to restore cookies from and save cookies to
|
||||
autosave: save during destruction (bool)
|
||||
ignore_discard: save even cookies that are requested to be discarded (bool)
|
||||
hide_cookie2: do not add Cookie2 header to requests
|
||||
|
||||
Future parameters might include (not yet implemented):
|
||||
|
||||
max_cookies 300
|
||||
max_cookies_per_domain 20
|
||||
max_cookie_size 4096
|
||||
|
||||
no_cookies list of domain names that we never return cookies to
|
||||
|
||||
=item $cookie_jar->get_cookies( $url_or_domain )
|
||||
|
||||
=item $cookie_jar->get_cookies( $url_or_domain, $cookie_key,... )
|
||||
|
||||
Returns a hash of the cookies that applies to the given URL. If a
|
||||
domainname is given as argument, then a prefix of "https://" is assumed.
|
||||
|
||||
If one or more $cookie_key parameters are provided return the given values,
|
||||
or C<undef> if the cookie isn't available.
|
||||
|
||||
=item $cookie_jar->add_cookie_header( $request )
|
||||
|
||||
The add_cookie_header() method will set the appropriate Cookie:-header
|
||||
for the I<HTTP::Request> object given as argument. The $request must
|
||||
have a valid url attribute before this method is called.
|
||||
|
||||
=item $cookie_jar->extract_cookies( $response )
|
||||
|
||||
The extract_cookies() method will look for Set-Cookie: and
|
||||
Set-Cookie2: headers in the I<HTTP::Response> object passed as
|
||||
argument. Any of these headers that are found are used to update
|
||||
the state of the $cookie_jar.
|
||||
|
||||
=item $cookie_jar->set_cookie( $version, $key, $val, $path, $domain, $port, $path_spec, $secure, $maxage, $discard, \%rest )
|
||||
|
||||
The set_cookie() method updates the state of the $cookie_jar. The
|
||||
$key, $val, $domain, $port and $path arguments are strings. The
|
||||
$path_spec, $secure, $discard arguments are boolean values. The $maxage
|
||||
value is a number indicating number of seconds that this cookie will
|
||||
live. A value of $maxage <= 0 will delete this cookie. The $version argument
|
||||
sets the version of the cookie; the default value is 0 ( original Netscape
|
||||
spec ). Setting $version to another value indicates the RFC to which the
|
||||
cookie conforms (e.g. version 1 for RFC 2109). %rest defines various other
|
||||
attributes like "Comment" and "CommentURL".
|
||||
|
||||
=item $cookie_jar->save
|
||||
|
||||
=item $cookie_jar->save( $file )
|
||||
|
||||
=item $cookie_jar->save( file => $file, ignore_discard => $ignore_discard )
|
||||
|
||||
This method saves the state of the $cookie_jar to a file.
|
||||
The state can then be restored later using the load() method. If a
|
||||
filename is not specified we will use the name specified during
|
||||
construction. If the $ignore_discard value is true (or not specified,
|
||||
but attribute I<ignore_discard> was set at cookie jar construction),
|
||||
then we will even save cookies that are marked to be discarded.
|
||||
|
||||
The default is to save a sequence of "Set-Cookie3" lines.
|
||||
"Set-Cookie3" is a proprietary LWP format, not known to be compatible
|
||||
with any browser. The I<HTTP::Cookies::Netscape> sub-class can
|
||||
be used to save in a format compatible with Netscape.
|
||||
|
||||
=item $cookie_jar->load
|
||||
|
||||
=item $cookie_jar->load( $file )
|
||||
|
||||
This method reads the cookies from the file and adds them to the
|
||||
$cookie_jar. The file must be in the format written by the save()
|
||||
method.
|
||||
|
||||
=item $cookie_jar->revert
|
||||
|
||||
This method empties the $cookie_jar and re-loads the $cookie_jar
|
||||
from the last save file.
|
||||
|
||||
=item $cookie_jar->clear
|
||||
|
||||
=item $cookie_jar->clear( $domain )
|
||||
|
||||
=item $cookie_jar->clear( $domain, $path )
|
||||
|
||||
=item $cookie_jar->clear( $domain, $path, $key )
|
||||
|
||||
Invoking this method without arguments will empty the whole
|
||||
$cookie_jar. If given a single argument only cookies belonging to
|
||||
that domain will be removed. If given two arguments, cookies
|
||||
belonging to the specified path within that domain are removed. If
|
||||
given three arguments, then the cookie with the specified key, path
|
||||
and domain is removed.
|
||||
|
||||
=item $cookie_jar->clear_temporary_cookies
|
||||
|
||||
Discard all temporary cookies. Scans for all cookies in the jar
|
||||
with either no expire field or a true C<discard> flag. To be
|
||||
called when the user agent shuts down according to RFC 2965.
|
||||
|
||||
=item $cookie_jar->scan( \&callback )
|
||||
|
||||
The argument is a subroutine that will be invoked for each cookie
|
||||
stored in the $cookie_jar. The subroutine will be invoked with
|
||||
the following arguments:
|
||||
|
||||
0 version
|
||||
1 key
|
||||
2 val
|
||||
3 path
|
||||
4 domain
|
||||
5 port
|
||||
6 path_spec
|
||||
7 secure
|
||||
8 expires
|
||||
9 discard
|
||||
10 hash
|
||||
|
||||
=item $cookie_jar->as_string
|
||||
|
||||
=item $cookie_jar->as_string( $skip_discardables )
|
||||
|
||||
The as_string() method will return the state of the $cookie_jar
|
||||
represented as a sequence of "Set-Cookie3" header lines separated by
|
||||
"\n". If $skip_discardables is TRUE, it will not return lines for
|
||||
cookies with the I<Discard> attribute.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<HTTP::Cookies::Netscape>, L<HTTP::Cookies::Microsoft>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Gisle Aas <gisle@activestate.com>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2002 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 cookie jars
|
||||
|
||||
@@ -0,0 +1,324 @@
|
||||
package HTTP::Cookies::Microsoft;
|
||||
|
||||
use strict;
|
||||
|
||||
our $VERSION = '6.11';
|
||||
|
||||
require HTTP::Cookies;
|
||||
our @ISA=qw(HTTP::Cookies);
|
||||
|
||||
sub load_cookies_from_file
|
||||
{
|
||||
my ($file) = @_;
|
||||
my @cookies;
|
||||
|
||||
open (my $fh, '<', $file) || return;
|
||||
|
||||
while (my $key = <$fh>) {
|
||||
chomp $key;
|
||||
my ($value, $domain_path, $flags, $lo_expire, $hi_expire);
|
||||
my ($lo_create, $hi_create, $sep);
|
||||
chomp($value = <$fh>);
|
||||
chomp($domain_path= <$fh>);
|
||||
chomp($flags = <$fh>); # 0x0001 bit is for secure
|
||||
chomp($lo_expire = <$fh>);
|
||||
chomp($hi_expire = <$fh>);
|
||||
chomp($lo_create = <$fh>);
|
||||
chomp($hi_create = <$fh>);
|
||||
chomp($sep = <$fh>);
|
||||
|
||||
if (!defined($key) || !defined($value) || !defined($domain_path) ||
|
||||
!defined($flags) || !defined($hi_expire) || !defined($lo_expire) ||
|
||||
!defined($hi_create) || !defined($lo_create) || !defined($sep) ||
|
||||
($sep ne '*'))
|
||||
{
|
||||
last;
|
||||
}
|
||||
|
||||
if ($domain_path =~ /^([^\/]+)(\/.*)$/) {
|
||||
my $domain = $1;
|
||||
my $path = $2;
|
||||
|
||||
push @cookies, {
|
||||
KEY => $key, VALUE => $value, DOMAIN => $domain,
|
||||
PATH => $path, FLAGS =>$flags, HIXP =>$hi_expire,
|
||||
LOXP => $lo_expire, HICREATE => $hi_create,
|
||||
LOCREATE => $lo_create
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
return \@cookies;
|
||||
}
|
||||
|
||||
sub get_user_name
|
||||
{
|
||||
use Win32;
|
||||
use locale;
|
||||
my $user = lc(Win32::LoginName());
|
||||
|
||||
return $user;
|
||||
}
|
||||
|
||||
# MSIE stores create and expire times as Win32 FILETIME,
|
||||
# which is 64 bits of 100 nanosecond intervals since Jan 01 1601
|
||||
#
|
||||
# But Cookies code expects time in 32-bit value expressed
|
||||
# in seconds since Jan 01 1970
|
||||
#
|
||||
sub epoch_time_offset_from_win32_filetime
|
||||
{
|
||||
my ($high, $low) = @_;
|
||||
|
||||
#--------------------------------------------------------
|
||||
# USEFUL CONSTANT
|
||||
#--------------------------------------------------------
|
||||
# 0x019db1de 0xd53e8000 is 1970 Jan 01 00:00:00 in Win32 FILETIME
|
||||
#
|
||||
# 100 nanosecond intervals == 0.1 microsecond intervals
|
||||
|
||||
my $filetime_low32_1970 = 0xd53e8000;
|
||||
my $filetime_high32_1970 = 0x019db1de;
|
||||
|
||||
#------------------------------------
|
||||
# ALGORITHM
|
||||
#------------------------------------
|
||||
# To go from 100 nanosecond intervals to seconds since 00:00 Jan 01 1970:
|
||||
#
|
||||
# 1. Adjust 100 nanosecond intervals to Jan 01 1970 base
|
||||
# 2. Divide by 10 to get to microseconds (1/millionth second)
|
||||
# 3. Divide by 1000000 (10 ^ 6) to get to seconds
|
||||
#
|
||||
# We can combine Step 2 & 3 into one divide.
|
||||
#
|
||||
# After much trial and error, I came up with the following code which
|
||||
# avoids using Math::BigInt or floating pt, but still gives correct answers
|
||||
|
||||
# If the filetime is before the epoch, return 0
|
||||
if (($high < $filetime_high32_1970) ||
|
||||
(($high == $filetime_high32_1970) && ($low < $filetime_low32_1970)))
|
||||
{
|
||||
return 0;
|
||||
}
|
||||
|
||||
# Can't multiply by 0x100000000, (1 << 32),
|
||||
# without Perl issuing an integer overflow warning
|
||||
#
|
||||
# So use two multiplies by 0x10000 instead of one multiply by 0x100000000
|
||||
#
|
||||
# The result is the same.
|
||||
#
|
||||
my $date1970 = (($filetime_high32_1970 * 0x10000) * 0x10000) + $filetime_low32_1970;
|
||||
my $time = (($high * 0x10000) * 0x10000) + $low;
|
||||
|
||||
$time -= $date1970;
|
||||
$time /= 10000000;
|
||||
|
||||
return $time;
|
||||
}
|
||||
|
||||
sub load_cookie
|
||||
{
|
||||
my($self, $file) = @_;
|
||||
my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
|
||||
my $cookie_data;
|
||||
|
||||
if (-f $file)
|
||||
{
|
||||
# open the cookie file and get the data
|
||||
$cookie_data = load_cookies_from_file($file);
|
||||
|
||||
foreach my $cookie (@{$cookie_data})
|
||||
{
|
||||
my $secure = ($cookie->{FLAGS} & 1) != 0;
|
||||
my $expires = epoch_time_offset_from_win32_filetime($cookie->{HIXP}, $cookie->{LOXP});
|
||||
|
||||
$self->set_cookie(undef, $cookie->{KEY}, $cookie->{VALUE},
|
||||
$cookie->{PATH}, $cookie->{DOMAIN}, undef,
|
||||
0, $secure, $expires-$now, 0);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub load
|
||||
{
|
||||
my($self, $cookie_index) = @_;
|
||||
my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
|
||||
my $cookie_dir = '';
|
||||
my $delay_load = (defined($self->{'delayload'}) && $self->{'delayload'});
|
||||
my $user_name = get_user_name();
|
||||
my $data;
|
||||
|
||||
$cookie_index ||= $self->{'file'} || return;
|
||||
if ($cookie_index =~ /[\\\/][^\\\/]+$/) {
|
||||
$cookie_dir = $` . "\\";
|
||||
}
|
||||
|
||||
open (my $fh, '<:raw', $cookie_index) || return;
|
||||
if (256 != read($fh, $data, 256)) {
|
||||
warn "$cookie_index file is not large enough";
|
||||
return;
|
||||
}
|
||||
|
||||
# Cookies' index.dat file starts with 32 bytes of signature
|
||||
# followed by an offset to the first record, stored as a little-endian DWORD
|
||||
my ($sig, $size) = unpack('a32 V', $data);
|
||||
|
||||
# check that sig is valid (only tested in IE6.0)
|
||||
if (($sig !~ /^Client UrlCache MMF Ver 5\.2/) || (0x4000 != $size)) {
|
||||
warn "$cookie_index ['$sig' $size] does not seem to contain cookies";
|
||||
return;
|
||||
}
|
||||
|
||||
# move the file ptr to start of the first record
|
||||
if (0 == seek($fh, $size, 0)) {
|
||||
return;
|
||||
}
|
||||
|
||||
# Cookies are usually stored in 'URL ' records in two contiguous 0x80 byte sectors (256 bytes)
|
||||
# so read in two 0x80 byte sectors and adjust if not a Cookie.
|
||||
while (256 == read($fh, $data, 256)) {
|
||||
# each record starts with a 4-byte signature
|
||||
# and a count (little-endian DWORD) of 0x80 byte sectors for the record
|
||||
($sig, $size) = unpack('a4 V', $data);
|
||||
|
||||
# Cookies are found in 'URL ' records
|
||||
if ('URL ' ne $sig) {
|
||||
# skip over uninteresting record: I've seen 'HASH' and 'LEAK' records
|
||||
if (($sig eq 'HASH') || ($sig eq 'LEAK')) {
|
||||
# '-2' takes into account the two 0x80 byte sectors we've just read in
|
||||
if (($size > 0) && ($size != 2)) {
|
||||
if (0 == seek($fh, ($size-2)*0x80, 1)) {
|
||||
# Seek failed. Something's wrong. Gonna stop.
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
#$REMOVE Need to check if URL records in Cookies' index.dat will
|
||||
# ever use more than two 0x80 byte sectors
|
||||
if ($size > 2) {
|
||||
my $more_data = ($size-2)*0x80;
|
||||
|
||||
if ($more_data != read($fh, $data, $more_data, 256)) {
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
(my $user_name2 = $user_name) =~ s/ /_/g;
|
||||
if ($data =~ /Cookie:\Q$user_name\E@([\x21-\xFF]+).*?((?:\Q$user_name\E|\Q$user_name2\E)@[\x21-\xFF]+\.txt)/) {
|
||||
my $cookie_file = $cookie_dir . $2; # form full pathname
|
||||
|
||||
if (!$delay_load) {
|
||||
$self->load_cookie($cookie_file);
|
||||
}
|
||||
else {
|
||||
my $domain = $1;
|
||||
|
||||
# grab only the domain name, drop everything from the first dir sep on
|
||||
if ($domain =~ m{[\\/]}) {
|
||||
$domain = $`;
|
||||
}
|
||||
|
||||
# set the delayload cookie for this domain with
|
||||
# the cookie_file as cookie for later-loading info
|
||||
$self->set_cookie(undef, 'cookie', $cookie_file, '//+delayload', $domain, undef, 0, 0, $now+86_400, 0);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTTP::Cookies::Microsoft - Access to Microsoft cookies files
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 6.11
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use LWP;
|
||||
use HTTP::Cookies::Microsoft;
|
||||
use Win32::TieRegistry(Delimiter => "/");
|
||||
my $cookies_dir = $Registry->
|
||||
{"CUser/Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/Cookies"};
|
||||
|
||||
$cookie_jar = HTTP::Cookies::Microsoft->new(
|
||||
file => "$cookies_dir\\index.dat",
|
||||
'delayload' => 1,
|
||||
);
|
||||
my $browser = LWP::UserAgent->new;
|
||||
$browser->cookie_jar( $cookie_jar );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a subclass of C<HTTP::Cookies> which
|
||||
loads Microsoft Internet Explorer 5.x and 6.x for Windows (MSIE)
|
||||
cookie files.
|
||||
|
||||
See the documentation for L<HTTP::Cookies>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
The following methods are provided:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $cookie_jar = HTTP::Cookies::Microsoft->new;
|
||||
|
||||
The constructor takes hash style parameters. In addition
|
||||
to the regular HTTP::Cookies parameters, HTTP::Cookies::Microsoft
|
||||
recognizes the following:
|
||||
|
||||
delayload: delay loading of cookie data until a request
|
||||
is actually made. This results in faster
|
||||
runtime unless you use most of the cookies
|
||||
since only the domain's cookie data
|
||||
is loaded on demand.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Please note that the code DOESN'T support saving to the MSIE
|
||||
cookie file format.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Johnny Lee <typo_pl@hotmail.com>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2002 Johnny Lee
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Gisle Aas <gisle@activestate.com>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2002 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: Access to Microsoft cookies files
|
||||
|
||||
133
gitportable/usr/share/perl5/vendor_perl/HTTP/Cookies/Netscape.pm
Normal file
133
gitportable/usr/share/perl5/vendor_perl/HTTP/Cookies/Netscape.pm
Normal file
@@ -0,0 +1,133 @@
|
||||
package HTTP::Cookies::Netscape;
|
||||
|
||||
use strict;
|
||||
|
||||
our $VERSION = '6.11';
|
||||
|
||||
require HTTP::Cookies;
|
||||
our @ISA=qw(HTTP::Cookies);
|
||||
|
||||
sub load
|
||||
{
|
||||
my ($self, $file) = @_;
|
||||
$file ||= $self->{'file'} || return;
|
||||
|
||||
local $/ = "\n"; # make sure we got standard record separator
|
||||
open (my $fh, '<', $file) || return;
|
||||
my $magic = <$fh>;
|
||||
chomp $magic;
|
||||
unless ($magic =~ /^#(?: Netscape)? HTTP Cookie File/) {
|
||||
warn "$file does not look like a netscape cookies file";
|
||||
return;
|
||||
}
|
||||
|
||||
my $now = time() - $HTTP::Cookies::EPOCH_OFFSET;
|
||||
while (my $line = <$fh>) {
|
||||
chomp($line);
|
||||
$line =~ s/\s*\#HttpOnly_//;
|
||||
next if $line =~ /^\s*\#/;
|
||||
next if $line =~ /^\s*$/;
|
||||
$line =~ tr/\n\r//d;
|
||||
my($domain,$bool1,$path,$secure, $expires,$key,$val) = split(/\t/, $line);
|
||||
$secure = ($secure eq "TRUE");
|
||||
$self->set_cookie(undef, $key, $val, $path, $domain, undef, 0, $secure, $expires-$now, 0);
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub save
|
||||
{
|
||||
my $self = shift;
|
||||
my %args = (
|
||||
file => $self->{'file'},
|
||||
ignore_discard => $self->{'ignore_discard'},
|
||||
@_ == 1 ? ( file => $_[0] ) : @_
|
||||
);
|
||||
Carp::croak('Unexpected argument to save method') if keys %args > 2;
|
||||
my $file = $args{'file'} || return;
|
||||
|
||||
open(my $fh, '>', $file) || return;
|
||||
|
||||
# Use old, now broken link to the old cookie spec just in case something
|
||||
# else (not us!) requires the comment block exactly this way.
|
||||
print {$fh} <<EOT;
|
||||
# Netscape HTTP Cookie File
|
||||
# http://www.netscape.com/newsref/std/cookie_spec.html
|
||||
# This is a generated file! Do not edit.
|
||||
|
||||
EOT
|
||||
|
||||
my $now = time - $HTTP::Cookies::EPOCH_OFFSET;
|
||||
$self->scan(sub {
|
||||
my ($version, $key, $val, $path, $domain, $port, $path_spec, $secure, $expires, $discard, $rest) = @_;
|
||||
return if $discard && !$args{'ignore_discard'};
|
||||
$expires = $expires ? $expires - $HTTP::Cookies::EPOCH_OFFSET : 0;
|
||||
return if $now > $expires;
|
||||
$secure = $secure ? "TRUE" : "FALSE";
|
||||
my $bool = $domain =~ /^\./ ? "TRUE" : "FALSE";
|
||||
print {$fh} join("\t", $domain, $bool, $path, $secure, $expires, $key, $val), "\n";
|
||||
});
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTTP::Cookies::Netscape - Access to Netscape cookies files
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 6.11
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use LWP;
|
||||
use HTTP::Cookies::Netscape;
|
||||
$cookie_jar = HTTP::Cookies::Netscape->new(
|
||||
file => "c:/program files/netscape/users/ZombieCharity/cookies.txt",
|
||||
);
|
||||
my $browser = LWP::UserAgent->new;
|
||||
$browser->cookie_jar( $cookie_jar );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a subclass of C<HTTP::Cookies> that reads (and optionally
|
||||
writes) Netscape/Mozilla cookie files.
|
||||
|
||||
See the documentation for L<HTTP::Cookies>.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Please note that the Netscape/Mozilla cookie file format can't store
|
||||
all the information available in the Set-Cookie2 headers, so you will
|
||||
probably lose some information if you save in this format.
|
||||
|
||||
At time of writing, this module seems to work fine with Mozilla
|
||||
Phoenix/Firebird.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<HTTP::Cookies::Microsoft>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Gisle Aas <gisle@activestate.com>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2002 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: Access to Netscape cookies files
|
||||
|
||||
1163
gitportable/usr/share/perl5/vendor_perl/HTTP/Daemon.pm
Normal file
1163
gitportable/usr/share/perl5/vendor_perl/HTTP/Daemon.pm
Normal file
File diff suppressed because it is too large
Load Diff
419
gitportable/usr/share/perl5/vendor_perl/HTTP/Date.pm
Normal file
419
gitportable/usr/share/perl5/vendor_perl/HTTP/Date.pm
Normal 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
gitportable/usr/share/perl5/vendor_perl/HTTP/Headers.pm
Normal file
879
gitportable/usr/share/perl5/vendor_perl/HTTP/Headers.pm
Normal file
@@ -0,0 +1,879 @@
|
||||
package HTTP::Headers;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '7.00';
|
||||
|
||||
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.00
|
||||
|
||||
=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
gitportable/usr/share/perl5/vendor_perl/HTTP/Headers/Auth.pm
Normal file
127
gitportable/usr/share/perl5/vendor_perl/HTTP/Headers/Auth.pm
Normal file
@@ -0,0 +1,127 @@
|
||||
package HTTP::Headers::Auth;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '7.00';
|
||||
|
||||
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.00
|
||||
|
||||
=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
gitportable/usr/share/perl5/vendor_perl/HTTP/Headers/ETag.pm
Normal file
123
gitportable/usr/share/perl5/vendor_perl/HTTP/Headers/ETag.pm
Normal file
@@ -0,0 +1,123 @@
|
||||
package HTTP::Headers::ETag;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '7.00';
|
||||
|
||||
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.00
|
||||
|
||||
=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
gitportable/usr/share/perl5/vendor_perl/HTTP/Headers/Util.pm
Normal file
213
gitportable/usr/share/perl5/vendor_perl/HTTP/Headers/Util.pm
Normal file
@@ -0,0 +1,213 @@
|
||||
package HTTP::Headers::Util;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '7.00';
|
||||
|
||||
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.00
|
||||
|
||||
=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
gitportable/usr/share/perl5/vendor_perl/HTTP/Message.pm
Normal file
1241
gitportable/usr/share/perl5/vendor_perl/HTTP/Message.pm
Normal file
File diff suppressed because it is too large
Load Diff
528
gitportable/usr/share/perl5/vendor_perl/HTTP/Negotiate.pm
Normal file
528
gitportable/usr/share/perl5/vendor_perl/HTTP/Negotiate.pm
Normal file
@@ -0,0 +1,528 @@
|
||||
package HTTP::Negotiate;
|
||||
|
||||
$VERSION = "6.01";
|
||||
sub Version { $VERSION; }
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(choose);
|
||||
|
||||
require HTTP::Headers;
|
||||
|
||||
$DEBUG = 0;
|
||||
|
||||
sub choose ($;$)
|
||||
{
|
||||
my($variants, $request) = @_;
|
||||
my(%accept);
|
||||
|
||||
unless (defined $request) {
|
||||
# Create a request object from the CGI environment variables
|
||||
$request = HTTP::Headers->new;
|
||||
$request->header('Accept', $ENV{HTTP_ACCEPT})
|
||||
if $ENV{HTTP_ACCEPT};
|
||||
$request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET})
|
||||
if $ENV{HTTP_ACCEPT_CHARSET};
|
||||
$request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING})
|
||||
if $ENV{HTTP_ACCEPT_ENCODING};
|
||||
$request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE})
|
||||
if $ENV{HTTP_ACCEPT_LANGUAGE};
|
||||
}
|
||||
|
||||
# Get all Accept values from the request. Build a hash initialized
|
||||
# like this:
|
||||
#
|
||||
# %accept = ( type => { 'audio/*' => { q => 0.2, mbx => 20000 },
|
||||
# 'audio/basic' => { q => 1 },
|
||||
# },
|
||||
# language => { 'no' => { q => 1 },
|
||||
# }
|
||||
# );
|
||||
|
||||
$request->scan(sub {
|
||||
my($key, $val) = @_;
|
||||
|
||||
my $type;
|
||||
if ($key =~ s/^Accept-//) {
|
||||
$type = lc($key);
|
||||
}
|
||||
elsif ($key eq "Accept") {
|
||||
$type = "type";
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
|
||||
$val =~ s/\s+//g;
|
||||
my $default_q = 1;
|
||||
for my $name (split(/,/, $val)) {
|
||||
my(%param, $param);
|
||||
if ($name =~ s/;(.*)//) {
|
||||
for $param (split(/;/, $1)) {
|
||||
my ($pk, $pv) = split(/=/, $param, 2);
|
||||
$param{lc $pk} = $pv;
|
||||
}
|
||||
}
|
||||
$name = lc $name;
|
||||
if (defined $param{'q'}) {
|
||||
$param{'q'} = 1 if $param{'q'} > 1;
|
||||
$param{'q'} = 0 if $param{'q'} < 0;
|
||||
}
|
||||
else {
|
||||
$param{'q'} = $default_q;
|
||||
|
||||
# This makes sure that the first ones are slightly better off
|
||||
# and therefore more likely to be chosen.
|
||||
$default_q -= 0.0001;
|
||||
}
|
||||
$accept{$type}{$name} = \%param;
|
||||
}
|
||||
});
|
||||
|
||||
# Check if any of the variants specify a language. We do this
|
||||
# because it influences how we treat those without (they default to
|
||||
# 0.5 instead of 1).
|
||||
my $any_lang = 0;
|
||||
for $var (@$variants) {
|
||||
if ($var->[5]) {
|
||||
$any_lang = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if ($DEBUG) {
|
||||
print "Negotiation parameters in the request\n";
|
||||
for $type (keys %accept) {
|
||||
print " $type:\n";
|
||||
for $name (keys %{$accept{$type}}) {
|
||||
print " $name\n";
|
||||
for $pv (keys %{$accept{$type}{$name}}) {
|
||||
print " $pv = $accept{$type}{$name}{$pv}\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my @Q = (); # This is where we collect the results of the
|
||||
# quality calculations
|
||||
|
||||
# Calculate quality for all the variants that are available.
|
||||
for (@$variants) {
|
||||
my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_;
|
||||
$qs = 1 unless defined $qs;
|
||||
$ct = '' unless defined $ct;
|
||||
$bs = 0 unless defined $bs;
|
||||
$lang = lc($lang) if $lang; # lg tags are always case-insensitive
|
||||
if ($DEBUG) {
|
||||
print "\nEvaluating $id (ct='$ct')\n";
|
||||
printf " qs = %.3f\n", $qs;
|
||||
print " enc = $enc\n" if $enc && !ref($enc);
|
||||
print " enc = @$enc\n" if $enc && ref($enc);
|
||||
print " cs = $cs\n" if $cs;
|
||||
print " lang = $lang\n" if $lang;
|
||||
print " bs = $bs\n" if $bs;
|
||||
}
|
||||
|
||||
# Calculate encoding quality
|
||||
my $qe = 1;
|
||||
# If the variant has no assigned Content-Encoding, or if no
|
||||
# Accept-Encoding field is present, then the value assigned
|
||||
# is "qe=1". If *all* of the variant's content encodings
|
||||
# are listed in the Accept-Encoding field, then the value
|
||||
# assigned is "qw=1". If *any* of the variant's content
|
||||
# encodings are not listed in the provided Accept-Encoding
|
||||
# field, then the value assigned is "qe=0"
|
||||
if (exists $accept{'encoding'} && $enc) {
|
||||
my @enc = ref($enc) ? @$enc : ($enc);
|
||||
for (@enc) {
|
||||
print "Is encoding $_ accepted? " if $DEBUG;
|
||||
unless(exists $accept{'encoding'}{$_}) {
|
||||
print "no\n" if $DEBUG;
|
||||
$qe = 0;
|
||||
last;
|
||||
}
|
||||
else {
|
||||
print "yes\n" if $DEBUG;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Calculate charset quality
|
||||
my $qc = 1;
|
||||
# If the variant's media-type has no charset parameter,
|
||||
# or the variant's charset is US-ASCII, or if no Accept-Charset
|
||||
# field is present, then the value assigned is "qc=1". If the
|
||||
# variant's charset is listed in the Accept-Charset field,
|
||||
# then the value assigned is "qc=1. Otherwise, if the variant's
|
||||
# charset is not listed in the provided Accept-Encoding field,
|
||||
# then the value assigned is "qc=0".
|
||||
if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) {
|
||||
$qc = 0 unless $accept{'charset'}{$cs};
|
||||
}
|
||||
|
||||
# Calculate language quality
|
||||
my $ql = 1;
|
||||
if ($lang && exists $accept{'language'}) {
|
||||
my @lang = ref($lang) ? @$lang : ($lang);
|
||||
# If any of the variant's content languages are listed
|
||||
# in the Accept-Language field, the the value assigned is
|
||||
# the largest of the "q" parameter values for those language
|
||||
# tags.
|
||||
my $q = undef;
|
||||
for (@lang) {
|
||||
next unless exists $accept{'language'}{$_};
|
||||
my $this_q = $accept{'language'}{$_}{'q'};
|
||||
$q = $this_q unless defined $q;
|
||||
$q = $this_q if $this_q > $q;
|
||||
}
|
||||
if(defined $q) {
|
||||
$DEBUG and print " -- Exact language match at q=$q\n";
|
||||
}
|
||||
else {
|
||||
# If there was no exact match and at least one of
|
||||
# the Accept-Language field values is a complete
|
||||
# subtag prefix of the content language tag(s), then
|
||||
# the "q" parameter value of the largest matching
|
||||
# prefix is used.
|
||||
$DEBUG and print " -- No exact language match\n";
|
||||
my $selected = undef;
|
||||
for $al (keys %{ $accept{'language'} }) {
|
||||
if (index($al, "$lang-") == 0) {
|
||||
# $lang starting with $al isn't enough, or else
|
||||
# Accept-Language: hu (Hungarian) would seem
|
||||
# to accept a document in hup (Hupa)
|
||||
$DEBUG and print " -- $al ISA $lang\n";
|
||||
$selected = $al unless defined $selected;
|
||||
$selected = $al if length($al) > length($selected);
|
||||
}
|
||||
else {
|
||||
$DEBUG and print " -- $lang isn't a $al\n";
|
||||
}
|
||||
}
|
||||
$q = $accept{'language'}{$selected}{'q'} if $selected;
|
||||
|
||||
# If none of the variant's content language tags or
|
||||
# tag prefixes are listed in the provided
|
||||
# Accept-Language field, then the value assigned
|
||||
# is "ql=0.001"
|
||||
$q = 0.001 unless defined $q;
|
||||
}
|
||||
$ql = $q;
|
||||
}
|
||||
else {
|
||||
$ql = 0.5 if $any_lang && exists $accept{'language'};
|
||||
}
|
||||
|
||||
my $q = 1;
|
||||
my $mbx = undef;
|
||||
# If no Accept field is given, then the value assigned is "q=1".
|
||||
# If at least one listed media range matches the variant's media
|
||||
# type, then the "q" parameter value assigned to the most specific
|
||||
# of those matched is used (e.g. "text/html;version=3.0" is more
|
||||
# specific than "text/html", which is more specific than "text/*",
|
||||
# which in turn is more specific than "*/*"). If not media range
|
||||
# in the provided Accept field matches the variant's media type,
|
||||
# then the value assigned is "q=0".
|
||||
if (exists $accept{'type'} && $ct) {
|
||||
# First we clean up our content-type
|
||||
$ct =~ s/\s+//g;
|
||||
my $params = "";
|
||||
$params = $1 if $ct =~ s/;(.*)//;
|
||||
my($type, $subtype) = split("/", $ct, 2);
|
||||
my %param = ();
|
||||
for $param (split(/;/, $params)) {
|
||||
my($pk,$pv) = split(/=/, $param, 2);
|
||||
$param{$pk} = $pv;
|
||||
}
|
||||
|
||||
my $sel_q = undef;
|
||||
my $sel_mbx = undef;
|
||||
my $sel_specificness = 0;
|
||||
|
||||
ACCEPT_TYPE:
|
||||
for $at (keys %{ $accept{'type'} }) {
|
||||
print "Consider $at...\n" if $DEBUG;
|
||||
my($at_type, $at_subtype) = split("/", $at, 2);
|
||||
# Is it a match on the type
|
||||
next if $at_type ne '*' && $at_type ne $type;
|
||||
next if $at_subtype ne '*' && $at_subtype ne $subtype;
|
||||
my $specificness = 0;
|
||||
$specificness++ if $at_type ne '*';
|
||||
$specificness++ if $at_subtype ne '*';
|
||||
# Let's see if content-type parameters also match
|
||||
while (($pk, $pv) = each %param) {
|
||||
print "Check if $pk = $pv is true\n" if $DEBUG;
|
||||
next unless exists $accept{'type'}{$at}{$pk};
|
||||
next ACCEPT_TYPE
|
||||
unless $accept{'type'}{$at}{$pk} eq $pv;
|
||||
print "yes it is!!\n" if $DEBUG;
|
||||
$specificness++;
|
||||
}
|
||||
print "Hurray, type match with specificness = $specificness\n"
|
||||
if $DEBUG;
|
||||
|
||||
if (!defined($sel_q) || $sel_specificness < $specificness) {
|
||||
$sel_q = $accept{'type'}{$at}{'q'};
|
||||
$sel_mbx = $accept{'type'}{$at}{'mbx'};
|
||||
$sel_specificness = $specificness;
|
||||
}
|
||||
}
|
||||
$q = $sel_q || 0;
|
||||
$mbx = $sel_mbx;
|
||||
}
|
||||
|
||||
my $Q;
|
||||
if (!defined($mbx) || $mbx >= $bs) {
|
||||
$Q = $qs * $qe * $qc * $ql * $q;
|
||||
}
|
||||
else {
|
||||
$Q = 0;
|
||||
print "Variant's size is too large ==> Q=0\n" if $DEBUG;
|
||||
}
|
||||
|
||||
if ($DEBUG) {
|
||||
$mbx = "undef" unless defined $mbx;
|
||||
printf "Q=%.4f", $Q;
|
||||
print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n";
|
||||
}
|
||||
|
||||
push(@Q, [$id, $Q, $bs]);
|
||||
}
|
||||
|
||||
|
||||
@Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q;
|
||||
|
||||
return @Q if wantarray;
|
||||
return undef unless @Q;
|
||||
return undef if $Q[0][1] == 0;
|
||||
$Q[0][0];
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
HTTP::Negotiate - choose a variant to serve
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use HTTP::Negotiate qw(choose);
|
||||
|
||||
# ID QS Content-Type Encoding Char-Set Lang Size
|
||||
$variants =
|
||||
[['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000],
|
||||
['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400],
|
||||
['var3', 0.3, 'image/gif', undef, undef, undef, 43555],
|
||||
];
|
||||
|
||||
@preferred = choose($variants, $request_headers);
|
||||
$the_one = choose($variants);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a complete implementation of the HTTP content
|
||||
negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps>
|
||||
chapter 12. Content negotiation allows for the selection of a
|
||||
preferred content representation based upon attributes of the
|
||||
negotiable variants and the value of the various Accept* header fields
|
||||
in the request.
|
||||
|
||||
The variants are ordered by preference by calling the function
|
||||
choose().
|
||||
|
||||
The first parameter is reference to an array of the variants to
|
||||
choose among.
|
||||
Each element in this array is an array with the values [$id, $qs,
|
||||
$content_type, $content_encoding, $charset, $content_language,
|
||||
$content_length] whose meanings are described
|
||||
below. The $content_encoding and $content_language can be either a
|
||||
single scalar value or an array reference if there are several values.
|
||||
|
||||
The second optional parameter is either a HTTP::Headers or a HTTP::Request
|
||||
object which is searched for "Accept*" headers. If this
|
||||
parameter is missing, then the accept specification is initialized
|
||||
from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET,
|
||||
HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE.
|
||||
|
||||
In an array context, choose() returns a list of [variant
|
||||
identifier, calculated quality, size] tuples. The values are sorted by
|
||||
quality, highest quality first. If the calculated quality is the same
|
||||
for two variants, then they are sorted by size (smallest first). I<E.g.>:
|
||||
|
||||
(['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]);
|
||||
|
||||
Note that also zero quality variants are included in the return list
|
||||
even if these should never be served to the client.
|
||||
|
||||
In a scalar context, it returns the identifier of the variant with the
|
||||
highest score or C<undef> if none have non-zero quality.
|
||||
|
||||
If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of
|
||||
noise is generated on STDOUT during evaluation of choose().
|
||||
|
||||
=head1 VARIANTS
|
||||
|
||||
A variant is described by a list of the following values. If the
|
||||
attribute does not make sense or is unknown for a variant, then use
|
||||
C<undef> instead.
|
||||
|
||||
=over 3
|
||||
|
||||
=item identifier
|
||||
|
||||
This is a string that you use as the name for the variant. This
|
||||
identifier for the preferred variants returned by choose().
|
||||
|
||||
=item qs
|
||||
|
||||
This is a number between 0.000 and 1.000 that describes the "source
|
||||
quality". This is what F<draft-ietf-http-v11-spec-00.ps> says about this
|
||||
value:
|
||||
|
||||
Source quality is measured by the content provider as representing the
|
||||
amount of degradation from the original source. For example, a
|
||||
picture in JPEG form would have a lower qs when translated to the XBM
|
||||
format, and much lower qs when translated to an ASCII-art
|
||||
representation. Note, however, that this is a function of the source
|
||||
- an original piece of ASCII-art may degrade in quality if it is
|
||||
captured in JPEG form. The qs values should be assigned to each
|
||||
variant by the content provider; if no qs value has been assigned, the
|
||||
default is generally "qs=1".
|
||||
|
||||
=item content-type
|
||||
|
||||
This is the media type of the variant. The media type does not
|
||||
include a charset attribute, but might contain other parameters.
|
||||
Examples are:
|
||||
|
||||
text/html
|
||||
text/html;version=2.0
|
||||
text/plain
|
||||
image/gif
|
||||
image/jpg
|
||||
|
||||
=item content-encoding
|
||||
|
||||
This is one or more content encodings that has been applied to the
|
||||
variant. The content encoding is generally used as a modifier to the
|
||||
content media type. The most common content encodings are:
|
||||
|
||||
gzip
|
||||
compress
|
||||
|
||||
=item content-charset
|
||||
|
||||
This is the character set used when the variant contains text.
|
||||
The charset value should generally be C<undef> or one of these:
|
||||
|
||||
us-ascii
|
||||
iso-8859-1 ... iso-8859-9
|
||||
iso-2022-jp
|
||||
iso-2022-jp-2
|
||||
iso-2022-kr
|
||||
unicode-1-1
|
||||
unicode-1-1-utf-7
|
||||
unicode-1-1-utf-8
|
||||
|
||||
=item content-language
|
||||
|
||||
This describes one or more languages that are used in the variant.
|
||||
Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A
|
||||
language is in this context a natural language spoken, written, or
|
||||
otherwise conveyed by human beings for communication of information to
|
||||
other human beings. Computer languages are explicitly excluded.
|
||||
|
||||
The language tags are defined by RFC 3066. Examples
|
||||
are:
|
||||
|
||||
no Norwegian
|
||||
en International English
|
||||
en-US US English
|
||||
en-cockney
|
||||
|
||||
=item content-length
|
||||
|
||||
This is the number of bytes used to represent the content.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ACCEPT HEADERS
|
||||
|
||||
The following Accept* headers can be used for describing content
|
||||
preferences in a request (This description is an edited extract from
|
||||
F<draft-ietf-http-v11-spec-00.ps>):
|
||||
|
||||
=over 3
|
||||
|
||||
=item Accept
|
||||
|
||||
This header can be used to indicate a list of media ranges which are
|
||||
acceptable as a response to the request. The "*" character is used to
|
||||
group media types into ranges, with "*/*" indicating all media types
|
||||
and "type/*" indicating all subtypes of that type.
|
||||
|
||||
The parameter q is used to indicate the quality factor, which
|
||||
represents the user's preference for that range of media types. The
|
||||
parameter mbx gives the maximum acceptable size of the response
|
||||
content. The default values are: q=1 and mbx=infinity. If no Accept
|
||||
header is present, then the client accepts all media types with q=1.
|
||||
|
||||
For example:
|
||||
|
||||
Accept: audio/*;q=0.2;mbx=200000, audio/basic
|
||||
|
||||
would mean: "I prefer audio/basic (of any size), but send me any audio
|
||||
type if it is the best available after an 80% mark-down in quality and
|
||||
its size is less than 200000 bytes"
|
||||
|
||||
|
||||
=item Accept-Charset
|
||||
|
||||
Used to indicate what character sets are acceptable for the response.
|
||||
The "us-ascii" character set is assumed to be acceptable for all user
|
||||
agents. If no Accept-Charset field is given, the default is that any
|
||||
charset is acceptable. Example:
|
||||
|
||||
Accept-Charset: iso-8859-1, unicode-1-1
|
||||
|
||||
|
||||
=item Accept-Encoding
|
||||
|
||||
Restricts the Content-Encoding values which are acceptable in the
|
||||
response. If no Accept-Encoding field is present, the server may
|
||||
assume that the client will accept any content encoding. An empty
|
||||
Accept-Encoding means that no content encoding is acceptable. Example:
|
||||
|
||||
Accept-Encoding: compress, gzip
|
||||
|
||||
|
||||
=item Accept-Language
|
||||
|
||||
This field is similar to Accept, but restricts the set of natural
|
||||
languages that are preferred in a response. Each language may be
|
||||
given an associated quality value which represents an estimate of the
|
||||
user's comprehension of that language. For example:
|
||||
|
||||
Accept-Language: no, en-gb;q=0.8, de;q=0.55
|
||||
|
||||
would mean: "I prefer Norwegian, but will accept British English (with
|
||||
80% comprehension) or German (with 55% comprehension).
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 1996,2001 Gisle Aas.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Gisle Aas <gisle@aas.no>
|
||||
|
||||
=cut
|
||||
352
gitportable/usr/share/perl5/vendor_perl/HTTP/Request.pm
Normal file
352
gitportable/usr/share/perl5/vendor_perl/HTTP/Request.pm
Normal file
@@ -0,0 +1,352 @@
|
||||
package HTTP::Request;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '7.00';
|
||||
|
||||
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(@_));
|
||||
}
|
||||
|
||||
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.00
|
||||
|
||||
=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
gitportable/usr/share/perl5/vendor_perl/HTTP/Request/Common.pm
Normal file
577
gitportable/usr/share/perl5/vendor_perl/HTTP/Request/Common.pm
Normal file
@@ -0,0 +1,577 @@
|
||||
package HTTP::Request::Common;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '7.00';
|
||||
|
||||
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.00
|
||||
|
||||
=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
gitportable/usr/share/perl5/vendor_perl/HTTP/Response.pm
Normal file
671
gitportable/usr/share/perl5/vendor_perl/HTTP/Response.pm
Normal file
@@ -0,0 +1,671 @@
|
||||
package HTTP::Response;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '7.00';
|
||||
|
||||
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(@_));
|
||||
}
|
||||
|
||||
|
||||
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/&/&/g;
|
||||
$body =~ s/</</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.00
|
||||
|
||||
=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
gitportable/usr/share/perl5/vendor_perl/HTTP/Status.pm
Normal file
389
gitportable/usr/share/perl5/vendor_perl/HTTP/Status.pm
Normal file
@@ -0,0 +1,389 @@
|
||||
package HTTP::Status;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '7.00';
|
||||
|
||||
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: Transparant 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.00
|
||||
|
||||
=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
|
||||
207
gitportable/usr/share/perl5/vendor_perl/IO/AtomicFile.pm
Normal file
207
gitportable/usr/share/perl5/vendor_perl/IO/AtomicFile.pm
Normal file
@@ -0,0 +1,207 @@
|
||||
package IO::AtomicFile;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use parent 'IO::File';
|
||||
|
||||
our $VERSION = '2.113';
|
||||
|
||||
#------------------------------
|
||||
# new ARGS...
|
||||
#------------------------------
|
||||
# Class method, constructor.
|
||||
# Any arguments are sent to open().
|
||||
#
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = $class->SUPER::new();
|
||||
${*$self}{'io_atomicfile_suffix'} = '';
|
||||
$self->open(@_) if @_;
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# DESTROY
|
||||
#------------------------------
|
||||
# Destructor.
|
||||
#
|
||||
sub DESTROY {
|
||||
shift->close(1); ### like close, but raises fatal exception on failure
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# open PATH, MODE
|
||||
#------------------------------
|
||||
# Class/instance method.
|
||||
#
|
||||
sub open {
|
||||
my ($self, $path, $mode) = @_;
|
||||
ref($self) or $self = $self->new; ### now we have an instance!
|
||||
|
||||
### Create tmp path, and remember this info:
|
||||
my $temp = "${path}..TMP" . ${*$self}{'io_atomicfile_suffix'};
|
||||
${*$self}{'io_atomicfile_temp'} = $temp;
|
||||
${*$self}{'io_atomicfile_path'} = $path;
|
||||
|
||||
### Open the file! Returns filehandle on success, for use as a constructor:
|
||||
$self->SUPER::open($temp, $mode) ? $self : undef;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# _closed [YESNO]
|
||||
#------------------------------
|
||||
# Instance method, private.
|
||||
# Are we already closed? Argument sets new value, returns previous one.
|
||||
#
|
||||
sub _closed {
|
||||
my $self = shift;
|
||||
my $oldval = ${*$self}{'io_atomicfile_closed'};
|
||||
${*$self}{'io_atomicfile_closed'} = shift if @_;
|
||||
$oldval;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# close
|
||||
#------------------------------
|
||||
# Instance method.
|
||||
# Close the handle, and rename the temp file to its final name.
|
||||
#
|
||||
sub close {
|
||||
my ($self, $die) = @_;
|
||||
unless ($self->_closed(1)) { ### sentinel...
|
||||
if ($self->SUPER::close()) {
|
||||
rename(${*$self}{'io_atomicfile_temp'},
|
||||
${*$self}{'io_atomicfile_path'})
|
||||
or ($die ? die "close (rename) atomic file: $!\n" : return undef);
|
||||
} else {
|
||||
($die ? die "close atomic file: $!\n" : return undef);
|
||||
}
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# delete
|
||||
#------------------------------
|
||||
# Instance method.
|
||||
# Close the handle, and delete the temp file.
|
||||
#
|
||||
sub delete {
|
||||
my $self = shift;
|
||||
unless ($self->_closed(1)) { ### sentinel...
|
||||
$self->SUPER::close();
|
||||
return unlink(${*$self}{'io_atomicfile_temp'});
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# detach
|
||||
#------------------------------
|
||||
# Instance method.
|
||||
# Close the handle, but DO NOT delete the temp file.
|
||||
#
|
||||
sub detach {
|
||||
my $self = shift;
|
||||
$self->SUPER::close() unless ($self->_closed(1));
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::AtomicFile - write a file which is updated atomically
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use feature 'say';
|
||||
use IO::AtomicFile;
|
||||
|
||||
# Write a temp file, and have it install itself when closed:
|
||||
my $fh = IO::AtomicFile->open("bar.dat", "w");
|
||||
$fh->say("Hello!");
|
||||
$fh->close || die "couldn't install atomic file: $!";
|
||||
|
||||
# Write a temp file, but delete it before it gets installed:
|
||||
my $fh = IO::AtomicFile->open("bar.dat", "w");
|
||||
$fh->say("Hello!");
|
||||
$fh->delete;
|
||||
|
||||
# Write a temp file, but neither install it nor delete it:
|
||||
my $fh = IO::AtomicFile->open("bar.dat", "w");
|
||||
$fh->say("Hello!");
|
||||
$fh->detach;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is intended for people who need to update files
|
||||
reliably in the face of unexpected program termination.
|
||||
|
||||
For example, you generally don't want to be halfway in the middle of
|
||||
writing I</etc/passwd> and have your program terminate! Even
|
||||
the act of writing a single scalar to a filehandle is I<not> atomic.
|
||||
|
||||
But this module gives you true atomic updates, via C<rename>.
|
||||
When you open a file I</foo/bar.dat> via this module, you are I<actually>
|
||||
opening a temporary file I</foo/bar.dat..TMP>, and writing your
|
||||
output there. The act of closing this file (either explicitly
|
||||
via C<close>, or implicitly via the destruction of the object)
|
||||
will cause C<rename> to be called... therefore, from the point
|
||||
of view of the outside world, the file's contents are updated
|
||||
in a single time quantum.
|
||||
|
||||
To ensure that problems do not go undetected, the C<close> method
|
||||
done by the destructor will raise a fatal exception if the C<rename>
|
||||
fails. The explicit C<close> just returns C<undef>.
|
||||
|
||||
You can also decide at any point to trash the file you've been
|
||||
building.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<IO::AtomicFile> inherits all methods from L<IO::File> and
|
||||
implements the following new ones.
|
||||
|
||||
=head2 close
|
||||
|
||||
$fh->close();
|
||||
|
||||
This method calls its parent L<IO::File/"close"> and then renames its temporary file
|
||||
as the original file name.
|
||||
|
||||
=head2 delete
|
||||
|
||||
$fh->delete();
|
||||
|
||||
This method calls its parent L<IO::File/"close"> and then deletes the temporary file.
|
||||
|
||||
=head2 detach
|
||||
|
||||
$fh->detach();
|
||||
|
||||
This method calls its parent L<IO::File/"close">. Unlike L<IO::AtomicFile/"delete"> it
|
||||
does not then delete the temporary file.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>).
|
||||
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
Dianne Skoll (F<dfs@roaringpenguin.com>).
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
629
gitportable/usr/share/perl5/vendor_perl/IO/HTML.pm
Normal file
629
gitportable/usr/share/perl5/vendor_perl/IO/HTML.pm
Normal file
@@ -0,0 +1,629 @@
|
||||
#---------------------------------------------------------------------
|
||||
package IO::HTML;
|
||||
#
|
||||
# Copyright 2020 Christopher J. Madsen
|
||||
#
|
||||
# Author: Christopher J. Madsen <perl@cjmweb.net>
|
||||
# Created: 14 Jan 2012
|
||||
#
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the same terms as Perl itself.
|
||||
#
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the
|
||||
# GNU General Public License or the Artistic License for more details.
|
||||
#
|
||||
# ABSTRACT: Open an HTML file with automatic charset detection
|
||||
#---------------------------------------------------------------------
|
||||
|
||||
use 5.008;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp 'croak';
|
||||
use Encode 2.10 qw(decode find_encoding); # need utf-8-strict encoding
|
||||
use Exporter 5.57 'import';
|
||||
|
||||
our $VERSION = '1.004';
|
||||
# This file is part of IO-HTML 1.004 (September 26, 2020)
|
||||
|
||||
|
||||
our $bytes_to_check ||= 1024;
|
||||
our $default_encoding ||= 'cp1252';
|
||||
|
||||
our @EXPORT = qw(html_file);
|
||||
our @EXPORT_OK = qw(find_charset_in html_file_and_encoding html_outfile
|
||||
sniff_encoding);
|
||||
|
||||
our %EXPORT_TAGS = (
|
||||
rw => [qw( html_file html_file_and_encoding html_outfile )],
|
||||
all => [ @EXPORT, @EXPORT_OK ],
|
||||
);
|
||||
|
||||
#=====================================================================
|
||||
|
||||
|
||||
sub html_file
|
||||
{
|
||||
(&html_file_and_encoding)[0]; # return just the filehandle
|
||||
} # end html_file
|
||||
|
||||
|
||||
# Note: I made html_file and html_file_and_encoding separate functions
|
||||
# (instead of making html_file context-sensitive) because I wanted to
|
||||
# use html_file in function calls (i.e. list context) without having
|
||||
# to write "scalar html_file" all the time.
|
||||
|
||||
sub html_file_and_encoding
|
||||
{
|
||||
my ($filename, $options) = @_;
|
||||
|
||||
$options ||= {};
|
||||
|
||||
open(my $in, '<:raw', $filename) or croak "Failed to open $filename: $!";
|
||||
|
||||
|
||||
my ($encoding, $bom) = sniff_encoding($in, $filename, $options);
|
||||
|
||||
if (not defined $encoding) {
|
||||
croak "No default encoding specified"
|
||||
unless defined($encoding = $default_encoding);
|
||||
$encoding = find_encoding($encoding) if $options->{encoding};
|
||||
} # end if we didn't find an encoding
|
||||
|
||||
binmode $in, sprintf(":encoding(%s):crlf",
|
||||
$options->{encoding} ? $encoding->name : $encoding);
|
||||
|
||||
return ($in, $encoding, $bom);
|
||||
} # end html_file_and_encoding
|
||||
#---------------------------------------------------------------------
|
||||
|
||||
|
||||
sub html_outfile
|
||||
{
|
||||
my ($filename, $encoding, $bom) = @_;
|
||||
|
||||
if (not defined $encoding) {
|
||||
croak "No default encoding specified"
|
||||
unless defined($encoding = $default_encoding);
|
||||
} # end if we didn't find an encoding
|
||||
elsif (ref $encoding) {
|
||||
$encoding = $encoding->name;
|
||||
}
|
||||
|
||||
open(my $out, ">:encoding($encoding)", $filename)
|
||||
or croak "Failed to open $filename: $!";
|
||||
|
||||
print $out "\x{FeFF}" if $bom;
|
||||
|
||||
return $out;
|
||||
} # end html_outfile
|
||||
#---------------------------------------------------------------------
|
||||
|
||||
|
||||
sub sniff_encoding
|
||||
{
|
||||
my ($in, $filename, $options) = @_;
|
||||
|
||||
$filename = 'file' unless defined $filename;
|
||||
$options ||= {};
|
||||
|
||||
my $pos = tell $in;
|
||||
croak "Could not seek $filename: $!" if $pos < 0;
|
||||
|
||||
croak "Could not read $filename: $!"
|
||||
unless defined read $in, my($buf), $bytes_to_check;
|
||||
|
||||
seek $in, $pos, 0 or croak "Could not seek $filename: $!";
|
||||
|
||||
|
||||
# Check for BOM:
|
||||
my $bom;
|
||||
my $encoding = do {
|
||||
if ($buf =~ /^\xFe\xFF/) {
|
||||
$bom = 2;
|
||||
'UTF-16BE';
|
||||
} elsif ($buf =~ /^\xFF\xFe/) {
|
||||
$bom = 2;
|
||||
'UTF-16LE';
|
||||
} elsif ($buf =~ /^\xEF\xBB\xBF/) {
|
||||
$bom = 3;
|
||||
'utf-8-strict';
|
||||
} else {
|
||||
find_charset_in($buf, $options); # check for <meta charset>
|
||||
}
|
||||
}; # end $encoding
|
||||
|
||||
if ($bom) {
|
||||
seek $in, $bom, 1 or croak "Could not seek $filename: $!";
|
||||
$bom = 1;
|
||||
}
|
||||
elsif (not defined $encoding) { # try decoding as UTF-8
|
||||
my $test = decode('utf-8-strict', $buf, Encode::FB_QUIET);
|
||||
if ($buf =~ /^(?: # nothing left over
|
||||
| [\xC2-\xDF] # incomplete 2-byte char
|
||||
| [\xE0-\xEF] [\x80-\xBF]? # incomplete 3-byte char
|
||||
| [\xF0-\xF4] [\x80-\xBF]{0,2} # incomplete 4-byte char
|
||||
)\z/x and $test =~ /[^\x00-\x7F]/) {
|
||||
$encoding = 'utf-8-strict';
|
||||
} # end if valid UTF-8 with at least one multi-byte character:
|
||||
} # end if testing for UTF-8
|
||||
|
||||
if (defined $encoding and $options->{encoding} and not ref $encoding) {
|
||||
$encoding = find_encoding($encoding);
|
||||
} # end if $encoding is a string and we want an object
|
||||
|
||||
return wantarray ? ($encoding, $bom) : $encoding;
|
||||
} # end sniff_encoding
|
||||
|
||||
#=====================================================================
|
||||
# Based on HTML5 8.2.2.2 Determining the character encoding:
|
||||
|
||||
# Get attribute from current position of $_
|
||||
sub _get_attribute
|
||||
{
|
||||
m!\G[\x09\x0A\x0C\x0D /]+!gc; # skip whitespace or /
|
||||
|
||||
return if /\G>/gc or not /\G(=?[^\x09\x0A\x0C\x0D =]*)/gc;
|
||||
|
||||
my ($name, $value) = (lc $1, '');
|
||||
|
||||
if (/\G[\x09\x0A\x0C\x0D ]*=[\x09\x0A\x0C\x0D ]*/gc) {
|
||||
if (/\G"/gc) {
|
||||
# Double-quoted attribute value
|
||||
/\G([^"]*)("?)/gc;
|
||||
return unless $2; # Incomplete attribute (missing closing quote)
|
||||
$value = lc $1;
|
||||
} elsif (/\G'/gc) {
|
||||
# Single-quoted attribute value
|
||||
/\G([^']*)('?)/gc;
|
||||
return unless $2; # Incomplete attribute (missing closing quote)
|
||||
$value = lc $1;
|
||||
} else {
|
||||
# Unquoted attribute value
|
||||
/\G([^\x09\x0A\x0C\x0D >]*)/gc;
|
||||
$value = lc $1;
|
||||
}
|
||||
} # end if attribute has value
|
||||
|
||||
return wantarray ? ($name, $value) : 1;
|
||||
} # end _get_attribute
|
||||
|
||||
# Examine a meta value for a charset:
|
||||
sub _get_charset_from_meta
|
||||
{
|
||||
for (shift) {
|
||||
while (/charset[\x09\x0A\x0C\x0D ]*=[\x09\x0A\x0C\x0D ]*/ig) {
|
||||
return $1 if (/\G"([^"]*)"/gc or
|
||||
/\G'([^']*)'/gc or
|
||||
/\G(?!['"])([^\x09\x0A\x0C\x0D ;]+)/gc);
|
||||
}
|
||||
} # end for value
|
||||
|
||||
return undef;
|
||||
} # end _get_charset_from_meta
|
||||
#---------------------------------------------------------------------
|
||||
|
||||
|
||||
sub find_charset_in
|
||||
{
|
||||
for (shift) {
|
||||
my $options = shift || {};
|
||||
# search only the first $bytes_to_check bytes (default 1024)
|
||||
my $stop = length > $bytes_to_check ? $bytes_to_check : length;
|
||||
|
||||
my $expect_pragma = (defined $options->{need_pragma}
|
||||
? $options->{need_pragma} : 1);
|
||||
|
||||
pos() = 0;
|
||||
while (pos() < $stop) {
|
||||
if (/\G<!--.*?(?<=--)>/sgc) {
|
||||
} # Skip comment
|
||||
elsif (m!\G<meta(?=[\x09\x0A\x0C\x0D /])!gic) {
|
||||
my ($got_pragma, $need_pragma, $charset);
|
||||
|
||||
while (my ($name, $value) = &_get_attribute) {
|
||||
if ($name eq 'http-equiv' and $value eq 'content-type') {
|
||||
$got_pragma = 1;
|
||||
} elsif ($name eq 'content' and not defined $charset) {
|
||||
$need_pragma = $expect_pragma
|
||||
if defined($charset = _get_charset_from_meta($value));
|
||||
} elsif ($name eq 'charset') {
|
||||
$charset = $value;
|
||||
$need_pragma = 0;
|
||||
}
|
||||
} # end while more attributes in this <meta> tag
|
||||
|
||||
if (defined $need_pragma and (not $need_pragma or $got_pragma)) {
|
||||
$charset = 'UTF-8' if $charset =~ /^utf-?16/;
|
||||
$charset = 'cp1252' if $charset eq 'iso-8859-1'; # people lie
|
||||
if (my $encoding = find_encoding($charset)) {
|
||||
return $options->{encoding} ? $encoding : $encoding->name;
|
||||
} # end if charset is a recognized encoding
|
||||
} # end if found charset
|
||||
} # end elsif <meta
|
||||
elsif (m!\G</?[a-zA-Z][^\x09\x0A\x0C\x0D >]*!gc) {
|
||||
1 while &_get_attribute;
|
||||
} # end elsif some other tag
|
||||
elsif (m{\G<[!/?][^>]*}gc) {
|
||||
} # skip unwanted things
|
||||
elsif (m/\G</gc) {
|
||||
} # skip < that doesn't open anything we recognize
|
||||
|
||||
# Advance to the next <:
|
||||
m/\G[^<]+/gc;
|
||||
} # end while not at search boundary
|
||||
} # end for string
|
||||
|
||||
return undef; # Couldn't find a charset
|
||||
} # end find_charset_in
|
||||
#---------------------------------------------------------------------
|
||||
|
||||
|
||||
# Shortcuts for people who don't like exported functions:
|
||||
*file = \&html_file;
|
||||
*file_and_encoding = \&html_file_and_encoding;
|
||||
*outfile = \&html_outfile;
|
||||
|
||||
#=====================================================================
|
||||
# Package Return Value:
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::HTML - Open an HTML file with automatic charset detection
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
This document describes version 1.004 of
|
||||
IO::HTML, released September 26, 2020.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::HTML; # exports html_file by default
|
||||
use HTML::TreeBuilder;
|
||||
|
||||
my $tree = HTML::TreeBuilder->new_from_file(
|
||||
html_file('foo.html')
|
||||
);
|
||||
|
||||
# Alternative interface:
|
||||
open(my $in, '<:raw', 'bar.html');
|
||||
my $encoding = IO::HTML::sniff_encoding($in, 'bar.html');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
IO::HTML provides an easy way to open a file containing HTML while
|
||||
automatically determining its encoding. It uses the HTML5 encoding
|
||||
sniffing algorithm specified in section 8.2.2.2 of the draft standard.
|
||||
|
||||
The algorithm as implemented here is:
|
||||
|
||||
=over
|
||||
|
||||
=item 1.
|
||||
|
||||
If the file begins with a byte order mark indicating UTF-16LE,
|
||||
UTF-16BE, or UTF-8, then that is the encoding.
|
||||
|
||||
=item 2.
|
||||
|
||||
If the first C<$bytes_to_check> bytes of the file contain a C<< <meta> >> tag that
|
||||
indicates the charset, and Encode recognizes the specified charset
|
||||
name, then that is the encoding. (This portion of the algorithm is
|
||||
implemented by C<find_charset_in>.)
|
||||
|
||||
The C<< <meta> >> tag can be in one of two formats:
|
||||
|
||||
<meta charset="...">
|
||||
<meta http-equiv="Content-Type" content="...charset=...">
|
||||
|
||||
The search is case-insensitive, and the order of attributes within the
|
||||
tag is irrelevant. Any additional attributes of the tag are ignored.
|
||||
The first matching tag with a recognized encoding ends the search.
|
||||
|
||||
=item 3.
|
||||
|
||||
If the first C<$bytes_to_check> bytes of the file are valid UTF-8 (with at least 1
|
||||
non-ASCII character), then the encoding is UTF-8.
|
||||
|
||||
=item 4.
|
||||
|
||||
If all else fails, use the default character encoding. The HTML5
|
||||
standard suggests the default encoding should be locale dependent, but
|
||||
currently it is always C<cp1252> unless you set
|
||||
C<$IO::HTML::default_encoding> to a different value. Note:
|
||||
C<sniff_encoding> does not apply this step; only C<html_file> does
|
||||
that.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
=head2 html_file
|
||||
|
||||
$filehandle = html_file($filename, \%options);
|
||||
|
||||
This function (exported by default) is the primary entry point. It
|
||||
opens the file specified by C<$filename> for reading, uses
|
||||
C<sniff_encoding> to find a suitable encoding layer, and applies it.
|
||||
It also applies the C<:crlf> layer. If the file begins with a BOM,
|
||||
the filehandle is positioned just after the BOM.
|
||||
|
||||
The optional second argument is a hashref containing options. The
|
||||
possible keys are described under C<find_charset_in>.
|
||||
|
||||
If C<sniff_encoding> is unable to determine the encoding, it defaults
|
||||
to C<$IO::HTML::default_encoding>, which is set to C<cp1252>
|
||||
(a.k.a. Windows-1252) by default. According to the standard, the
|
||||
default should be locale dependent, but that is not currently
|
||||
implemented.
|
||||
|
||||
It dies if the file cannot be opened, or if C<sniff_encoding> cannot
|
||||
determine the encoding and C<$IO::HTML::default_encoding> has been set
|
||||
to C<undef>.
|
||||
|
||||
|
||||
=head2 html_file_and_encoding
|
||||
|
||||
($filehandle, $encoding, $bom)
|
||||
= html_file_and_encoding($filename, \%options);
|
||||
|
||||
This function (exported only by request) is just like C<html_file>,
|
||||
but returns more information. In addition to the filehandle, it
|
||||
returns the name of the encoding used, and a flag indicating whether a
|
||||
byte order mark was found (if C<$bom> is true, the file began with a
|
||||
BOM). This may be useful if you want to write the file out again
|
||||
(especially in conjunction with the C<html_outfile> function).
|
||||
|
||||
The optional second argument is a hashref containing options. The
|
||||
possible keys are described under C<find_charset_in>.
|
||||
|
||||
It dies if the file cannot be opened, or if C<sniff_encoding> cannot
|
||||
determine the encoding and C<$IO::HTML::default_encoding> has been set
|
||||
to C<undef>.
|
||||
|
||||
The result of calling C<html_file_and_encoding> in scalar context is undefined
|
||||
(in the C sense of there is no guarantee what you'll get).
|
||||
|
||||
|
||||
=head2 html_outfile
|
||||
|
||||
$filehandle = html_outfile($filename, $encoding, $bom);
|
||||
|
||||
This function (exported only by request) opens C<$filename> for output
|
||||
using C<$encoding>, and writes a BOM to it if C<$bom> is true.
|
||||
If C<$encoding> is C<undef>, it defaults to C<$IO::HTML::default_encoding>.
|
||||
C<$encoding> may be either an encoding name or an Encode::Encoding object.
|
||||
|
||||
It dies if the file cannot be opened, or if both C<$encoding> and
|
||||
C<$IO::HTML::default_encoding> are C<undef>.
|
||||
|
||||
|
||||
=head2 sniff_encoding
|
||||
|
||||
($encoding, $bom) = sniff_encoding($filehandle, $filename, \%options);
|
||||
|
||||
This function (exported only by request) runs the HTML5 encoding
|
||||
sniffing algorithm on C<$filehandle> (which must be seekable, and
|
||||
should have been opened in C<:raw> mode). C<$filename> is used only
|
||||
for error messages (if there's a problem using the filehandle), and
|
||||
defaults to "file" if omitted. The optional third argument is a
|
||||
hashref containing options. The possible keys are described under
|
||||
C<find_charset_in>.
|
||||
|
||||
It returns Perl's canonical name for the encoding, which is not
|
||||
necessarily the same as the MIME or IANA charset name. It returns
|
||||
C<undef> if the encoding cannot be determined. C<$bom> is true if the
|
||||
file began with a byte order mark. In scalar context, it returns only
|
||||
C<$encoding>.
|
||||
|
||||
The filehandle's position is restored to its original position
|
||||
(normally the beginning of the file) unless C<$bom> is true. In that
|
||||
case, the position is immediately after the BOM.
|
||||
|
||||
Tip: If you want to run C<sniff_encoding> on a file you've already
|
||||
loaded into a string, open an in-memory file on the string, and pass
|
||||
that handle:
|
||||
|
||||
($encoding, $bom) = do {
|
||||
open(my $fh, '<', \$string); sniff_encoding($fh)
|
||||
};
|
||||
|
||||
(This only makes sense if C<$string> contains bytes, not characters.)
|
||||
|
||||
|
||||
=head2 find_charset_in
|
||||
|
||||
$encoding = find_charset_in($string_containing_HTML, \%options);
|
||||
|
||||
This function (exported only by request) looks for charset information
|
||||
in a C<< <meta> >> tag in a possibly-incomplete HTML document using
|
||||
the "two step" algorithm specified by HTML5. It does not look for a BOM.
|
||||
The C<< <meta> >> tag must begin within the first C<$IO::HTML::bytes_to_check>
|
||||
bytes of the string.
|
||||
|
||||
It returns Perl's canonical name for the encoding, which is not
|
||||
necessarily the same as the MIME or IANA charset name. It returns
|
||||
C<undef> if no charset is specified or if the specified charset is not
|
||||
recognized by the Encode module.
|
||||
|
||||
The optional second argument is a hashref containing options. The
|
||||
following keys are recognized:
|
||||
|
||||
=over
|
||||
|
||||
=item C<encoding>
|
||||
|
||||
If true, return the L<Encode::Encoding> object instead of its name.
|
||||
Defaults to false.
|
||||
|
||||
=item C<need_pragma>
|
||||
|
||||
If true (the default), follow the HTML5 spec and examine the
|
||||
C<content> attribute only of C<< <meta http-equiv="Content-Type" >>.
|
||||
If set to 0, relax the HTML5 spec, and look for "charset=" in the
|
||||
C<content> attribute of I<every> meta tag.
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
By default, only C<html_file> is exported. Other functions may be
|
||||
exported on request.
|
||||
|
||||
For people who prefer not to export functions, all functions beginning
|
||||
with C<html_> have an alias without that prefix (e.g. you can call
|
||||
C<IO::HTML::file(...)> instead of C<IO::HTML::html_file(...)>. These
|
||||
aliases are not exportable.
|
||||
|
||||
=for Pod::Coverage
|
||||
file
|
||||
file_and_encoding
|
||||
outfile
|
||||
|
||||
The following export tags are available:
|
||||
|
||||
=over
|
||||
|
||||
=item C<:all>
|
||||
|
||||
All exportable functions.
|
||||
|
||||
=item C<:rw>
|
||||
|
||||
C<html_file>, C<html_file_and_encoding>, C<html_outfile>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
The HTML5 specification, section 8.2.2.2 Determining the character encoding:
|
||||
L<http://www.w3.org/TR/html5/syntax.html#determining-the-character-encoding>
|
||||
|
||||
=head1 DIAGNOSTICS
|
||||
|
||||
=over
|
||||
|
||||
=item C<< Could not read %s: %s >>
|
||||
|
||||
The specified file could not be read from for the reason specified by C<$!>.
|
||||
|
||||
|
||||
=item C<< Could not seek %s: %s >>
|
||||
|
||||
The specified file could not be rewound for the reason specified by C<$!>.
|
||||
|
||||
|
||||
=item C<< Failed to open %s: %s >>
|
||||
|
||||
The specified file could not be opened for reading for the reason
|
||||
specified by C<$!>.
|
||||
|
||||
|
||||
=item C<< No default encoding specified >>
|
||||
|
||||
The C<sniff_encoding> algorithm didn't find an encoding to use, and
|
||||
you set C<$IO::HTML::default_encoding> to C<undef>.
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=head1 CONFIGURATION AND ENVIRONMENT
|
||||
|
||||
There are two global variables that affect IO::HTML. If you need to
|
||||
change them, you should do so using C<local> if possible:
|
||||
|
||||
my $file = do {
|
||||
# This file may define the charset later in the header
|
||||
local $IO::HTML::bytes_to_check = 4096;
|
||||
html_file(...);
|
||||
};
|
||||
|
||||
=over
|
||||
|
||||
=item C<$bytes_to_check>
|
||||
|
||||
This is the number of bytes that C<sniff_encoding> will read from the
|
||||
stream. It is also the number of bytes that C<find_charset_in> will
|
||||
search for a C<< <meta> >> tag containing charset information.
|
||||
It must be a positive integer.
|
||||
|
||||
The HTML 5 specification recommends using the default value of 1024,
|
||||
but some pages do not follow the specification.
|
||||
|
||||
=item C<$default_encoding>
|
||||
|
||||
This is the encoding that C<html_file> and C<html_file_and_encoding>
|
||||
will use if no encoding can be detected by C<sniff_encoding>.
|
||||
The default value is C<cp1252> (a.k.a. Windows-1252).
|
||||
|
||||
Setting it to C<undef> will cause the file subroutines to croak if
|
||||
C<sniff_encoding> fails to determine the encoding. (C<sniff_encoding>
|
||||
itself does not use C<$default_encoding>).
|
||||
|
||||
=back
|
||||
|
||||
=head1 DEPENDENCIES
|
||||
|
||||
IO::HTML has no non-core dependencies for Perl 5.8.7+. With earlier
|
||||
versions of Perl 5.8, you need to upgrade L<Encode> to at least
|
||||
version 2.10, and
|
||||
you may need to upgrade L<Exporter> to at least version
|
||||
5.57.
|
||||
|
||||
=head1 INCOMPATIBILITIES
|
||||
|
||||
None reported.
|
||||
|
||||
=head1 BUGS AND LIMITATIONS
|
||||
|
||||
No bugs have been reported.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Christopher J. Madsen S<C<< <perl AT cjmweb.net> >>>
|
||||
|
||||
Please report any bugs or feature requests
|
||||
to S<C<< <bug-IO-HTML AT rt.cpan.org> >>>
|
||||
or through the web interface at
|
||||
L<< http://rt.cpan.org/Public/Bug/Report.html?Queue=IO-HTML >>.
|
||||
|
||||
You can follow or contribute to IO-HTML's development at
|
||||
L<< https://github.com/madsen/io-html >>.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2020 by Christopher J. Madsen.
|
||||
|
||||
This is free software; you can redistribute it and/or modify it under
|
||||
the same terms as the Perl 5 programming language system itself.
|
||||
|
||||
=head1 DISCLAIMER OF WARRANTY
|
||||
|
||||
BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
|
||||
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
|
||||
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
|
||||
PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
|
||||
EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
||||
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
|
||||
ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
|
||||
YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
|
||||
NECESSARY SERVICING, REPAIR, OR CORRECTION.
|
||||
|
||||
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
|
||||
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
|
||||
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE
|
||||
LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
|
||||
OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
|
||||
THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
|
||||
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
|
||||
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
|
||||
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
|
||||
SUCH DAMAGES.
|
||||
|
||||
=cut
|
||||
335
gitportable/usr/share/perl5/vendor_perl/IO/InnerFile.pm
Normal file
335
gitportable/usr/share/perl5/vendor_perl/IO/InnerFile.pm
Normal file
@@ -0,0 +1,335 @@
|
||||
package IO::InnerFile;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Symbol;
|
||||
|
||||
our $VERSION = '2.113';
|
||||
|
||||
sub new {
|
||||
my ($class, $fh, $start, $lg) = @_;
|
||||
$start = 0 if (!$start or ($start < 0));
|
||||
$lg = 0 if (!$lg or ($lg < 0));
|
||||
|
||||
### Create the underlying "object":
|
||||
my $a = {
|
||||
FH => $fh,
|
||||
CRPOS => 0,
|
||||
START => $start,
|
||||
LG => $lg,
|
||||
};
|
||||
|
||||
### Create a new filehandle tied to this object:
|
||||
$fh = gensym;
|
||||
tie(*$fh, $class, $a);
|
||||
return bless($fh, $class);
|
||||
}
|
||||
|
||||
sub TIEHANDLE {
|
||||
my ($class, $data) = @_;
|
||||
return bless($data, $class);
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my ($self) = @_;
|
||||
$self->close() if (ref($self) eq 'SCALAR');
|
||||
}
|
||||
|
||||
sub set_length { tied(${$_[0]})->{LG} = $_[1]; }
|
||||
sub get_length { tied(${$_[0]})->{LG}; }
|
||||
sub add_length { tied(${$_[0]})->{LG} += $_[1]; }
|
||||
|
||||
sub set_start { tied(${$_[0]})->{START} = $_[1]; }
|
||||
sub get_start { tied(${$_[0]})->{START}; }
|
||||
sub set_end { tied(${$_[0]})->{LG} = $_[1] - tied(${$_[0]})->{START}; }
|
||||
sub get_end { tied(${$_[0]})->{LG} + tied(${$_[0]})->{START}; }
|
||||
|
||||
sub write { shift->WRITE(@_) }
|
||||
sub print { shift->PRINT(@_) }
|
||||
sub printf { shift->PRINTF(@_) }
|
||||
sub flush { "0 but true"; }
|
||||
sub fileno { }
|
||||
sub binmode { 1; }
|
||||
sub getc { return GETC(tied(${$_[0]}) ); }
|
||||
sub read { return READ( tied(${$_[0]}), @_[1,2,3] ); }
|
||||
sub readline { return READLINE( tied(${$_[0]}) ); }
|
||||
|
||||
sub getline { return READLINE( tied(${$_[0]}) ); }
|
||||
sub close { return CLOSE(tied(${$_[0]}) ); }
|
||||
|
||||
sub seek {
|
||||
my ($self, $ofs, $whence) = @_;
|
||||
$self = tied( $$self );
|
||||
|
||||
$self->{CRPOS} = $ofs if ($whence == 0);
|
||||
$self->{CRPOS}+= $ofs if ($whence == 1);
|
||||
$self->{CRPOS} = $self->{LG} + $ofs if ($whence == 2);
|
||||
|
||||
$self->{CRPOS} = 0 if ($self->{CRPOS} < 0);
|
||||
$self->{CRPOS} = $self->{LG} if ($self->{CRPOS} > $self->{LG});
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub tell {
|
||||
return tied(${$_[0]})->{CRPOS};
|
||||
}
|
||||
|
||||
sub WRITE {
|
||||
die "inner files can only open for reading\n";
|
||||
}
|
||||
|
||||
sub PRINT {
|
||||
die "inner files can only open for reading\n";
|
||||
}
|
||||
|
||||
sub PRINTF {
|
||||
die "inner files can only open for reading\n";
|
||||
}
|
||||
|
||||
sub GETC {
|
||||
my ($self) = @_;
|
||||
return 0 if ($self->{CRPOS} >= $self->{LG});
|
||||
|
||||
my $data;
|
||||
|
||||
### Save and seek...
|
||||
my $old_pos = $self->{FH}->tell;
|
||||
$self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
|
||||
|
||||
### ...read...
|
||||
my $lg = $self->{FH}->read($data, 1);
|
||||
$self->{CRPOS} += $lg;
|
||||
|
||||
### ...and restore:
|
||||
$self->{FH}->seek($old_pos, 0);
|
||||
|
||||
$self->{LG} = $self->{CRPOS} unless ($lg);
|
||||
return ($lg ? $data : undef);
|
||||
}
|
||||
|
||||
sub READ {
|
||||
my ($self, $undefined, $lg, $ofs) = @_;
|
||||
$undefined = undef;
|
||||
|
||||
return 0 if ($self->{CRPOS} >= $self->{LG});
|
||||
$lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
|
||||
return 0 unless ($lg);
|
||||
|
||||
### Save and seek...
|
||||
my $old_pos = $self->{FH}->tell;
|
||||
$self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
|
||||
|
||||
### ...read...
|
||||
$lg = $self->{FH}->read($_[1], $lg, $_[3] );
|
||||
$self->{CRPOS} += $lg;
|
||||
|
||||
### ...and restore:
|
||||
$self->{FH}->seek($old_pos, 0);
|
||||
|
||||
$self->{LG} = $self->{CRPOS} unless ($lg);
|
||||
return $lg;
|
||||
}
|
||||
|
||||
sub READLINE {
|
||||
my ($self) = @_;
|
||||
return $self->_readline_helper() unless wantarray;
|
||||
my @arr;
|
||||
while(defined(my $line = $self->_readline_helper())) {
|
||||
push(@arr, $line);
|
||||
}
|
||||
return @arr;
|
||||
}
|
||||
|
||||
sub _readline_helper {
|
||||
my ($self) = @_;
|
||||
return undef if ($self->{CRPOS} >= $self->{LG});
|
||||
|
||||
# Handle slurp mode (CPAN ticket #72710)
|
||||
if (! defined($/)) {
|
||||
my $text;
|
||||
$self->READ($text, $self->{LG} - $self->{CRPOS});
|
||||
return $text;
|
||||
}
|
||||
|
||||
### Save and seek...
|
||||
my $old_pos = $self->{FH}->tell;
|
||||
$self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
|
||||
|
||||
### ...read...
|
||||
my $text = $self->{FH}->getline;
|
||||
|
||||
### ...and restore:
|
||||
$self->{FH}->seek($old_pos, 0);
|
||||
|
||||
#### If we detected a new EOF ...
|
||||
unless (defined $text) {
|
||||
$self->{LG} = $self->{CRPOS};
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $lg=length($text);
|
||||
|
||||
$lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
|
||||
$self->{CRPOS} += $lg;
|
||||
|
||||
return substr($text, 0,$lg);
|
||||
}
|
||||
|
||||
sub CLOSE { %{$_[0]}=(); }
|
||||
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::InnerFile - define a file inside another file
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use IO::InnerFile;
|
||||
|
||||
# Read a subset of a file:
|
||||
my $fh = _some_file_handle;
|
||||
my $start = 10;
|
||||
my $length = 50;
|
||||
my $inner = IO::InnerFile->new($fh, $start, $length);
|
||||
while (my $line = <$inner>) {
|
||||
# ...
|
||||
}
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
If you have a file handle that can C<seek> and C<tell>, then you
|
||||
can open an L<IO::InnerFile> on a range of the underlying file.
|
||||
|
||||
=head1 CONSTRUCTORS
|
||||
|
||||
L<IO::InnerFile> implements the following constructors.
|
||||
|
||||
=head2 new
|
||||
|
||||
my $inner = IO::InnerFile->new($fh);
|
||||
$inner = IO::InnerFile->new($fh, 10);
|
||||
$inner = IO::InnerFile->new($fh, 10, 50);
|
||||
|
||||
Create a new L<IO::InnerFile> opened on the given file handle.
|
||||
The file handle supplied B<MUST> be able to both C<seek> and C<tell>.
|
||||
|
||||
The second and third parameters are start and length. Both are defaulted
|
||||
to zero (C<0>). Negative values are silently coerced to zero.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<IO::InnerFile> implements the following methods.
|
||||
|
||||
=head2 add_length
|
||||
|
||||
$inner->add_length(30);
|
||||
|
||||
Add to the virtual length of the inner file by the number given in bytes.
|
||||
|
||||
=head2 add_start
|
||||
|
||||
$inner->add_start(30);
|
||||
|
||||
Add to the virtual position of the inner file by the number given in bytes.
|
||||
|
||||
=head2 binmode
|
||||
|
||||
$inner->binmode();
|
||||
|
||||
This is a NOOP method just to satisfy the normal L<IO::File> interface.
|
||||
|
||||
=head2 close
|
||||
|
||||
=head2 fileno
|
||||
|
||||
$inner->fileno();
|
||||
|
||||
This is a NOOP method just to satisfy the normal L<IO::File> interface.
|
||||
|
||||
=head2 flush
|
||||
|
||||
$inner->flush();
|
||||
|
||||
This is a NOOP method just to satisfy the normal L<IO::File> interface.
|
||||
|
||||
=head2 get_end
|
||||
|
||||
my $num_bytes = $inner->get_end();
|
||||
|
||||
Get the virtual end position of the inner file in bytes.
|
||||
|
||||
=head2 get_length
|
||||
|
||||
my $num_bytes = $inner->get_length();
|
||||
|
||||
Get the virtual length of the inner file in bytes.
|
||||
|
||||
=head2 get_start
|
||||
|
||||
my $num_bytes = $inner->get_start();
|
||||
|
||||
Get the virtual position of the inner file in bytes.
|
||||
|
||||
=head2 getc
|
||||
|
||||
=head2 getline
|
||||
|
||||
=head2 print LIST
|
||||
|
||||
=head2 printf
|
||||
|
||||
=head2 read
|
||||
|
||||
=head2 readline
|
||||
|
||||
=head2 seek
|
||||
|
||||
=head2 set_end
|
||||
|
||||
$inner->set_end(30);
|
||||
|
||||
Set the virtual end of the inner file in bytes (this basically just alters the length).
|
||||
|
||||
=head2 set_length
|
||||
|
||||
$inner->set_length(30);
|
||||
|
||||
Set the virtual length of the inner file in bytes.
|
||||
|
||||
=head2 set_start
|
||||
|
||||
$inner->set_start(30);
|
||||
|
||||
Set the virtual start position of the inner file in bytes.
|
||||
|
||||
=head2 tell
|
||||
|
||||
=head2 write
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>).
|
||||
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
Dianne Skoll (F<dfs@roaringpenguin.com>).
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
174
gitportable/usr/share/perl5/vendor_perl/IO/Lines.pm
Normal file
174
gitportable/usr/share/perl5/vendor_perl/IO/Lines.pm
Normal file
@@ -0,0 +1,174 @@
|
||||
package IO::Lines;
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use IO::ScalarArray;
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
our $VERSION = '2.113';
|
||||
|
||||
# Inheritance:
|
||||
our @ISA = qw(IO::ScalarArray); ### also gets us new_tie :-)
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Lines - IO:: interface for reading/writing an array of lines
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::Lines;
|
||||
|
||||
### See IO::ScalarArray for details
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class implements objects which behave just like FileHandle
|
||||
(or IO::Handle) objects, except that you may use them to write to
|
||||
(or read from) an array of lines. C<tiehandle> capable as well.
|
||||
|
||||
This is a subclass of L<IO::ScalarArray|IO::ScalarArray>
|
||||
in which the underlying
|
||||
array has its data stored in a line-oriented-format: that is,
|
||||
every element ends in a C<"\n">, with the possible exception of the
|
||||
final element. This makes C<getline()> I<much> more efficient;
|
||||
if you plan to do line-oriented reading/printing, you want this class.
|
||||
|
||||
The C<print()> method will enforce this rule, so you can print
|
||||
arbitrary data to the line-array: it will break the data at
|
||||
newlines appropriately.
|
||||
|
||||
See L<IO::ScalarArray> for full usage and warnings.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# getline
|
||||
#
|
||||
# Instance method, override.
|
||||
# Return the next line, or undef on end of data.
|
||||
# Can safely be called in an array context.
|
||||
# Currently, lines are delimited by "\n".
|
||||
#
|
||||
sub getline {
|
||||
my $self = shift;
|
||||
|
||||
if (!defined $/) {
|
||||
return join( '', $self->_getlines_for_newlines );
|
||||
}
|
||||
elsif ($/ eq "\n") {
|
||||
if (!*$self->{Pos}) { ### full line...
|
||||
return *$self->{AR}[*$self->{Str}++];
|
||||
}
|
||||
else { ### partial line...
|
||||
my $partial = substr(*$self->{AR}[*$self->{Str}++], *$self->{Pos});
|
||||
*$self->{Pos} = 0;
|
||||
return $partial;
|
||||
}
|
||||
}
|
||||
else {
|
||||
croak 'unsupported $/: must be "\n" or undef';
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# getlines
|
||||
#
|
||||
# Instance method, override.
|
||||
# Return an array comprised of the remaining lines, or () on end of data.
|
||||
# Must be called in an array context.
|
||||
# Currently, lines are delimited by "\n".
|
||||
#
|
||||
sub getlines {
|
||||
my $self = shift;
|
||||
wantarray or croak("can't call getlines in scalar context!");
|
||||
|
||||
if ((defined $/) and ($/ eq "\n")) {
|
||||
return $self->_getlines_for_newlines(@_);
|
||||
}
|
||||
else { ### slow but steady
|
||||
return $self->SUPER::getlines(@_);
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# _getlines_for_newlines
|
||||
#
|
||||
# Instance method, private.
|
||||
# If $/ is newline, do fast getlines.
|
||||
# This CAN NOT invoke getline!
|
||||
#
|
||||
sub _getlines_for_newlines {
|
||||
my $self = shift;
|
||||
my ($rArray, $Str, $Pos) = @{*$self}{ qw( AR Str Pos ) };
|
||||
my @partial = ();
|
||||
|
||||
if ($Pos) { ### partial line...
|
||||
@partial = (substr( $rArray->[ $Str++ ], $Pos ));
|
||||
*$self->{Pos} = 0;
|
||||
}
|
||||
*$self->{Str} = scalar @$rArray; ### about to exhaust @$rArray
|
||||
return (@partial,
|
||||
@$rArray[ $Str .. $#$rArray ]); ### remaining full lines...
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# print ARGS...
|
||||
#
|
||||
# Instance method, override.
|
||||
# Print ARGS to the underlying line array.
|
||||
#
|
||||
sub print {
|
||||
if (defined $\ && $\ ne "\n") {
|
||||
croak 'unsupported $\: must be "\n" or undef';
|
||||
}
|
||||
|
||||
my $self = shift;
|
||||
### print STDERR "\n[[ARRAY WAS...\n", @{*$self->{AR}}, "<<EOF>>\n";
|
||||
my @lines = split /^/, join('', @_); @lines or return 1;
|
||||
|
||||
### Did the previous print not end with a newline?
|
||||
### If so, append first line:
|
||||
if (@{*$self->{AR}} and (*$self->{AR}[-1] !~ /\n\Z/)) {
|
||||
*$self->{AR}[-1] .= shift @lines;
|
||||
}
|
||||
push @{*$self->{AR}}, @lines; ### add the remainder
|
||||
### print STDERR "\n[[ARRAY IS NOW...\n", @{*$self->{AR}}, "<<EOF>>\n";
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
$Id: Lines.pm,v 1.3 2005/02/10 21:21:53 dfs Exp $
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>).
|
||||
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
Dianne Skoll (F<dfs@roaringpenguin.com>).
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
724
gitportable/usr/share/perl5/vendor_perl/IO/Scalar.pm
Normal file
724
gitportable/usr/share/perl5/vendor_perl/IO/Scalar.pm
Normal file
@@ -0,0 +1,724 @@
|
||||
package IO::Scalar;
|
||||
|
||||
use strict;
|
||||
|
||||
use Carp;
|
||||
use IO::Handle;
|
||||
|
||||
### Stringification, courtesy of B. K. Oxley (binkley): :-)
|
||||
use overload '""' => sub { ${*{$_[0]}->{SR}} };
|
||||
use overload 'bool' => sub { 1 }; ### have to do this, so object is true!
|
||||
|
||||
### The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
our $VERSION = '2.113';
|
||||
|
||||
### Inheritance:
|
||||
our @ISA = qw(IO::Handle);
|
||||
|
||||
### This stuff should be got rid of ASAP.
|
||||
require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
|
||||
|
||||
#==============================
|
||||
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Scalar - IO:: interface for reading/writing a scalar
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Perform I/O on strings, using the basic OO interface...
|
||||
|
||||
use 5.005;
|
||||
use IO::Scalar;
|
||||
$data = "My message:\n";
|
||||
|
||||
### Open a handle on a string, and append to it:
|
||||
$SH = new IO::Scalar \$data;
|
||||
$SH->print("Hello");
|
||||
$SH->print(", world!\nBye now!\n");
|
||||
print "The string is now: ", $data, "\n";
|
||||
|
||||
### Open a handle on a string, read it line-by-line, then close it:
|
||||
$SH = new IO::Scalar \$data;
|
||||
while (defined($_ = $SH->getline)) {
|
||||
print "Got line: $_";
|
||||
}
|
||||
$SH->close;
|
||||
|
||||
### Open a handle on a string, and slurp in all the lines:
|
||||
$SH = new IO::Scalar \$data;
|
||||
print "All lines:\n", $SH->getlines;
|
||||
|
||||
### Get the current position (either of two ways):
|
||||
$pos = $SH->getpos;
|
||||
$offset = $SH->tell;
|
||||
|
||||
### Set the current position (either of two ways):
|
||||
$SH->setpos($pos);
|
||||
$SH->seek($offset, 0);
|
||||
|
||||
### Open an anonymous temporary scalar:
|
||||
$SH = new IO::Scalar;
|
||||
$SH->print("Hi there!");
|
||||
print "I printed: ", ${$SH->sref}, "\n"; ### get at value
|
||||
|
||||
|
||||
Don't like OO for your I/O? No problem.
|
||||
Thanks to the magic of an invisible tie(), the following now
|
||||
works out of the box, just as it does with IO::Handle:
|
||||
|
||||
use 5.005;
|
||||
use IO::Scalar;
|
||||
$data = "My message:\n";
|
||||
|
||||
### Open a handle on a string, and append to it:
|
||||
$SH = new IO::Scalar \$data;
|
||||
print $SH "Hello";
|
||||
print $SH ", world!\nBye now!\n";
|
||||
print "The string is now: ", $data, "\n";
|
||||
|
||||
### Open a handle on a string, read it line-by-line, then close it:
|
||||
$SH = new IO::Scalar \$data;
|
||||
while (<$SH>) {
|
||||
print "Got line: $_";
|
||||
}
|
||||
close $SH;
|
||||
|
||||
### Open a handle on a string, and slurp in all the lines:
|
||||
$SH = new IO::Scalar \$data;
|
||||
print "All lines:\n", <$SH>;
|
||||
|
||||
### Get the current position (WARNING: requires 5.6):
|
||||
$offset = tell $SH;
|
||||
|
||||
### Set the current position (WARNING: requires 5.6):
|
||||
seek $SH, $offset, 0;
|
||||
|
||||
### Open an anonymous temporary scalar:
|
||||
$SH = new IO::Scalar;
|
||||
print $SH "Hi there!";
|
||||
print "I printed: ", ${$SH->sref}, "\n"; ### get at value
|
||||
|
||||
|
||||
And for you folks with 1.x code out there: the old tie() style still works,
|
||||
though this is I<unnecessary and deprecated>:
|
||||
|
||||
use IO::Scalar;
|
||||
|
||||
### Writing to a scalar...
|
||||
my $s;
|
||||
tie *OUT, 'IO::Scalar', \$s;
|
||||
print OUT "line 1\nline 2\n", "line 3\n";
|
||||
print "String is now: $s\n"
|
||||
|
||||
### Reading and writing an anonymous scalar...
|
||||
tie *OUT, 'IO::Scalar';
|
||||
print OUT "line 1\nline 2\n", "line 3\n";
|
||||
tied(OUT)->seek(0,0);
|
||||
while (<OUT>) {
|
||||
print "Got line: ", $_;
|
||||
}
|
||||
|
||||
|
||||
Stringification works, too!
|
||||
|
||||
my $SH = new IO::Scalar \$data;
|
||||
print $SH "Hello, ";
|
||||
print $SH "world!";
|
||||
print "I printed: $SH\n";
|
||||
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is part of the IO::Stringy distribution;
|
||||
see L<IO::Stringy> for change log and general information.
|
||||
|
||||
The IO::Scalar class implements objects which behave just like
|
||||
IO::Handle (or FileHandle) objects, except that you may use them
|
||||
to write to (or read from) scalars. These handles are
|
||||
automatically C<tiehandle>d (though please see L<"WARNINGS">
|
||||
for information relevant to your Perl version).
|
||||
|
||||
|
||||
Basically, this:
|
||||
|
||||
my $s;
|
||||
$SH = new IO::Scalar \$s;
|
||||
$SH->print("Hel", "lo, "); ### OO style
|
||||
$SH->print("world!\n"); ### ditto
|
||||
|
||||
Or this:
|
||||
|
||||
my $s;
|
||||
$SH = tie *OUT, 'IO::Scalar', \$s;
|
||||
print OUT "Hel", "lo, "; ### non-OO style
|
||||
print OUT "world!\n"; ### ditto
|
||||
|
||||
Causes $s to be set to:
|
||||
|
||||
"Hello, world!\n"
|
||||
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
=head2 Construction
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item new [ARGS...]
|
||||
|
||||
I<Class method.>
|
||||
Return a new, unattached scalar handle.
|
||||
If any arguments are given, they're sent to open().
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless \do { local *FH }, $class;
|
||||
tie *$self, $class, $self;
|
||||
$self->open(@_); ### open on anonymous by default
|
||||
$self;
|
||||
}
|
||||
sub DESTROY {
|
||||
shift->close;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item open [SCALARREF]
|
||||
|
||||
I<Instance method.>
|
||||
Open the scalar handle on a new scalar, pointed to by SCALARREF.
|
||||
If no SCALARREF is given, a "private" scalar is created to hold
|
||||
the file data.
|
||||
|
||||
Returns the self object on success, undefined on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub open {
|
||||
my ($self, $sref) = @_;
|
||||
|
||||
### Sanity:
|
||||
defined($sref) or do {my $s = ''; $sref = \$s};
|
||||
(ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";
|
||||
|
||||
### Setup:
|
||||
*$self->{Pos} = 0; ### seek position
|
||||
*$self->{SR} = $sref; ### scalar reference
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item opened
|
||||
|
||||
I<Instance method.>
|
||||
Is the scalar handle opened on something?
|
||||
|
||||
=cut
|
||||
|
||||
sub opened {
|
||||
*{shift()}->{SR};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item close
|
||||
|
||||
I<Instance method.>
|
||||
Disassociate the scalar handle from its underlying scalar.
|
||||
Done automatically on destroy.
|
||||
|
||||
=cut
|
||||
|
||||
sub close {
|
||||
my $self = shift;
|
||||
%{*$self} = ();
|
||||
1;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
#==============================
|
||||
|
||||
=head2 Input and output
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item flush
|
||||
|
||||
I<Instance method.>
|
||||
No-op, provided for OO compatibility.
|
||||
|
||||
=cut
|
||||
|
||||
sub flush { "0 but true" }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item fileno
|
||||
|
||||
I<Instance method.>
|
||||
No-op, returns undef
|
||||
|
||||
=cut
|
||||
|
||||
sub fileno { }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getc
|
||||
|
||||
I<Instance method.>
|
||||
Return the next character, or undef if none remain.
|
||||
|
||||
=cut
|
||||
|
||||
sub getc {
|
||||
my $self = shift;
|
||||
|
||||
### Return undef right away if at EOF; else, move pos forward:
|
||||
return undef if $self->eof;
|
||||
substr(${*$self->{SR}}, *$self->{Pos}++, 1);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getline
|
||||
|
||||
I<Instance method.>
|
||||
Return the next line, or undef on end of string.
|
||||
Can safely be called in an array context.
|
||||
Currently, lines are delimited by "\n".
|
||||
|
||||
=cut
|
||||
|
||||
sub getline {
|
||||
my $self = shift;
|
||||
|
||||
### Return undef right away if at EOF:
|
||||
return undef if $self->eof;
|
||||
|
||||
### Get next line:
|
||||
my $sr = *$self->{SR};
|
||||
my $i = *$self->{Pos}; ### Start matching at this point.
|
||||
|
||||
### Minimal impact implementation!
|
||||
### We do the fast thing (no regexps) if using the
|
||||
### classic input record separator.
|
||||
|
||||
### Case 1: $/ is undef: slurp all...
|
||||
if (!defined($/)) {
|
||||
*$self->{Pos} = length $$sr;
|
||||
return substr($$sr, $i);
|
||||
}
|
||||
|
||||
### Case 2: $/ is "\n": zoom zoom zoom...
|
||||
elsif ($/ eq "\012") {
|
||||
|
||||
### Seek ahead for "\n"... yes, this really is faster than regexps.
|
||||
my $len = length($$sr);
|
||||
for (; $i < $len; ++$i) {
|
||||
last if ord (substr ($$sr, $i, 1)) == 10;
|
||||
}
|
||||
|
||||
### Extract the line:
|
||||
my $line;
|
||||
if ($i < $len) { ### We found a "\n":
|
||||
$line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
|
||||
*$self->{Pos} = $i+1; ### Remember where we finished up.
|
||||
}
|
||||
else { ### No "\n"; slurp the remainder:
|
||||
$line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
|
||||
*$self->{Pos} = $len;
|
||||
}
|
||||
return $line;
|
||||
}
|
||||
|
||||
### Case 3: $/ is ref to int. Do fixed-size records.
|
||||
### (Thanks to Dominique Quatravaux.)
|
||||
elsif (ref($/)) {
|
||||
my $len = length($$sr);
|
||||
my $i = ${$/} + 0;
|
||||
my $line = substr ($$sr, *$self->{Pos}, $i);
|
||||
*$self->{Pos} += $i;
|
||||
*$self->{Pos} = $len if (*$self->{Pos} > $len);
|
||||
return $line;
|
||||
}
|
||||
|
||||
### Case 4: $/ is either "" (paragraphs) or something weird...
|
||||
### This is Graham's general-purpose stuff, which might be
|
||||
### a tad slower than Case 2 for typical data, because
|
||||
### of the regexps.
|
||||
else {
|
||||
pos($$sr) = $i;
|
||||
|
||||
### If in paragraph mode, skip leading lines (and update i!):
|
||||
length($/) or
|
||||
(($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));
|
||||
|
||||
### If we see the separator in the buffer ahead...
|
||||
if (length($/)
|
||||
? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp!
|
||||
: $$sr =~ m,\n\n,g ### (a paragraph)
|
||||
) {
|
||||
*$self->{Pos} = pos $$sr;
|
||||
return substr($$sr, $i, *$self->{Pos}-$i);
|
||||
}
|
||||
### Else if no separator remains, just slurp the rest:
|
||||
else {
|
||||
*$self->{Pos} = length $$sr;
|
||||
return substr($$sr, $i);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getlines
|
||||
|
||||
I<Instance method.>
|
||||
Get all remaining lines.
|
||||
It will croak() if accidentally called in a scalar context.
|
||||
|
||||
=cut
|
||||
|
||||
sub getlines {
|
||||
my $self = shift;
|
||||
wantarray or croak("can't call getlines in scalar context!");
|
||||
my ($line, @lines);
|
||||
push @lines, $line while (defined($line = $self->getline));
|
||||
@lines;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item print ARGS...
|
||||
|
||||
I<Instance method.>
|
||||
Print ARGS to the underlying scalar.
|
||||
|
||||
B<Warning:> this continues to always cause a seek to the end
|
||||
of the string, but if you perform seek()s and tell()s, it is
|
||||
still safer to explicitly seek-to-end before subsequent print()s.
|
||||
|
||||
=cut
|
||||
|
||||
sub print {
|
||||
my $self = shift;
|
||||
*$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
|
||||
1;
|
||||
}
|
||||
sub _unsafe_print {
|
||||
my $self = shift;
|
||||
my $append = join('', @_) . $\;
|
||||
${*$self->{SR}} .= $append;
|
||||
*$self->{Pos} += length($append);
|
||||
1;
|
||||
}
|
||||
sub _old_print {
|
||||
my $self = shift;
|
||||
${*$self->{SR}} .= join('', @_) . $\;
|
||||
*$self->{Pos} = length(${*$self->{SR}});
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item read BUF, NBYTES, [OFFSET]
|
||||
|
||||
I<Instance method.>
|
||||
Read some bytes from the scalar.
|
||||
Returns the number of bytes actually read, 0 on end-of-file, undef on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub read {
|
||||
my $self = $_[0];
|
||||
my $n = $_[2];
|
||||
my $off = $_[3] || 0;
|
||||
|
||||
my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
|
||||
$n = length($read);
|
||||
*$self->{Pos} += $n;
|
||||
($off ? substr($_[1], $off) : $_[1]) = $read;
|
||||
return $n;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item write BUF, NBYTES, [OFFSET]
|
||||
|
||||
I<Instance method.>
|
||||
Write some bytes to the scalar.
|
||||
|
||||
=cut
|
||||
|
||||
sub write {
|
||||
my $self = $_[0];
|
||||
my $n = $_[2];
|
||||
my $off = $_[3] || 0;
|
||||
|
||||
my $data = substr($_[1], $off, $n);
|
||||
$n = length($data);
|
||||
$self->print($data);
|
||||
return $n;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item sysread BUF, LEN, [OFFSET]
|
||||
|
||||
I<Instance method.>
|
||||
Read some bytes from the scalar.
|
||||
Returns the number of bytes actually read, 0 on end-of-file, undef on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub sysread {
|
||||
my $self = shift;
|
||||
$self->read(@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item syswrite BUF, NBYTES, [OFFSET]
|
||||
|
||||
I<Instance method.>
|
||||
Write some bytes to the scalar.
|
||||
|
||||
=cut
|
||||
|
||||
sub syswrite {
|
||||
my $self = shift;
|
||||
$self->write(@_);
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#==============================
|
||||
|
||||
=head2 Seeking/telling and other attributes
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item autoflush
|
||||
|
||||
I<Instance method.>
|
||||
No-op, provided for OO compatibility.
|
||||
|
||||
=cut
|
||||
|
||||
sub autoflush {}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item binmode
|
||||
|
||||
I<Instance method.>
|
||||
No-op, provided for OO compatibility.
|
||||
|
||||
=cut
|
||||
|
||||
sub binmode {}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item clearerr
|
||||
|
||||
I<Instance method.> Clear the error and EOF flags. A no-op.
|
||||
|
||||
=cut
|
||||
|
||||
sub clearerr { 1 }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item eof
|
||||
|
||||
I<Instance method.> Are we at end of file?
|
||||
|
||||
=cut
|
||||
|
||||
sub eof {
|
||||
my $self = shift;
|
||||
(*$self->{Pos} >= length(${*$self->{SR}}));
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item seek OFFSET, WHENCE
|
||||
|
||||
I<Instance method.> Seek to a given position in the stream.
|
||||
|
||||
=cut
|
||||
|
||||
sub seek {
|
||||
my ($self, $pos, $whence) = @_;
|
||||
my $eofpos = length(${*$self->{SR}});
|
||||
|
||||
### Seek:
|
||||
if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET
|
||||
elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR
|
||||
elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END
|
||||
else { croak "bad seek whence ($whence)" }
|
||||
|
||||
### Fixup:
|
||||
if (*$self->{Pos} < 0) { *$self->{Pos} = 0 }
|
||||
if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
|
||||
return 1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item sysseek OFFSET, WHENCE
|
||||
|
||||
I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.>
|
||||
|
||||
=cut
|
||||
|
||||
sub sysseek {
|
||||
my $self = shift;
|
||||
$self->seek (@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item tell
|
||||
|
||||
I<Instance method.>
|
||||
Return the current position in the stream, as a numeric offset.
|
||||
|
||||
=cut
|
||||
|
||||
sub tell { *{shift()}->{Pos} }
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# use_RS [YESNO]
|
||||
#
|
||||
# I<Instance method.>
|
||||
# Obey the current setting of $/, like IO::Handle does?
|
||||
# Default is false in 1.x, but cold-welded true in 2.x and later.
|
||||
#
|
||||
sub use_RS {
|
||||
my ($self, $yesno) = @_;
|
||||
carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item setpos POS
|
||||
|
||||
I<Instance method.>
|
||||
Set the current position, using the opaque value returned by C<getpos()>.
|
||||
|
||||
=cut
|
||||
|
||||
sub setpos { shift->seek($_[0],0) }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getpos
|
||||
|
||||
I<Instance method.>
|
||||
Return the current position in the string, as an opaque object.
|
||||
|
||||
=cut
|
||||
|
||||
*getpos = \&tell;
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item sref
|
||||
|
||||
I<Instance method.>
|
||||
Return a reference to the underlying scalar.
|
||||
|
||||
=cut
|
||||
|
||||
sub sref { *{shift()}->{SR} }
|
||||
|
||||
|
||||
#------------------------------
|
||||
# Tied handle methods...
|
||||
#------------------------------
|
||||
|
||||
# Conventional tiehandle interface:
|
||||
sub TIEHANDLE {
|
||||
((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar"))
|
||||
? $_[1]
|
||||
: shift->new(@_));
|
||||
}
|
||||
sub GETC { shift->getc(@_) }
|
||||
sub PRINT { shift->print(@_) }
|
||||
sub PRINTF { shift->print(sprintf(shift, @_)) }
|
||||
sub READ { shift->read(@_) }
|
||||
sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
|
||||
sub WRITE { shift->write(@_); }
|
||||
sub CLOSE { shift->close(@_); }
|
||||
sub SEEK { shift->seek(@_); }
|
||||
sub TELL { shift->tell(@_); }
|
||||
sub EOF { shift->eof(@_); }
|
||||
sub BINMODE { 1; }
|
||||
|
||||
#------------------------------------------------------------
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>).
|
||||
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
Dianne Skoll (F<dfs@roaringpenguin.com>).
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
751
gitportable/usr/share/perl5/vendor_perl/IO/ScalarArray.pm
Normal file
751
gitportable/usr/share/perl5/vendor_perl/IO/ScalarArray.pm
Normal file
@@ -0,0 +1,751 @@
|
||||
package IO::ScalarArray;
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use IO::Handle;
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
our $VERSION = '2.113';
|
||||
|
||||
# Inheritance:
|
||||
our @ISA = qw(IO::Handle);
|
||||
require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::ScalarArray - IO:: interface for reading/writing an array of scalars
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Perform I/O on strings, using the basic OO interface...
|
||||
|
||||
use IO::ScalarArray;
|
||||
@data = ("My mes", "sage:\n");
|
||||
|
||||
### Open a handle on an array, and append to it:
|
||||
$AH = new IO::ScalarArray \@data;
|
||||
$AH->print("Hello");
|
||||
$AH->print(", world!\nBye now!\n");
|
||||
print "The array is now: ", @data, "\n";
|
||||
|
||||
### Open a handle on an array, read it line-by-line, then close it:
|
||||
$AH = new IO::ScalarArray \@data;
|
||||
while (defined($_ = $AH->getline)) {
|
||||
print "Got line: $_";
|
||||
}
|
||||
$AH->close;
|
||||
|
||||
### Open a handle on an array, and slurp in all the lines:
|
||||
$AH = new IO::ScalarArray \@data;
|
||||
print "All lines:\n", $AH->getlines;
|
||||
|
||||
### Get the current position (either of two ways):
|
||||
$pos = $AH->getpos;
|
||||
$offset = $AH->tell;
|
||||
|
||||
### Set the current position (either of two ways):
|
||||
$AH->setpos($pos);
|
||||
$AH->seek($offset, 0);
|
||||
|
||||
### Open an anonymous temporary array:
|
||||
$AH = new IO::ScalarArray;
|
||||
$AH->print("Hi there!");
|
||||
print "I printed: ", @{$AH->aref}, "\n"; ### get at value
|
||||
|
||||
|
||||
Don't like OO for your I/O? No problem.
|
||||
Thanks to the magic of an invisible tie(), the following now
|
||||
works out of the box, just as it does with IO::Handle:
|
||||
|
||||
use IO::ScalarArray;
|
||||
@data = ("My mes", "sage:\n");
|
||||
|
||||
### Open a handle on an array, and append to it:
|
||||
$AH = new IO::ScalarArray \@data;
|
||||
print $AH "Hello";
|
||||
print $AH ", world!\nBye now!\n";
|
||||
print "The array is now: ", @data, "\n";
|
||||
|
||||
### Open a handle on a string, read it line-by-line, then close it:
|
||||
$AH = new IO::ScalarArray \@data;
|
||||
while (<$AH>) {
|
||||
print "Got line: $_";
|
||||
}
|
||||
close $AH;
|
||||
|
||||
### Open a handle on a string, and slurp in all the lines:
|
||||
$AH = new IO::ScalarArray \@data;
|
||||
print "All lines:\n", <$AH>;
|
||||
|
||||
### Get the current position (WARNING: requires 5.6):
|
||||
$offset = tell $AH;
|
||||
|
||||
### Set the current position (WARNING: requires 5.6):
|
||||
seek $AH, $offset, 0;
|
||||
|
||||
### Open an anonymous temporary scalar:
|
||||
$AH = new IO::ScalarArray;
|
||||
print $AH "Hi there!";
|
||||
print "I printed: ", @{$AH->aref}, "\n"; ### get at value
|
||||
|
||||
|
||||
And for you folks with 1.x code out there: the old tie() style still works,
|
||||
though this is I<unnecessary and deprecated>:
|
||||
|
||||
use IO::ScalarArray;
|
||||
|
||||
### Writing to a scalar...
|
||||
my @a;
|
||||
tie *OUT, 'IO::ScalarArray', \@a;
|
||||
print OUT "line 1\nline 2\n", "line 3\n";
|
||||
print "Array is now: ", @a, "\n"
|
||||
|
||||
### Reading and writing an anonymous scalar...
|
||||
tie *OUT, 'IO::ScalarArray';
|
||||
print OUT "line 1\nline 2\n", "line 3\n";
|
||||
tied(OUT)->seek(0,0);
|
||||
while (<OUT>) {
|
||||
print "Got line: ", $_;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is part of the IO::Stringy distribution;
|
||||
see L<IO::Stringy> for change log and general information.
|
||||
|
||||
The IO::ScalarArray class implements objects which behave just like
|
||||
IO::Handle (or FileHandle) objects, except that you may use them
|
||||
to write to (or read from) arrays of scalars. Logically, an
|
||||
array of scalars defines an in-core "file" whose contents are
|
||||
the concatenation of the scalars in the array. The handles created by
|
||||
this class are automatically C<tiehandle>d (though please see L<"WARNINGS">
|
||||
for information relevant to your Perl version).
|
||||
|
||||
For writing large amounts of data with individual print() statements,
|
||||
this class is likely to be more efficient than IO::Scalar.
|
||||
|
||||
Basically, this:
|
||||
|
||||
my @a;
|
||||
$AH = new IO::ScalarArray \@a;
|
||||
$AH->print("Hel", "lo, "); ### OO style
|
||||
$AH->print("world!\n"); ### ditto
|
||||
|
||||
Or this:
|
||||
|
||||
my @a;
|
||||
$AH = new IO::ScalarArray \@a;
|
||||
print $AH "Hel", "lo, "; ### non-OO style
|
||||
print $AH "world!\n"; ### ditto
|
||||
|
||||
Causes @a to be set to the following array of 3 strings:
|
||||
|
||||
( "Hel" ,
|
||||
"lo, " ,
|
||||
"world!\n" )
|
||||
|
||||
See L<IO::Scalar> and compare with this class.
|
||||
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
=head2 Construction
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item new [ARGS...]
|
||||
|
||||
I<Class method.>
|
||||
Return a new, unattached array handle.
|
||||
If any arguments are given, they're sent to open().
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless \do { local *FH }, $class;
|
||||
tie *$self, $class, $self;
|
||||
$self->open(@_); ### open on anonymous by default
|
||||
$self;
|
||||
}
|
||||
sub DESTROY {
|
||||
shift->close;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item open [ARRAYREF]
|
||||
|
||||
I<Instance method.>
|
||||
Open the array handle on a new array, pointed to by ARRAYREF.
|
||||
If no ARRAYREF is given, a "private" array is created to hold
|
||||
the file data.
|
||||
|
||||
Returns the self object on success, undefined on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub open {
|
||||
my ($self, $aref) = @_;
|
||||
|
||||
### Sanity:
|
||||
defined($aref) or do {my @a; $aref = \@a};
|
||||
(ref($aref) eq "ARRAY") or croak "open needs a ref to a array";
|
||||
|
||||
### Setup:
|
||||
$self->setpos([0,0]);
|
||||
*$self->{AR} = $aref;
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item opened
|
||||
|
||||
I<Instance method.>
|
||||
Is the array handle opened on something?
|
||||
|
||||
=cut
|
||||
|
||||
sub opened {
|
||||
*{shift()}->{AR};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item close
|
||||
|
||||
I<Instance method.>
|
||||
Disassociate the array handle from its underlying array.
|
||||
Done automatically on destroy.
|
||||
|
||||
=cut
|
||||
|
||||
sub close {
|
||||
my $self = shift;
|
||||
%{*$self} = ();
|
||||
1;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
#==============================
|
||||
|
||||
=head2 Input and output
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item flush
|
||||
|
||||
I<Instance method.>
|
||||
No-op, provided for OO compatibility.
|
||||
|
||||
=cut
|
||||
|
||||
sub flush { "0 but true" }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item fileno
|
||||
|
||||
I<Instance method.>
|
||||
No-op, returns undef
|
||||
|
||||
=cut
|
||||
|
||||
sub fileno { }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getc
|
||||
|
||||
I<Instance method.>
|
||||
Return the next character, or undef if none remain.
|
||||
This does a read(1), which is somewhat costly.
|
||||
|
||||
=cut
|
||||
|
||||
sub getc {
|
||||
my $buf = '';
|
||||
($_[0]->read($buf, 1) ? $buf : undef);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getline
|
||||
|
||||
I<Instance method.>
|
||||
Return the next line, or undef on end of data.
|
||||
Can safely be called in an array context.
|
||||
Currently, lines are delimited by "\n".
|
||||
|
||||
=cut
|
||||
|
||||
sub getline {
|
||||
my $self = shift;
|
||||
my ($str, $line) = (undef, '');
|
||||
|
||||
|
||||
### Minimal impact implementation!
|
||||
### We do the fast thing (no regexps) if using the
|
||||
### classic input record separator.
|
||||
|
||||
### Case 1: $/ is undef: slurp all...
|
||||
if (!defined($/)) {
|
||||
|
||||
return undef if ($self->eof);
|
||||
|
||||
### Get the rest of the current string, followed by remaining strings:
|
||||
my $ar = *$self->{AR};
|
||||
my @slurp = (
|
||||
substr($ar->[*$self->{Str}], *$self->{Pos}),
|
||||
@$ar[(1 + *$self->{Str}) .. $#$ar ]
|
||||
);
|
||||
|
||||
### Seek to end:
|
||||
$self->_setpos_to_eof;
|
||||
return join('', @slurp);
|
||||
}
|
||||
|
||||
### Case 2: $/ is "\n":
|
||||
elsif ($/ eq "\012") {
|
||||
|
||||
### Until we hit EOF (or exited because of a found line):
|
||||
until ($self->eof) {
|
||||
### If at end of current string, go fwd to next one (won't be EOF):
|
||||
if ($self->_eos) {++*$self->{Str}, *$self->{Pos}=0};
|
||||
|
||||
### Get ref to current string in array, and set internal pos mark:
|
||||
$str = \(*$self->{AR}[*$self->{Str}]); ### get current string
|
||||
pos($$str) = *$self->{Pos}; ### start matching from here
|
||||
|
||||
### Get from here to either \n or end of string, and add to line:
|
||||
$$str =~ m/\G(.*?)((\n)|\Z)/g; ### match to 1st \n or EOS
|
||||
$line .= $1.$2; ### add it
|
||||
*$self->{Pos} += length($1.$2); ### move fwd by len matched
|
||||
return $line if $3; ### done, got line with "\n"
|
||||
}
|
||||
return ($line eq '') ? undef : $line; ### return undef if EOF
|
||||
}
|
||||
|
||||
### Case 3: $/ is ref to int. Bail out.
|
||||
elsif (ref($/)) {
|
||||
croak '$/ given as a ref to int; currently unsupported';
|
||||
}
|
||||
|
||||
### Case 4: $/ is either "" (paragraphs) or something weird...
|
||||
### Bail for now.
|
||||
else {
|
||||
croak '$/ as given is currently unsupported';
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getlines
|
||||
|
||||
I<Instance method.>
|
||||
Get all remaining lines.
|
||||
It will croak() if accidentally called in a scalar context.
|
||||
|
||||
=cut
|
||||
|
||||
sub getlines {
|
||||
my $self = shift;
|
||||
wantarray or croak("can't call getlines in scalar context!");
|
||||
my ($line, @lines);
|
||||
push @lines, $line while (defined($line = $self->getline));
|
||||
@lines;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item print ARGS...
|
||||
|
||||
I<Instance method.>
|
||||
Print ARGS to the underlying array.
|
||||
|
||||
Currently, this always causes a "seek to the end of the array"
|
||||
and generates a new array entry. This may change in the future.
|
||||
|
||||
=cut
|
||||
|
||||
sub print {
|
||||
my $self = shift;
|
||||
push @{*$self->{AR}}, join('', @_) . (defined($\) ? $\ : ""); ### add the data
|
||||
$self->_setpos_to_eof;
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item read BUF, NBYTES, [OFFSET];
|
||||
|
||||
I<Instance method.>
|
||||
Read some bytes from the array.
|
||||
Returns the number of bytes actually read, 0 on end-of-file, undef on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub read {
|
||||
my $self = $_[0];
|
||||
### we must use $_[1] as a ref
|
||||
my $n = $_[2];
|
||||
my $off = $_[3] || 0;
|
||||
|
||||
### print "getline\n";
|
||||
my $justread;
|
||||
my $len;
|
||||
($off ? substr($_[1], $off) : $_[1]) = '';
|
||||
|
||||
### Stop when we have zero bytes to go, or when we hit EOF:
|
||||
my @got;
|
||||
until (!$n or $self->eof) {
|
||||
### If at end of current string, go forward to next one (won't be EOF):
|
||||
if ($self->_eos) {
|
||||
++*$self->{Str};
|
||||
*$self->{Pos} = 0;
|
||||
}
|
||||
|
||||
### Get longest possible desired substring of current string:
|
||||
$justread = substr(*$self->{AR}[*$self->{Str}], *$self->{Pos}, $n);
|
||||
$len = length($justread);
|
||||
push @got, $justread;
|
||||
$n -= $len;
|
||||
*$self->{Pos} += $len;
|
||||
}
|
||||
$_[1] .= join('', @got);
|
||||
return length($_[1])-$off;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item write BUF, NBYTES, [OFFSET];
|
||||
|
||||
I<Instance method.>
|
||||
Write some bytes into the array.
|
||||
|
||||
=cut
|
||||
|
||||
sub write {
|
||||
my $self = $_[0];
|
||||
my $n = $_[2];
|
||||
my $off = $_[3] || 0;
|
||||
|
||||
my $data = substr($_[1], $n, $off);
|
||||
$n = length($data);
|
||||
$self->print($data);
|
||||
return $n;
|
||||
}
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
#==============================
|
||||
|
||||
=head2 Seeking/telling and other attributes
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item autoflush
|
||||
|
||||
I<Instance method.>
|
||||
No-op, provided for OO compatibility.
|
||||
|
||||
=cut
|
||||
|
||||
sub autoflush {}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item binmode
|
||||
|
||||
I<Instance method.>
|
||||
No-op, provided for OO compatibility.
|
||||
|
||||
=cut
|
||||
|
||||
sub binmode {}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item clearerr
|
||||
|
||||
I<Instance method.> Clear the error and EOF flags. A no-op.
|
||||
|
||||
=cut
|
||||
|
||||
sub clearerr { 1 }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item eof
|
||||
|
||||
I<Instance method.> Are we at end of file?
|
||||
|
||||
=cut
|
||||
|
||||
sub eof {
|
||||
### print "checking EOF [*$self->{Str}, *$self->{Pos}]\n";
|
||||
### print "SR = ", $#{*$self->{AR}}, "\n";
|
||||
|
||||
return 0 if (*{$_[0]}->{Str} < $#{*{$_[0]}->{AR}}); ### before EOA
|
||||
return 1 if (*{$_[0]}->{Str} > $#{*{$_[0]}->{AR}}); ### after EOA
|
||||
### ### at EOA, past EOS:
|
||||
((*{$_[0]}->{Str} == $#{*{$_[0]}->{AR}}) && ($_[0]->_eos));
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# _eos
|
||||
#
|
||||
# I<Instance method, private.> Are we at end of the CURRENT string?
|
||||
#
|
||||
sub _eos {
|
||||
(*{$_[0]}->{Pos} >= length(*{$_[0]}->{AR}[*{$_[0]}->{Str}])); ### past last char
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item seek POS,WHENCE
|
||||
|
||||
I<Instance method.>
|
||||
Seek to a given position in the stream.
|
||||
Only a WHENCE of 0 (SEEK_SET) is supported.
|
||||
|
||||
=cut
|
||||
|
||||
sub seek {
|
||||
my ($self, $pos, $whence) = @_;
|
||||
|
||||
### Seek:
|
||||
if ($whence == 0) { $self->_seek_set($pos); }
|
||||
elsif ($whence == 1) { $self->_seek_cur($pos); }
|
||||
elsif ($whence == 2) { $self->_seek_end($pos); }
|
||||
else { croak "bad seek whence ($whence)" }
|
||||
return 1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# _seek_set POS
|
||||
#
|
||||
# Instance method, private.
|
||||
# Seek to $pos relative to start:
|
||||
#
|
||||
sub _seek_set {
|
||||
my ($self, $pos) = @_;
|
||||
|
||||
### Advance through array until done:
|
||||
my $istr = 0;
|
||||
while (($pos >= 0) && ($istr < scalar(@{*$self->{AR}}))) {
|
||||
if (length(*$self->{AR}[$istr]) > $pos) { ### it's in this string!
|
||||
return $self->setpos([$istr, $pos]);
|
||||
}
|
||||
else { ### it's in next string
|
||||
$pos -= length(*$self->{AR}[$istr++]); ### move forward one string
|
||||
}
|
||||
}
|
||||
### If we reached this point, pos is at or past end; zoom to EOF:
|
||||
return $self->_setpos_to_eof;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# _seek_cur POS
|
||||
#
|
||||
# Instance method, private.
|
||||
# Seek to $pos relative to current position.
|
||||
#
|
||||
sub _seek_cur {
|
||||
my ($self, $pos) = @_;
|
||||
$self->_seek_set($self->tell + $pos);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# _seek_end POS
|
||||
#
|
||||
# Instance method, private.
|
||||
# Seek to $pos relative to end.
|
||||
# We actually seek relative to beginning, which is simple.
|
||||
#
|
||||
sub _seek_end {
|
||||
my ($self, $pos) = @_;
|
||||
$self->_seek_set($self->_tell_eof + $pos);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item tell
|
||||
|
||||
I<Instance method.>
|
||||
Return the current position in the stream, as a numeric offset.
|
||||
|
||||
=cut
|
||||
|
||||
sub tell {
|
||||
my $self = shift;
|
||||
my $off = 0;
|
||||
my ($s, $str_s);
|
||||
for ($s = 0; $s < *$self->{Str}; $s++) { ### count all "whole" scalars
|
||||
defined($str_s = *$self->{AR}[$s]) or $str_s = '';
|
||||
###print STDERR "COUNTING STRING $s (". length($str_s) . ")\n";
|
||||
$off += length($str_s);
|
||||
}
|
||||
###print STDERR "COUNTING POS ($self->{Pos})\n";
|
||||
return ($off += *$self->{Pos}); ### plus the final, partial one
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# _tell_eof
|
||||
#
|
||||
# Instance method, private.
|
||||
# Get position of EOF, as a numeric offset.
|
||||
# This is identical to the size of the stream - 1.
|
||||
#
|
||||
sub _tell_eof {
|
||||
my $self = shift;
|
||||
my $len = 0;
|
||||
foreach (@{*$self->{AR}}) { $len += length($_) }
|
||||
$len;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item setpos POS
|
||||
|
||||
I<Instance method.>
|
||||
Seek to a given position in the array, using the opaque getpos() value.
|
||||
Don't expect this to be a number.
|
||||
|
||||
=cut
|
||||
|
||||
sub setpos {
|
||||
my ($self, $pos) = @_;
|
||||
(ref($pos) eq 'ARRAY') or
|
||||
die "setpos: only use a value returned by getpos!\n";
|
||||
(*$self->{Str}, *$self->{Pos}) = @$pos;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# _setpos_to_eof
|
||||
#
|
||||
# Fast-forward to EOF.
|
||||
#
|
||||
sub _setpos_to_eof {
|
||||
my $self = shift;
|
||||
$self->setpos([scalar(@{*$self->{AR}}), 0]);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getpos
|
||||
|
||||
I<Instance method.>
|
||||
Return the current position in the array, as an opaque value.
|
||||
Don't expect this to be a number.
|
||||
|
||||
=cut
|
||||
|
||||
sub getpos {
|
||||
[*{$_[0]}->{Str}, *{$_[0]}->{Pos}];
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item aref
|
||||
|
||||
I<Instance method.>
|
||||
Return a reference to the underlying array.
|
||||
|
||||
=cut
|
||||
|
||||
sub aref {
|
||||
*{shift()}->{AR};
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
# Tied handle methods...
|
||||
#------------------------------
|
||||
|
||||
### Conventional tiehandle interface:
|
||||
sub TIEHANDLE { (defined($_[1]) && UNIVERSAL::isa($_[1],"IO::ScalarArray"))
|
||||
? $_[1]
|
||||
: shift->new(@_) }
|
||||
sub GETC { shift->getc(@_) }
|
||||
sub PRINT { shift->print(@_) }
|
||||
sub PRINTF { shift->print(sprintf(shift, @_)) }
|
||||
sub READ { shift->read(@_) }
|
||||
sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
|
||||
sub WRITE { shift->write(@_); }
|
||||
sub CLOSE { shift->close(@_); }
|
||||
sub SEEK { shift->seek(@_); }
|
||||
sub TELL { shift->tell(@_); }
|
||||
sub EOF { shift->eof(@_); }
|
||||
sub BINMODE { 1; }
|
||||
|
||||
#------------------------------------------------------------
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
# SOME PRIVATE NOTES:
|
||||
#
|
||||
# * The "current position" is the position before the next
|
||||
# character to be read/written.
|
||||
#
|
||||
# * Str gives the string index of the current position, 0-based
|
||||
#
|
||||
# * Pos gives the offset within AR[Str], 0-based.
|
||||
#
|
||||
# * Inital pos is [0,0]. After print("Hello"), it is [1,0].
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>).
|
||||
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
Dianne Skoll (F<dfs@roaringpenguin.com>).
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
3813
gitportable/usr/share/perl5/vendor_perl/IO/Socket/SSL.pm
Normal file
3813
gitportable/usr/share/perl5/vendor_perl/IO/Socket/SSL.pm
Normal file
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,380 @@
|
||||
|
||||
package IO::Socket::SSL::Intercept;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp 'croak';
|
||||
use IO::Socket::SSL::Utils;
|
||||
use Net::SSLeay;
|
||||
|
||||
our $VERSION = '2.056';
|
||||
|
||||
|
||||
sub new {
|
||||
my ($class,%args) = @_;
|
||||
|
||||
my $cacert = delete $args{proxy_cert};
|
||||
if ( ! $cacert ) {
|
||||
if ( my $f = delete $args{proxy_cert_file} ) {
|
||||
$cacert = PEM_file2cert($f);
|
||||
} else {
|
||||
croak "no proxy_cert or proxy_cert_file given";
|
||||
}
|
||||
}
|
||||
|
||||
my $cakey = delete $args{proxy_key};
|
||||
if ( ! $cakey ) {
|
||||
if ( my $f = delete $args{proxy_key_file} ) {
|
||||
$cakey = PEM_file2key($f);
|
||||
} else {
|
||||
croak "no proxy_cert or proxy_cert_file given";
|
||||
}
|
||||
}
|
||||
|
||||
my $certkey = delete $args{cert_key};
|
||||
if ( ! $certkey ) {
|
||||
if ( my $f = delete $args{cert_key_file} ) {
|
||||
$certkey = PEM_file2key($f);
|
||||
}
|
||||
}
|
||||
|
||||
my $cache = delete $args{cache} || {};
|
||||
if (ref($cache) eq 'CODE') {
|
||||
# check cache type
|
||||
my $type = $cache->('type');
|
||||
if (!$type) {
|
||||
# old cache interface - change into new interface
|
||||
# get: $cache->(fp)
|
||||
# set: $cache->(fp,cert,key)
|
||||
my $oc = $cache;
|
||||
$cache = sub {
|
||||
my ($fp,$create_cb) = @_;
|
||||
my @ck = $oc->($fp);
|
||||
$oc->($fp, @ck = &$create_cb) if !@ck;
|
||||
return @ck;
|
||||
};
|
||||
} elsif ($type == 1) {
|
||||
# current interface:
|
||||
# get/set: $cache->(fp,cb_create)
|
||||
} else {
|
||||
die "invalid type of cache: $type";
|
||||
}
|
||||
}
|
||||
|
||||
my $self = bless {
|
||||
cacert => $cacert,
|
||||
cakey => $cakey,
|
||||
certkey => $certkey,
|
||||
cache => $cache,
|
||||
serial => delete $args{serial},
|
||||
};
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# call various ssl _free routines
|
||||
my $self = shift or return;
|
||||
for ( \$self->{cacert},
|
||||
map { \$_->{cert} } ref($self->{cache}) ne 'CODE' ? values %{$self->{cache}} :()) {
|
||||
$$_ or next;
|
||||
CERT_free($$_);
|
||||
$$_ = undef;
|
||||
}
|
||||
for ( \$self->{cakey}, \$self->{pubkey} ) {
|
||||
$$_ or next;
|
||||
KEY_free($$_);
|
||||
$$_ = undef;
|
||||
}
|
||||
}
|
||||
|
||||
sub clone_cert {
|
||||
my ($self,$old_cert,$clone_key) = @_;
|
||||
|
||||
my $hash = CERT_asHash($old_cert);
|
||||
my $create_cb = sub {
|
||||
# if not in cache create new certificate based on original
|
||||
# copy most but not all extensions
|
||||
if (my $ext = $hash->{ext}) {
|
||||
@$ext = grep {
|
||||
defined($_->{sn}) && $_->{sn} !~m{^(?:
|
||||
authorityInfoAccess |
|
||||
subjectKeyIdentifier |
|
||||
authorityKeyIdentifier |
|
||||
certificatePolicies |
|
||||
crlDistributionPoints
|
||||
)$}x
|
||||
} @$ext;
|
||||
}
|
||||
my ($clone,$key) = CERT_create(
|
||||
%$hash,
|
||||
ignore_invalid_args => 1,
|
||||
issuer_cert => $self->{cacert},
|
||||
issuer_key => $self->{cakey},
|
||||
key => $self->{certkey},
|
||||
serial =>
|
||||
! defined($self->{serial}) ? (unpack('L',$hash->{x509_digest_sha256}))[0] :
|
||||
ref($self->{serial}) eq 'CODE' ? $self->{serial}($old_cert,$hash) :
|
||||
++$self->{serial},
|
||||
);
|
||||
return ($clone,$key);
|
||||
};
|
||||
|
||||
$clone_key ||= substr(unpack("H*", $hash->{x509_digest_sha256}),0,32);
|
||||
my $c = $self->{cache};
|
||||
return $c->($clone_key,$create_cb) if ref($c) eq 'CODE';
|
||||
|
||||
my $e = $c->{$clone_key} ||= do {
|
||||
my ($cert,$key) = &$create_cb;
|
||||
{ cert => $cert, key => $key };
|
||||
};
|
||||
$e->{atime} = time();
|
||||
return ($e->{cert},$e->{key});
|
||||
}
|
||||
|
||||
|
||||
sub STORABLE_freeze { my $self = shift; $self->serialize() }
|
||||
sub STORABLE_thaw { my ($class,undef,$data) = @_; $class->unserialize($data) }
|
||||
|
||||
sub serialize {
|
||||
my $self = shift;
|
||||
my $data = pack("N",2); # version
|
||||
$data .= pack("N/a", PEM_cert2string($self->{cacert}));
|
||||
$data .= pack("N/a", PEM_key2string($self->{cakey}));
|
||||
if ( $self->{certkey} ) {
|
||||
$data .= pack("N/a", PEM_key2string($self->{certkey}));
|
||||
} else {
|
||||
$data .= pack("N/a", '');
|
||||
}
|
||||
$data .= pack("N",$self->{serial});
|
||||
if ( ref($self->{cache}) eq 'HASH' ) {
|
||||
while ( my($k,$v) = each %{ $self->{cache}} ) {
|
||||
$data .= pack("N/aN/aN/aN", $k,
|
||||
PEM_cert2string($k->{cert}),
|
||||
$k->{key} ? PEM_key2string($k->{key}) : '',
|
||||
$k->{atime});
|
||||
}
|
||||
}
|
||||
return $data;
|
||||
}
|
||||
|
||||
sub unserialize {
|
||||
my ($class,$data) = @_;
|
||||
unpack("N",substr($data,0,4,'')) == 2 or
|
||||
croak("serialized with wrong version");
|
||||
( my $cacert,my $cakey,my $certkey,my $serial,$data)
|
||||
= unpack("N/aN/aN/aNa*",$data);
|
||||
my $self = bless {
|
||||
serial => $serial,
|
||||
cacert => PEM_string2cert($cacert),
|
||||
cakey => PEM_string2key($cakey),
|
||||
$certkey ? ( certkey => PEM_string2key($certkey)):(),
|
||||
}, ref($class)||$class;
|
||||
|
||||
$self->{cache} = {} if $data ne '';
|
||||
while ( $data ne '' ) {
|
||||
(my $key,my $cert,my $certkey, my $atime,$data) = unpack("N/aN/aNa*",$data);
|
||||
$self->{cache}{$key} = {
|
||||
cert => PEM_string2cert($cert),
|
||||
$key ? ( key => PEM_string2key($certkey)):(),
|
||||
atime => $atime
|
||||
};
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Socket::SSL::Intercept -- SSL interception (man in the middle)
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::Socket::SSL::Intercept;
|
||||
# create interceptor with proxy certificates
|
||||
my $mitm = IO::Socket::SSL::Intercept->new(
|
||||
proxy_cert_file => 'proxy_cert.pem',
|
||||
proxy_key_file => 'proxy_key.pem',
|
||||
...
|
||||
);
|
||||
my $listen = IO::Socket::INET->new( LocalAddr => .., Listen => .. );
|
||||
while (1) {
|
||||
# TCP accept new client
|
||||
my $client = $listen->accept or next;
|
||||
# SSL connect to server
|
||||
my $server = IO::Socket::SSL->new(
|
||||
PeerAddr => ..,
|
||||
SSL_verify_mode => ...,
|
||||
...
|
||||
) or die "ssl connect failed: $!,$SSL_ERROR";
|
||||
# clone server certificate
|
||||
my ($cert,$key) = $mitm->clone_cert( $server->peer_certificate );
|
||||
# and upgrade client side to SSL with cloned certificate
|
||||
IO::Socket::SSL->start_SSL($client,
|
||||
SSL_server => 1,
|
||||
SSL_cert => $cert,
|
||||
SSL_key => $key
|
||||
) or die "upgrade failed: $SSL_ERROR";
|
||||
# now transfer data between $client and $server and analyze
|
||||
# the unencrypted data
|
||||
...
|
||||
}
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides functionality to clone certificates and sign them with a
|
||||
proxy certificate, thus making it easy to intercept SSL connections (man in the
|
||||
middle). It also manages a cache of the generated certificates.
|
||||
|
||||
=head1 How Intercepting SSL Works
|
||||
|
||||
Intercepting SSL connections is useful for analyzing encrypted traffic for
|
||||
security reasons or for testing. It does not break the end-to-end security of
|
||||
SSL, e.g. a properly written client will notice the interception unless you
|
||||
explicitly configure the client to trust your interceptor.
|
||||
Intercepting SSL works the following way:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Create a new CA certificate, which will be used to sign the cloned certificates.
|
||||
This proxy CA certificate should be trusted by the client, or (a properly
|
||||
written client) will throw error messages or deny the connections because it
|
||||
detected a man in the middle attack.
|
||||
Due to the way the interception works there no support for client side
|
||||
certificates is possible.
|
||||
|
||||
Using openssl such a proxy CA certificate and private key can be created with:
|
||||
|
||||
openssl genrsa -out proxy_key.pem 1024
|
||||
openssl req -new -x509 -extensions v3_ca -key proxy_key.pem -out proxy_cert.pem
|
||||
# export as PKCS12 for import into browser
|
||||
openssl pkcs12 -export -in proxy_cert.pem -inkey proxy_key.pem -out proxy_cert.p12
|
||||
|
||||
=item *
|
||||
|
||||
Configure client to connect to use intercepting proxy or somehow redirect
|
||||
connections from client to the proxy (e.g. packet filter redirects, ARP or DNS
|
||||
spoofing etc).
|
||||
|
||||
=item *
|
||||
|
||||
Accept the TCP connection from the client, e.g. don't do any SSL handshakes with
|
||||
the client yet.
|
||||
|
||||
=item *
|
||||
|
||||
Establish the SSL connection to the server and verify the servers certificate as
|
||||
usually. Then create a new certificate based on the original servers
|
||||
certificate, but signed by your proxy CA.
|
||||
This is the step where IO::Socket::SSL::Intercept helps.
|
||||
|
||||
=item *
|
||||
|
||||
Upgrade the TCP connection to the client to SSL using the cloned certificate
|
||||
from the server. If the client trusts your proxy CA it will accept the upgrade
|
||||
to SSL.
|
||||
|
||||
=item *
|
||||
|
||||
Transfer data between client and server. While the connections to client and
|
||||
server are both encrypted with SSL you will read/write the unencrypted data in
|
||||
your proxy application.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
IO::Socket::SSL::Intercept helps creating the cloned certificate with the
|
||||
following methods:
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<< $mitm = IO::Socket::SSL::Intercept->new(%args) >>
|
||||
|
||||
This creates a new interceptor object. C<%args> should be
|
||||
|
||||
=over 8
|
||||
|
||||
=item proxy_cert X509 | proxy_cert_file filename
|
||||
|
||||
This is the proxy certificate.
|
||||
It can be either given by an X509 object from L<Net::SSLeay>s internal
|
||||
representation, or using a file in PEM format.
|
||||
|
||||
=item proxy_key EVP_PKEY | proxy_key_file filename
|
||||
|
||||
This is the key for the proxy certificate.
|
||||
It can be either given by an EVP_PKEY object from L<Net::SSLeay>s internal
|
||||
representation, or using a file in PEM format.
|
||||
The key should not have a passphrase.
|
||||
|
||||
=item pubkey EVP_PKEY | pubkey_file filename
|
||||
|
||||
This optional argument specifies the public key used for the cloned certificate.
|
||||
It can be either given by an EVP_PKEY object from L<Net::SSLeay>s internal
|
||||
representation, or using a file in PEM format.
|
||||
If not given it will create a new public key on each call of C<new>.
|
||||
|
||||
=item serial INTEGER|CODE
|
||||
|
||||
This optional argument gives the starting point for the serial numbers of the
|
||||
newly created certificates. If not set the serial number will be created based
|
||||
on the digest of the original certificate. If the value is code it will be
|
||||
called with C<< serial(original_cert,CERT_asHash(original_cert)) >> and should
|
||||
return the new serial number.
|
||||
|
||||
=item cache HASH | SUBROUTINE
|
||||
|
||||
This optional argument gives a way to cache created certificates, so that they
|
||||
don't get recreated on future accesses to the same host.
|
||||
If the argument ist not given an internal HASH ist used.
|
||||
|
||||
If the argument is a hash it will store for each generated certificate a hash
|
||||
reference with C<cert> and C<atime> in the hash, where C<atime> is the time of
|
||||
last access (to expire unused entries) and C<cert> is the certificate. Please
|
||||
note, that the certificate is in L<Net::SSLeay>s internal X509 format and can
|
||||
thus not be simply dumped and restored.
|
||||
The key for the hash is an C<ident> either given to C<clone_cert> or generated
|
||||
from the original certificate.
|
||||
|
||||
If the argument is a subroutine it will be called as C<< $cache->(ident,sub) >>.
|
||||
This call should return either an existing (cached) C<< (cert,key) >> or
|
||||
call C<sub> without arguments to create a new C<< (cert,key) >>, store it
|
||||
and return it.
|
||||
If called with C<< $cache->('type') >> the function should just return 1 to
|
||||
signal that it supports the current type of cache. If it returns nothing
|
||||
instead the older cache interface is assumed for compatibility reasons.
|
||||
|
||||
=back
|
||||
|
||||
=item B<< ($clone_cert,$key) = $mitm->clone_cert($original_cert,[ $ident ]) >>
|
||||
|
||||
This clones the given certificate.
|
||||
An ident as the key into the cache can be given (like C<host:port>), if not it
|
||||
will be created from the properties of the original certificate.
|
||||
It returns the cloned certificate and its key (which is the same for alle
|
||||
created certificates).
|
||||
|
||||
=item B<< $string = $mitm->serialize >>
|
||||
|
||||
This creates a serialized version of the object (e.g. a string) which can then
|
||||
be used to persistently store created certificates over restarts of the
|
||||
application. The cache will only be serialized if it is a HASH.
|
||||
To work together with L<Storable> the C<STORABLE_freeze> function is defined to
|
||||
call C<serialize>.
|
||||
|
||||
=item B<< $mitm = IO::Socket::SSL::Intercept->unserialize($string) >>
|
||||
|
||||
This restores an Intercept object from a serialized string.
|
||||
To work together with L<Storable> the C<STORABLE_thaw> function is defined to
|
||||
call C<unserialize>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Steffen Ullrich
|
||||
16132
gitportable/usr/share/perl5/vendor_perl/IO/Socket/SSL/PublicSuffix.pm
Normal file
16132
gitportable/usr/share/perl5/vendor_perl/IO/Socket/SSL/PublicSuffix.pm
Normal file
File diff suppressed because it is too large
Load Diff
800
gitportable/usr/share/perl5/vendor_perl/IO/Socket/SSL/Utils.pm
Normal file
800
gitportable/usr/share/perl5/vendor_perl/IO/Socket/SSL/Utils.pm
Normal file
@@ -0,0 +1,800 @@
|
||||
|
||||
package IO::Socket::SSL::Utils;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp 'croak';
|
||||
use Net::SSLeay;
|
||||
|
||||
# old versions of Exporter do not export 'import' yet
|
||||
require Exporter;
|
||||
*import = \&Exporter::import;
|
||||
|
||||
our $VERSION = '2.015';
|
||||
our @EXPORT = qw(
|
||||
PEM_file2cert PEM_file2certs PEM_string2cert PEM_cert2file PEM_certs2file PEM_cert2string
|
||||
PEM_file2key PEM_string2key PEM_key2file PEM_key2string
|
||||
KEY_free CERT_free
|
||||
KEY_create_rsa CERT_asHash CERT_create
|
||||
);
|
||||
|
||||
sub PEM_file2cert {
|
||||
my $file = shift;
|
||||
my $bio = Net::SSLeay::BIO_new_file($file,'r') or
|
||||
croak "cannot read $file: $!";
|
||||
my $cert = Net::SSLeay::PEM_read_bio_X509($bio);
|
||||
Net::SSLeay::BIO_free($bio);
|
||||
$cert or croak "cannot parse $file as PEM X509 cert: ".
|
||||
Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
||||
return $cert;
|
||||
}
|
||||
|
||||
sub PEM_cert2file {
|
||||
my ($cert,$file) = @_;
|
||||
my $string = Net::SSLeay::PEM_get_string_X509($cert)
|
||||
or croak("cannot get string from cert");
|
||||
open( my $fh,'>',$file ) or croak("cannot write $file: $!");
|
||||
print $fh $string;
|
||||
}
|
||||
|
||||
use constant PEM_R_NO_START_LINE => 108;
|
||||
sub PEM_file2certs {
|
||||
my $file = shift;
|
||||
my $bio = Net::SSLeay::BIO_new_file($file,'r') or
|
||||
croak "cannot read $file: $!";
|
||||
my @certs;
|
||||
while (1) {
|
||||
if (my $cert = Net::SSLeay::PEM_read_bio_X509($bio)) {
|
||||
push @certs, $cert;
|
||||
} else {
|
||||
Net::SSLeay::BIO_free($bio);
|
||||
my $error = Net::SSLeay::ERR_get_error();
|
||||
last if ($error & 0xfff) == PEM_R_NO_START_LINE && @certs;
|
||||
croak "cannot parse $file as PEM X509 cert: " .
|
||||
Net::SSLeay::ERR_error_string($error);
|
||||
}
|
||||
}
|
||||
return @certs;
|
||||
}
|
||||
|
||||
sub PEM_certs2file {
|
||||
my $file = shift;
|
||||
open( my $fh,'>',$file ) or croak("cannot write $file: $!");
|
||||
for my $cert (@_) {
|
||||
my $string = Net::SSLeay::PEM_get_string_X509($cert)
|
||||
or croak("cannot get string from cert");
|
||||
print $fh $string;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub PEM_string2cert {
|
||||
my $string = shift;
|
||||
my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem());
|
||||
Net::SSLeay::BIO_write($bio,$string);
|
||||
my $cert = Net::SSLeay::PEM_read_bio_X509($bio);
|
||||
Net::SSLeay::BIO_free($bio);
|
||||
$cert or croak "cannot parse string as PEM X509 cert: ".
|
||||
Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
||||
return $cert;
|
||||
}
|
||||
|
||||
sub PEM_cert2string {
|
||||
my $cert = shift;
|
||||
return Net::SSLeay::PEM_get_string_X509($cert)
|
||||
|| croak("cannot get string from cert");
|
||||
}
|
||||
|
||||
sub PEM_file2key {
|
||||
my $file = shift;
|
||||
my $bio = Net::SSLeay::BIO_new_file($file,'r') or
|
||||
croak "cannot read $file: $!";
|
||||
my $key = Net::SSLeay::PEM_read_bio_PrivateKey($bio);
|
||||
Net::SSLeay::BIO_free($bio);
|
||||
$key or croak "cannot parse $file as PEM private key: ".
|
||||
Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
||||
return $key;
|
||||
}
|
||||
|
||||
sub PEM_key2file {
|
||||
my ($key,$file) = @_;
|
||||
my $string = Net::SSLeay::PEM_get_string_PrivateKey($key)
|
||||
or croak("cannot get string from key");
|
||||
open( my $fh,'>',$file ) or croak("cannot write $file: $!");
|
||||
print $fh $string;
|
||||
}
|
||||
|
||||
sub PEM_string2key {
|
||||
my $string = shift;
|
||||
my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem());
|
||||
Net::SSLeay::BIO_write($bio,$string);
|
||||
my $key = Net::SSLeay::PEM_read_bio_PrivateKey($bio);
|
||||
Net::SSLeay::BIO_free($bio);
|
||||
$key or croak "cannot parse string as PEM private key: ".
|
||||
Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error());
|
||||
return $key;
|
||||
}
|
||||
|
||||
sub PEM_key2string {
|
||||
my $key = shift;
|
||||
return Net::SSLeay::PEM_get_string_PrivateKey($key)
|
||||
|| croak("cannot get string from key");
|
||||
}
|
||||
|
||||
sub CERT_free {
|
||||
Net::SSLeay::X509_free($_) for @_;
|
||||
}
|
||||
|
||||
sub KEY_free {
|
||||
Net::SSLeay::EVP_PKEY_free($_) for @_;
|
||||
}
|
||||
|
||||
sub KEY_create_rsa {
|
||||
my $bits = shift || 2048;
|
||||
my $key = Net::SSLeay::EVP_PKEY_new();
|
||||
my $rsa = Net::SSLeay::RSA_generate_key($bits, 0x10001); # 0x10001 = RSA_F4
|
||||
Net::SSLeay::EVP_PKEY_assign_RSA($key,$rsa);
|
||||
return $key;
|
||||
}
|
||||
|
||||
if (defined &Net::SSLeay::EC_KEY_generate_key) {
|
||||
push @EXPORT,'KEY_create_ec';
|
||||
*KEY_create_ec = sub {
|
||||
my $curve = shift || 'prime256v1';
|
||||
my $key = Net::SSLeay::EVP_PKEY_new();
|
||||
my $ec = Net::SSLeay::EC_KEY_generate_key($curve);
|
||||
Net::SSLeay::EVP_PKEY_assign_EC_KEY($key,$ec);
|
||||
return $key;
|
||||
}
|
||||
}
|
||||
|
||||
# extract information from cert
|
||||
my %gen2i = qw( OTHERNAME 0 EMAIL 1 DNS 2 X400 3 DIRNAME 4 EDIPARTY 5 URI 6 IP 7 RID 8 );
|
||||
my %i2gen = reverse %gen2i;
|
||||
sub CERT_asHash {
|
||||
my $cert = shift;
|
||||
my $digest_name = shift || 'sha256';
|
||||
|
||||
my %hash = (
|
||||
version => Net::SSLeay::X509_get_version($cert),
|
||||
not_before => _asn1t2t(Net::SSLeay::X509_get_notBefore($cert)),
|
||||
not_after => _asn1t2t(Net::SSLeay::X509_get_notAfter($cert)),
|
||||
serial => Net::SSLeay::P_ASN1_INTEGER_get_dec(
|
||||
Net::SSLeay::X509_get_serialNumber($cert)),
|
||||
signature_alg => Net::SSLeay::OBJ_obj2txt (
|
||||
Net::SSLeay::P_X509_get_signature_alg($cert)),
|
||||
crl_uri => [ Net::SSLeay::P_X509_get_crl_distribution_points($cert) ],
|
||||
keyusage => [ Net::SSLeay::P_X509_get_key_usage($cert) ],
|
||||
extkeyusage => {
|
||||
oid => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,0) ],
|
||||
nid => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,1) ],
|
||||
sn => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,2) ],
|
||||
ln => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,3) ],
|
||||
},
|
||||
"pubkey_digest_$digest_name" => Net::SSLeay::X509_pubkey_digest(
|
||||
$cert,_digest($digest_name)),
|
||||
"x509_digest_$digest_name" => Net::SSLeay::X509_digest(
|
||||
$cert,_digest($digest_name)),
|
||||
"fingerprint_$digest_name" => Net::SSLeay::X509_get_fingerprint(
|
||||
$cert,$digest_name),
|
||||
);
|
||||
|
||||
for([ subject => Net::SSLeay::X509_get_subject_name($cert) ],
|
||||
[ issuer => Net::SSLeay::X509_get_issuer_name($cert) ]) {
|
||||
my ($what,$subj) = @$_;
|
||||
my %subj;
|
||||
for ( 0..Net::SSLeay::X509_NAME_entry_count($subj)-1 ) {
|
||||
my $e = Net::SSLeay::X509_NAME_get_entry($subj,$_);
|
||||
my $k = Net::SSLeay::OBJ_obj2txt(
|
||||
Net::SSLeay::X509_NAME_ENTRY_get_object($e));
|
||||
my $v = Net::SSLeay::P_ASN1_STRING_get(
|
||||
Net::SSLeay::X509_NAME_ENTRY_get_data($e));
|
||||
if (!exists $subj{$k}) {
|
||||
$subj{$k} = $v;
|
||||
} elsif (!ref $subj{$k}) {
|
||||
$subj{$k} = [ $subj{$k}, $v ];
|
||||
} else {
|
||||
push @{$subj{$k}}, $v;
|
||||
}
|
||||
}
|
||||
$hash{$what} = \%subj;
|
||||
}
|
||||
|
||||
|
||||
if ( my @names = Net::SSLeay::X509_get_subjectAltNames($cert) ) {
|
||||
my $alt = $hash{subjectAltNames} = [];
|
||||
while (my ($t,$v) = splice(@names,0,2)) {
|
||||
$t = $i2gen{$t} || die "unknown type $t in subjectAltName";
|
||||
if ( $t eq 'IP' ) {
|
||||
if (length($v) == 4) {
|
||||
$v = join('.',unpack("CCCC",$v));
|
||||
} elsif ( length($v) == 16 ) {
|
||||
my @v = unpack("nnnnnnnn",$v);
|
||||
my ($best0,$last0);
|
||||
for(my $i=0;$i<@v;$i++) {
|
||||
if ($v[$i] == 0) {
|
||||
if ($last0) {
|
||||
$last0->[1] = $i;
|
||||
$last0->[2]++;
|
||||
$best0 = $last0 if ++$last0->[2]>$best0->[2];
|
||||
} else {
|
||||
$last0 = [ $i,$i,0 ];
|
||||
$best0 ||= $last0;
|
||||
}
|
||||
} else {
|
||||
$last0 = undef;
|
||||
}
|
||||
}
|
||||
if ($best0) {
|
||||
$v = '';
|
||||
$v .= join(':', map { sprintf( "%x",$_) } @v[0..$best0->[0]-1]) if $best0->[0]>0;
|
||||
$v .= '::';
|
||||
$v .= join(':', map { sprintf( "%x",$_) } @v[$best0->[1]+1..$#v]) if $best0->[1]<$#v;
|
||||
} else {
|
||||
$v = join(':', map { sprintf( "%x",$_) } @v);
|
||||
}
|
||||
}
|
||||
}
|
||||
push @$alt,[$t,$v]
|
||||
}
|
||||
}
|
||||
|
||||
my @ext;
|
||||
for( 0..Net::SSLeay::X509_get_ext_count($cert)-1 ) {
|
||||
my $e = Net::SSLeay::X509_get_ext($cert,$_);
|
||||
my $o = Net::SSLeay::X509_EXTENSION_get_object($e);
|
||||
my $nid = Net::SSLeay::OBJ_obj2nid($o);
|
||||
push @ext, {
|
||||
oid => Net::SSLeay::OBJ_obj2txt($o),
|
||||
nid => ( $nid > 0 ) ? $nid : undef,
|
||||
sn => ( $nid > 0 ) ? Net::SSLeay::OBJ_nid2sn($nid) : undef,
|
||||
critical => Net::SSLeay::X509_EXTENSION_get_critical($e),
|
||||
data => Net::SSLeay::X509V3_EXT_print($e),
|
||||
}
|
||||
}
|
||||
$hash{ext} = \@ext;
|
||||
|
||||
if ( defined(&Net::SSLeay::P_X509_get_ocsp_uri)) {
|
||||
$hash{ocsp_uri} = [ Net::SSLeay::P_X509_get_ocsp_uri($cert) ];
|
||||
} else {
|
||||
$hash{ocsp_uri} = [];
|
||||
for( @ext ) {
|
||||
$_->{sn} or next;
|
||||
$_->{sn} eq 'authorityInfoAccess' or next;
|
||||
push @{ $hash{ocsp_uri}}, $_->{data} =~m{\bOCSP - URI:(\S+)}g;
|
||||
}
|
||||
}
|
||||
|
||||
return \%hash;
|
||||
}
|
||||
|
||||
sub CERT_create {
|
||||
my %args = @_%2 ? %{ shift() } : @_;
|
||||
|
||||
my $cert = Net::SSLeay::X509_new();
|
||||
my $digest_name = delete $args{digest} || 'sha256';
|
||||
|
||||
Net::SSLeay::ASN1_INTEGER_set(
|
||||
Net::SSLeay::X509_get_serialNumber($cert),
|
||||
delete $args{serial} || rand(2**32),
|
||||
);
|
||||
|
||||
# version default to 2 (V3)
|
||||
Net::SSLeay::X509_set_version($cert,
|
||||
delete $args{version} || 2 );
|
||||
|
||||
# not_before default to now
|
||||
Net::SSLeay::ASN1_TIME_set(
|
||||
Net::SSLeay::X509_get_notBefore($cert),
|
||||
delete $args{not_before} || time()
|
||||
);
|
||||
|
||||
# not_after default to now+365 days
|
||||
Net::SSLeay::ASN1_TIME_set(
|
||||
Net::SSLeay::X509_get_notAfter($cert),
|
||||
delete $args{not_after} || time() + 365*86400
|
||||
);
|
||||
|
||||
# set subject
|
||||
my $subj_e = Net::SSLeay::X509_get_subject_name($cert);
|
||||
my $subj = delete $args{subject} || {
|
||||
organizationName => 'IO::Socket::SSL',
|
||||
commonName => 'IO::Socket::SSL Test'
|
||||
};
|
||||
|
||||
while ( my ($k,$v) = each %$subj ) {
|
||||
# Not everything we get is nice - try with MBSTRING_UTF8 first and if it
|
||||
# fails try V_ASN1_T61STRING and finally V_ASN1_OCTET_STRING
|
||||
for (ref($v) ? @$v : ($v)) {
|
||||
Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,0x1000,$_,-1,0)
|
||||
or Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,20,$_,-1,0)
|
||||
or Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,4,$_,-1,0)
|
||||
or croak("failed to add entry for $k - ".
|
||||
Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()));
|
||||
}
|
||||
}
|
||||
|
||||
my @ext = (
|
||||
&Net::SSLeay::NID_subject_key_identifier => 'hash',
|
||||
&Net::SSLeay::NID_authority_key_identifier => 'keyid',
|
||||
);
|
||||
if ( my $altsubj = delete $args{subjectAltNames} ) {
|
||||
push @ext,
|
||||
&Net::SSLeay::NID_subject_alt_name =>
|
||||
join(',', map { "$_->[0]:$_->[1]" } @$altsubj)
|
||||
}
|
||||
|
||||
my $key = delete $args{key} || KEY_create_rsa();
|
||||
Net::SSLeay::X509_set_pubkey($cert,$key);
|
||||
|
||||
my $is = delete $args{issuer};
|
||||
my $issuer_cert = delete $args{issuer_cert} || $is && $is->[0] || $cert;
|
||||
my $issuer_key = delete $args{issuer_key} || $is && $is->[1] || $key;
|
||||
|
||||
my %purpose;
|
||||
if (my $p = delete $args{purpose}) {
|
||||
if (!ref($p)) {
|
||||
$purpose{lc($2)} = (!$1 || $1 eq '+') ? 1:0
|
||||
while $p =~m{([+-]?)(\w+)}g;
|
||||
} elsif (ref($p) eq 'ARRAY') {
|
||||
for(@$p) {
|
||||
m{^([+-]?)(\w+)$} or die "invalid entry in purpose: $_";
|
||||
$purpose{lc($2)} = (!$1 || $1 eq '+') ? 1:0
|
||||
}
|
||||
} else {
|
||||
while( my ($k,$v) = each %$p) {
|
||||
$purpose{lc($k)} = ($v && $v ne '-')?1:0;
|
||||
}
|
||||
}
|
||||
}
|
||||
if (delete $args{CA}) {
|
||||
# add defaults for CA
|
||||
%purpose = (
|
||||
ca => 1, sslca => 1, emailca => 1, objca => 1,
|
||||
%purpose
|
||||
);
|
||||
}
|
||||
if (!%purpose) {
|
||||
%purpose = (server => 1, client => 1);
|
||||
}
|
||||
|
||||
my (%key_usage,%ext_key_usage,%cert_type,%basic_constraints);
|
||||
|
||||
my %dS = ( digitalSignature => \%key_usage );
|
||||
my %kE = ( keyEncipherment => \%key_usage );
|
||||
my %CA = ( 'CA:TRUE' => \%basic_constraints, %dS, keyCertSign => \%key_usage );
|
||||
my @disable;
|
||||
for(
|
||||
[ client => { %dS, %kE, clientAuth => \%ext_key_usage, client => \%cert_type } ],
|
||||
[ server => { %dS, %kE, serverAuth => \%ext_key_usage, server => \%cert_type } ],
|
||||
[ email => { %dS, %kE, emailProtection => \%ext_key_usage, email => \%cert_type } ],
|
||||
[ objsign => { %dS, %kE, codeSigning => \%ext_key_usage, objsign => \%cert_type } ],
|
||||
|
||||
[ CA => { %CA }],
|
||||
[ sslCA => { %CA, sslCA => \%cert_type }],
|
||||
[ emailCA => { %CA, emailCA => \%cert_type }],
|
||||
[ objCA => { %CA, objCA => \%cert_type }],
|
||||
|
||||
[ emailProtection => { %dS, %kE, emailProtection => \%ext_key_usage, email => \%cert_type } ],
|
||||
[ codeSigning => { %dS, %kE, codeSigning => \%ext_key_usage, objsign => \%cert_type } ],
|
||||
|
||||
[ timeStamping => { timeStamping => \%ext_key_usage } ],
|
||||
[ digitalSignature => { digitalSignature => \%key_usage } ],
|
||||
[ nonRepudiation => { nonRepudiation => \%key_usage } ],
|
||||
[ keyEncipherment => { keyEncipherment => \%key_usage } ],
|
||||
[ dataEncipherment => { dataEncipherment => \%key_usage } ],
|
||||
[ keyAgreement => { keyAgreement => \%key_usage } ],
|
||||
[ keyCertSign => { keyCertSign => \%key_usage } ],
|
||||
[ cRLSign => { cRLSign => \%key_usage } ],
|
||||
[ encipherOnly => { encipherOnly => \%key_usage } ],
|
||||
[ decipherOnly => { decipherOnly => \%key_usage } ],
|
||||
[ clientAuth => { clientAuth => \%ext_key_usage } ],
|
||||
[ serverAuth => { serverAuth => \%ext_key_usage } ],
|
||||
) {
|
||||
exists $purpose{lc($_->[0])} or next;
|
||||
if (delete $purpose{lc($_->[0])}) {
|
||||
while (my($k,$h) = each %{$_->[1]}) {
|
||||
$h->{$k} = 1;
|
||||
}
|
||||
} else {
|
||||
push @disable, $_->[1];
|
||||
}
|
||||
}
|
||||
die "unknown purpose ".join(",",keys %purpose) if %purpose;
|
||||
for(@disable) {
|
||||
while (my($k,$h) = each %$_) {
|
||||
delete $h->{$k};
|
||||
}
|
||||
}
|
||||
|
||||
if (%basic_constraints) {
|
||||
push @ext,&Net::SSLeay::NID_basic_constraints,
|
||||
=> join(",",'critical', sort keys %basic_constraints);
|
||||
} else {
|
||||
push @ext, &Net::SSLeay::NID_basic_constraints => 'critical,CA:FALSE';
|
||||
}
|
||||
push @ext,&Net::SSLeay::NID_key_usage
|
||||
=> join(",",'critical', sort keys %key_usage) if %key_usage;
|
||||
push @ext,&Net::SSLeay::NID_netscape_cert_type
|
||||
=> join(",",sort keys %cert_type) if %cert_type;
|
||||
push @ext,&Net::SSLeay::NID_ext_key_usage
|
||||
=> join(",",sort keys %ext_key_usage) if %ext_key_usage;
|
||||
Net::SSLeay::P_X509_add_extensions($cert, $issuer_cert, @ext);
|
||||
|
||||
my %have_ext;
|
||||
for(my $i=0;$i<@ext;$i+=2) {
|
||||
$have_ext{ $ext[$i] }++
|
||||
}
|
||||
for my $ext (@{ delete $args{ext} || [] }) {
|
||||
my $nid = $ext->{nid}
|
||||
|| $ext->{sn} && Net::SSLeay::OBJ_sn2nid($ext->{sn})
|
||||
|| croak "cannot determine NID of extension";
|
||||
$have_ext{$nid} and next;
|
||||
my $val = $ext->{data};
|
||||
if ($nid == 177) {
|
||||
# authorityInfoAccess:
|
||||
# OpenSSL i2v does not output the same way as expected by i2v :(
|
||||
for (split(/\n/,$val)) {
|
||||
s{ - }{;}; # "OCSP - URI:..." -> "OCSP;URI:..."
|
||||
$_ = "critical,$_" if $ext->{critical};
|
||||
Net::SSLeay::P_X509_add_extensions($cert,$issuer_cert,$nid,$_);
|
||||
}
|
||||
} else {
|
||||
$val = "critical,$val" if $ext->{critical};
|
||||
Net::SSLeay::P_X509_add_extensions($cert, $issuer_cert, $nid, $val);
|
||||
}
|
||||
}
|
||||
|
||||
die "unknown arguments: ". join(" ", sort keys %args)
|
||||
if !delete $args{ignore_invalid_args} && %args;
|
||||
|
||||
Net::SSLeay::X509_set_issuer_name($cert,
|
||||
Net::SSLeay::X509_get_subject_name($issuer_cert));
|
||||
Net::SSLeay::X509_sign($cert,$issuer_key,_digest($digest_name));
|
||||
|
||||
return ($cert,$key);
|
||||
}
|
||||
|
||||
|
||||
|
||||
if ( defined &Net::SSLeay::ASN1_TIME_timet ) {
|
||||
*_asn1t2t = \&Net::SSLeay::ASN1_TIME_timet
|
||||
} else {
|
||||
require Time::Local;
|
||||
my %mon2i = qw(
|
||||
Jan 0 Feb 1 Mar 2 Apr 3 May 4 Jun 5
|
||||
Jul 6 Aug 7 Sep 8 Oct 9 Nov 10 Dec 11
|
||||
);
|
||||
*_asn1t2t = sub {
|
||||
my $t = Net::SSLeay::P_ASN1_TIME_put2string( shift );
|
||||
my ($mon,$d,$h,$m,$s,$y,$tz) = split(/[\s:]+/,$t);
|
||||
defined( $mon = $mon2i{$mon} ) or die "invalid month in $t";
|
||||
$tz ||= $y =~s{^(\d+)([A-Z]\S*)}{$1} && $2;
|
||||
if ( ! $tz ) {
|
||||
return Time::Local::timelocal($s,$m,$h,$d,$mon,$y)
|
||||
} elsif ( $tz eq 'GMT' ) {
|
||||
return Time::Local::timegm($s,$m,$h,$d,$mon,$y)
|
||||
} else {
|
||||
die "unexpected TZ $tz from ASN1_TIME_print";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
my %digest;
|
||||
sub _digest {
|
||||
my $digest_name = shift;
|
||||
return $digest{$digest_name} ||= do {
|
||||
Net::SSLeay::SSLeay_add_ssl_algorithms();
|
||||
Net::SSLeay::EVP_get_digestbyname($digest_name)
|
||||
or die "Digest algorithm $digest_name is not available";
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Socket::SSL::Utils -- loading, storing, creating certificates and keys
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IO::Socket::SSL::Utils;
|
||||
|
||||
$cert = PEM_file2cert('cert.pem'); # load certificate from file
|
||||
my $hash = CERT_asHash($cert); # get details from certificate
|
||||
PEM_cert2file($cert,'cert.pem'); # write certificate to file
|
||||
CERT_free($cert); # free memory within OpenSSL
|
||||
|
||||
@certs = PEM_file2certs('chain.pem'); # load multiple certificates from file
|
||||
PEM_certs2file('chain.pem', @certs); # write multiple certificates to file
|
||||
CERT_free(@certs); # free memory for all within OpenSSL
|
||||
|
||||
my $cert = PEM_string2cert($pem); # load certificate from PEM string
|
||||
$pem = PEM_cert2string($cert); # convert certificate to PEM string
|
||||
|
||||
$key = KEY_create_rsa(2048); # create new 2048-bit RSA key
|
||||
PEM_key2file($key,"key.pem"); # and write it to file
|
||||
KEY_free($key); # free memory within OpenSSL
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides various utility functions to work with certificates and
|
||||
private keys, shielding some of the complexity of the underlying Net::SSLeay and
|
||||
OpenSSL.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Functions converting between string or file and certificates and keys.
|
||||
They croak if the operation cannot be completed.
|
||||
|
||||
=over 8
|
||||
|
||||
=item PEM_file2cert(file) -> cert
|
||||
|
||||
=item PEM_cert2file(cert,file)
|
||||
|
||||
=item PEM_file2certs(file) -> @certs
|
||||
|
||||
=item PEM_certs2file(file,@certs)
|
||||
|
||||
=item PEM_string2cert(string) -> cert
|
||||
|
||||
=item PEM_cert2string(cert) -> string
|
||||
|
||||
=item PEM_file2key(file) -> key
|
||||
|
||||
=item PEM_key2file(key,file)
|
||||
|
||||
=item PEM_string2key(string) -> key
|
||||
|
||||
=item PEM_key2string(key) -> string
|
||||
|
||||
=back
|
||||
|
||||
=item *
|
||||
|
||||
Functions for cleaning up.
|
||||
Each loaded or created cert and key must be freed to not leak memory.
|
||||
|
||||
=over 8
|
||||
|
||||
=item CERT_free(@certs)
|
||||
|
||||
=item KEY_free(@keys)
|
||||
|
||||
=back
|
||||
|
||||
=item * KEY_create_rsa(bits) -> key
|
||||
|
||||
Creates an RSA key pair, bits defaults to 2048.
|
||||
|
||||
=item * KEY_create_ec(curve) -> key
|
||||
|
||||
Creates an EC key, curve defaults to C<prime256v1>.
|
||||
|
||||
=item * CERT_asHash(cert,[digest_algo]) -> hash
|
||||
|
||||
Extracts the information from the certificate into a hash and uses the given
|
||||
digest_algo (default: SHA-256) to determine digest of pubkey and cert.
|
||||
The resulting hash contains:
|
||||
|
||||
=over 8
|
||||
|
||||
=item subject
|
||||
|
||||
Hash with the parts of the subject, e.g. commonName, countryName,
|
||||
organizationName, stateOrProvinceName, localityName. If there are multiple
|
||||
values for any of these parts the hash value will be an array ref with the
|
||||
values in order instead of just a scalar.
|
||||
|
||||
=item subjectAltNames
|
||||
|
||||
Array with list of alternative names. Each entry in the list is of
|
||||
C<[type,value]>, where C<type> can be OTHERNAME, EMAIL, DNS, X400, DIRNAME,
|
||||
EDIPARTY, URI, IP or RID.
|
||||
|
||||
=item issuer
|
||||
|
||||
Hash with the parts of the issuer, e.g. commonName, countryName,
|
||||
organizationName, stateOrProvinceName, localityName. If there are multiple
|
||||
values for any of these parts the hash value will be an array ref with the
|
||||
values in order instead of just a scalar.
|
||||
|
||||
=item not_before, not_after
|
||||
|
||||
The time frame, where the certificate is valid, as time_t, e.g. can be converted
|
||||
with localtime or similar functions.
|
||||
|
||||
=item serial
|
||||
|
||||
The serial number
|
||||
|
||||
=item crl_uri
|
||||
|
||||
List of URIs for CRL distribution.
|
||||
|
||||
=item ocsp_uri
|
||||
|
||||
List of URIs for revocation checking using OCSP.
|
||||
|
||||
=item keyusage
|
||||
|
||||
List of keyUsage information in the certificate.
|
||||
|
||||
=item extkeyusage
|
||||
|
||||
List of extended key usage information from the certificate. Each entry in
|
||||
this list consists of a hash with oid, nid, ln and sn.
|
||||
|
||||
=item pubkey_digest_xxx
|
||||
|
||||
Binary digest of the pubkey using the given digest algorithm, e.g.
|
||||
pubkey_digest_sha256 if (the default) SHA-256 was used.
|
||||
|
||||
=item x509_digest_xxx
|
||||
|
||||
Binary digest of the X.509 certificate using the given digest algorithm, e.g.
|
||||
x509_digest_sha256 if (the default) SHA-256 was used.
|
||||
|
||||
=item fingerprint_xxx
|
||||
|
||||
Fingerprint of the certificate using the given digest algorithm, e.g.
|
||||
fingerprint_sha256 if (the default) SHA-256 was used. Contrary to digest_* this
|
||||
is an ASCII string with a list if hexadecimal numbers, e.g.
|
||||
"73:59:75:5C:6D...".
|
||||
|
||||
=item signature_alg
|
||||
|
||||
Algorithm used to sign certificate, e.g. C<sha256WithRSAEncryption>.
|
||||
|
||||
=item ext
|
||||
|
||||
List of extensions.
|
||||
Each entry in the list is a hash with oid, nid, sn, critical flag (boolean) and
|
||||
data (string representation given by X509V3_EXT_print).
|
||||
|
||||
=item version
|
||||
|
||||
Certificate version, usually 2 (x509v3)
|
||||
|
||||
=back
|
||||
|
||||
=item * CERT_create(hash) -> (cert,key)
|
||||
|
||||
Creates a certificate based on the given hash.
|
||||
If the issuer is not specified the certificate will be self-signed.
|
||||
The following keys can be given:
|
||||
|
||||
=over 8
|
||||
|
||||
=item subject
|
||||
|
||||
Hash with the parts of the subject, e.g. commonName, countryName, ... as
|
||||
described in C<CERT_asHash>.
|
||||
Default points to IO::Socket::SSL.
|
||||
|
||||
=item not_before
|
||||
|
||||
A time_t value when the certificate starts to be valid. Defaults to current
|
||||
time.
|
||||
|
||||
=item not_after
|
||||
|
||||
A time_t value when the certificate ends to be valid. Defaults to current
|
||||
time plus one 365 days.
|
||||
|
||||
=item serial
|
||||
|
||||
The serial number. If not given a random number will be used.
|
||||
|
||||
=item version
|
||||
|
||||
The version of the certificate, default 2 (x509v3).
|
||||
|
||||
=item CA true|false
|
||||
|
||||
If true declare certificate as CA, defaults to false.
|
||||
|
||||
=item purpose string|array|hash
|
||||
|
||||
Set the purpose of the certificate.
|
||||
The different purposes can be given as a string separated by non-word character,
|
||||
as array or hash. With string or array each purpose can be prefixed with '+'
|
||||
(enable) or '-' (disable) and same can be done with the value when given as a
|
||||
hash. By default enabling the purpose is assumed.
|
||||
|
||||
If the CA option is given and true the defaults "ca,sslca,emailca,objca" are
|
||||
assumed, but can be overridden with explicit purpose.
|
||||
If the CA option is given and false the defaults "server,client" are assumed.
|
||||
If no CA option and no purpose is given it defaults to "server,client".
|
||||
|
||||
Purpose affects basicConstraints, keyUsage, extKeyUsage and netscapeCertType.
|
||||
The following purposes are defined (case is not important):
|
||||
|
||||
client
|
||||
server
|
||||
email
|
||||
objsign
|
||||
|
||||
CA
|
||||
sslCA
|
||||
emailCA
|
||||
objCA
|
||||
|
||||
emailProtection
|
||||
codeSigning
|
||||
timeStamping
|
||||
|
||||
digitalSignature
|
||||
nonRepudiation
|
||||
keyEncipherment
|
||||
dataEncipherment
|
||||
keyAgreement
|
||||
keyCertSign
|
||||
cRLSign
|
||||
encipherOnly
|
||||
decipherOnly
|
||||
|
||||
Examples:
|
||||
|
||||
# root-CA for SSL certificates
|
||||
purpose => 'sslCA' # or CA => 1
|
||||
|
||||
# server certificate and CA (typically self-signed)
|
||||
purpose => 'sslCA,server'
|
||||
|
||||
# client certificate
|
||||
purpose => 'client',
|
||||
|
||||
|
||||
=item ext [{ sn => .., data => ... }, ... ]
|
||||
|
||||
List of extensions. The type of the extension can be specified as name with
|
||||
C<sn> or as NID with C<nid> and the data with C<data>. These data must be in the
|
||||
same syntax as expected within openssl.cnf, e.g. something like
|
||||
C<OCSP;URI=http://...>. Additionally the critical flag can be set with
|
||||
C<critical => 1>.
|
||||
|
||||
=item key key
|
||||
|
||||
use given key as key for certificate, otherwise a new one will be generated and
|
||||
returned
|
||||
|
||||
=item issuer_cert cert
|
||||
|
||||
set issuer for new certificate
|
||||
|
||||
=item issuer_key key
|
||||
|
||||
sign new certificate with given key
|
||||
|
||||
=item issuer [ cert, key ]
|
||||
|
||||
Instead of giving issuer_key and issuer_cert as separate arguments they can be
|
||||
given both together.
|
||||
|
||||
=item digest algorithm
|
||||
|
||||
specify the algorithm used to sign the certificate, default SHA-256.
|
||||
|
||||
=item ignore_invalid_args
|
||||
|
||||
ignore any unknown arguments which might be in the argument list (which might be
|
||||
in the arguments for example as result from CERT_asHash)
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Steffen Ullrich
|
||||
63
gitportable/usr/share/perl5/vendor_perl/IO/Stringy.pm
Normal file
63
gitportable/usr/share/perl5/vendor_perl/IO/Stringy.pm
Normal file
@@ -0,0 +1,63 @@
|
||||
package IO::Stringy;
|
||||
use strict;
|
||||
use Exporter;
|
||||
|
||||
our $VERSION = '2.113';
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO-stringy - I/O on in-core objects like strings and arrays
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use IO::AtomicFile; # Write a file which is updated atomically
|
||||
use IO::InnerFile; # define a file inside another file
|
||||
use IO::Lines; # I/O handle to read/write to array of lines
|
||||
use IO::Scalar; # I/O handle to read/write to a string
|
||||
use IO::ScalarArray; # I/O handle to read/write to array of scalars
|
||||
use IO::Wrap; # Wrap old-style FHs in standard OO interface
|
||||
use IO::WrapTie; # Tie your handles & retain full OO interface
|
||||
|
||||
# ...
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This toolkit primarily provides modules for performing both traditional
|
||||
and object-oriented i/o) on things I<other> than normal filehandles;
|
||||
in particular, L<IO::Scalar|IO::Scalar>, L<IO::ScalarArray|IO::ScalarArray>,
|
||||
and L<IO::Lines|IO::Lines>.
|
||||
|
||||
In the more-traditional IO::Handle front, we
|
||||
have L<IO::AtomicFile|IO::AtomicFile>
|
||||
which may be used to painlessly create files which are updated
|
||||
atomically.
|
||||
|
||||
And in the "this-may-prove-useful" corner, we have L<IO::Wrap|IO::Wrap>,
|
||||
whose exported wraphandle() function will clothe anything that's not
|
||||
a blessed object in an IO::Handle-like wrapper... so you can just
|
||||
use OO syntax and stop worrying about whether your function's caller
|
||||
handed you a string, a globref, or a FileHandle.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>).
|
||||
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
Dianne Skoll (F<dfs@roaringpenguin.com>).
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
315
gitportable/usr/share/perl5/vendor_perl/IO/Wrap.pm
Normal file
315
gitportable/usr/share/perl5/vendor_perl/IO/Wrap.pm
Normal file
@@ -0,0 +1,315 @@
|
||||
package IO::Wrap;
|
||||
|
||||
use strict;
|
||||
use Exporter;
|
||||
use FileHandle;
|
||||
use Carp;
|
||||
|
||||
our $VERSION = '2.113';
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(wraphandle);
|
||||
|
||||
|
||||
#------------------------------
|
||||
# wraphandle RAW
|
||||
#------------------------------
|
||||
sub wraphandle {
|
||||
my $raw = shift;
|
||||
new IO::Wrap $raw;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# new STREAM
|
||||
#------------------------------
|
||||
sub new {
|
||||
my ($class, $stream) = @_;
|
||||
no strict 'refs';
|
||||
|
||||
### Convert raw scalar to globref:
|
||||
ref($stream) or $stream = \*$stream;
|
||||
|
||||
### Wrap globref and incomplete objects:
|
||||
if ((ref($stream) eq 'GLOB') or ### globref
|
||||
(ref($stream) eq 'FileHandle') && !defined(&FileHandle::read)) {
|
||||
return bless \$stream, $class;
|
||||
}
|
||||
$stream; ### already okay!
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# I/O methods...
|
||||
#------------------------------
|
||||
sub close {
|
||||
my $self = shift;
|
||||
return close($$self);
|
||||
}
|
||||
sub fileno {
|
||||
my $self = shift;
|
||||
my $fh = $$self;
|
||||
return fileno($fh);
|
||||
}
|
||||
|
||||
sub getline {
|
||||
my $self = shift;
|
||||
my $fh = $$self;
|
||||
return scalar(<$fh>);
|
||||
}
|
||||
sub getlines {
|
||||
my $self = shift;
|
||||
wantarray or croak("Can't call getlines in scalar context!");
|
||||
my $fh = $$self;
|
||||
<$fh>;
|
||||
}
|
||||
sub print {
|
||||
my $self = shift;
|
||||
print { $$self } @_;
|
||||
}
|
||||
sub read {
|
||||
my $self = shift;
|
||||
return read($$self, $_[0], $_[1]);
|
||||
}
|
||||
sub seek {
|
||||
my $self = shift;
|
||||
return seek($$self, $_[0], $_[1]);
|
||||
}
|
||||
sub tell {
|
||||
my $self = shift;
|
||||
return tell($$self);
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::Wrap - Wrap raw filehandles in the IO::Handle interface
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use IO::Wrap;
|
||||
|
||||
# this is a fairly senseless use case as IO::Handle already does this.
|
||||
my $wrap_fh = IO::Wrap->new(\*STDIN);
|
||||
my $line = $wrap_fh->getline();
|
||||
|
||||
# Do stuff with any kind of filehandle (including a bare globref), or
|
||||
# any kind of blessed object that responds to a print() message.
|
||||
|
||||
# already have a globref? a FileHandle? a scalar filehandle name?
|
||||
$wrap_fh = IO::Wrap->new($some_unknown_thing);
|
||||
|
||||
# At this point, we know we have an IO::Handle-like object! YAY
|
||||
$wrap_fh->print("Hey there!");
|
||||
|
||||
You can also do this using a convenience wrapper function
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use IO::Wrap qw(wraphandle);
|
||||
|
||||
# this is a fairly senseless use case as IO::Handle already does this.
|
||||
my $wrap_fh = wraphandle(\*STDIN);
|
||||
my $line = $wrap_fh->getline();
|
||||
|
||||
# Do stuff with any kind of filehandle (including a bare globref), or
|
||||
# any kind of blessed object that responds to a print() message.
|
||||
|
||||
# already have a globref? a FileHandle? a scalar filehandle name?
|
||||
$wrap_fh = wraphandle($some_unknown_thing);
|
||||
|
||||
# At this point, we know we have an IO::Handle-like object! YAY
|
||||
$wrap_fh->print("Hey there!");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Let's say you want to write some code which does I/O, but you don't
|
||||
want to force the caller to provide you with a L<FileHandle> or L<IO::Handle>
|
||||
object. You want them to be able to say:
|
||||
|
||||
do_stuff(\*STDOUT);
|
||||
do_stuff('STDERR');
|
||||
do_stuff($some_FileHandle_object);
|
||||
do_stuff($some_IO_Handle_object);
|
||||
|
||||
And even:
|
||||
|
||||
do_stuff($any_object_with_a_print_method);
|
||||
|
||||
Sure, one way to do it is to force the caller to use C<tiehandle()>.
|
||||
But that puts the burden on them. Another way to do it is to
|
||||
use B<IO::Wrap>.
|
||||
|
||||
Clearly, when wrapping a raw external filehandle (like C<\*STDOUT>),
|
||||
I didn't want to close the file descriptor when the wrapper object is
|
||||
destroyed; the user might not appreciate that! Hence, there's no
|
||||
C<DESTROY> method in this class.
|
||||
|
||||
When wrapping a L<FileHandle> object, however, I believe that Perl will
|
||||
invoke the C<FileHandle::DESTROY> when the last reference goes away,
|
||||
so in that case, the filehandle is closed if the wrapped L<FileHandle>
|
||||
really was the last reference to it.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
L<IO::Wrap> makes the following functions available.
|
||||
|
||||
=head2 wraphandle
|
||||
|
||||
# wrap a filehandle glob
|
||||
my $fh = wraphandle(\*STDIN);
|
||||
# wrap a raw filehandle glob by name
|
||||
$fh = wraphandle('STDIN');
|
||||
# wrap a handle in an object
|
||||
$fh = wraphandle('Class::HANDLE');
|
||||
|
||||
# wrap a blessed FileHandle object
|
||||
use FileHandle;
|
||||
my $fho = FileHandle->new("/tmp/foo.txt", "r");
|
||||
$fh = wraphandle($fho);
|
||||
|
||||
# wrap any other blessed object that shares IO::Handle's interface
|
||||
$fh = wraphandle($some_object);
|
||||
|
||||
This function is simply a wrapper to the L<IO::Wrap/"new"> constructor method.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<IO::Wrap> implements the following methods.
|
||||
|
||||
=head2 close
|
||||
|
||||
$fh->close();
|
||||
|
||||
The C<close> method will attempt to close the system file descriptor. For a
|
||||
more complete description, read L<perlfunc/close>.
|
||||
|
||||
=head2 fileno
|
||||
|
||||
my $int = $fh->fileno();
|
||||
|
||||
The C<fileno> method returns the file descriptor for the wrapped filehandle.
|
||||
See L<perlfunc/fileno> for more information.
|
||||
|
||||
=head2 getline
|
||||
|
||||
my $data = $fh->getline();
|
||||
|
||||
The C<getline> method mimics the function by the same name in L<IO::Handle>.
|
||||
It's like calling C<< my $data = <$fh>; >> but only in scalar context.
|
||||
|
||||
=head2 getlines
|
||||
|
||||
my @data = $fh->getlines();
|
||||
|
||||
The C<getlines> method mimics the function by the same name in L<IO::Handle>.
|
||||
It's like calling C<< my @data = <$fh>; >> but only in list context. Calling
|
||||
this method in scalar context will result in a croak.
|
||||
|
||||
=head2 new
|
||||
|
||||
# wrap a filehandle glob
|
||||
my $fh = IO::Wrap->new(\*STDIN);
|
||||
# wrap a raw filehandle glob by name
|
||||
$fh = IO::Wrap->new('STDIN');
|
||||
# wrap a handle in an object
|
||||
$fh = IO::Wrap->new('Class::HANDLE');
|
||||
|
||||
# wrap a blessed FileHandle object
|
||||
use FileHandle;
|
||||
my $fho = FileHandle->new("/tmp/foo.txt", "r");
|
||||
$fh = IO::Wrap->new($fho);
|
||||
|
||||
# wrap any other blessed object that shares IO::Handle's interface
|
||||
$fh = IO::Wrap->new($some_object);
|
||||
|
||||
The C<new> constructor method takes in a single argument and decides to wrap
|
||||
it or not it based on what it seems to be.
|
||||
|
||||
A raw scalar file handle name, like C<"STDOUT"> or C<"Class::HANDLE"> can be
|
||||
wrapped, returning an L<IO::Wrap> object instance.
|
||||
|
||||
A raw filehandle glob, like C<\*STDOUT> can also be wrapped, returning an
|
||||
L<IO::Wrawp> object instance.
|
||||
|
||||
A blessed L<FileHandle> object can also be wrapped. This is a special case
|
||||
where an L<IO::Wrap> object instance will only be returned in the case that
|
||||
your L<FileHandle> object doesn't support the C<read> method.
|
||||
|
||||
Also, any other kind of blessed object that conforms to the
|
||||
L<IO::Handle> interface can be passed in. In this case, you just get back
|
||||
that object.
|
||||
|
||||
In other words, we only wrap it into an L<IO::Wrap> object when what you've
|
||||
supplied doesn't already conform to the L<IO::Handle> interface.
|
||||
|
||||
If you get back an L<IO::Wrap> object, it will obey a basic subset of
|
||||
the C<IO::> interface. It will do so with object B<methods>, not B<operators>.
|
||||
|
||||
=head3 CAVEATS
|
||||
|
||||
This module does not allow you to wrap filehandle names which are given
|
||||
as strings that lack the package they were opened in. That is, if a user
|
||||
opens FOO in package Foo, they must pass it to you either as C<\*FOO>
|
||||
or as C<"Foo::FOO">. However, C<"STDIN"> and friends will work just fine.
|
||||
|
||||
=head2 print
|
||||
|
||||
$fh->print("Some string");
|
||||
$fh->print("more", " than one", " string");
|
||||
|
||||
The C<print> method will attempt to print a string or list of strings to the
|
||||
filehandle. For a more complete description, read
|
||||
L<perlfunc/print>.
|
||||
|
||||
=head2 read
|
||||
|
||||
my $buffer;
|
||||
# try to read 30 chars into the buffer starting at the
|
||||
# current cursor position.
|
||||
my $num_chars_read = $fh->read($buffer, 30);
|
||||
|
||||
The L<read> method attempts to read a number of characters, starting at the
|
||||
filehandle's current cursor position. It returns the number of characters
|
||||
actually read. See L<perlfunc/read> for more information.
|
||||
|
||||
=head2 seek
|
||||
|
||||
use Fcntl qw(:seek); # import the SEEK_CUR, SEEK_SET, SEEK_END constants
|
||||
# seek to the position in bytes
|
||||
$fh->seek(0, SEEK_SET);
|
||||
# seek to the position in bytes from the current position
|
||||
$fh->seek(22, SEEK_CUR);
|
||||
# seek to the EOF plus bytes
|
||||
$fh->seek(0, SEEK_END);
|
||||
|
||||
The C<seek> method will attempt to set the cursor to a given position in bytes
|
||||
for the wrapped file handle. See L<perlfunc/seek> for more information.
|
||||
|
||||
=head2 tell
|
||||
|
||||
my $bytes = $fh->tell();
|
||||
|
||||
The C<tell> method will attempt to return the current position of the cursor
|
||||
in bytes for the wrapped file handle. See L<perlfunc/tell> for more
|
||||
information.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>).
|
||||
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
Dianne Skoll (F<dfs@roaringpenguin.com>).
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
484
gitportable/usr/share/perl5/vendor_perl/IO/WrapTie.pm
Normal file
484
gitportable/usr/share/perl5/vendor_perl/IO/WrapTie.pm
Normal file
@@ -0,0 +1,484 @@
|
||||
package IO::WrapTie;
|
||||
|
||||
use strict;
|
||||
use Exporter;
|
||||
|
||||
# Inheritance, exporting, and package version:
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(wraptie);
|
||||
our $VERSION = '2.113';
|
||||
|
||||
# Function, exported.
|
||||
sub wraptie {
|
||||
IO::WrapTie::Master->new(@_);
|
||||
}
|
||||
|
||||
# Class method; BACKWARDS-COMPATIBILITY ONLY!
|
||||
sub new {
|
||||
shift;
|
||||
IO::WrapTie::Master->new(@_);
|
||||
}
|
||||
|
||||
|
||||
|
||||
#------------------------------------------------------------
|
||||
package # hide from pause
|
||||
IO::WrapTie::Master;
|
||||
#------------------------------------------------------------
|
||||
|
||||
use strict;
|
||||
use vars qw($AUTOLOAD);
|
||||
use IO::Handle;
|
||||
|
||||
# We inherit from IO::Handle to get methods which invoke i/o operators,
|
||||
# like print(), on our tied handle:
|
||||
our @ISA = qw(IO::Handle);
|
||||
|
||||
#------------------------------
|
||||
# new SLAVE, TIEARGS...
|
||||
#------------------------------
|
||||
# Create a new subclass of IO::Handle which...
|
||||
#
|
||||
# (1) Handles i/o OPERATORS because it is tied to an instance of
|
||||
# an i/o-like class, like IO::Scalar.
|
||||
#
|
||||
# (2) Handles i/o METHODS by delegating them to that same tied object!.
|
||||
#
|
||||
# Arguments are the slave class (e.g., IO::Scalar), followed by all
|
||||
# the arguments normally sent into that class's C<TIEHANDLE> method.
|
||||
# In other words, much like the arguments to tie(). :-)
|
||||
#
|
||||
# NOTE:
|
||||
# The thing $x we return must be a BLESSED REF, for ($x->print()).
|
||||
# The underlying symbol must be a FILEHANDLE, for (print $x "foo").
|
||||
# It has to have a way of getting to the "real" back-end object...
|
||||
#
|
||||
sub new {
|
||||
my $master = shift;
|
||||
my $io = IO::Handle->new; ### create a new handle
|
||||
my $slave = shift;
|
||||
tie *$io, $slave, @_; ### tie: will invoke slave's TIEHANDLE
|
||||
bless $io, $master; ### return a master
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# AUTOLOAD
|
||||
#------------------------------
|
||||
# Delegate method invocations on the master to the underlying slave.
|
||||
#
|
||||
sub AUTOLOAD {
|
||||
my $method = $AUTOLOAD;
|
||||
$method =~ s/.*:://;
|
||||
my $self = shift; tied(*$self)->$method(\@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# PRELOAD
|
||||
#------------------------------
|
||||
# Utility.
|
||||
#
|
||||
# Most methods like print(), getline(), etc. which work on the tied object
|
||||
# via Perl's i/o operators (like 'print') are inherited from IO::Handle.
|
||||
#
|
||||
# Other methods, like seek() and sref(), we must delegate ourselves.
|
||||
# AUTOLOAD takes care of these.
|
||||
#
|
||||
# However, it may be necessary to preload delegators into your
|
||||
# own class. PRELOAD will do this.
|
||||
#
|
||||
sub PRELOAD {
|
||||
my $class = shift;
|
||||
foreach (@_) {
|
||||
eval "sub ${class}::$_ { my \$s = shift; tied(*\$s)->$_(\@_) }";
|
||||
}
|
||||
}
|
||||
|
||||
# Preload delegators for some standard methods which we can't simply
|
||||
# inherit from IO::Handle... for example, some IO::Handle methods
|
||||
# assume that there is an underlying file descriptor.
|
||||
#
|
||||
PRELOAD IO::WrapTie::Master
|
||||
qw(open opened close read clearerr eof seek tell setpos getpos);
|
||||
|
||||
|
||||
|
||||
#------------------------------------------------------------
|
||||
package # hide from pause
|
||||
IO::WrapTie::Slave;
|
||||
#------------------------------------------------------------
|
||||
# Teeny private class providing a new_tie constructor...
|
||||
#
|
||||
# HOW IT ALL WORKS:
|
||||
#
|
||||
# Slaves inherit from this class.
|
||||
#
|
||||
# When you send a new_tie() message to a tie-slave class (like IO::Scalar),
|
||||
# it first determines what class should provide its master, via TIE_MASTER.
|
||||
# In this case, IO::Scalar->TIE_MASTER would return IO::Scalar::Master.
|
||||
# Then, we create a new master (an IO::Scalar::Master) with the same args
|
||||
# sent to new_tie.
|
||||
#
|
||||
# In general, the new() method of the master is inherited directly
|
||||
# from IO::WrapTie::Master.
|
||||
#
|
||||
sub new_tie {
|
||||
my $self = shift;
|
||||
$self->TIE_MASTER->new($self,@_); ### e.g., IO::Scalar::Master->new(@_)
|
||||
}
|
||||
|
||||
# Default class method for new_tie().
|
||||
# All your tie-slave class (like IO::Scalar) has to do is override this
|
||||
# method with a method that returns the name of an appropriate "master"
|
||||
# class for tying that slave.
|
||||
#
|
||||
sub TIE_MASTER { 'IO::WrapTie::Master' }
|
||||
|
||||
#------------------------------
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
package IO::WrapTie; ### for doc generator
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IO::WrapTie - wrap tieable objects in IO::Handle interface
|
||||
|
||||
I<This is currently Alpha code, released for comments.
|
||||
Please give me your feedback!>
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
First of all, you'll need tie(), so:
|
||||
|
||||
require 5.004;
|
||||
|
||||
I<Function interface (experimental).>
|
||||
Use this with any existing class...
|
||||
|
||||
use IO::WrapTie;
|
||||
use FooHandle; ### implements TIEHANDLE interface
|
||||
|
||||
### Suppose we want a "FooHandle->new(&FOO_RDWR, 2)".
|
||||
### We can instead say...
|
||||
|
||||
$FH = wraptie('FooHandle', &FOO_RDWR, 2);
|
||||
|
||||
### Now we can use...
|
||||
print $FH "Hello, "; ### traditional operator syntax...
|
||||
$FH->print("world!\n"); ### ...and OO syntax as well!
|
||||
|
||||
I<OO interface (preferred).>
|
||||
You can inherit from the L<IO::WrapTie/"Slave"> mixin to get a
|
||||
nifty C<new_tie()> constructor...
|
||||
|
||||
#------------------------------
|
||||
package FooHandle; ### a class which can TIEHANDLE
|
||||
|
||||
use IO::WrapTie;
|
||||
@ISA = qw(IO::WrapTie::Slave); ### inherit new_tie()
|
||||
...
|
||||
|
||||
|
||||
#------------------------------
|
||||
package main;
|
||||
|
||||
$FH = FooHandle->new_tie(&FOO_RDWR, 2); ### $FH is an IO::WrapTie::Master
|
||||
print $FH "Hello, "; ### traditional operator syntax
|
||||
$FH->print("world!\n"); ### OO syntax
|
||||
|
||||
See IO::Scalar as an example. It also shows you how to create classes
|
||||
which work both with and without 5.004.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Suppose you have a class C<FooHandle>, where...
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
C<FooHandle> does not inherit from L<IO::Handle>. That is, it performs
|
||||
file handle-like I/O, but to something other than an underlying
|
||||
file descriptor. Good examples are L<IO::Scalar> (for printing to a
|
||||
string) and L<IO::Lines> (for printing to an array of lines).
|
||||
|
||||
=item *
|
||||
|
||||
C<FooHandle> implements the C<TIEHANDLE> interface (see L<perltie>).
|
||||
That is, it provides methods C<TIEHANDLE>, C<GETC>, C<PRINT>, C<PRINTF>,
|
||||
C<READ>, and C<READLINE>.
|
||||
|
||||
=item *
|
||||
|
||||
C<FooHandle> implements the traditional OO interface of
|
||||
L<FileHandle> and L<IO::Handle>. i.e., it contains methods like C<getline>,
|
||||
C<read>, C<print>, C<seek>, C<tell>, C<eof>, etc.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
Normally, users of your class would have two options:
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
B<Use only OO syntax,> and forsake named I/O operators like C<print>.
|
||||
|
||||
=item *
|
||||
|
||||
B<Use with tie,> and forsake treating it as a first-class object
|
||||
(i.e., class-specific methods can only be invoked through the underlying
|
||||
object via C<tied>... giving the object a "split personality").
|
||||
|
||||
=back
|
||||
|
||||
|
||||
But now with L<IO::WrapTie>, you can say:
|
||||
|
||||
$WT = wraptie('FooHandle', &FOO_RDWR, 2);
|
||||
$WT->print("Hello, world\n"); ### OO syntax
|
||||
print $WT "Yes!\n"; ### Named operator syntax too!
|
||||
$WT->weird_stuff; ### Other methods!
|
||||
|
||||
And if you're authoring a class like C<FooHandle>, just have it inherit
|
||||
from C<IO::WrapTie::Slave> and that first line becomes even prettier:
|
||||
|
||||
$WT = FooHandle->new_tie(&FOO_RDWR, 2);
|
||||
|
||||
B<The bottom line:> now, almost any class can look and work exactly like
|
||||
an L<IO::Handle> and be used both with OO and non-OO file handle syntax.
|
||||
|
||||
|
||||
=head1 HOW IT ALL WORKS
|
||||
|
||||
|
||||
=head2 The data structures
|
||||
|
||||
Consider this example code, using classes in this distribution:
|
||||
|
||||
use IO::Scalar;
|
||||
use IO::WrapTie;
|
||||
|
||||
$WT = wraptie('IO::Scalar',\$s);
|
||||
print $WT "Hello, ";
|
||||
$WT->print("world!\n");
|
||||
|
||||
In it, the C<wraptie> function creates a data structure as follows:
|
||||
|
||||
* $WT is a blessed reference to a tied filehandle
|
||||
$WT glob; that glob is tied to the "Slave" object.
|
||||
| * You would do all your i/o with $WT directly.
|
||||
|
|
||||
|
|
||||
| ,---isa--> IO::WrapTie::Master >--isa--> IO::Handle
|
||||
V /
|
||||
.-------------.
|
||||
| |
|
||||
| | * Perl i/o operators work on the tied object,
|
||||
| "Master" | invoking the C<TIEHANDLE> methods.
|
||||
| | * Method invocations are delegated to the tied
|
||||
| | slave.
|
||||
`-------------'
|
||||
|
|
||||
tied(*$WT) | .---isa--> IO::WrapTie::Slave
|
||||
V /
|
||||
.-------------.
|
||||
| |
|
||||
| "Slave" | * Instance of FileHandle-like class which doesn't
|
||||
| | actually use file descriptors, like IO::Scalar.
|
||||
| IO::Scalar | * The slave can be any kind of object.
|
||||
| | * Must implement the C<TIEHANDLE> interface.
|
||||
`-------------'
|
||||
|
||||
|
||||
I<NOTE:> just as an L<IO::Handle> is really just a blessed reference to a
|
||||
I<traditional> file handle glob. So also, an C<IO::WrapTie::Master>
|
||||
is really just a blessed reference to a file handle
|
||||
glob I<which has been tied to some "slave" class.>
|
||||
|
||||
|
||||
=head2 How C<wraptie> works
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
The call to function C<wraptie(SLAVECLASS, TIEARGS...)> is
|
||||
passed onto C<IO::WrapTie::Master::new()>.
|
||||
Note that class C<IO::WrapTie::Master> is a subclass of L<IO::Handle>.
|
||||
|
||||
=item 2.
|
||||
|
||||
The C<< IO::WrapTie::Master->new >> method creates a new L<IO::Handle> object,
|
||||
re-blessed into class C<IO::WrapTie::Master>. This object is the I<master>,
|
||||
which will be returned from the constructor. At the same time...
|
||||
|
||||
=item 3.
|
||||
|
||||
The C<new> method also creates the I<slave>: this is an instance
|
||||
of C<SLAVECLASS> which is created by tying the master's L<IO::Handle>
|
||||
to C<SLAVECLASS> via C<tie>.
|
||||
This call to C<tie> creates the slave in the following manner:
|
||||
|
||||
=item 4.
|
||||
|
||||
Class C<SLAVECLASS> is sent the message C<TIEHANDLE>; it
|
||||
will usually delegate this to C<< SLAVECLASS->new(TIEARGS) >>, resulting
|
||||
in a new instance of C<SLAVECLASS> being created and returned.
|
||||
|
||||
=item 5.
|
||||
|
||||
Once both master and slave have been created, the master is returned
|
||||
to the caller.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head2 How I/O operators work (on the master)
|
||||
|
||||
Consider using an i/o operator on the master:
|
||||
|
||||
print $WT "Hello, world!\n";
|
||||
|
||||
Since the master C<$WT> is really a C<blessed> reference to a glob,
|
||||
the normal Perl I/O operators like C<print> may be used on it.
|
||||
They will just operate on the symbol part of the glob.
|
||||
|
||||
Since the glob is tied to the slave, the slave's C<PRINT> method
|
||||
(part of the C<TIEHANDLE> interface) will be automatically invoked.
|
||||
|
||||
If the slave is an L<IO::Scalar>, that means L<IO::Scalar/"PRINT"> will be
|
||||
invoked, and that method happens to delegate to the C<print> method
|
||||
of the same class. So the I<real> work is ultimately done by
|
||||
L<IO::Scalar/"print">.
|
||||
|
||||
|
||||
=head2 How methods work (on the master)
|
||||
|
||||
Consider using a method on the master:
|
||||
|
||||
$WT->print("Hello, world!\n");
|
||||
|
||||
Since the master C<$WT> is blessed into the class C<IO::WrapTie::Master>,
|
||||
Perl first attempts to find a C<print> method there. Failing that,
|
||||
Perl next attempts to find a C<print> method in the super class,
|
||||
L<IO::Handle>. It just so happens that there I<is> such a method;
|
||||
that method merely invokes the C<print> I/O operator on the self object...
|
||||
and for that, see above!
|
||||
|
||||
But let's suppose we're dealing with a method which I<isn't> part
|
||||
of L<IO::Handle>... for example:
|
||||
|
||||
my $sref = $WT->sref;
|
||||
|
||||
In this case, the intuitive behavior is to have the master delegate the
|
||||
method invocation to the slave (now do you see where the designations
|
||||
come from?). This is indeed what happens: C<IO::WrapTie::Master> contains
|
||||
an C<AUTOLOAD> method which performs the delegation.
|
||||
|
||||
So: when C<sref> can't be found in L<IO::Handle>, the C<AUTOLOAD> method
|
||||
of C<IO::WrapTie::Master> is invoked, and the standard behavior of
|
||||
delegating the method to the underlying slave (here, an L<IO::Scalar>)
|
||||
is done.
|
||||
|
||||
Sometimes, to get this to work properly, you may need to create
|
||||
a subclass of C<IO::WrapTie::Master> which is an effective master for
|
||||
I<your> class, and do the delegation there.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
B<Why not simply use the object's OO interface?>
|
||||
|
||||
Because that means forsaking the use of named operators
|
||||
like C<print>, and you may need to pass the object to a subroutine
|
||||
which will attempt to use those operators:
|
||||
|
||||
$O = FooHandle->new(&FOO_RDWR, 2);
|
||||
$O->print("Hello, world\n"); ### OO syntax is okay, BUT....
|
||||
|
||||
sub nope { print $_[0] "Nope!\n" }
|
||||
X nope($O); ### ERROR!!! (not a glob ref)
|
||||
|
||||
|
||||
B<Why not simply use tie()?>
|
||||
Because (1) you have to use C<tied> to invoke methods in the
|
||||
object's public interface (yuck), and (2) you may need to pass
|
||||
the tied symbol to another subroutine which will attempt to treat
|
||||
it in an OO-way... and that will break it:
|
||||
|
||||
tie *T, 'FooHandle', &FOO_RDWR, 2;
|
||||
print T "Hello, world\n"; ### Operator is okay, BUT...
|
||||
|
||||
tied(*T)->other_stuff; ### yuck! AND...
|
||||
|
||||
sub nope { shift->print("Nope!\n") }
|
||||
X nope(\*T); ### ERROR!!! (method "print" on unblessed ref)
|
||||
|
||||
|
||||
B<Why a master and slave?>
|
||||
|
||||
Why not simply write C<FooHandle> to inherit from L<IO::Handle?>
|
||||
I tried this, with an implementation similar to that of L<IO::Socket>.
|
||||
The problem is that I<the whole point is to use this with objects
|
||||
that don't have an underlying file/socket descriptor.>.
|
||||
Subclassing L<IO::Handle> will work fine for the OO stuff, and fine with
|
||||
named operators I<if> you C<tie>... but if you just attempt to say:
|
||||
|
||||
$IO = FooHandle->new(&FOO_RDWR, 2);
|
||||
print $IO "Hello!\n";
|
||||
|
||||
you get a warning from Perl like:
|
||||
|
||||
Filehandle GEN001 never opened
|
||||
|
||||
because it's trying to do system-level I/O on an (unopened) file
|
||||
descriptor. To avoid this, you apparently have to C<tie> the handle...
|
||||
which brings us right back to where we started! At least the
|
||||
L<IO::WrapTie> mixin lets us say:
|
||||
|
||||
$IO = FooHandle->new_tie(&FOO_RDWR, 2);
|
||||
print $IO "Hello!\n";
|
||||
|
||||
and so is not I<too> bad. C<:-)>
|
||||
|
||||
|
||||
=head1 WARNINGS
|
||||
|
||||
Remember: this stuff is for doing L<FileHandle>-like I/O on things
|
||||
I<without underlying file descriptors>. If you have an underlying
|
||||
file descriptor, you're better off just inheriting from L<IO::Handle>.
|
||||
|
||||
B<Be aware that new_tie() always returns an instance of a
|
||||
kind of IO::WrapTie::Master...> it does B<not> return an instance
|
||||
of the I/O class you're tying to!
|
||||
|
||||
Invoking some methods on the master object causes C<AUTOLOAD> to delegate
|
||||
them to the slave object... so it I<looks> like you're manipulating a
|
||||
C<FooHandle> object directly, but you're not.
|
||||
|
||||
I have not explored all the ramifications of this use of C<tie>.
|
||||
I<Here there be dragons>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>).
|
||||
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
Dianne Skoll (F<dfs@roaringpenguin.com>).
|
||||
|
||||
=head1 COPYRIGHT & LICENSE
|
||||
|
||||
Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
1844
gitportable/usr/share/perl5/vendor_perl/JSON.pm
Normal file
1844
gitportable/usr/share/perl5/vendor_perl/JSON.pm
Normal file
File diff suppressed because it is too large
Load Diff
3256
gitportable/usr/share/perl5/vendor_perl/JSON/backportPP.pm
Normal file
3256
gitportable/usr/share/perl5/vendor_perl/JSON/backportPP.pm
Normal file
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,44 @@
|
||||
package # This is JSON::backportPP
|
||||
JSON::PP::Boolean;
|
||||
|
||||
use strict;
|
||||
require overload;
|
||||
local $^W;
|
||||
overload::unimport('overload', qw(0+ ++ -- fallback));
|
||||
overload::import('overload',
|
||||
"0+" => sub { ${$_[0]} },
|
||||
"++" => sub { $_[0] = ${$_[0]} + 1 },
|
||||
"--" => sub { $_[0] = ${$_[0]} - 1 },
|
||||
fallback => 1,
|
||||
);
|
||||
|
||||
$JSON::backportPP::Boolean::VERSION = '4.12';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# do not "use" yourself
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module exists only to provide overload resolution for Storable and similar modules. See
|
||||
L<JSON::PP> for more info about this class.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
@@ -0,0 +1,131 @@
|
||||
package # This is JSON::backportPP
|
||||
JSON::backportPP5005;
|
||||
|
||||
use 5.005;
|
||||
use strict;
|
||||
|
||||
my @properties;
|
||||
|
||||
$JSON::PP5005::VERSION = '1.10';
|
||||
|
||||
BEGIN {
|
||||
|
||||
sub utf8::is_utf8 {
|
||||
0; # It is considered that UTF8 flag off for Perl 5.005.
|
||||
}
|
||||
|
||||
sub utf8::upgrade {
|
||||
}
|
||||
|
||||
sub utf8::downgrade {
|
||||
1; # must always return true.
|
||||
}
|
||||
|
||||
sub utf8::encode {
|
||||
}
|
||||
|
||||
sub utf8::decode {
|
||||
}
|
||||
|
||||
*JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
|
||||
*JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
|
||||
*JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
|
||||
*JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
|
||||
|
||||
# missing in B module.
|
||||
sub B::SVp_IOK () { 0x01000000; }
|
||||
sub B::SVp_NOK () { 0x02000000; }
|
||||
sub B::SVp_POK () { 0x04000000; }
|
||||
|
||||
$INC{'bytes.pm'} = 1; # dummy
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub _encode_ascii {
|
||||
join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) );
|
||||
}
|
||||
|
||||
|
||||
sub _encode_latin1 {
|
||||
join('', map { chr($_) } unpack('C*', $_[0]) );
|
||||
}
|
||||
|
||||
|
||||
sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm
|
||||
my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode
|
||||
my $bit = unpack('B32', pack('N', $uni));
|
||||
|
||||
if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) {
|
||||
my ($w, $x, $y, $z) = ($1, $2, $3, $4);
|
||||
return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z));
|
||||
}
|
||||
else {
|
||||
Carp::croak("Invalid surrogate pair");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub _decode_unicode {
|
||||
my ($u) = @_;
|
||||
my ($utf8bit);
|
||||
|
||||
if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff
|
||||
return pack( 'H2', $1 );
|
||||
}
|
||||
|
||||
my $bit = unpack("B*", pack("H*", $u));
|
||||
|
||||
if ( $bit =~ /^00000(.....)(......)$/ ) {
|
||||
$utf8bit = sprintf('110%s10%s', $1, $2);
|
||||
}
|
||||
elsif ( $bit =~ /^(....)(......)(......)$/ ) {
|
||||
$utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3);
|
||||
}
|
||||
else {
|
||||
Carp::croak("Invalid escaped unicode");
|
||||
}
|
||||
|
||||
return pack('B*', $utf8bit);
|
||||
}
|
||||
|
||||
|
||||
sub JSON::PP::incr_text {
|
||||
$_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
|
||||
|
||||
if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
|
||||
Carp::croak("incr_text can not be called when the incremental parser already started parsing");
|
||||
}
|
||||
|
||||
$_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 );
|
||||
$_[0]->{_incr_parser}->{incr_text};
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
JSON::PP calls internally.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
|
||||
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2007-2012 by Makamaka Hannyaharamitu
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
@@ -0,0 +1,173 @@
|
||||
package # This is JSON::backportPP
|
||||
JSON::backportPP56;
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
|
||||
my @properties;
|
||||
|
||||
$JSON::PP56::VERSION = '1.08';
|
||||
|
||||
BEGIN {
|
||||
|
||||
sub utf8::is_utf8 {
|
||||
my $len = length $_[0]; # char length
|
||||
{
|
||||
use bytes; # byte length;
|
||||
return $len != length $_[0]; # if !=, UTF8-flagged on.
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub utf8::upgrade {
|
||||
; # noop;
|
||||
}
|
||||
|
||||
|
||||
sub utf8::downgrade ($;$) {
|
||||
return 1 unless ( utf8::is_utf8( $_[0] ) );
|
||||
|
||||
if ( _is_valid_utf8( $_[0] ) ) {
|
||||
my $downgrade;
|
||||
for my $c ( unpack( "U*", $_[0] ) ) {
|
||||
if ( $c < 256 ) {
|
||||
$downgrade .= pack("C", $c);
|
||||
}
|
||||
else {
|
||||
$downgrade .= pack("U", $c);
|
||||
}
|
||||
}
|
||||
$_[0] = $downgrade;
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
Carp::croak("Wide character in subroutine entry") unless ( $_[1] );
|
||||
0;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub utf8::encode ($) { # UTF8 flag off
|
||||
if ( utf8::is_utf8( $_[0] ) ) {
|
||||
$_[0] = pack( "C*", unpack( "C*", $_[0] ) );
|
||||
}
|
||||
else {
|
||||
$_[0] = pack( "U*", unpack( "C*", $_[0] ) );
|
||||
$_[0] = pack( "C*", unpack( "C*", $_[0] ) );
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub utf8::decode ($) { # UTF8 flag on
|
||||
if ( _is_valid_utf8( $_[0] ) ) {
|
||||
utf8::downgrade( $_[0] );
|
||||
$_[0] = pack( "U*", unpack( "U*", $_[0] ) );
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
*JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
|
||||
*JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
|
||||
*JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates;
|
||||
*JSON::PP::JSON_PP_decode_unicode = \&JSON::PP::_decode_unicode;
|
||||
|
||||
unless ( defined &B::SVp_NOK ) { # missing in B module.
|
||||
eval q{ sub B::SVp_NOK () { 0x02000000; } };
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub _encode_ascii {
|
||||
join('',
|
||||
map {
|
||||
$_ <= 127 ?
|
||||
chr($_) :
|
||||
$_ <= 65535 ?
|
||||
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
|
||||
} _unpack_emu($_[0])
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
sub _encode_latin1 {
|
||||
join('',
|
||||
map {
|
||||
$_ <= 255 ?
|
||||
chr($_) :
|
||||
$_ <= 65535 ?
|
||||
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
|
||||
} _unpack_emu($_[0])
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
sub _unpack_emu { # for Perl 5.6 unpack warnings
|
||||
return !utf8::is_utf8($_[0]) ? unpack('C*', $_[0])
|
||||
: _is_valid_utf8($_[0]) ? unpack('U*', $_[0])
|
||||
: unpack('C*', $_[0]);
|
||||
}
|
||||
|
||||
|
||||
sub _is_valid_utf8 {
|
||||
my $str = $_[0];
|
||||
my $is_utf8;
|
||||
|
||||
while ($str =~ /(?:
|
||||
(
|
||||
[\x00-\x7F]
|
||||
|[\xC2-\xDF][\x80-\xBF]
|
||||
|[\xE0][\xA0-\xBF][\x80-\xBF]
|
||||
|[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
|
||||
|[\xED][\x80-\x9F][\x80-\xBF]
|
||||
|[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
|
||||
|[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
|
||||
|[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
|
||||
|[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
|
||||
)
|
||||
| (.)
|
||||
)/xg)
|
||||
{
|
||||
if (defined $1) {
|
||||
$is_utf8 = 1 if (!defined $is_utf8);
|
||||
}
|
||||
else {
|
||||
$is_utf8 = 0 if (!defined $is_utf8);
|
||||
if ($is_utf8) { # eventually, not utf8
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $is_utf8;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
JSON::PP56 - Helper module in using JSON::PP in Perl 5.6
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
JSON::PP calls internally.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
|
||||
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2007-2012 by Makamaka Hannyaharamitu
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
669
gitportable/usr/share/perl5/vendor_perl/LWP.pm
Normal file
669
gitportable/usr/share/perl5/vendor_perl/LWP.pm
Normal file
@@ -0,0 +1,669 @@
|
||||
package LWP;
|
||||
|
||||
our $VERSION = '6.78';
|
||||
|
||||
require LWP::UserAgent; # this should load everything you need
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding utf-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
LWP - The World-Wide Web library for Perl
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use LWP;
|
||||
print "This is libwww-perl-$LWP::VERSION\n";
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The libwww-perl collection is a set of Perl modules which provides a
|
||||
simple and consistent application programming interface (API) to the
|
||||
World-Wide Web. The main focus of the library is to provide classes
|
||||
and functions that allow you to write WWW clients. The library also
|
||||
contain modules that are of more general use and even classes that
|
||||
help you implement simple HTTP servers.
|
||||
|
||||
Most modules in this library provide an object oriented API. The user
|
||||
agent, requests sent and responses received from the WWW server are
|
||||
all represented by objects. This makes a simple and powerful
|
||||
interface to these services. The interface is easy to extend
|
||||
and customize for your own needs.
|
||||
|
||||
The main features of the library are:
|
||||
|
||||
=over 3
|
||||
|
||||
=item *
|
||||
|
||||
Contains various reusable components (modules) that can be
|
||||
used separately or together.
|
||||
|
||||
=item *
|
||||
|
||||
Provides an object oriented model of HTTP-style communication. Within
|
||||
this framework we currently support access to C<http>, C<https>, C<gopher>,
|
||||
C<ftp>, C<news>, C<file>, and C<mailto> resources.
|
||||
|
||||
=item *
|
||||
|
||||
Provides a full object oriented interface or
|
||||
a very simple procedural interface.
|
||||
|
||||
=item *
|
||||
|
||||
Supports the basic and digest authorization schemes.
|
||||
|
||||
=item *
|
||||
|
||||
Supports transparent redirect handling.
|
||||
|
||||
=item *
|
||||
|
||||
Supports access through proxy servers.
|
||||
|
||||
=item *
|
||||
|
||||
Provides parser for F<robots.txt> files and a framework for constructing robots.
|
||||
|
||||
=item *
|
||||
|
||||
Supports parsing of HTML forms.
|
||||
|
||||
=item *
|
||||
|
||||
Implements HTTP content negotiation algorithm that can
|
||||
be used both in protocol modules and in server scripts (like CGI
|
||||
scripts).
|
||||
|
||||
=item *
|
||||
|
||||
Supports HTTP cookies.
|
||||
|
||||
=item *
|
||||
|
||||
Some simple command line clients, for instance C<lwp-request> and C<lwp-download>.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 HTTP STYLE COMMUNICATION
|
||||
|
||||
|
||||
The libwww-perl library is based on HTTP style communication. This
|
||||
section tries to describe what that means.
|
||||
|
||||
Let us start with this quote from the HTTP specification document
|
||||
L<http://www.w3.org/Protocols/>:
|
||||
|
||||
=over 3
|
||||
|
||||
=item *
|
||||
|
||||
The HTTP protocol is based on a request/response paradigm. A client
|
||||
establishes a connection with a server and sends a request to the
|
||||
server in the form of a request method, URI, and protocol version,
|
||||
followed by a MIME-like message containing request modifiers, client
|
||||
information, and possible body content. The server responds with a
|
||||
status line, including the message's protocol version and a success or
|
||||
error code, followed by a MIME-like message containing server
|
||||
information, entity meta-information, and possible body content.
|
||||
|
||||
=back
|
||||
|
||||
What this means to libwww-perl is that communication always take place
|
||||
through these steps: First a I<request> object is created and
|
||||
configured. This object is then passed to a server and we get a
|
||||
I<response> object in return that we can examine. A request is always
|
||||
independent of any previous requests, i.e. the service is stateless.
|
||||
The same simple model is used for any kind of service we want to
|
||||
access.
|
||||
|
||||
For example, if we want to fetch a document from a remote file server,
|
||||
then we send it a request that contains a name for that document and
|
||||
the response will contain the document itself. If we access a search
|
||||
engine, then the content of the request will contain the query
|
||||
parameters and the response will contain the query result. If we want
|
||||
to send a mail message to somebody then we send a request object which
|
||||
contains our message to the mail server and the response object will
|
||||
contain an acknowledgment that tells us that the message has been
|
||||
accepted and will be forwarded to the recipient(s).
|
||||
|
||||
It is as simple as that!
|
||||
|
||||
|
||||
=head2 The Request Object
|
||||
|
||||
The libwww-perl request object has the class name L<HTTP::Request>.
|
||||
The fact that the class name uses C<HTTP::> as a
|
||||
prefix only implies that we use the HTTP model of communication. It
|
||||
does not limit the kind of services we can try to pass this I<request>
|
||||
to. For instance, we will send L<HTTP::Request>s both to ftp and
|
||||
gopher servers, as well as to the local file system.
|
||||
|
||||
The main attributes of the request objects are:
|
||||
|
||||
=over 3
|
||||
|
||||
=item *
|
||||
|
||||
B<method> is a short string that tells what kind of
|
||||
request this is. The most common methods are B<GET>, B<PUT>,
|
||||
B<POST> and B<HEAD>.
|
||||
|
||||
=item *
|
||||
|
||||
B<uri> is a string denoting the protocol, server and
|
||||
the name of the "document" we want to access. The B<uri> might
|
||||
also encode various other parameters.
|
||||
|
||||
=item *
|
||||
|
||||
B<headers> contains additional information about the
|
||||
request and can also used to describe the content. The headers
|
||||
are a set of keyword/value pairs.
|
||||
|
||||
=item *
|
||||
|
||||
B<content> is an arbitrary amount of data.
|
||||
|
||||
=back
|
||||
|
||||
=head2 The Response Object
|
||||
|
||||
The libwww-perl response object has the class name L<HTTP::Response>.
|
||||
The main attributes of objects of this class are:
|
||||
|
||||
=over 3
|
||||
|
||||
=item *
|
||||
|
||||
B<code> is a numerical value that indicates the overall
|
||||
outcome of the request.
|
||||
|
||||
=item *
|
||||
|
||||
B<message> is a short, human readable string that
|
||||
corresponds to the I<code>.
|
||||
|
||||
=item *
|
||||
|
||||
B<headers> contains additional information about the
|
||||
response and describe the content.
|
||||
|
||||
=item *
|
||||
|
||||
B<content> is an arbitrary amount of data.
|
||||
|
||||
=back
|
||||
|
||||
Since we don't want to handle all possible I<code> values directly in
|
||||
our programs, a libwww-perl response object has methods that can be
|
||||
used to query what kind of response this is. The most commonly used
|
||||
response classification methods are:
|
||||
|
||||
=over 3
|
||||
|
||||
=item is_success()
|
||||
|
||||
The request was successfully received, understood or accepted.
|
||||
|
||||
=item is_error()
|
||||
|
||||
The request failed. The server or the resource might not be
|
||||
available, access to the resource might be denied or other things might
|
||||
have failed for some reason.
|
||||
|
||||
=back
|
||||
|
||||
=head2 The User Agent
|
||||
|
||||
Let us assume that we have created a I<request> object. What do we
|
||||
actually do with it in order to receive a I<response>?
|
||||
|
||||
The answer is that you pass it to a I<user agent> object and this
|
||||
object takes care of all the things that need to be done
|
||||
(like low-level communication and error handling) and returns
|
||||
a I<response> object. The user agent represents your
|
||||
application on the network and provides you with an interface that
|
||||
can accept I<requests> and return I<responses>.
|
||||
|
||||
The user agent is an interface layer between
|
||||
your application code and the network. Through this interface you are
|
||||
able to access the various servers on the network.
|
||||
|
||||
The class name for the user agent is L<LWP::UserAgent>. Every
|
||||
libwww-perl application that wants to communicate should create at
|
||||
least one object of this class. The main method provided by this
|
||||
object is request(). This method takes an L<HTTP::Request> object as
|
||||
argument and (eventually) returns a L<HTTP::Response> object.
|
||||
|
||||
The user agent has many other attributes that let you
|
||||
configure how it will interact with the network and with your
|
||||
application.
|
||||
|
||||
=over 3
|
||||
|
||||
=item *
|
||||
|
||||
B<timeout> specifies how much time we give remote servers to
|
||||
respond before the library disconnects and creates an
|
||||
internal I<timeout> response.
|
||||
|
||||
=item *
|
||||
|
||||
B<agent> specifies the name that your application uses when it
|
||||
presents itself on the network.
|
||||
|
||||
=item *
|
||||
|
||||
B<from> can be set to the e-mail address of the person
|
||||
responsible for running the application. If this is set, then the
|
||||
address will be sent to the servers with every request.
|
||||
|
||||
=item *
|
||||
|
||||
B<parse_head> specifies whether we should initialize response
|
||||
headers from the C<< <head> >> section of HTML documents.
|
||||
|
||||
=item *
|
||||
|
||||
B<proxy> and B<no_proxy> specify if and when to go through
|
||||
a proxy server. L<http://www.w3.org/History/1994/WWW/Proxies/>
|
||||
|
||||
=item *
|
||||
|
||||
B<credentials> provides a way to set up user names and
|
||||
passwords needed to access certain services.
|
||||
|
||||
=back
|
||||
|
||||
Many applications want even more control over how they interact
|
||||
with the network and they get this by sub-classing
|
||||
L<LWP::UserAgent>. The library includes a
|
||||
sub-class, L<LWP::RobotUA>, for robot applications.
|
||||
|
||||
=head2 An Example
|
||||
|
||||
This example shows how the user agent, a request and a response are
|
||||
represented in actual perl code:
|
||||
|
||||
# Create a user agent object
|
||||
use LWP::UserAgent;
|
||||
my $ua = LWP::UserAgent->new;
|
||||
$ua->agent("MyApp/0.1 ");
|
||||
|
||||
# Create a request
|
||||
my $req = HTTP::Request->new(POST => 'http://search.cpan.org/search');
|
||||
$req->content_type('application/x-www-form-urlencoded');
|
||||
$req->content('query=libwww-perl&mode=dist');
|
||||
|
||||
# Pass request to the user agent and get a response back
|
||||
my $res = $ua->request($req);
|
||||
|
||||
# Check the outcome of the response
|
||||
if ($res->is_success) {
|
||||
print $res->content;
|
||||
}
|
||||
else {
|
||||
print $res->status_line, "\n";
|
||||
}
|
||||
|
||||
The C<$ua> is created once when the application starts up. New request
|
||||
objects should normally created for each request sent.
|
||||
|
||||
|
||||
=head1 NETWORK SUPPORT
|
||||
|
||||
This section discusses the various protocol schemes and
|
||||
the HTTP style methods that headers may be used for each.
|
||||
|
||||
For all requests, a "User-Agent" header is added and initialized from
|
||||
the C<< $ua->agent >> attribute before the request is handed to the network
|
||||
layer. In the same way, a "From" header is initialized from the
|
||||
$ua->from attribute.
|
||||
|
||||
For all responses, the library adds a header called "Client-Date".
|
||||
This header holds the time when the response was received by
|
||||
your application. The format and semantics of the header are the
|
||||
same as the server created "Date" header. You may also encounter other
|
||||
"Client-XXX" headers. They are all generated by the library
|
||||
internally and are not received from the servers.
|
||||
|
||||
=head2 HTTP Requests
|
||||
|
||||
HTTP requests are just handed off to an HTTP server and it
|
||||
decides what happens. Few servers implement methods beside the usual
|
||||
"GET", "HEAD", "POST" and "PUT", but CGI-scripts may implement
|
||||
any method they like.
|
||||
|
||||
If the server is not available then the library will generate an
|
||||
internal error response.
|
||||
|
||||
The library automatically adds a "Host" and a "Content-Length" header
|
||||
to the HTTP request before it is sent over the network.
|
||||
|
||||
For a GET request you might want to add an "If-Modified-Since" or
|
||||
"If-None-Match" header to make the request conditional.
|
||||
|
||||
For a POST request you should add the "Content-Type" header. When you
|
||||
try to emulate HTML E<lt>FORM> handling you should usually let the value
|
||||
of the "Content-Type" header be "application/x-www-form-urlencoded".
|
||||
See L<lwpcook> for examples of this.
|
||||
|
||||
The libwww-perl HTTP implementation currently support the HTTP/1.1
|
||||
and HTTP/1.0 protocol.
|
||||
|
||||
The library allows you to access proxy server through HTTP. This
|
||||
means that you can set up the library to forward all types of request
|
||||
through the HTTP protocol module. See L<LWP::UserAgent> for
|
||||
documentation of this.
|
||||
|
||||
|
||||
=head2 HTTPS Requests
|
||||
|
||||
HTTPS requests are HTTP requests over an encrypted network connection
|
||||
using the SSL protocol developed by Netscape. Everything about HTTP
|
||||
requests above also apply to HTTPS requests. In addition the library
|
||||
will add the headers "Client-SSL-Cipher", "Client-SSL-Cert-Subject" and
|
||||
"Client-SSL-Cert-Issuer" to the response. These headers denote the
|
||||
encryption method used and the name of the server owner.
|
||||
|
||||
The request can contain the header "If-SSL-Cert-Subject" in order to
|
||||
make the request conditional on the content of the server certificate.
|
||||
If the certificate subject does not match, no request is sent to the
|
||||
server and an internally generated error response is returned. The
|
||||
value of the "If-SSL-Cert-Subject" header is interpreted as a Perl
|
||||
regular expression.
|
||||
|
||||
|
||||
=head2 FTP Requests
|
||||
|
||||
The library currently supports GET, HEAD and PUT requests. GET
|
||||
retrieves a file or a directory listing from an FTP server. PUT
|
||||
stores a file on a ftp server.
|
||||
|
||||
You can specify a ftp account for servers that want this in addition
|
||||
to user name and password. This is specified by including an "Account"
|
||||
header in the request.
|
||||
|
||||
User name/password can be specified using basic authorization or be
|
||||
encoded in the URL. Failed logins return an UNAUTHORIZED response with
|
||||
"WWW-Authenticate: Basic" and can be treated like basic authorization
|
||||
for HTTP.
|
||||
|
||||
The library supports ftp ASCII transfer mode by specifying the "type=a"
|
||||
parameter in the URL. It also supports transfer of ranges for FTP transfers
|
||||
using the "Range" header.
|
||||
|
||||
Directory listings are by default returned unprocessed (as returned
|
||||
from the ftp server) with the content media type reported to be
|
||||
"text/ftp-dir-listing". The L<File::Listing> module provides methods
|
||||
for parsing of these directory listing.
|
||||
|
||||
The ftp module is also able to convert directory listings to HTML and
|
||||
this can be requested via the standard HTTP content negotiation
|
||||
mechanisms (add an "Accept: text/html" header in the request if you
|
||||
want this).
|
||||
|
||||
For normal file retrievals, the "Content-Type" is guessed based on the
|
||||
file name suffix. See L<LWP::MediaTypes>.
|
||||
|
||||
The "If-Modified-Since" request header works for servers that implement
|
||||
the C<MDTM> command. It will probably not work for directory listings though.
|
||||
|
||||
Example:
|
||||
|
||||
$req = HTTP::Request->new(GET => 'ftp://me:passwd@ftp.some.where.com/');
|
||||
$req->header(Accept => "text/html, */*;q=0.1");
|
||||
|
||||
=head2 News Requests
|
||||
|
||||
Access to the USENET News system is implemented through the NNTP
|
||||
protocol. The name of the news server is obtained from the
|
||||
NNTP_SERVER environment variable and defaults to "news". It is not
|
||||
possible to specify the hostname of the NNTP server in news: URLs.
|
||||
|
||||
The library supports GET and HEAD to retrieve news articles through the
|
||||
NNTP protocol. You can also post articles to newsgroups by using
|
||||
(surprise!) the POST method.
|
||||
|
||||
GET on newsgroups is not implemented yet.
|
||||
|
||||
Examples:
|
||||
|
||||
$req = HTTP::Request->new(GET => 'news:abc1234@a.sn.no');
|
||||
|
||||
$req = HTTP::Request->new(POST => 'news:comp.lang.perl.test');
|
||||
$req->header(Subject => 'This is a test',
|
||||
From => 'me@some.where.org');
|
||||
$req->content(<<EOT);
|
||||
This is the content of the message that we are sending to
|
||||
the world.
|
||||
EOT
|
||||
|
||||
|
||||
=head2 Gopher Request
|
||||
|
||||
The library supports the GET and HEAD methods for gopher requests. All
|
||||
request header values are ignored. HEAD cheats and returns a
|
||||
response without even talking to server.
|
||||
|
||||
Gopher menus are always converted to HTML.
|
||||
|
||||
The response "Content-Type" is generated from the document type
|
||||
encoded (as the first letter) in the request URL path itself.
|
||||
|
||||
Example:
|
||||
|
||||
$req = HTTP::Request->new(GET => 'gopher://gopher.sn.no/');
|
||||
|
||||
|
||||
|
||||
=head2 File Request
|
||||
|
||||
The library supports GET and HEAD methods for file requests. The
|
||||
"If-Modified-Since" header is supported. All other headers are
|
||||
ignored. The I<host> component of the file URL must be empty or set
|
||||
to "localhost". Any other I<host> value will be treated as an error.
|
||||
|
||||
Directories are always converted to an HTML document. For normal
|
||||
files, the "Content-Type" and "Content-Encoding" in the response are
|
||||
guessed based on the file suffix.
|
||||
|
||||
Example:
|
||||
|
||||
$req = HTTP::Request->new(GET => 'file:/etc/passwd');
|
||||
|
||||
|
||||
=head2 Mailto Request
|
||||
|
||||
You can send (aka "POST") mail messages using the library. All
|
||||
headers specified for the request are passed on to the mail system.
|
||||
The "To" header is initialized from the mail address in the URL.
|
||||
|
||||
Example:
|
||||
|
||||
$req = HTTP::Request->new(POST => 'mailto:libwww@perl.org');
|
||||
$req->header(Subject => "subscribe");
|
||||
$req->content("Please subscribe me to the libwww-perl mailing list!\n");
|
||||
|
||||
=head2 CPAN Requests
|
||||
|
||||
URLs with scheme C<cpan:> are redirected to a suitable CPAN
|
||||
mirror. If you have your own local mirror of CPAN you might tell LWP
|
||||
to use it for C<cpan:> URLs by an assignment like this:
|
||||
|
||||
$LWP::Protocol::cpan::CPAN = "file:/local/CPAN/";
|
||||
|
||||
Suitable CPAN mirrors are also picked up from the configuration for
|
||||
the CPAN.pm, so if you have used that module a suitable mirror should
|
||||
be picked automatically. If neither of these apply, then a redirect
|
||||
to the generic CPAN http location is issued.
|
||||
|
||||
Example request to download the newest perl:
|
||||
|
||||
$req = HTTP::Request->new(GET => "cpan:src/latest.tar.gz");
|
||||
|
||||
|
||||
=head1 OVERVIEW OF CLASSES AND PACKAGES
|
||||
|
||||
This table should give you a quick overview of the classes provided by the
|
||||
library. Indentation shows class inheritance.
|
||||
|
||||
LWP::MemberMixin -- Access to member variables of Perl5 classes
|
||||
LWP::UserAgent -- WWW user agent class
|
||||
LWP::RobotUA -- When developing a robot applications
|
||||
LWP::Protocol -- Interface to various protocol schemes
|
||||
LWP::Protocol::http -- http:// access
|
||||
LWP::Protocol::file -- file:// access
|
||||
LWP::Protocol::ftp -- ftp:// access
|
||||
...
|
||||
|
||||
LWP::Authen::Basic -- Handle 401 and 407 responses
|
||||
LWP::Authen::Digest
|
||||
|
||||
HTTP::Headers -- MIME/RFC822 style header (used by HTTP::Message)
|
||||
HTTP::Message -- HTTP style message
|
||||
HTTP::Request -- HTTP request
|
||||
HTTP::Response -- HTTP response
|
||||
HTTP::Daemon -- A HTTP server class
|
||||
|
||||
WWW::RobotRules -- Parse robots.txt files
|
||||
WWW::RobotRules::AnyDBM_File -- Persistent RobotRules
|
||||
|
||||
Net::HTTP -- Low level HTTP client
|
||||
|
||||
The following modules provide various functions and definitions.
|
||||
|
||||
LWP -- This file. Library version number and documentation.
|
||||
LWP::MediaTypes -- MIME types configuration (text/html etc.)
|
||||
LWP::Simple -- Simplified procedural interface for common functions
|
||||
HTTP::Status -- HTTP status code (200 OK etc)
|
||||
HTTP::Date -- Date parsing module for HTTP date formats
|
||||
HTTP::Negotiate -- HTTP content negotiation calculation
|
||||
File::Listing -- Parse directory listings
|
||||
HTML::Form -- Processing for <form>s in HTML documents
|
||||
|
||||
|
||||
=head1 MORE DOCUMENTATION
|
||||
|
||||
All modules contain detailed information on the interfaces they
|
||||
provide. The L<lwpcook> manpage is the libwww-perl cookbook that contain
|
||||
examples of typical usage of the library. You might want to take a
|
||||
look at how the scripts L<lwp-request>, L<lwp-download>, L<lwp-dump>
|
||||
and L<lwp-mirror> are implemented.
|
||||
|
||||
=head1 ENVIRONMENT
|
||||
|
||||
The following environment variables are used by LWP:
|
||||
|
||||
=over
|
||||
|
||||
=item HOME
|
||||
|
||||
The L<LWP::MediaTypes> functions will look for the F<.media.types> and
|
||||
F<.mime.types> files relative to you home directory.
|
||||
|
||||
=item http_proxy
|
||||
|
||||
=item ftp_proxy
|
||||
|
||||
=item xxx_proxy
|
||||
|
||||
=item no_proxy
|
||||
|
||||
These environment variables can be set to enable communication through
|
||||
a proxy server. See the description of the C<env_proxy> method in
|
||||
L<LWP::UserAgent>.
|
||||
|
||||
=item PERL_LWP_ENV_PROXY
|
||||
|
||||
If set to a TRUE value, then the L<LWP::UserAgent> will by default call
|
||||
C<env_proxy> during initialization. This makes LWP honor the proxy variables
|
||||
described above.
|
||||
|
||||
=item PERL_LWP_SSL_VERIFY_HOSTNAME
|
||||
|
||||
The default C<verify_hostname> setting for L<LWP::UserAgent>. If
|
||||
not set the default will be 1. Set it as 0 to disable hostname
|
||||
verification (the default prior to libwww-perl 5.840.
|
||||
|
||||
=item PERL_LWP_SSL_CA_FILE
|
||||
|
||||
=item PERL_LWP_SSL_CA_PATH
|
||||
|
||||
The file and/or directory
|
||||
where the trusted Certificate Authority certificates
|
||||
is located. See L<LWP::UserAgent> for details.
|
||||
|
||||
=item PERL_HTTP_URI_CLASS
|
||||
|
||||
Used to decide what URI objects to instantiate. The default is L<URI>.
|
||||
You might want to set it to L<URI::URL> for compatibility with old times.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
LWP was made possible by contributions from Adam Newby, Albert
|
||||
Dvornik, Alexandre Duret-Lutz, Andreas Gustafsson, Andreas König,
|
||||
Andrew Pimlott, Andy Lester, Ben Coleman, Benjamin Low, Ben Low, Ben
|
||||
Tilly, Blair Zajac, Bob Dalgleish, BooK, Brad Hughes, Brian
|
||||
J. Murrell, Brian McCauley, Charles C. Fu, Charles Lane, Chris Nandor,
|
||||
Christian Gilmore, Chris W. Unger, Craig Macdonald, Dale Couch, Dan
|
||||
Kubb, Dave Dunkin, Dave W. Smith, David Coppit, David Dick, David
|
||||
D. Kilzer, Doug MacEachern, Edward Avis, erik, Gary Shea, Gisle Aas,
|
||||
Graham Barr, Gurusamy Sarathy, Hans de Graaff, Harald Joerg, Harry
|
||||
Bochner, Hugo, Ilya Zakharevich, INOUE Yoshinari, Ivan Panchenko, Jack
|
||||
Shirazi, James Tillman, Jan Dubois, Jared Rhine, Jim Stern, Joao
|
||||
Lopes, John Klar, Johnny Lee, Josh Kronengold, Josh Rai, Joshua
|
||||
Chamas, Joshua Hoblitt, Kartik Subbarao, Keiichiro Nagano, Ken
|
||||
Williams, KONISHI Katsuhiro, Lee T Lindley, Liam Quinn, Marc Hedlund,
|
||||
Marc Langheinrich, Mark D. Anderson, Marko Asplund, Mark Stosberg,
|
||||
Markus B Krüger, Markus Laker, Martijn Koster, Martin Thurn, Matthew
|
||||
Eldridge, Matthew.van.Eerde, Matt Sergeant, Michael A. Chase, Michael
|
||||
Quaranta, Michael Thompson, Mike Schilli, Moshe Kaminsky, Nathan
|
||||
Torkington, Nicolai Langfeldt, Norton Allen, Olly Betts, Paul
|
||||
J. Schinder, peterm, Philip Guenther, Daniel Buenzli, Pon Hwa Lin,
|
||||
Radoslaw Zielinski, Radu Greab, Randal L. Schwartz, Richard Chen,
|
||||
Robin Barker, Roy Fielding, Sander van Zoest, Sean M. Burke,
|
||||
shildreth, Slaven Rezic, Steve A Fink, Steve Hay, Steven Butler,
|
||||
Steve_Kilbane, Takanori Ugai, Thomas Lotterer, Tim Bunce, Tom Hughes,
|
||||
Tony Finch, Ville Skyttä, Ward Vandewege, William York, Yale Huang,
|
||||
and Yitzchak Scott-Thoennes.
|
||||
|
||||
LWP owes a lot in motivation, design, and code, to the libwww-perl
|
||||
library for Perl4 by Roy Fielding, which included work from Alberto
|
||||
Accomazzi, James Casey, Brooks Cutter, Martijn Koster, Oscar
|
||||
Nierstrasz, Mel Melchner, Gertjan van Oosten, Jared Rhine, Jack
|
||||
Shirazi, Gene Spafford, Marc VanHeyningen, Steven E. Brenner, Marion
|
||||
Hakanson, Waldemar Kebsch, Tony Sanders, and Larry Wall; see the
|
||||
libwww-perl-0.40 library for details.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 1995-2009, Gisle Aas
|
||||
Copyright 1995, Martijn Koster
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 AVAILABILITY
|
||||
|
||||
The latest version of this library is likely to be available from CPAN
|
||||
as well as:
|
||||
|
||||
http://github.com/libwww-perl/libwww-perl
|
||||
|
||||
The best place to discuss this code is on the <libwww@perl.org>
|
||||
mailing list.
|
||||
|
||||
=cut
|
||||
86
gitportable/usr/share/perl5/vendor_perl/LWP/Authen/Basic.pm
Normal file
86
gitportable/usr/share/perl5/vendor_perl/LWP/Authen/Basic.pm
Normal file
@@ -0,0 +1,86 @@
|
||||
package LWP::Authen::Basic;
|
||||
|
||||
use strict;
|
||||
|
||||
our $VERSION = '6.78';
|
||||
|
||||
require Encode;
|
||||
require MIME::Base64;
|
||||
|
||||
sub auth_header {
|
||||
my($class, $user, $pass, $request, $ua, $h) = @_;
|
||||
|
||||
my $userpass = "$user:$pass";
|
||||
# https://tools.ietf.org/html/rfc7617#section-2.1
|
||||
my $charset = uc($h->{auth_param}->{charset} || "");
|
||||
$userpass = Encode::encode($charset, $userpass)
|
||||
if ($charset eq "UTF-8");
|
||||
|
||||
return "Basic " . MIME::Base64::encode($userpass, "");
|
||||
}
|
||||
|
||||
sub _reauth_requested {
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub authenticate
|
||||
{
|
||||
my($class, $ua, $proxy, $auth_param, $response,
|
||||
$request, $arg, $size) = @_;
|
||||
|
||||
my $realm = $auth_param->{realm} || "";
|
||||
my $url = $proxy ? $request->{proxy} : $request->uri_canonical;
|
||||
return $response unless $url;
|
||||
my $host_port = $url->host_port;
|
||||
my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
|
||||
|
||||
my @m = $proxy ? (m_proxy => $url) : (m_host_port => $host_port);
|
||||
push(@m, realm => $realm);
|
||||
|
||||
my $h = $ua->get_my_handler("request_prepare", @m, sub {
|
||||
$_[0]{callback} = sub {
|
||||
my($req, $ua, $h) = @_;
|
||||
my($user, $pass) = $ua->credentials($host_port, $h->{realm});
|
||||
if (defined $user) {
|
||||
my $auth_value = $class->auth_header($user, $pass, $req, $ua, $h);
|
||||
$req->header($auth_header => $auth_value);
|
||||
}
|
||||
};
|
||||
});
|
||||
$h->{auth_param} = $auth_param;
|
||||
|
||||
my $reauth_requested
|
||||
= $class->_reauth_requested($auth_param, $ua, $request, $auth_header);
|
||||
if ( !$proxy
|
||||
&& (!$request->header($auth_header) || $reauth_requested)
|
||||
&& $ua->credentials($host_port, $realm))
|
||||
{
|
||||
# we can make sure this handler applies and retry
|
||||
add_path($h, $url->path)
|
||||
unless $reauth_requested; # Do not clobber up path list for retries
|
||||
return $ua->request($request->clone, $arg, $size, $response);
|
||||
}
|
||||
|
||||
my($user, $pass) = $ua->get_basic_credentials($realm, $url, $proxy);
|
||||
unless (defined $user and defined $pass) {
|
||||
$ua->set_my_handler("request_prepare", undef, @m); # delete handler
|
||||
return $response;
|
||||
}
|
||||
|
||||
# check that the password has changed
|
||||
my ($olduser, $oldpass) = $ua->credentials($host_port, $realm);
|
||||
return $response if (defined $olduser and defined $oldpass and
|
||||
$user eq $olduser and $pass eq $oldpass);
|
||||
|
||||
$ua->credentials($host_port, $realm, $user, $pass);
|
||||
add_path($h, $url->path) unless $proxy;
|
||||
return $ua->request($request->clone, $arg, $size, $response);
|
||||
}
|
||||
|
||||
sub add_path {
|
||||
my($h, $path) = @_;
|
||||
$path =~ s,[^/]+\z,,;
|
||||
push(@{$h->{m_path_prefix}}, $path);
|
||||
}
|
||||
|
||||
1;
|
||||
80
gitportable/usr/share/perl5/vendor_perl/LWP/Authen/Digest.pm
Normal file
80
gitportable/usr/share/perl5/vendor_perl/LWP/Authen/Digest.pm
Normal file
@@ -0,0 +1,80 @@
|
||||
package LWP::Authen::Digest;
|
||||
|
||||
use strict;
|
||||
use parent 'LWP::Authen::Basic';
|
||||
|
||||
our $VERSION = '6.78';
|
||||
|
||||
require Digest::MD5;
|
||||
|
||||
sub _reauth_requested {
|
||||
my ($class, $auth_param, $ua, $request, $auth_header) = @_;
|
||||
my $ret = defined($$auth_param{stale}) && lc($$auth_param{stale}) eq 'true';
|
||||
if ($ret) {
|
||||
my $hdr = $request->header($auth_header);
|
||||
$hdr =~ tr/,/;/; # "," is used to separate auth-params!!
|
||||
($hdr) = HTTP::Headers::Util::split_header_words($hdr);
|
||||
my $nonce = {@$hdr}->{nonce};
|
||||
delete $$ua{authen_md5_nonce_count}{$nonce};
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub auth_header {
|
||||
my($class, $user, $pass, $request, $ua, $h) = @_;
|
||||
|
||||
my $auth_param = $h->{auth_param};
|
||||
|
||||
my $nc = sprintf "%08X", ++$ua->{authen_md5_nonce_count}{$auth_param->{nonce}};
|
||||
my $cnonce = sprintf "%8x", time;
|
||||
|
||||
my $uri = $request->uri->path_query;
|
||||
$uri = "/" unless length $uri;
|
||||
|
||||
my $md5 = Digest::MD5->new;
|
||||
|
||||
my(@digest);
|
||||
$md5->add(join(":", $user, $auth_param->{realm}, $pass));
|
||||
push(@digest, $md5->hexdigest);
|
||||
$md5->reset;
|
||||
|
||||
push(@digest, $auth_param->{nonce});
|
||||
|
||||
if ($auth_param->{qop}) {
|
||||
push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
|
||||
}
|
||||
|
||||
$md5->add(join(":", $request->method, $uri));
|
||||
push(@digest, $md5->hexdigest);
|
||||
$md5->reset;
|
||||
|
||||
$md5->add(join(":", @digest));
|
||||
my($digest) = $md5->hexdigest;
|
||||
$md5->reset;
|
||||
|
||||
my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
|
||||
@resp{qw(username uri response algorithm)} = ($user, $uri, $digest, "MD5");
|
||||
|
||||
if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
|
||||
@resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
|
||||
}
|
||||
|
||||
my(@order) = qw(username realm qop algorithm uri nonce nc cnonce response opaque);
|
||||
my @pairs;
|
||||
for (@order) {
|
||||
next unless defined $resp{$_};
|
||||
|
||||
# RFC2617 says that qop-value and nc-value should be unquoted.
|
||||
if ( $_ eq 'qop' || $_ eq 'nc' ) {
|
||||
push(@pairs, "$_=" . $resp{$_});
|
||||
}
|
||||
else {
|
||||
push(@pairs, "$_=" . qq("$resp{$_}"));
|
||||
}
|
||||
}
|
||||
|
||||
my $auth_value = "Digest " . join(", ", @pairs);
|
||||
return $auth_value;
|
||||
}
|
||||
|
||||
1;
|
||||
183
gitportable/usr/share/perl5/vendor_perl/LWP/Authen/Ntlm.pm
Normal file
183
gitportable/usr/share/perl5/vendor_perl/LWP/Authen/Ntlm.pm
Normal file
@@ -0,0 +1,183 @@
|
||||
package LWP::Authen::Ntlm;
|
||||
|
||||
use strict;
|
||||
|
||||
our $VERSION = '6.78';
|
||||
|
||||
use Authen::NTLM "1.02";
|
||||
use MIME::Base64 "2.12";
|
||||
|
||||
sub authenticate {
|
||||
my($class, $ua, $proxy, $auth_param, $response,
|
||||
$request, $arg, $size) = @_;
|
||||
|
||||
my($user, $pass) = $ua->get_basic_credentials($auth_param->{realm},
|
||||
$request->uri, $proxy);
|
||||
|
||||
unless(defined $user and defined $pass) {
|
||||
return $response;
|
||||
}
|
||||
|
||||
if (!$ua->conn_cache()) {
|
||||
warn "The keep_alive option must be enabled for NTLM authentication to work. NTLM authentication aborted.\n";
|
||||
return $response;
|
||||
}
|
||||
|
||||
my($domain, $username) = split(/\\/, $user);
|
||||
|
||||
ntlm_domain($domain);
|
||||
ntlm_user($username);
|
||||
ntlm_password($pass);
|
||||
|
||||
my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
|
||||
|
||||
# my ($challenge) = $response->header('WWW-Authenticate');
|
||||
my $challenge;
|
||||
foreach ($response->header('WWW-Authenticate')) {
|
||||
last if /^NTLM/ && ($challenge=$_);
|
||||
}
|
||||
|
||||
if ($challenge eq 'NTLM') {
|
||||
# First phase, send handshake
|
||||
my $auth_value = "NTLM " . ntlm();
|
||||
ntlm_reset();
|
||||
|
||||
# Need to check this isn't a repeated fail!
|
||||
my $r = $response;
|
||||
my $retry_count = 0;
|
||||
while ($r) {
|
||||
my $auth = $r->request->header($auth_header);
|
||||
++$retry_count if ($auth && $auth eq $auth_value);
|
||||
if ($retry_count > 2) {
|
||||
# here we know this failed before
|
||||
$response->header("Client-Warning" =>
|
||||
"Credentials for '$user' failed before");
|
||||
return $response;
|
||||
}
|
||||
$r = $r->previous;
|
||||
}
|
||||
|
||||
my $referral = $request->clone;
|
||||
$referral->header($auth_header => $auth_value);
|
||||
return $ua->request($referral, $arg, $size, $response);
|
||||
}
|
||||
|
||||
else {
|
||||
# Second phase, use the response challenge (unless non-401 code
|
||||
# was returned, in which case, we just send back the response
|
||||
# object, as is
|
||||
my $auth_value;
|
||||
if ($response->code ne '401') {
|
||||
return $response;
|
||||
}
|
||||
else {
|
||||
my $challenge;
|
||||
foreach ($response->header('WWW-Authenticate')) {
|
||||
last if /^NTLM/ && ($challenge=$_);
|
||||
}
|
||||
$challenge =~ s/^NTLM //;
|
||||
ntlm();
|
||||
$auth_value = "NTLM " . ntlm($challenge);
|
||||
ntlm_reset();
|
||||
}
|
||||
|
||||
my $referral = $request->clone;
|
||||
$referral->header($auth_header => $auth_value);
|
||||
my $response2 = $ua->request($referral, $arg, $size, $response);
|
||||
return $response2;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
LWP::Authen::Ntlm - Library for enabling NTLM authentication (Microsoft) in LWP
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use LWP::UserAgent;
|
||||
use HTTP::Request::Common;
|
||||
my $url = 'http://www.company.com/protected_page.html';
|
||||
|
||||
# Set up the ntlm client and then the base64 encoded ntlm handshake message
|
||||
my $ua = LWP::UserAgent->new(keep_alive=>1);
|
||||
$ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');
|
||||
|
||||
$request = GET $url;
|
||||
print "--Performing request now...-----------\n";
|
||||
$response = $ua->request($request);
|
||||
print "--Done with request-------------------\n";
|
||||
|
||||
if ($response->is_success) {print "It worked!->" . $response->code . "\n"}
|
||||
else {print "It didn't work!->" . $response->code . "\n"}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<LWP::Authen::Ntlm> allows LWP to authenticate against servers that are using the
|
||||
NTLM authentication scheme popularized by Microsoft. This type of authentication is
|
||||
common on intranets of Microsoft-centric organizations.
|
||||
|
||||
The module takes advantage of the Authen::NTLM module by Mark Bush. Since there
|
||||
is also another Authen::NTLM module available from CPAN by Yee Man Chan with an
|
||||
entirely different interface, it is necessary to ensure that you have the correct
|
||||
NTLM module.
|
||||
|
||||
In addition, there have been problems with incompatibilities between different
|
||||
versions of L<Mime::Base64>, which Bush's L<Authen::NTLM> makes use of. Therefore, it is
|
||||
necessary to ensure that your Mime::Base64 module supports exporting of the
|
||||
C<encode_base64> and C<decode_base64> functions.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
The module is used indirectly through LWP, rather than including it directly in your
|
||||
code. The LWP system will invoke the NTLM authentication when it encounters the
|
||||
authentication scheme while attempting to retrieve a URL from a server. In order
|
||||
for the NTLM authentication to work, you must have a few things set up in your
|
||||
code prior to attempting to retrieve the URL:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Enable persistent HTTP connections
|
||||
|
||||
To do this, pass the C<< "keep_alive=>1" >> option to the L<LWP::UserAgent> when creating it, like this:
|
||||
|
||||
my $ua = LWP::UserAgent->new(keep_alive=>1);
|
||||
|
||||
=item *
|
||||
|
||||
Set the credentials on the UserAgent object
|
||||
|
||||
The credentials must be set like this:
|
||||
|
||||
$ua->credentials('www.company.com:80', '', "MyDomain\\MyUserCode", 'MyPassword');
|
||||
|
||||
Note that you cannot use the L<HTTP::Request> object's C<authorization_basic()> method to set
|
||||
the credentials. Note, too, that the C<'www.company.com:80'> portion only sets credentials
|
||||
on the specified port AND it is case-sensitive (this is due to the way LWP is coded, and
|
||||
has nothing to do with LWP::Authen::Ntlm)
|
||||
|
||||
=back
|
||||
|
||||
=head1 AVAILABILITY
|
||||
|
||||
General queries regarding LWP should be made to the LWP Mailing List.
|
||||
|
||||
Questions specific to LWP::Authen::Ntlm can be forwarded to jtillman@bigfoot.com
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2002 James Tillman. 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<LWP>, L<LWP::UserAgent>, L<lwpcook>.
|
||||
|
||||
=cut
|
||||
350
gitportable/usr/share/perl5/vendor_perl/LWP/ConnCache.pm
Normal file
350
gitportable/usr/share/perl5/vendor_perl/LWP/ConnCache.pm
Normal file
@@ -0,0 +1,350 @@
|
||||
package LWP::ConnCache;
|
||||
|
||||
use strict;
|
||||
|
||||
our $VERSION = '6.78';
|
||||
our $DEBUG;
|
||||
|
||||
sub new {
|
||||
my($class, %cnf) = @_;
|
||||
|
||||
my $total_capacity = 1;
|
||||
if (exists $cnf{total_capacity}) {
|
||||
$total_capacity = delete $cnf{total_capacity};
|
||||
}
|
||||
if (%cnf && $^W) {
|
||||
require Carp;
|
||||
Carp::carp("Unrecognised options: @{[sort keys %cnf]}")
|
||||
}
|
||||
my $self = bless { cc_conns => [] }, $class;
|
||||
$self->total_capacity($total_capacity);
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub deposit {
|
||||
my($self, $type, $key, $conn) = @_;
|
||||
push(@{$self->{cc_conns}}, [$conn, $type, $key, time]);
|
||||
$self->enforce_limits($type);
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub withdraw {
|
||||
my($self, $type, $key) = @_;
|
||||
my $conns = $self->{cc_conns};
|
||||
for my $i (0 .. @$conns - 1) {
|
||||
my $c = $conns->[$i];
|
||||
next unless $c->[1] eq $type && $c->[2] eq $key;
|
||||
splice(@$conns, $i, 1); # remove it
|
||||
return $c->[0];
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
sub total_capacity {
|
||||
my $self = shift;
|
||||
my $old = $self->{cc_limit_total};
|
||||
if (@_) {
|
||||
$self->{cc_limit_total} = shift;
|
||||
$self->enforce_limits;
|
||||
}
|
||||
$old;
|
||||
}
|
||||
|
||||
|
||||
sub capacity {
|
||||
my $self = shift;
|
||||
my $type = shift;
|
||||
my $old = $self->{cc_limit}{$type};
|
||||
if (@_) {
|
||||
$self->{cc_limit}{$type} = shift;
|
||||
$self->enforce_limits($type);
|
||||
}
|
||||
$old;
|
||||
}
|
||||
|
||||
|
||||
sub enforce_limits {
|
||||
my($self, $type) = @_;
|
||||
my $conns = $self->{cc_conns};
|
||||
|
||||
my @types = $type ? ($type) : ($self->get_types);
|
||||
for $type (@types) {
|
||||
next unless $self->{cc_limit};
|
||||
my $limit = $self->{cc_limit}{$type};
|
||||
next unless defined $limit;
|
||||
for my $i (reverse 0 .. @$conns - 1) {
|
||||
next unless $conns->[$i][1] eq $type;
|
||||
if (--$limit < 0) {
|
||||
$self->dropping(splice(@$conns, $i, 1), "$type capacity exceeded");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (defined(my $total = $self->{cc_limit_total})) {
|
||||
while (@$conns > $total) {
|
||||
$self->dropping(shift(@$conns), "Total capacity exceeded");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub dropping {
|
||||
my($self, $c, $reason) = @_;
|
||||
print "DROPPING @$c [$reason]\n" if $DEBUG;
|
||||
}
|
||||
|
||||
|
||||
sub drop {
|
||||
my($self, $checker, $reason) = @_;
|
||||
if (ref($checker) ne "CODE") {
|
||||
# make it so
|
||||
if (!defined $checker) {
|
||||
$checker = sub { 1 }; # drop all of them
|
||||
}
|
||||
elsif (_looks_like_number($checker)) {
|
||||
my $age_limit = $checker;
|
||||
my $time_limit = time - $age_limit;
|
||||
$reason ||= "older than $age_limit";
|
||||
$checker = sub { $_[3] < $time_limit };
|
||||
}
|
||||
else {
|
||||
my $type = $checker;
|
||||
$reason ||= "drop $type";
|
||||
$checker = sub { $_[1] eq $type }; # match on type
|
||||
}
|
||||
}
|
||||
$reason ||= "drop";
|
||||
|
||||
local $SIG{__DIE__}; # don't interfere with eval below
|
||||
local $@;
|
||||
my @c;
|
||||
for (@{$self->{cc_conns}}) {
|
||||
my $drop;
|
||||
eval {
|
||||
if (&$checker(@$_)) {
|
||||
$self->dropping($_, $reason);
|
||||
$drop++;
|
||||
}
|
||||
};
|
||||
push(@c, $_) unless $drop;
|
||||
}
|
||||
@{$self->{cc_conns}} = @c;
|
||||
}
|
||||
|
||||
|
||||
sub prune {
|
||||
my $self = shift;
|
||||
$self->drop(sub { !shift->ping }, "ping");
|
||||
}
|
||||
|
||||
|
||||
sub get_types {
|
||||
my $self = shift;
|
||||
my %t;
|
||||
$t{$_->[1]}++ for @{$self->{cc_conns}};
|
||||
return keys %t;
|
||||
}
|
||||
|
||||
|
||||
sub get_connections {
|
||||
my($self, $type) = @_;
|
||||
my @c;
|
||||
for (@{$self->{cc_conns}}) {
|
||||
push(@c, $_->[0]) if !$type || ($type && $type eq $_->[1]);
|
||||
}
|
||||
@c;
|
||||
}
|
||||
|
||||
|
||||
sub _looks_like_number {
|
||||
$_[0] =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
LWP::ConnCache - Connection cache manager
|
||||
|
||||
=head1 NOTE
|
||||
|
||||
This module is experimental. Details of its interface is likely to
|
||||
change in the future.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use LWP::ConnCache;
|
||||
my $cache = LWP::ConnCache->new;
|
||||
$cache->deposit($type, $key, $sock);
|
||||
$sock = $cache->withdraw($type, $key);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<LWP::ConnCache> class is the standard connection cache manager
|
||||
for L<LWP::UserAgent>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
The following basic methods are provided:
|
||||
|
||||
=head2 new
|
||||
|
||||
my $cache = LWP::ConnCache->new( %options )
|
||||
|
||||
This method constructs a new L<LWP::ConnCache> object. The only
|
||||
option currently accepted is C<total_capacity>. If specified it
|
||||
initializes the L<LWP::ConnCache/total_capacity> option. It defaults to C<1>.
|
||||
|
||||
=head2 total_capacity
|
||||
|
||||
my $cap = $cache->total_capacity;
|
||||
$cache->total_capacity(0); # drop all immediately
|
||||
$cache->total_capacity(undef); # no limit
|
||||
$cache->total_capacity($number);
|
||||
|
||||
Get/sets the number of connection that will be cached. Connections
|
||||
will start to be dropped when this limit is reached. If set to C<0>,
|
||||
then all connections are immediately dropped. If set to C<undef>,
|
||||
then there is no limit.
|
||||
|
||||
=head2 capacity
|
||||
|
||||
my $http_capacity = $cache->capacity('http');
|
||||
$cache->capacity('http', 2 );
|
||||
|
||||
Get/set a limit for the number of connections of the specified type
|
||||
that can be cached. The first parameter is a short string like
|
||||
C<"http"> or C<"ftp">.
|
||||
|
||||
=head2 drop
|
||||
|
||||
$cache->drop(); # Drop ALL connections
|
||||
# which is just a synonym for:
|
||||
$cache->drop(sub{1}); # Drop ALL connections
|
||||
# drop all connections older than 22 seconds and add a reason for it!
|
||||
$cache->drop(22, "Older than 22 secs dropped");
|
||||
# which is just a synonym for:
|
||||
$cache->drop(sub {
|
||||
my ($conn, $type, $key, $deposit_time) = @_;
|
||||
if ($deposit_time < 22) {
|
||||
# true values drop the connection
|
||||
return 1;
|
||||
}
|
||||
# false values don't drop the connection
|
||||
return 0;
|
||||
}, "Older than 22 secs dropped" );
|
||||
|
||||
Drop connections by some criteria. The $checker argument is a
|
||||
subroutine that is called for each connection. If the routine returns
|
||||
a TRUE value then the connection is dropped. The routine is called
|
||||
with C<($conn, $type, $key, $deposit_time)> as arguments.
|
||||
|
||||
Shortcuts: If the C<$checker> argument is absent (or C<undef>) all cached
|
||||
connections are dropped. If the $checker is a number then all
|
||||
connections untouched that the given number of seconds or more are
|
||||
dropped. If $checker is a string then all connections of the given
|
||||
type are dropped.
|
||||
|
||||
The C<reason> is passed on to the L<LWP::ConnCache/dropped> method.
|
||||
|
||||
=head2 prune
|
||||
|
||||
$cache->prune();
|
||||
|
||||
Calling this method will drop all connections that are dead. This is
|
||||
tested by calling the L<LWP::ConnCache/ping> method on the connections. If
|
||||
the L<LWP::ConnCache/ping> method exists and returns a false value, then the
|
||||
connection is dropped.
|
||||
|
||||
=head2 get_types
|
||||
|
||||
my @types = $cache->get_types();
|
||||
|
||||
This returns all the C<type> fields used for the currently cached
|
||||
connections.
|
||||
|
||||
=head2 get_connections
|
||||
|
||||
my @conns = $cache->get_connections(); # all connections
|
||||
my @conns = $cache->get_connections('http'); # connections for http
|
||||
|
||||
This returns all connection objects of the specified type. If no type
|
||||
is specified then all connections are returned. In scalar context the
|
||||
number of cached connections of the specified type is returned.
|
||||
|
||||
=head1 PROTOCOL METHODS
|
||||
|
||||
The following methods are called by low-level protocol modules to
|
||||
try to save away connections and to get them back.
|
||||
|
||||
=head2 deposit
|
||||
|
||||
$cache->deposit($type, $key, $conn);
|
||||
|
||||
This method adds a new connection to the cache. As a result, other
|
||||
already cached connections might be dropped. Multiple connections with
|
||||
the same type/key might be added.
|
||||
|
||||
=head2 withdraw
|
||||
|
||||
my $conn = $cache->withdraw($type, $key);
|
||||
|
||||
This method tries to fetch back a connection that was previously
|
||||
deposited. If no cached connection with the specified $type/$key is
|
||||
found, then C<undef> is returned. There is not guarantee that a
|
||||
deposited connection can be withdrawn, as the cache manger is free to
|
||||
drop connections at any time.
|
||||
|
||||
=head1 INTERNAL METHODS
|
||||
|
||||
The following methods are called internally. Subclasses might want to
|
||||
override them.
|
||||
|
||||
=head2 enforce_limits
|
||||
|
||||
$conn->enforce_limits([$type])
|
||||
|
||||
This method is called with after a new connection is added (deposited)
|
||||
in the cache or capacity limits are adjusted. The default
|
||||
implementation drops connections until the specified capacity limits
|
||||
are not exceeded.
|
||||
|
||||
=head2 dropping
|
||||
|
||||
$conn->dropping($conn_record, $reason)
|
||||
|
||||
This method is called when a connection is dropped. The record
|
||||
belonging to the dropped connection is passed as the first argument
|
||||
and a string describing the reason for the drop is passed as the
|
||||
second argument. The default implementation makes some noise if the
|
||||
C<$LWP::ConnCache::DEBUG> variable is set and nothing more.
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
For specialized cache policy it makes sense to subclass
|
||||
C<LWP::ConnCache> and perhaps override the L<LWP::ConnCache/deposit>,
|
||||
L<LWP::ConnCache/enforce_limits>, and L<LWP::ConnCache/dropping> methods.
|
||||
|
||||
The object itself is a hash. Keys prefixed with C<cc_> are reserved
|
||||
for the base class.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<LWP::UserAgent>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2001 Gisle Aas.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
112
gitportable/usr/share/perl5/vendor_perl/LWP/Debug.pm
Normal file
112
gitportable/usr/share/perl5/vendor_perl/LWP/Debug.pm
Normal file
@@ -0,0 +1,112 @@
|
||||
package LWP::Debug; # legacy
|
||||
|
||||
our $VERSION = '6.78';
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(level trace debug conns);
|
||||
|
||||
use Carp ();
|
||||
|
||||
my @levels = qw(trace debug conns);
|
||||
our %current_level = ();
|
||||
|
||||
sub import {
|
||||
my $pack = shift;
|
||||
my $callpkg = caller(0);
|
||||
my @symbols = ();
|
||||
my @levels = ();
|
||||
for (@_) {
|
||||
if (/^[-+]/) {
|
||||
push(@levels, $_);
|
||||
}
|
||||
else {
|
||||
push(@symbols, $_);
|
||||
}
|
||||
}
|
||||
Exporter::export($pack, $callpkg, @symbols);
|
||||
level(@levels);
|
||||
}
|
||||
|
||||
sub level {
|
||||
for (@_) {
|
||||
if ($_ eq '+') { # all on
|
||||
# switch on all levels
|
||||
%current_level = map { $_ => 1 } @levels;
|
||||
}
|
||||
elsif ($_ eq '-') { # all off
|
||||
%current_level = ();
|
||||
}
|
||||
elsif (/^([-+])(\w+)$/) {
|
||||
$current_level{$2} = $1 eq '+';
|
||||
}
|
||||
else {
|
||||
Carp::croak("Illegal level format $_");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub trace { _log(@_) if $current_level{'trace'}; }
|
||||
sub debug { _log(@_) if $current_level{'debug'}; }
|
||||
sub conns { _log(@_) if $current_level{'conns'}; }
|
||||
|
||||
sub _log {
|
||||
my $msg = shift;
|
||||
$msg .= "\n" unless $msg =~ /\n$/; # ensure trailing "\n"
|
||||
|
||||
my ($package, $filename, $line, $sub) = caller(2);
|
||||
print STDERR "$sub: $msg";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
LWP::Debug - deprecated
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module has been deprecated. Please see L<LWP::ConsoleLogger> for your
|
||||
debugging needs.
|
||||
|
||||
LWP::Debug is used to provide tracing facilities, but these are not used
|
||||
by LWP any more. The code in this module is kept around
|
||||
(undocumented) so that 3rd party code that happens to use the old
|
||||
interfaces continue to run.
|
||||
|
||||
One useful feature that LWP::Debug provided (in an imprecise and
|
||||
troublesome way) was network traffic monitoring. The following
|
||||
section provides some hints about recommended replacements.
|
||||
|
||||
=head2 Network traffic monitoring
|
||||
|
||||
The best way to monitor the network traffic that LWP generates is to
|
||||
use an external TCP monitoring program. The
|
||||
L<WireShark|http://www.wireshark.org/> program is highly recommended for this.
|
||||
|
||||
Another approach it to use a debugging HTTP proxy server and make
|
||||
LWP direct all its traffic via this one. Call C<< $ua->proxy >> to
|
||||
set it up and then just use LWP as before.
|
||||
|
||||
For less precise monitoring needs just setting up a few simple
|
||||
handlers might do. The following example sets up handlers to dump the
|
||||
request and response objects that pass through LWP:
|
||||
|
||||
use LWP::UserAgent;
|
||||
$ua = LWP::UserAgent->new;
|
||||
$ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
|
||||
|
||||
$ua->add_handler("request_send", sub { shift->dump; return });
|
||||
$ua->add_handler("response_done", sub { shift->dump; return });
|
||||
|
||||
$ua->get("http://www.example.com");
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<LWP::ConsoleLogger>, L<LWP::ConsoleLogger::Everywhere>, L<LWP::UserAgent>
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,29 @@
|
||||
package LWP::Debug::TraceHTTP;
|
||||
|
||||
# Just call:
|
||||
#
|
||||
# require LWP::Debug::TraceHTTP;
|
||||
# LWP::Protocol::implementor('http', 'LWP::Debug::TraceHTTP');
|
||||
#
|
||||
# to use this module to trace all calls to the HTTP socket object in
|
||||
# programs that use LWP.
|
||||
|
||||
use strict;
|
||||
use parent 'LWP::Protocol::http';
|
||||
|
||||
our $VERSION = '6.78';
|
||||
|
||||
package # hide from PAUSE
|
||||
LWP::Debug::TraceHTTP::Socket;
|
||||
|
||||
use Data::Dump 1.13;
|
||||
use Data::Dump::Trace qw(autowrap mcall);
|
||||
|
||||
autowrap("LWP::Protocol::http::Socket" => "sock");
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
return mcall("LWP::Protocol::http::Socket" => "new", undef, @_);
|
||||
}
|
||||
|
||||
1;
|
||||
7
gitportable/usr/share/perl5/vendor_perl/LWP/DebugFile.pm
Normal file
7
gitportable/usr/share/perl5/vendor_perl/LWP/DebugFile.pm
Normal file
@@ -0,0 +1,7 @@
|
||||
package LWP::DebugFile;
|
||||
|
||||
our $VERSION = '6.78';
|
||||
|
||||
# legacy stub
|
||||
|
||||
1;
|
||||
292
gitportable/usr/share/perl5/vendor_perl/LWP/MediaTypes.pm
Normal file
292
gitportable/usr/share/perl5/vendor_perl/LWP/MediaTypes.pm
Normal 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.
|
||||
|
||||
48
gitportable/usr/share/perl5/vendor_perl/LWP/MemberMixin.pm
Normal file
48
gitportable/usr/share/perl5/vendor_perl/LWP/MemberMixin.pm
Normal file
@@ -0,0 +1,48 @@
|
||||
package LWP::MemberMixin;
|
||||
|
||||
our $VERSION = '6.78';
|
||||
|
||||
sub _elem {
|
||||
my $self = shift;
|
||||
my $elem = shift;
|
||||
my $old = $self->{$elem};
|
||||
$self->{$elem} = shift if @_;
|
||||
return $old;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
LWP::MemberMixin - Member access mixin class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Foo;
|
||||
use parent qw(LWP::MemberMixin);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A mixin class to get methods that provide easy access to member
|
||||
variables in the C<%$self>.
|
||||
Ideally there should be better Perl language support for this.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
There is only one method provided:
|
||||
|
||||
=head2 _elem
|
||||
|
||||
_elem($elem [, $val])
|
||||
|
||||
Internal method to get/set the value of member variable
|
||||
C<$elem>. If C<$val> is present it is used as the new value
|
||||
for the member variable. If it is not present the current
|
||||
value is not touched. In both cases the previous value of
|
||||
the member variable is returned.
|
||||
|
||||
=cut
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user