#!/usr/bin/perl -w use warnings; use strict; use CGI; use LWP; use XML::Parser; use HTML::Parser; my $cgi = new CGI; sub handle_YadisXML_start { my ($p, $tag, %attrs) = @_; my $vars = $p->{-YADISvars}; my $attrs = \%attrs; my ($k,$v, $nsdefined); my $xmlns = $vars->{-xmlns}->[$#{$vars->{-xmlns}}]; while (($k, $v) = each %$attrs) { my ($ns, $nsv); if ($k eq 'xmlns') { $ns = ''; $nsv = $v; } elsif (substr($k, 0, 6) eq 'xmlns:') { $ns = substr($k, 6).":"; $nsv = $v; } if (defined($nsv) && (defined( { 'xri://$xrds' => 1, 'xri://$xrd*($v*2.0)' => 1 }->{$nsv}))) { if (defined($nsdefined)) { my %xmlns = %$xmlns; push @{$vars->{-xmlns}}, \%xmlns; $xmlns= \%xmlns; } $vars->{-namespaces}->{$nsv} = $ns; $xmlns->{$nsv} = $ns; } } push @{$vars->{-nsstack}}, $nsdefined; my $tagstack = $vars->{-tagstack}; if ($tag eq "$xmlns->{'xri://$xrds'}XRDS") { push @{$vars->{-errors}}, "$tag in unexpected place, expected at top level" if ($#$tagstack >= 0); } elsif ($tag eq "$xmlns->{'xri://$xrd*($v*2.0)'}XRD") { push @{$vars->{-errors}}, "$tag in unexpected place, expected in <$xmlns->{'xri://$xrds'}XRDS> block" if ($tagstack->[$#$tagstack] ne "$xmlns->{'xri://$xrds'}XRDS"); } elsif ($tag eq "$xmlns->{'xri://$xrd*($v*2.0)'}Service") { my $priority = $attrs->{"$xmlns->{'xri://$xrd*($v*2.0)'}priority"}; if (!defined($priority)) { # Assume namespace of the parent $priority = $attrs->{'priority'}; } $vars->{-lastPriority} = $priority; $vars->{-lastType} = []; $vars->{-lastURI} = []; push @{$vars->{-errors}}, "$tag in unexpected place, expected in <$xmlns->{'xri://$xrd*($v*2.0)'}XRD> block" if ($tagstack->[$#$tagstack] ne "$xmlns->{'xri://$xrd*($v*2.0)'}XRD"); } elsif ($tag eq "$xmlns->{'xri://$xrd*($v*2.0)'}Type") { $vars->{-text} = ''; push @{$vars->{-errors}}, "$tag in unexpected place, expected in <$xmlns->{'xri://$xrd*($v*2.0)'}Service> block" if ($tagstack->[$#$tagstack] ne "$xmlns->{'xri://$xrd*($v*2.0)'}Service"); } elsif ($tag eq "$xmlns->{'xri://$xrd*($v*2.0)'}URI") { $vars->{-text} = ''; push @{$vars->{-errors}}, "$tag in unexpected place, expected in <$xmlns->{'xri://$xrd*($v*2.0)'}Service> block" if ($tagstack->[$#$tagstack] ne "$xmlns->{'xri://$xrd*($v*2.0)'}Service"); } elsif ($tag =~ /^(.*\:)?(Service|Type|URI)$/) { push @{$vars->{-errors}}, "'$tag' found in unexpected namespace '$1', expected in namespace for 'xri://\$xrd*(\$v*2.0)' which is $xmlns->{'xri://$xrd*($v*2.0)'}"; } push @$tagstack, $tag; } sub handle_YadisXML_end { my ($p, $tag) = @_; my $vars = $p->{-YADISvars}; my $tagstack = $vars->{-tagstack}; my $xmlns = $vars->{-xmlns}->[$#{$vars->{-xmlns}}]; pop @$tagstack; if ($tag eq "$xmlns->{'xri://$xrd*($v*2.0)'}Service") { push @{$vars->{-results}}, [ $vars->{-lastPriority}, $vars->{-lastType}, $vars->{-lastURI} ]; undef $vars->{-priority}; } elsif ($tag eq "$xmlns->{'xri://$xrd*($v*2.0)'}Type") { push @{$vars->{-lastType}}, $vars->{-text}; } elsif ($tag eq "$xmlns->{'xri://$xrd*($v*2.0)'}URI") { push @{$vars->{-lastURI}}, $vars->{-text}; } pop @{$vars->{-xmlns}} if (pop @{$vars->{-nsstack}}); } sub handle_YadisXML_char { my ($p, $text) = @_; my $vars = $p->{-YADISvars}; $vars->{-text} .= $text; } sub StartHTMLTag() { my ($p, $tag, $attrs) = @_; $p->{-YADIS_locals} = {} unless defined ($p->{-YADIS_locals}); my $locals = $p->{-YADIS_locals}; $locals->{-YADIS_in_head} = 1 if ($tag eq 'head'); my $headtagfound; # if we found and responded to a tag that should only be in the
if ($tag eq 'link') { if (defined($attrs->{'rel'})) { if (lc($attrs->{'rel'}) eq 'openid.server') { push @{$p->{-OPENIDlocations}}, [$attrs->{'href'}, undef, undef]; $headtagfound = 1; } } } elsif ($tag eq 'meta') { if (defined($attrs->{'http-equiv'})) { if (lc($attrs->{'http-equiv'}) eq 'x-xrds-location') { push @{$p->{-YADISlocations}}, [$attrs->{'content'}, 'body', 'x-rds-location']; } } # end of if we have an http-equiv attribute } # end of tag meta if ($headtagfound) { print " found outside HTML head section\n" unless $locals->{-YADIS_in_head}; } } sub EndHTMLTag() { my ($p, $tag ) = @_; my $locals = $p->{-YADIS_locals}; $locals->{-YADIS_in_head} = 0 if ($tag eq 'head'); } # The CGI lib seems to sometimes return arrays instead of single values for HTTP content types. # This routine provides a comparison function for it. sub contentTypeIs($$) { my ($contentType, $requiredMime) = @_; if( ref( $contentType ) eq "ARRAY" ) { foreach( @{$contentType} ) { if( substr($_, 0, length($requiredMime)) eq $requiredMime ) { return 1; } } return 0; } else { return substr($contentType, 0, length($requiredMime)) eq $requiredMime; } } # GetYadisXMLDocURLsFromResponse # # Look through a response and retrieve the YADIS XML Document from # a respones to an LWP::UserAgent->get(...) operation. # # $method - string, either 'GET' or 'HEAD' # $hadheader - whether or not the header included an Accept:... for # the YADIS type # $response - the response from the LWP::UserAgent->get(...) # $yadisurl - the URL we tried to retrieve this from # $yadisURLs - a reference to an array of returned values sub GetYadisXMLDocURLsFromResponse($$$$$) { my ($method, $hadheader, $response, $yadisurl, $yadisXMLDocURLs) = @_; my $yadisXMLDocURL = $response->headers->{'x-xrds-location'}; if (defined($yadisXMLDocURL)) { print "Warning: $err
\n"; return $err; } return undef; } print $cgi->header(); print <Yadis Test Client |
Given a Yadis URL, this program attempts to give diagnostic information about the various ways in which it can discover the eventual URL for the Yadis XRDS document.
You must enter fully-qualified URLs; e.g. http://example.com/ instead of just example.com.
EOF if ($cgi->param('url')) { my $yadisurl = $cgi->param('url'); my $escapedyadisurl = $cgi->escapeHTML($yadisurl); print "Warning: URL was previously" ." defined as " .$cgi->escapeHTML($yadisDocURL) ." by $yadisDocURLsource, " ." is now ".$cgi->escapeHTML($url->[0])."
\n"; } } $yadisDocURLsource = 'HTTP "HEAD" method without '. "Accept: application/xrds+xml
header from $url->[1]";
$yadisDocURL = $url->[0];
push @yadisDocURLsources, $yadisDocURLsource;
}
foreach $url (@yadisDocURLsGetNone)
{
if (defined($yadisDocURL))
{
if ($yadisDocURL ne $url->[0])
{
print "Warning: URL was previously" ." defined as " .$cgi->escapeHTML($yadisDocURL) ." by $yadisDocURLsource, " ." is now ".$cgi->escapeHTML($url->[0])."
\n"; } } $yadisDocURLsource = 'HTTP "GET" method without '. "Accept: application/xrds+xml
header from $url->[1]";
$yadisDocURL = $url->[0];
push @yadisDocURLsources, $yadisDocURLsource;
}
foreach $url (@yadisDocURLsHeadRds)
{
if (defined($yadisDocURL))
{
if ($yadisDocURL ne $url->[0])
{
print "Warning: URL was previously" ." defined as " .$cgi->escapeHTML($yadisDocURL) ." by $yadisDocURLsource, " ." is now ".$cgi->escapeHTML($url->[0])."
\n"; } } $yadisDocURLsource = 'HTTP "HEAD" method with '. "Accept: application/xrds+xml
header from $url->[1]";
$yadisDocURL = $url->[0];
push @yadisDocURLsources, $yadisDocURLsource;
}
foreach $url (@yadisDocURLsGetRds)
{
if (defined($yadisDocURL))
{
if ($yadisDocURL ne $url->[0])
{
print "Warning: URL was previously" ." defined as " .$cgi->escapeHTML($yadisDocURL) ." by $yadisDocURLsource, " ." is now ".$cgi->escapeHTML($url->[0])."
\n"; } } $yadisDocURLsource = 'HTTP "GET" method with '. "Accept: application/xrds+xml
header from $url->[1]";
$yadisDocURL = $url->[0];
push @yadisDocURLsources, $yadisDocURLsource;
}
if (defined($yadisDocURL))
{
print 'derived ' .$cgi->escapeHTML($yadisDocURL)." from:
\nPriority | Type(s) | URI | Note |
---|---|---|---|
$priority | "; print ''.join(' ', map {$cgi->escapeHTML($_)} @$types).' | ';
print ''.join(' ', map {$cgi->escapeHTML($_)} @$uris).' | ';
print ''; print $cgi->escapeHTML($error); print ' | '; print "
Error: parsing of document failed with:
'; print "\n".$cgi->escapeHTML($@)."\n"; } } else { print '
Error: Unable to retrieve Yadis' .' XRDS document from '.$cgi->escapeHTML($yadisDocURL)."
\n"; } } else { print 'Error: Unable to locate Yadis XRDS document from ' .$escapedyadisurl."
\n"; } print "\n"; } print $cgi->start_form( -method=>'GET' ); print 'Yadis URL: '; print $cgi->textfield(-name=>'url', -size=>50 ); print $cgi->submit(); print $cgi->end_form; print "\n\n\n";