incubator-heraldry-commits mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From ket...@apache.org
Subject svn commit: r463017 - in /incubator/heraldry/libraries/perl/yadis: ./ trunk/ trunk/MANIFEST trunk/Makefile.PL trunk/README trunk/lib/ trunk/lib/Net/ trunk/lib/Net/Yadis.pm trunk/lib/Net/Yadis/ trunk/lib/Net/Yadis/HTMLParse.pm trunk/t/ trunk/t/yadis.t
Date Wed, 11 Oct 2006 22:41:40 GMT
Author: keturn
Date: Wed Oct 11 15:41:38 2006
New Revision: 463017

URL: http://svn.apache.org/viewvc?view=rev&rev=463017
Log:
Initial import of Perl Yadis libraries from JanRain.

Added:
    incubator/heraldry/libraries/perl/yadis/
    incubator/heraldry/libraries/perl/yadis/trunk/   (with props)
    incubator/heraldry/libraries/perl/yadis/trunk/MANIFEST
    incubator/heraldry/libraries/perl/yadis/trunk/Makefile.PL
    incubator/heraldry/libraries/perl/yadis/trunk/README
    incubator/heraldry/libraries/perl/yadis/trunk/lib/
    incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/
    incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis/
    incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis.pm   (with props)
    incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis/HTMLParse.pm
    incubator/heraldry/libraries/perl/yadis/trunk/t/
    incubator/heraldry/libraries/perl/yadis/trunk/t/yadis.t   (with props)

Propchange: incubator/heraldry/libraries/perl/yadis/trunk/
------------------------------------------------------------------------------
--- svn:ignore (added)
+++ svn:ignore Wed Oct 11 15:41:38 2006
@@ -0,0 +1 @@
+_darcs

Added: incubator/heraldry/libraries/perl/yadis/trunk/MANIFEST
URL: http://svn.apache.org/viewvc/incubator/heraldry/libraries/perl/yadis/trunk/MANIFEST?view=auto&rev=463017
==============================================================================
--- incubator/heraldry/libraries/perl/yadis/trunk/MANIFEST (added)
+++ incubator/heraldry/libraries/perl/yadis/trunk/MANIFEST Wed Oct 11 15:41:38 2006
@@ -0,0 +1,6 @@
+lib/Net/Yadis/HTMLParse.pm
+lib/Net/Yadis.pm
+t/yadis.t
+Makefile.PL
+README
+MANIFEST

Added: incubator/heraldry/libraries/perl/yadis/trunk/Makefile.PL
URL: http://svn.apache.org/viewvc/incubator/heraldry/libraries/perl/yadis/trunk/Makefile.PL?view=auto&rev=463017
==============================================================================
--- incubator/heraldry/libraries/perl/yadis/trunk/Makefile.PL (added)
+++ incubator/heraldry/libraries/perl/yadis/trunk/Makefile.PL Wed Oct 11 15:41:38 2006
@@ -0,0 +1,11 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    'NAME' => 'Net::Yadis',
+    'AUTHOR' => 'Dag Arneson <dag@janrain.com>',
+    'VERSION_FROM' => 'lib/Net/Yadis.pm',
+    'PREREQ_PM' => {
+                    'LWP::UserAgent' => 0,
+                    'XML::XPath' => 0,
+                   },
+    );

Added: incubator/heraldry/libraries/perl/yadis/trunk/README
URL: http://svn.apache.org/viewvc/incubator/heraldry/libraries/perl/yadis/trunk/README?view=auto&rev=463017
==============================================================================
--- incubator/heraldry/libraries/perl/yadis/trunk/README (added)
+++ incubator/heraldry/libraries/perl/yadis/trunk/README Wed Oct 11 15:41:38 2006
@@ -0,0 +1,27 @@
+Yadis 0.7
+Dag Arneson, JanRain Inc.  dag@janrain.com
+
+This library does Yadis discovery and parses XRDS services documents
+(hopefully) as per Yadis spec 0.92.  
+
+Dependencies:
+LWPx::ParanoidAgent or LWP::UserAgent
+XML::XPath
+
+Usage is simple:
+
+my $yadis = Net::Yadis->discover($url);
+
+#get the highest priority service matching $type_regexp
+$svc = $yadis->service_of_type($type_regexp);
+$nsvc = $yadis->service_of_type($type_regexp); # next one
+
+@services = $yadis->services; # get all services as a list
+
+$uri = $svc->uri; # The highest Priority URI
+$backupuri = $svc->uri; # URI with next highest priority
+
+@uris = $svc->uris; # or get them as a list
+
+$svc->is_type($type_regexp) # just to be sure
+

Added: incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis.pm
URL: http://svn.apache.org/viewvc/incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis.pm?view=auto&rev=463017
==============================================================================
--- incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis.pm (added)
+++ incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis.pm Wed Oct 11 15:41:38 2006
@@ -0,0 +1,501 @@
+#!/usr/bin/perl
+# Copyright 2006 JanRain Inc.  Licensed under LGPL
+# Author: Dag Arneson <dag@janrain.com>
+
+package Net::Yadis;
+
+use warnings;
+use strict;
+
+our $VERSION = "1.0";
+
+use XML::XPath;
+
+eval "use LWPx::ParanoidAgent;";
+my $userAgentClass;
+if($@) {
+    warn "consider installing more secure LWPx::ParanoidAgent\n";
+    use LWP::UserAgent;
+    $userAgentClass = "LWP::UserAgent";
+}
+else {
+    $userAgentClass = "LWPx::ParanoidAgent";
+}
+sub _userAgentClass { # Mainly for testing.  Needs to be able to get and post
+    my $agent = shift;
+    $userAgentClass = $agent if $agent;
+    return $userAgentClass;
+}
+
+# finds meta http-equiv tags
+use Net::Yadis::HTMLParse qw(parseMetaTags);
+
+# must be lowercase.
+my $YADIS_HEADER = 'x-xrds-location'; # this header is in the 1.0 yadis spec
+# The following header was in an early version of the spec, and was 
+# still in wide use at the time of writing
+my $COMPAT_YADIS_HEADER = 'x-yadis-location';
+
+=head1 Net::Yadis
+
+This package performs the Yadis service discovery protocol, and parses
+XRDS xml documents.
+
+=head2 Methods
+
+=head3 discover
+
+This constructor performs the discovery protocol on a url and returns
+a yadis object that parses the XRDS document for you.
+
+ eval {
+   $yadis=Net::Yadis->discover($url);
+ }
+ warn "Yadis failed: $@" if $@;
+ 
+Will die on errors: HTTP errors, missing Yadis magic, malformed XRDS
+
+=cut
+
+sub discover {
+    my $caller = shift;
+    my $uri = shift;
+
+    my $ua = $userAgentClass->new;
+    my $resp = $ua->get($uri, 'Accept' => 'application/xrds+xml');
+
+    die "Failed to fetch $uri" unless $resp->is_success;
+    $uri = $resp->base;
+    my ($xrds_text, $xrds_uri);
+    my $ct = $resp->header('content-type');
+    if ($ct and $ct eq 'application/xrds+xml') {
+        $xrds_text = $resp->content;
+        $xrds_uri = $resp->base;
+    }
+    else {
+        my $yadloc = $resp->header($YADIS_HEADER) || $resp->header($COMPAT_YADIS_HEADER);
+        
+        unless($yadloc) {
+            my $equiv_headers = parseMetaTags($resp->content);
+            $yadloc = $equiv_headers->{$YADIS_HEADER} || $equiv_headers->{$COMPAT_YADIS_HEADER};
+        }
+        if($yadloc) {
+            my $resp2 = $ua->get($yadloc);
+            die "Bad Yadis URL: $uri - Could not fetch $yadloc" unless $resp2->is_success;

+            $xrds_text = $resp2->content;
+            $xrds_uri = $resp2->base; # but out of spec if not equal to $yadloc
+        }
+        else {
+            die "$uri is not a YADIS URL";
+        }
+    }
+    $caller->new($uri, $xrds_uri, $xrds_text)
+}
+
+=head3 new
+
+You may also skip discovery and go straight to xrds parsing with the C<new>
+constructor.
+
+ $yadis = Net::Yadis->new($yadis_url, $xrds_url, $xml);
+
+=over
+
+=item $yadis_url
+
+the identity URL
+
+=item $xrds_url
+
+where we got the xrds document
+
+=item $xml
+
+the XRDS xml as text
+
+=back
+
+We don't trap death from XML::XPath; malformed xml causes this
+
+=cut
+
+sub new {
+    my $caller = shift;
+    my ($yadis_url, $xrds_url, $xml) = @_;
+
+    my $class = ref($caller) || $caller;
+
+    my $xrds;
+    $xrds = XML::XPath->new(xml => $xml);
+    $xrds->set_namespace("xrds", 'xri://$xrds');
+    $xrds->set_namespace("xrd", 'xri://$xrd*($v*2.0)');
+    
+    my @svc_nodes = sort byPriority
+            $xrds->findnodes("/xrds:XRDS/xrd:XRD[last()]/xrd:Service");
+    my @services;
+    for(@svc_nodes) {
+        push @services, Net::Yadis::Service->new($xrds, $_);
+    }
+    
+    my $self = {
+        yadis_url     => $yadis_url,
+        xrds_url => $xrds_url,
+        xrds    => $xrds,
+        xml     => $xml,
+        services => \@services,
+        };
+
+    bless ($self, $class);
+}
+
+=head3 Accessor methods
+
+=over
+
+=item xml
+
+The XML text of the XRDS document.
+
+=item url
+
+The Yadis URL.
+
+=item xrds_url
+
+The URL where the XRDS document was found.
+
+=item xrds_xpath
+
+The XML::XPath object used internally is made available to allow custom
+XPath queries.
+
+=item services
+
+An array of Net::Yadis::Service objects representing the services
+advertised in the XRDS file.
+
+=back
+
+=cut
+
+sub xml {
+    my $self = shift;
+    $self->{xml};
+}
+sub url {
+    my $self = shift;
+    $self->{yadis_url};
+}
+sub xrds_url {
+    my $self = shift;
+    $self->{xrds_url};
+}
+sub xrds_xpath {
+    my $self = shift;
+    $self->{xrds};
+}
+
+# sorting helper function for xpath nodes
+# I wonder if doing the random order for the services significantly
+# increases the running time of this function.
+sub byPriority {
+    my $apriori = $a->getAttribute('priority');
+    my $bpriori = $b->getAttribute('priority');
+    srand;
+    # a defined priority comes before an undefined priority.
+    if (not defined($apriori)) { # we assume nothing
+        return defined($bpriori) || ((rand > 0.5) ? 1 : -1);
+    }
+    elsif (not defined($bpriori)) {
+        return -1;
+    }
+    int($apriori) <=> int($bpriori) || ((rand > 0.5) ? 1 : -1);
+}
+
+# using a sorting helper from another package doesn't work, so
+# we use this function when sorting URIs in the service object
+sub _triage {
+    sort byPriority @_;
+}
+
+sub services {
+    my $self = shift;
+    return @{$self->{services}} 
+}
+
+=head3 filter_services
+
+Pass in a filter function reference to this guy.  The filter function
+must take a Net::Yadis::Service object, and return a scalar of some sort
+or undef.  The scalars returned from the filter will be returned in an
+array from this method.
+
+=head4 Example
+
+    my $filter = sub {
+        my $service = shift;
+        if ($service->is_type($typere)) {
+            # here we simply return the service object, but you may return
+            # something else if you wish to extract the data and discard
+            # the xpath object contained in the service object.
+            return $service;
+        }
+        else {
+            return undef;
+        }
+    };
+
+    my $typeservices = $yadis->filter_services($filter);
+
+=cut
+
+sub filter_services {
+    my $self = shift;
+    my $filter = shift;
+    
+    my @allservices = $self->services;
+    my @filteredservices;
+    for my $service (@allservices) {
+        my $filtered_service = &$filter($service);
+        push @filteredservices, $filtered_service if defined($filtered_service);
+    }
+
+    return @filteredservices;
+}
+
+=head3 services_of_type
+
+A predefined filtering method that takes a regexp for filtering service
+types.
+
+=cut
+
+# here is an example using a filter function
+sub services_of_type {
+    my $self = shift;
+    my $typere = shift;
+    
+    my $filter = sub {
+        my $service = shift;
+        if ($service->is_type($typere)) {
+            # here we simply return the service object, but you may return
+            # something else if you wish to extract the data and discard
+            # the xpath object contained in the service object.
+            return $service;
+        }
+        else {
+            return undef;
+        }
+    };
+    return $self->filter_services($filter);
+}
+
+=head3 service_of_type
+
+Hey, a perl generator! sequential calls will return the services one 
+at a time, in ascending priority order with ties randomly decided.
+make sure that the type argument is identical for each call, or the list
+will start again from the top.  You'll have to store the yadis object in
+a session for this guy to be useful.
+
+=cut
+
+sub service_of_type {
+    my $self = shift;
+    my $typere = shift;
+
+    # remaining services of type
+    my $rsot = $self->{rsot};
+    my @remaining_services;
+    if (defined($rsot->{$typere})) {
+        @remaining_services = @{$rsot->{$typere}};
+    }
+    else {
+        @remaining_services = $self->services_of_type($typere);
+    }
+    my $service = shift @remaining_services;
+    $rsot->{$typere} = \@remaining_services;
+    $self->{rsot}=$rsot;
+    return $service;
+}
+
+1;
+
+package Net::Yadis::Service;
+
+=head1 Net::Yadis::Service
+
+An object representing a service tag in an XRDS document.
+
+=head2 Methods
+
+=head3 is_type
+
+Takes a regexp or a string and returns a boolean value: do any of the
+C<< <Type> >> tags in the C<< <Service> >> tag match
this type?
+
+=cut
+
+#typere: regexp or string
+sub is_type {
+    my $self = shift;
+    my $typere = shift;
+     
+    my $xrds = $self->{xrds};
+    my $typenodes = $xrds->findnodes("./xrd:Type", $self->{node});
+    my $is_type = 0;
+    while($typenodes->size) {
+        # string_value contains the first node's value <shrug>
+        if ($typenodes->string_value =~ qr{$typere}) {
+            $is_type = 1;
+            last;
+        }
+        $typenodes->shift;
+    }
+    return $is_type;
+}
+
+=head3 types
+
+Returns a list of the contents of the C<< <Type> >> tags of this service
+element.
+
+=cut
+
+sub types {
+    my $self = shift;
+    
+    my $xrds = $self->{xrds};
+    my @typenodes = $xrds->findnodes("./xrd:Type", $self->{node});
+    my @types;
+    for my $tn (@typenodes) {
+        push @types, $xrds->getNodeText($tn);
+    }
+    return @types;
+}
+
+=head3 uris
+
+Returns a list of the contents of the C<< <URI> >> tags of this service
+element, in priority order, ties randomly decided.
+
+=cut
+
+
+sub uris {
+    my $self = shift;
+    
+    my $xrds = $self->{xrds};
+    my @urinodes = Net::Yadis::_triage $xrds->findnodes("./xrd:URI", $self->{node});
+    my @uris;
+    for my $un (@urinodes) {
+        push @uris, $xrds->getNodeText($un);
+    }
+    return @uris;
+}
+
+=head3 uri
+
+another perl 'generator'. sequential calls will return the uris one 
+at a time, in ascending priority order with ties randomly decided
+
+=cut
+
+sub uri {
+    my $self = shift;
+    my @untried_uris;
+    if (defined($self->{untried_uris})) {
+        @untried_uris = @{$self->{untried_uris}};
+    } else {
+        @untried_uris = $self->uris;
+    }
+    my $uri = shift (@untried_uris);
+    $self->{untried_uris} = \@untried_uris;
+    return $uri;
+}
+
+=head3 getAttribute
+
+Get an attribute of the service tag by name.
+
+ $priority = $service->getAttribute('priority');
+
+=cut
+
+sub getAttribute {
+    my $self = shift;
+    my $key = shift;
+    my $node = $self->{node};
+    $node->getAttribute($key);
+}
+
+=head3 findTag
+
+Get the contents of a child tag of the service tag.
+
+ $service->findTag($tag_name, $namespace);
+
+For example:
+
+ $delegate = $service->findTag('Delegate', $OPENID_NS);
+
+=cut
+
+sub findTag {
+    my $self = shift;
+    my $tagname = shift;
+    my $namespace = shift;
+
+    my $xrds = $self->{xrds};
+    my $svcnode = $self->{node};
+    
+    my $value;
+    if($namespace) {
+        $xrds->set_namespace("asdf", $namespace);
+        $value = $xrds->findvalue("./asdf:$tagname", $svcnode);
+    }
+    else {
+        $value = $xrds->findvalue("./$tagname", $svcnode);
+    }
+    
+    return $value;
+}
+
+=head3 xrds
+
+Returns the xrds document as an XML::XPath for custom XPath queries.
+
+=cut
+
+sub xrds {
+    my $self = shift;
+    return $self->{xrds};
+}
+
+=head3 node
+
+Returns the XPath node of the C<< <Service> >> tag, for custom XPath queries.
+
+=cut
+
+sub node {
+    my $self = shift;
+    return $self->{node};
+}
+
+sub new {
+    my $caller = shift;
+    my ($xrds, $node) = @_;
+
+    my $class = ref($caller) || $caller;
+
+    my $self = {
+        xrds => $xrds,
+        node => $node,
+    };
+
+    bless($self, $class);
+}
+
+1;
+

Propchange: incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis.pm
------------------------------------------------------------------------------
    svn:executable = *

Added: incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis/HTMLParse.pm
URL: http://svn.apache.org/viewvc/incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis/HTMLParse.pm?view=auto&rev=463017
==============================================================================
--- incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis/HTMLParse.pm (added)
+++ incubator/heraldry/libraries/perl/yadis/trunk/lib/Net/Yadis/HTMLParse.pm Wed Oct 11 15:41:38
2006
@@ -0,0 +1,136 @@
+package Net::Yadis::HTMLParse;
+
+use strict;
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(parseMetaTags);
+
+my $htmlre = qr{
+# Starts with the tag name at a word boundary, where the tag name is
+# not a namespace
+<html\b(?!:)
+
+# All of the stuff up to a ">", hopefully attributes.
+([^>]*?)
+
+(?: # Match a short tag
+    />
+
+|   # Match a full tag
+    >
+
+    # contents
+    (.*?)
+
+    # Closed by
+    (?: # One of the specified close tags
+        </?html\s*>
+
+        # End of the string
+    |   \Z
+
+    )
+
+)
+}isox;
+
+my $headre = qr{
+# Starts with the tag name at a word boundary, where the tag name is
+# not a namespace
+<head\b(?!:)
+
+# All of the stuff up to a ">", hopefully attributes.
+([^>]*?)
+
+(?: # Match a short tag
+    />
+
+|   # Match a full tag
+    >
+
+    # match the contents of the full tag
+    (.*?)
+
+    # Closed by
+    (?: # One of the specified close tags
+        </?(?:head|body)\s*>
+
+        # End of the string
+    |   \Z
+
+    )
+
+)
+}soxi;
+
+# http-equiv = $2 || $3
+# content = $5 || $6
+my $tagre = qr{
+<meta\s+http-equiv=
+(?:
+# between matching quote marks
+(["'])(.*?)\1
+|
+# or up to whitespace
+([^"'\s]+)
+)
+\s*
+content=
+(?:
+# between matching quote marks
+(["'])(.*?)\4
+|
+# or up to whitespace
+([^"'\s]+)
+)
+\s*
+/?>?
+}sixo;
+
+
+my $removere = qr{
+  # Comments
+  <!--.*?-->
+
+  # CDATA blocks
+| <!\[CDATA\[.*?\]\]>
+
+  # script blocks
+| <script\b
+
+  # make sure script is not an XML namespace
+  (?!:)
+
+  [^>]*>.*?</script>
+}soix;
+
+my %replacements = (
+    'amp'   => '&',
+    'lt'    => '<',
+    'gt'    => '>',
+    'quot'  => '"',
+    );
+    
+sub parseMetaTags {
+    my ($html) = @_;
+
+    $html =~ s/$removere//;
+    $html =~ $htmlre or return ();
+    my $htmlcontents = $2;
+    $htmlcontents =~ $headre or return ();
+    my $head = $2;
+    defined $head or return ();
+    
+    my %headerhash;
+    foreach my $tag ($head =~ /$tagre/g) {
+        my ($httpequiv,$content) = ($2 || $3, $5 || $6);
+        for my $pat (keys %replacements) {
+            $httpequiv =~ s/&$pat;/$replacements{$pat}/g;
+            $content =~ s/&$pat;/$replacements{$pat}/g;
+        }
+        $headerhash{lc($httpequiv)}=$content;
+    }
+    
+    return \%headerhash;
+}
+

Added: incubator/heraldry/libraries/perl/yadis/trunk/t/yadis.t
URL: http://svn.apache.org/viewvc/incubator/heraldry/libraries/perl/yadis/trunk/t/yadis.t?view=auto&rev=463017
==============================================================================
--- incubator/heraldry/libraries/perl/yadis/trunk/t/yadis.t (added)
+++ incubator/heraldry/libraries/perl/yadis/trunk/t/yadis.t Wed Oct 11 15:41:38 2006
@@ -0,0 +1,206 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 27;
+
+use Net::Yadis;
+
+package testFetcher;
+
+use Test::More;
+use HTTP::Response;
+use LWP::UserAgent;
+sub new {
+    bless {realAgent => LWP::UserAgent->new}
+}
+
+my $GOOD_XRDS = '<?xml version="1.0" encoding="UTF-8"?>
+<xrds:XRDS
+    xmlns:xrds="xri://$xrds"
+    xmlns="xri://$xrd*($v*2.0)"
+    xmlns:openid="http://openid.net/xmlns/1.0">
+  <XRD>
+
+    <Service priority="10">
+      <Type>http://openid.net/signon/1.0</Type>
+    </Service>
+
+  </XRD>
+</xrds:XRDS>
+';
+my $HTML_PAGE = "<html><head></head><body>foo!</body></html>";
+my $HTML_EQUIV_PAGE = "<html><head><meta http-equiv='x-xrds-location' content='http://xrds.as.text/'></head><body>foo!</body></html>";
+my $HTML_EQUIV_COMPAT_PAGE = "<html><head><meta http-equiv='x-yadis-location'
content='http://xrds.as.text/'></head><body>foo!</body></html>";
+
+sub get {
+    my $self = shift;
+    my $uri = shift;
+    my %headers = @_;
+
+    my $response = HTTP::Response->new;
+
+    if ($uri eq 'http://content.negotiation/') {
+        $response->code(200);
+        if($headers{'Accept'} eq 'application/xrds+xml') {
+            $response->header('Content-Type', 'application/xrds+xml');
+            $response->content($GOOD_XRDS);
+            $response->header('Content-Location', $uri);
+        }
+        else {
+            $response->header('Content-Type', 'text/plain');
+            $response->content("ERROR: yadis lib doesn't send accept header");
+            $response->header('Content-Location', $uri);
+        }
+    }
+    elsif ($uri eq 'http://http.header/') {
+        $response->code(200);
+        $response->header('X-XRDS-Location', 'http://xrds.as.text/');
+        $response->content($HTML_PAGE);
+        $response->header('Content-Location', $uri);
+    }
+    elsif ($uri eq 'http://http.equiv/') {
+        $response->code(200);
+        $response->content($HTML_EQUIV_PAGE);
+        $response->header('Content-Location', $uri);
+    }
+    elsif ($uri eq 'http://not.found/') {
+        $response->code(404);
+    }
+    elsif ($uri eq 'http://xrds.as.text/') {
+        $response->code(200);
+        $response->header('Content-Type', 'text/plain');
+        $response->content($GOOD_XRDS);
+        $response->header('Content-Location', $uri);
+    }
+    elsif ($uri eq 'http://network.error/') {
+        $response = $self->{realAgent}->get($uri);
+    }
+    elsif ($uri eq 'http://redirect.me/') {
+        $response->code(200);
+        $response->content($HTML_EQUIV_PAGE);
+        $response->header('Content-Location', 'http://redirect.ed/');
+    }
+    elsif ($uri eq 'http://http.compat.header/') {
+        $response->code(200);
+        $response->header('X-Yadis-Location', 'http://xrds.as.text/');
+        $response->content($HTML_PAGE);
+        $response->header('Content-Location', $uri);
+    }
+    elsif ($uri eq 'http://http.compat.equiv/') {
+        $response->code(200);
+        $response->content($HTML_EQUIV_COMPAT_PAGE);
+        $response->header('Content-Location', $uri);
+    }
+    return $response;
+}
+
+sub post {
+};
+
+package YadisTest;
+use Test::More;
+
+Net::Yadis::_userAgentClass('testFetcher');
+
+my ($yadis, $svc, $svb, @services, @types, @uris);
+
+# discovery failures
+eval {$yadis = Net::Yadis->discover('http://network.error/');};
+ok($@, "Network error dies");
+
+eval {$yadis = Net::Yadis->discover('http://not.found/');};
+ok($@, "404 dies");
+
+eval {$yadis = Net::Yadis->discover('http://xrds.as.text/');};
+ok($@, "Not a Yadis URL dies");
+
+# discovery successes
+eval {$yadis = Net::Yadis->discover('http://content.negotiation/');};
+is($yadis->url, 'http://content.negotiation/',
+        "Content Negotiation correct yadis url");
+is($yadis->xrds_url, 'http://content.negotiation/',
+        "CN correct xrds URL");
+eval {$yadis = Net::Yadis->discover('http://http.header/');};
+is($yadis->url, 'http://http.header/',
+        "Http header correct yadis url");
+is($yadis->xrds_url, 'http://xrds.as.text/',
+        "header correct xrds URL");
+eval {$yadis = Net::Yadis->discover('http://http.equiv/');};
+print $@ if $@;
+is($yadis->url, 'http://http.equiv/',
+        "Http equiv correct yadis url");
+is($yadis->xrds_url, 'http://xrds.as.text/',
+        "equiv correct xrds URL");
+eval {$yadis = Net::Yadis->discover('http://http.compat.header/');};
+is($yadis->url, 'http://http.compat.header/',
+        "Http old header correct yadis url");
+is($yadis->xrds_url, 'http://xrds.as.text/',
+        "old header correct xrds URL");
+eval {$yadis = Net::Yadis->discover('http://http.compat.equiv/');};
+is($yadis->url, 'http://http.compat.equiv/',
+        "Http old equiv correct yadis url");
+is($yadis->xrds_url, 'http://xrds.as.text/',
+        "old equiv correct xrds URL");
+eval {$yadis = Net::Yadis->discover('http://redirect.me/');};
+is($yadis->url, 'http://redirect.ed/',
+        "yadis url follows redirects");
+
+
+
+# test prioritizing and getting attributes of tags in the service
+my $xrds_xml = '<?xml version="1.0" encoding="UTF-8"?>
+<xrds:XRDS
+    xmlns:xrds="xri://$xrds"
+    xmlns="xri://$xrd*($v*2.0)"
+    xmlns:openid="http://openid.net/xmlns/1.0">
+  <XRD>
+
+    <Service priority="10">
+      <Type>http://openid.net/signon/1.0</Type>
+      <URI>http://www.myopenid.com/servir</URI>
+      <URI priority="57">http://www.myopenid.com/servor</URI>
+      <URI priority="64">http://www.myopenid.com/server</URI>
+      <openid:Delegate>http://frank.livejournal.com/</openid:Delegate>
+      <junk>Ton Cents</junk>
+    </Service>
+
+    <Service priority="5">
+      <Type>http://openid.net/signon/1.0</Type>
+      <URI>http://www.myclosedid.com/servir</URI>
+      <URI priority="57">http://www.myclosedid.com/servor</URI>
+      <URI priority="64">http://www.myclosedid.com/server</URI>
+      <openid:Delegate>http://frank.livejournal.com/</openid:Delegate>
+      <junk>Con Tents</junk>
+    </Service>
+
+  </XRD>
+</xrds:XRDS>
+';
+
+eval{
+    $yadis = Net::Yadis->new("http://foobar.voodoo.com/", 
+                             "http://foobar.voodoo.com/xrds",
+                             $xrds_xml);
+    };
+isa_ok($yadis, "Net::Yadis", "New from foodoo voobar example")
+    or diag($@);
+
+$svc = $yadis->service_of_type("^http://openid.net/signon/");
+is($svc->uri, "http://www.myclosedid.com/servor", "foobar.voodoo.com svc 1 URI 1");
+is($svc->uri, "http://www.myclosedid.com/server", "foobar.voodoo.com svc 1 URI 2");
+is($svc->uri, "http://www.myclosedid.com/servir", "foobar.voodoo.com svc 1 URI 3");
+is($svc->uri, undef, "foobar.voodoo.com svc1 has 3 URIs");
+my ($contents, $attrs) = $svc->findTag("junk");
+is($contents, "Con Tents", "foobar.voodoo.com svc 1 findTag junk contents");
+is($svc->getAttribute("priority"), "5", "svc->getAttribute works");
+
+$svc = $yadis->service_of_type("^http://openid.net/signon/");
+is($svc->uri, "http://www.myopenid.com/servor", "foobar.voodoo.com svc 2 URI 1");
+is($svc->uri, "http://www.myopenid.com/server", "foobar.voodoo.com svc 2 URI 2");
+is($svc->uri, "http://www.myopenid.com/servir", "foobar.voodoo.com svc 2 URI 3");
+is($svc->uri, undef, "foobar.voodoo.com svc 2 has 3 URIs");
+($contents, $attrs) = $svc->findTag("junk");
+is($contents, "Ton Cents", "foobar.voodoo.com svc 2 findTag junk contents");
+is($svc->getAttribute("priority"), "10", "svc->getAttribute still works");
+

Propchange: incubator/heraldry/libraries/perl/yadis/trunk/t/yadis.t
------------------------------------------------------------------------------
    svn:executable = *



Mime
View raw message