D7net
Home
Console
Upload
information
Create File
Create Folder
About
Tools
:
/
usr
/
share
/
perl5
/
vendor_perl
/
HTTP
/
Headers
/
Filename :
Auth.pm
back
Copy
package HTTP::Headers::Auth; use strict; use warnings; our $VERSION = '6.18'; 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 6.18 =head1 AUTHOR Gisle Aas <gisle@activestate.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1994-2017 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