This is an automated email from the git hooks/post-receive script.
gregoa pushed a commit to annotated tag v1.13
in repository libnet-openid-common-perl.
commit 3b775293dfb5725a3849ad0f29f5cb719961d8d1
Author: Roger Crew <c...@cs.stanford.edu>
Date: Sun Nov 6 07:10:07 2011 -0800
pay attention to charset on YADIS content-type (closes #41310)
---
dist.ini | 2 ++
lib/Net/OpenID/Yadis.pm | 34 +++++++++++++++++++++++++++++-----
2 files changed, 31 insertions(+), 5 deletions(-)
diff --git a/dist.ini b/dist.ini
index ee3c92d..69da024 100644
--- a/dist.ini
+++ b/dist.ini
@@ -38,6 +38,8 @@ Time::Local = 0
MIME::Base64 = 0
Math::BigInt = 0
Crypt::DH::GMP = 0
+Encode = 0
+Email::MIME::ContentType = 0
[Prereqs / TestRequires]
Test::More = 0
diff --git a/lib/Net/OpenID/Yadis.pm b/lib/Net/OpenID/Yadis.pm
index 08c2b58..1c45d75 100644
--- a/lib/Net/OpenID/Yadis.pm
+++ b/lib/Net/OpenID/Yadis.pm
@@ -9,6 +9,8 @@ use Net::OpenID::URIFetch;
use XML::Simple;
use Net::OpenID::Yadis::Service;
use Net::OpenID::Common;
+use Email::MIME::ContentType;
+use Encode;
our @EXPORT = qw(YR_HEAD YR_GET YR_XRDS);
@@ -148,16 +150,40 @@ sub discover {
$self->identity_url($final_url) if ($count < YR_XRDS);
+ # (1) found YADIS/XRDS-Location headers
if ($count < YR_XRDS and
my $doc_url = $headers{'x-yadis-location'} ||
$headers{'x-xrds-location'}
) {
return $self->discover($doc_url, YR_XRDS);
}
- elsif ( (my $ctype = (split /;\s*/, $headers{'content-type'})[0]) eq
'application/xrds+xml') {
+
+ # (2) is content type YADIS document?
+ my $pct = parse_content_type($headers{'content-type'});
+ my $ctype = join '/', @{$pct}{qw(discrete composite)}; # really should be
qw(type subtype)
+ if ($ctype eq 'application/xrds+xml') {
+ #survey says Yes!
$self->xrd_url($final_url);
+
+ my $charset = $pct->{attributes}->{charset};
+ if ($charset && (lc($charset) ne 'utf-8') &&
Encode::find_encoding($charset)) {
+ # not UTF-8, but it's one of the ones we know about, so...
+ Encode::from_to($xrd,$charset,'utf-8');
+ # And now we are UTF-8, BUT...
+ # XML spec requires specifying the encoding in the prolog
+ # whenever it's not UTF-8 *and* death if the specified encoding
+ # doesn't match the actual encoding, so we have to fix the prolog
+ my $encoding_re =
qr/\s+encoding\s*=\s*['"][A-Z][-A-Za-z0-9._]*["']/;
+ $xrd =~ s/$encoding_re//
+ # but make sure there *is* a prolog, first; also allow for the
+ # possibility of BOM (byte-order mark) re-encoding into
+ # garbage at the beginning
+ if ($xrd =~
m/\A.{0,4}<?xml\s+version\s*=\s*['"][0-9.]+["']$encoding_re/);
+ }
return $self->parse_xrd($xrd);
}
- elsif ( $ctype eq 'text/html' and
+
+ # (3) YADIS/XRDS-location might be in a <meta> tag.
+ if ( $ctype eq 'text/html' and
my ($meta) = grep {
my $heqv = lc($_->{'http-equiv'}||'');
$heqv eq 'x-yadis-location' || $heqv eq 'x-xrds-location'
@@ -166,9 +192,7 @@ sub discover {
) {
return $self->discover($meta->{content}, YR_XRDS);
}
- else {
- return $self->_fail($count == YR_GET ? "no_yadis_document" :
"too_many_hops");
- }
+ return $self->_fail($count == YR_GET ? "no_yadis_document" :
"too_many_hops");
}
sub parse_xrd {
--
Alioth's /usr/local/bin/git-commit-notice on
/srv/git.debian.org/git/pkg-perl/packages/libnet-openid-common-perl.git
_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
