r71278 - in /branches/upstream/libgravatar-url-perl/current: Build.PL Changes MANIFEST MANIFEST.SKIP META.yml SIGNATURE lib/Gravatar/URL.pm lib/Libravatar/ lib/Libravatar/URL.pm lib/Unicornify/URL.pm t/libravatar.t t/url.t
ansgar at users.alioth.debian.org
ansgar at users.alioth.debian.org
Sat Mar 12 17:27:27 UTC 2011
Author: ansgar
Date: Sat Mar 12 17:27:03 2011
New Revision: 71278
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=71278
Log:
[svn-upgrade] new version libgravatar-url-perl (1.03)
Added:
branches/upstream/libgravatar-url-perl/current/lib/Libravatar/
branches/upstream/libgravatar-url-perl/current/lib/Libravatar/URL.pm
branches/upstream/libgravatar-url-perl/current/t/libravatar.t (with props)
Removed:
branches/upstream/libgravatar-url-perl/current/SIGNATURE
Modified:
branches/upstream/libgravatar-url-perl/current/Build.PL
branches/upstream/libgravatar-url-perl/current/Changes
branches/upstream/libgravatar-url-perl/current/MANIFEST
branches/upstream/libgravatar-url-perl/current/MANIFEST.SKIP
branches/upstream/libgravatar-url-perl/current/META.yml
branches/upstream/libgravatar-url-perl/current/lib/Gravatar/URL.pm
branches/upstream/libgravatar-url-perl/current/lib/Unicornify/URL.pm
branches/upstream/libgravatar-url-perl/current/t/url.t
Modified: branches/upstream/libgravatar-url-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgravatar-url-perl/current/Build.PL?rev=71278&op=diff
==============================================================================
--- branches/upstream/libgravatar-url-perl/current/Build.PL (original)
+++ branches/upstream/libgravatar-url-perl/current/Build.PL Sat Mar 12 17:27:03 2011
@@ -30,11 +30,12 @@
},
requires => {
- 'URI::Escape' => 0,
- 'Digest::MD5' => 0,
- 'Carp' => 0,
- perl => '5.6.0',
- 'parent' => 0,
+ 'Net::DNS::Resolver' => 0,
+ 'URI::Escape' => 0,
+ 'Digest::MD5' => 0,
+ 'Carp' => 0,
+ perl => '5.6.0',
+ 'parent' => 0,
},
);
Modified: branches/upstream/libgravatar-url-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgravatar-url-perl/current/Changes?rev=71278&op=diff
==============================================================================
--- branches/upstream/libgravatar-url-perl/current/Changes (original)
+++ branches/upstream/libgravatar-url-perl/current/Changes Sat Mar 12 17:27:03 2011
@@ -1,3 +1,16 @@
+1.03 Sat Mar 12 18:17:03 NZDT 2011
+ New Features
+ * Added Libravatar::URL for federated avatar hosting with a Gravatar
+ fallback. (http://www.libravatar.org)
+ * Add new optional 'https' parameter to deliver avatars over HTTPS.
+
+ New Docs
+ * Updated the defaults with the new "retro" and mystery man values.
+ * Document the https base URL now available.
+
+ New Co-Maintainer (Francois Marier)
+
+
1.02 Thu Apr 1 15:36:52 PDT 2010
New Features
* Added Unicornify::URL for generated unicorn avatars, OMG!!!
Modified: branches/upstream/libgravatar-url-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgravatar-url-perl/current/MANIFEST?rev=71278&op=diff
==============================================================================
--- branches/upstream/libgravatar-url-perl/current/MANIFEST (original)
+++ branches/upstream/libgravatar-url-perl/current/MANIFEST Sat Mar 12 17:27:03 2011
@@ -1,13 +1,14 @@
Build.PL
Changes
lib/Gravatar/URL.pm
+lib/Libravatar/URL.pm
lib/Unicornify/URL.pm
-MANIFEST
+MANIFEST This list of files
MANIFEST.SKIP
META.yml
t/deprecated.t
t/error.t
t/id.t
+t/libravatar.t
t/unicornify.t
t/url.t
-SIGNATURE Added here by Module::Build
Modified: branches/upstream/libgravatar-url-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgravatar-url-perl/current/MANIFEST.SKIP?rev=71278&op=diff
==============================================================================
--- branches/upstream/libgravatar-url-perl/current/MANIFEST.SKIP (original)
+++ branches/upstream/libgravatar-url-perl/current/MANIFEST.SKIP Sat Mar 12 17:27:03 2011
@@ -1,4 +1,5 @@
-#!start included /usr/local/lib/perl5/5.10.1/ExtUtils/MANIFEST.SKIP
+
+#!start included /Users/schwern/perl5/perlbrew/perls/perl-v5.12.2/lib/5.12.2/ExtUtils/MANIFEST.SKIP
# Avoid version control files.
\bRCS\b
\bCVS\b
@@ -54,5 +55,6 @@
# Avoid MYMETA files
^MYMETA\.
-#!end included /usr/local/lib/perl5/5.10.1/ExtUtils/MANIFEST.SKIP
+#!end included /Users/schwern/perl5/perlbrew/perls/perl-v5.12.2/lib/5.12.2/ExtUtils/MANIFEST.SKIP
+
Modified: branches/upstream/libgravatar-url-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgravatar-url-perl/current/META.yml?rev=71278&op=diff
==============================================================================
--- branches/upstream/libgravatar-url-perl/current/META.yml (original)
+++ branches/upstream/libgravatar-url-perl/current/META.yml Sat Mar 12 17:27:03 2011
@@ -1,34 +1,38 @@
---
-abstract: 'Make URLs for Gravatars from an email address'
+name: Gravatar-URL
+version: 1.03
author: []
-build_requires:
- Test::More: 0.4
- Test::Warn: 0.11
-configure_requires:
- Module::Build: 0.2808
-generated_by: 'Module::Build version 0.3603'
-keywords:
- - Gravatar
+abstract: Make URLs for Gravatars from an email address
license: perl
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
-name: Gravatar-URL
-provides:
- Gravatar::URL:
- file: lib/Gravatar/URL.pm
- version: 1.02
- Unicornify::URL:
- file: lib/Unicornify/URL.pm
- version: 1.02
-requires:
- Carp: 0
- Digest::MD5: 0
- URI::Escape: 0
- parent: 0
- perl: v5.6.0
resources:
bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Gravatar-URL
license: http://dev.perl.org/licenses/
repository: http://github.com/schwern/gravatar-url/tree/master
-version: 1.02
+build_requires:
+ Test::More: 0.4
+ Test::Warn: 0.11
+requires:
+ Carp: 0
+ Digest::MD5: 0
+ Net::DNS::Resolver: 0
+ URI::Escape: 0
+ parent: 0
+ perl: v5.6.0
+configure_requires:
+ Module::Build: 0.2808
+provides:
+ Gravatar::URL:
+ file: lib/Gravatar/URL.pm
+ version: 1.03
+ Libravatar::URL:
+ file: lib/Libravatar/URL.pm
+ version: 1.03
+ Unicornify::URL:
+ file: lib/Unicornify/URL.pm
+ version: 1.03
+generated_by: Module::Build version 0.340201
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+keywords:
+ - Gravatar
Modified: branches/upstream/libgravatar-url-perl/current/lib/Gravatar/URL.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgravatar-url-perl/current/lib/Gravatar/URL.pm?rev=71278&op=diff
==============================================================================
--- branches/upstream/libgravatar-url-perl/current/lib/Gravatar/URL.pm (original)
+++ branches/upstream/libgravatar-url-perl/current/lib/Gravatar/URL.pm Sat Mar 12 17:27:03 2011
@@ -7,7 +7,7 @@
use Digest::MD5 qw(md5_hex);
use Carp;
-our $VERSION = '1.02';
+our $VERSION = '1.03';
use parent 'Exporter';
our @EXPORT = qw(
@@ -15,8 +15,8 @@
gravatar_url
);
-my $Gravatar_Base = "http://www.gravatar.com/avatar/";
-
+my $Gravatar_Http_Base = "http://www.gravatar.com/avatar/";
+my $Gravatar_Https_Base = "https://secure.gravatar.com/avatar/";
=head1 NAME
@@ -85,9 +85,10 @@
Relative URLs will be relative to the base (ie. gravatar.com), not your web site.
Gravatar defines special values that you may use as a default to
-produce dynamic default images. These are "identicon", "monsterid" and
-"wavatar". "404" will cause the URL to return an HTTP 404 "Not Found"
-error instead. See L<http://en.gravatar.com/site/implement/url> for
+produce dynamic default images. These are "identicon", "monsterid",
+"wavatar" and "retro". "404" will cause the URL to return an HTTP 404 "Not Found"
+error instead whereas "mm" will display the same "mystery man" image for all
+missing people. See L<http://en.gravatar.com/site/implement/url> for
more info.
If omitted, Gravatar will serve up their default image, the blue G.
@@ -107,7 +108,8 @@
This is the URL of the location of the Gravatar server you wish to
grab Gravatars from. Defaults to
-L<http://www.gravatar.com/avatar/">.
+L<http://www.gravatar.com/avatar/"> for HTTP and
+L<https://secure.gravatar.com/avatar/> for HTTPS.
=head4 short_keys
@@ -116,11 +118,22 @@
short_keys defaults to true.
+=head4 https
+
+If true, serve avatars over HTTPS instead of HTTP.
+
+You should select this option if your site is served over HTTPS to
+avoid browser warnings about the presence of insecure content.
+
+https defaults to false.
+
=cut
my %defaults = (
short_keys => 1,
- base => $Gravatar_Base
+ base_http => $Gravatar_Http_Base,
+ base_https => $Gravatar_Https_Base,
+ https => 0,
);
sub gravatar_url {
@@ -179,8 +192,13 @@
my($hash, $defaults) = @_;
for my $key (keys %$defaults) {
+ next if 'base_http' eq $key or 'base_https' eq $key;
next if exists $hash->{$key};
$hash->{$key} = $defaults->{$key};
+ }
+
+ if (not exists $hash->{'base'}) {
+ $hash->{'base'} = $hash->{'https'} ? $defaults->{base_https} : $defaults->{base_http};
}
return;
@@ -210,11 +228,12 @@
=head1 LICENSE
Copyright 2007 - 2009, Michael G Schwern <schwern at pobox.com>.
+Copyright 2011, Francois Marier <fmarier at gmail.com>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
-See F<http://www.perl.com/perl/misc/Artistic.html>
+See F<http://dev.perl.org/licenses/artistic.html>
=head1 SEE ALSO
Added: branches/upstream/libgravatar-url-perl/current/lib/Libravatar/URL.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgravatar-url-perl/current/lib/Libravatar/URL.pm?rev=71278&op=file
==============================================================================
--- branches/upstream/libgravatar-url-perl/current/lib/Libravatar/URL.pm (added)
+++ branches/upstream/libgravatar-url-perl/current/lib/Libravatar/URL.pm Sat Mar 12 17:27:03 2011
@@ -1,0 +1,236 @@
+package Libravatar::URL;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.03';
+
+use Gravatar::URL qw(gravatar_url);
+
+use parent 'Exporter';
+our @EXPORT = qw(
+ libravatar_url
+);
+
+my $Libravatar_Http_Base = "http://cdn.libravatar.org/avatar";
+my $Libravatar_Https_Base = "https://seccdn.libravatar.org/avatar";
+
+=head1 NAME
+
+Libravatar::URL - Make URLs for Libravatars from an email address
+
+=head1 SYNOPSIS
+
+ use Libravatar::URL;
+
+ my $url = libravatar_url( email => 'larry at example.org' );
+
+=head1 DESCRIPTION
+
+See L<http://www.libravatar.org> for more information.
+
+=head1 Functions
+
+=head3 B<libravatar_url>
+
+ my $url = libravatar_url( email => $email, %options );
+
+Constructs a URL to fetch the Libravatar for the given $email address.
+
+C<%options> are optional. C<libravatar_url> will accept all the
+options of L<Gravatar::URL/gravatar_url> except for C<rating> and C<border>.
+
+The available options are...
+
+=head4 size
+
+Specifies the desired width and height of the avatar (they are square).
+
+Valid values are from 1 to 512 inclusive. Any size other than 80 may
+cause the original image to be downsampled using bicubic resampling
+before output.
+
+ size => 40, # 40 x 40 image
+
+=head4 default
+
+The url to use if the user has no avatar.
+
+ default => "http://www.example.org/nobody.jpg"
+
+Relative URLs will be relative to the base (ie. libravatar.org), not your web site.
+
+Libravatar defines special values that you may use as a default to
+produce dynamic default images. These are "identicon", "monsterid",
+"wavatar" and "retro". "404" will cause the URL to return an HTTP 404 "Not Found"
+error instead and "mm" will display the same "mystery man" image for everybody.
+See L<http://www.libravatar.org/api> for more info.
+
+If omitted, Libravatar will serve up their default image, the orange butterfly.
+
+=head4 base
+
+This is the URL of the location of the Libravatar server you wish to
+grab avatars from. Defaults to
+L<http://cdn.libravatar.org/avatar/> for HTTP and
+L<https://seccdn.libravatar.org/avatar/> for HTTPS.
+
+=head4 short_keys
+
+If true, use short key names when constructing the URL. "s" instead
+of "size", "d" instead of "default" and so on.
+
+short_keys defaults to true.
+
+=head4 https
+
+If true, serve avatars over HTTPS instead of HTTP.
+
+You should select this option if your site is served over HTTPS to
+avoid browser warnings about the presence of insecure content.
+
+https defaults to false.
+
+=cut
+
+my %defaults = (
+ short_keys => 1,
+);
+
+# Extra the domain component of an email address
+sub email_domain {
+ my ( $email ) = @_;
+ return undef unless $email;
+
+ if ( $email =~ m/@([^@]+)$/ ) {
+ return $1;
+ }
+ return undef;
+}
+
+# Return the right (target, port) pair from a list of SRV records
+sub srv_hostname {
+ my @records = @_;
+ return ( undef, undef ) unless scalar(@records) > 0;
+
+ if ( 1 == scalar(@records) ) {
+ my $rr = shift @records;
+ return ( $rr->target, $rr->port );
+ }
+
+ # Keep only the servers in the top priority
+ my @priority_records;
+ my $total_weight = 0;
+ my $top_priority = $records[0]->priority; # highest priority = lowest number
+
+ foreach my $rr (@records) {
+ if ( $rr->priority > $top_priority ) {
+ # ignore the record ($rr has lower priority)
+ next;
+ }
+ elsif ( $rr->priority < $top_priority ) {
+ # reset the array ($rr has higher priority)
+ $top_priority = $rr->priority;
+ $total_weight = 0;
+ @priority_records = ();
+ }
+
+ $total_weight += $rr->weight;
+
+ if ( $rr->weight > 0 ) {
+ push @priority_records, [ $total_weight, $rr ];
+ }
+ else {
+ # Zero-weigth elements must come first
+ unshift @priority_records, [ 0, $rr ];
+ }
+ }
+
+ if ( 1 == scalar(@priority_records) ) {
+ my $record = shift @priority_records;
+ my ( $weighted_index, $rr ) = @$record;
+ return ( $rr->target, $rr->port );
+ }
+
+ # Select first record according to RFC2782 weight ordering algorithm (page 3)
+ my $random_number = int(rand($total_weight + 1));
+
+ foreach my $record (@priority_records) {
+ my ( $weighted_index, $rr ) = @$record;
+
+ if ( $weighted_index >= $random_number ) {
+ return ( $rr->target, $rr->port );
+ }
+ }
+
+ die 'There is something wrong with our SRV weight ordering algorithm';
+}
+
+# Convert (target, port) to a full avatar base URL
+sub build_url {
+ my ( $target, $port, $https ) = @_;
+ return undef unless $target;
+
+ my $url = $https ? 'https' : 'http' . '://' . $target;
+ if ( $port && !$https && ($port != 80) or $port && $https && ($port != 443) ) {
+ $url .= ':' . $port;
+ }
+ $url .= '/avatar';
+
+ return $url;
+}
+
+sub federated_url {
+ my ( $email, $https ) = @_;
+ my $domain = email_domain($email);
+ return undef unless $domain;
+
+ require Net::DNS::Resolver;
+ my $fast_resolver = Net::DNS::Resolver->new(retry => 1, tcp_timeout => 1, udp_timeout => 1, dnssec => 1);
+ my $srv_prefix = $https ? '_avatars-sec' : '_avatars';
+ my $packet = $fast_resolver->query($srv_prefix . '._tcp.' . $domain, 'SRV');
+
+ if ( $packet and $packet->answer ) {
+ my ( $target, $port ) = srv_hostname($packet->answer);
+ return build_url($target, $port, $https);
+ }
+ return undef;
+}
+
+sub libravatar_url {
+ my %args = @_;
+ my $custom_base = defined $args{base};
+
+ $defaults{base_http} = $Libravatar_Http_Base;
+ $defaults{base_https} = $Libravatar_Https_Base;
+ Gravatar::URL::_apply_defaults(\%args, \%defaults);
+
+ if ( !$custom_base ) {
+ my $federated_url = federated_url($args{email}, $args{https});
+ if ( $federated_url ) {
+ $args{base} = $federated_url;
+ }
+ }
+
+ return gravatar_url(%args);
+}
+
+=head1 LICENSE
+
+Copyright 2011, Francois Marier <fmarier at gmail.com>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/artistic.html>
+
+
+=head1 SEE ALSO
+
+L<http://www.libravatar.org> - The Libravatar web site
+
+L<http://www.libravatar.org/api> - The Libravatar API documentation
+
+=cut
+
+1;
Modified: branches/upstream/libgravatar-url-perl/current/lib/Unicornify/URL.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgravatar-url-perl/current/lib/Unicornify/URL.pm?rev=71278&op=diff
==============================================================================
--- branches/upstream/libgravatar-url-perl/current/lib/Unicornify/URL.pm (original)
+++ branches/upstream/libgravatar-url-perl/current/lib/Unicornify/URL.pm Sat Mar 12 17:27:03 2011
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '1.02';
+our $VERSION = '1.03';
use Gravatar::URL qw(gravatar_url);
Added: branches/upstream/libgravatar-url-perl/current/t/libravatar.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgravatar-url-perl/current/t/libravatar.t?rev=71278&op=file
==============================================================================
--- branches/upstream/libgravatar-url-perl/current/t/libravatar.t (added)
+++ branches/upstream/libgravatar-url-perl/current/t/libravatar.t Sat Mar 12 17:27:03 2011
@@ -1,0 +1,148 @@
+#!/usr/bin/perl -w
+
+use Test::More;
+
+BEGIN { use_ok 'Net::DNS';
+ use_ok 'Libravatar::URL'; }
+
+{
+ my @domain_tests = (
+ ['',
+ undef,
+ ],
+
+ ['notanemail',
+ undef,
+ ],
+
+ ['larry at example.com',
+ 'example.com',
+ ],
+
+ ['larry at example.com@example.org',
+ 'example.org',
+ ],
+
+ ['@example.org',
+ 'example.org',
+ ],
+
+ ['larry@@example.com',
+ 'example.com',
+ ],
+ );
+
+ for my $test (@domain_tests) {
+ my ($email, $domain) = @$test;
+ is Libravatar::URL::email_domain($email), $domain;
+ }
+
+ my @url_tests = (
+ [undef, undef,
+ undef,
+ ],
+
+ ['example.com', undef,
+ 'http://example.com/avatar',
+ ],
+
+ ['example.com', 80,
+ 'http://example.com/avatar',
+ ],
+
+ ['example.com', 81,
+ 'http://example.com:81/avatar',
+ ],
+ );
+
+ for my $test (@url_tests) {
+ my ($target, $port, $url) = @$test;
+ is Libravatar::URL::build_url($target, $port), $url;
+ }
+
+ my @srv_tests = (
+ [[
+ ],
+ [undef, undef],
+ ],
+
+ [['_avatars._tcp.example.com. IN SRV 0 0 80 avatars.example.com',
+ ],
+ ['avatars.example.com', 80],
+ ],
+
+ [['_avatars._tcp.example.com. IN SRV 10 0 81 avatars2.example.com',
+ '_avatars._tcp.example.com. IN SRV 0 0 80 avatars.example.com',
+ ],
+ ['avatars.example.com', 80],
+ ],
+
+ [['_avatars._tcp.example.com. IN SRV 10 0 83 avatars4.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 0 82 avatars3.example.com',
+ '_avatars._tcp.example.com. IN SRV 1 0 81 avatars21.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 0 80 avatars.example.com',
+ ],
+ ['avatars21.example.com', 81],
+ ],
+
+ # The following ones are randomly selected which is why we
+ # have to initialize the random number to a canned value
+
+ # random_number = 49
+ [['_avatars._tcp.example.com. IN SRV 10 1 83 avatars4.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 5 82 avatars3.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 10 8100 avatars2.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 50 800 avatars1.example.com',
+ '_avatars._tcp.example.com. IN SRV 20 0 80 avatars.example.com',
+ ],
+ ['avatars1.example.com', 800],
+ ],
+
+ # random_number = 0
+ [['_avatars._tcp.example.com. IN SRV 10 1 83 avatars4.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 0 82 avatars3.example.com',
+ '_avatars._tcp.example.com. IN SRV 20 0 81 avatars2.example.com',
+ '_avatars._tcp.example.com. IN SRV 20 0 80 avatars.example.com',
+ ],
+ ['avatars3.example.com', 82],
+ ],
+
+ # random_number = 1
+ [['_avatars._tcp.example.com. IN SRV 10 0 83 avatars4.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 0 82 avatars3.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 10 601 avatars20.example.com',
+ '_avatars._tcp.example.com. IN SRV 20 0 80 avatars.example.com',
+ ],
+ ['avatars20.example.com', 601],
+ ],
+
+ # random_number = 40
+ [['_avatars._tcp.example.com. IN SRV 10 1 83 avatars4.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 5 82 avatars3.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 10 8100 avatars2.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 30 8 avatars10.example.com',
+ '_avatars._tcp.example.com. IN SRV 10 50 800 avatars1.example.com',
+ '_avatars._tcp.example.com. IN SRV 20 0 80 avatars.example.com',
+ ],
+ ['avatars10.example.com', 8],
+ ],
+ );
+
+ srand(42); # to make these tests predictable
+
+ for my $test (@srv_tests) {
+ my ($srv_strings, $pair) = @$test;
+
+ my @srv_records = ();
+ for $str (@$srv_strings) {
+ my $record = Net::DNS::RR->new($str);
+ push @srv_records, $record;
+ }
+
+ my @result = Libravatar::URL::srv_hostname(@srv_records);
+ is_deeply \@result, $pair;
+ }
+
+ $test_count = @domain_tests + @url_tests + @srv_tests + 2;
+ done_testing($test_count);
+}
Propchange: branches/upstream/libgravatar-url-perl/current/t/libravatar.t
------------------------------------------------------------------------------
svn:executable = *
Modified: branches/upstream/libgravatar-url-perl/current/t/url.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgravatar-url-perl/current/t/url.t?rev=71278&op=diff
==============================================================================
--- branches/upstream/libgravatar-url-perl/current/t/url.t (original)
+++ branches/upstream/libgravatar-url-perl/current/t/url.t Sat Mar 12 17:27:03 2011
@@ -2,12 +2,30 @@
use Test::More 'no_plan';
-BEGIN { use_ok 'Gravatar::URL'; }
+BEGIN { use_ok 'Gravatar::URL';
+ use_ok 'Libravatar::URL'; }
-{
+my %interfaces = (
+ libravatar => {
+ func => \&libravatar_url,
+ base => 'http://cdn.libravatar.org/avatar',
+ https_base => 'https://seccdn.libravatar.org/avatar',
+ },
+ gravatar => {
+ func => \&gravatar_url,
+ base => 'http://www.gravatar.com/avatar',
+ https_base => 'https://secure.gravatar.com/avatar',
+ },
+);
+
+for my $interface_name (keys %interfaces) {
+ my $interface = $interfaces{$interface_name};
+ my $base = $interface->{base};
+ my $https_base = $interface->{https_base};
+ my $func = $interface->{func};
+
my $id = 'a60fc0828e808b9a6a9d50f1792240c8';
my $email = 'whatever at wherever.whichever';
- my $base = 'http://www.gravatar.com/avatar';
my @tests = (
[{ email => $email },
@@ -19,7 +37,26 @@
],
[{ email => $email,
+ https => 1
+ },
+ "$https_base/$id",
+ ],
+
+ [{ email => $email,
+ https => 0
+ },
+ "$base/$id",
+ ],
+
+ [{ email => $email,
base => 'http://example.com/gravatar'
+ },
+ "http://example.com/gravatar/$id",
+ ],
+
+ [{ email => $email,
+ base => 'http://example.com/gravatar',
+ https => 1
},
"http://example.com/gravatar/$id",
],
@@ -87,7 +124,7 @@
);
# Add tests for the special defaults.
- for my $special ("identicon", "monsterid", "wavatar") {
+ for my $special ("identicon", "mm", "monsterid", "retro", "wavatar") {
my $test = [{ default => $special,
email => $email,
},
@@ -98,7 +135,6 @@
for my $test (@tests) {
my($args, $url) = @$test;
- is gravatar_url( %$args ), $url, join ", ", keys %$args;
+ is &$func( %$args ), $url, join ", ", keys %$args;
}
}
-
More information about the Pkg-perl-cvs-commits
mailing list