Gravatar-URL-1.06000755000765000765 011734325764 14202 5ustar00schwernschwern000000000000Gravatar-URL-1.06/Build.PL000555000765000765 172711734325764 15645 0ustar00schwernschwern000000000000#!/usr/bin/perl -w use 5.006; use strict; use Module::Build; my $builder = Module::Build->new( module_name => 'Gravatar::URL', license => 'perl', meta_merge => { resources => { bugtracker => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Gravatar-URL', repository => 'http://github.com/schwern/gravatar-url/tree/master', }, keywords => [ 'Gravatar' ], configure_requires => { 'Module::Build' => 0.2808 }, }, build_requires => { 'Test::More' => 0.40, 'Test::Warn' => 0.11, }, requires => { 'Net::DNS::Resolver' => 0, 'URI::Escape' => 0, 'Digest::MD5' => 0, 'Digest::SHA' => 0, 'Carp' => 0, perl => '5.6.0', 'parent' => 0, }, ); $builder->create_build_script(); Gravatar-URL-1.06/Changes000444000765000765 416311734325764 15636 0ustar00schwernschwern0000000000001.06 Tue Mar 27 12:55:30 BST 2012 Bug fixes * Fixed some undef warnings during sanitization. Test fixes * Adapt to changes in Carp 1.25 [rt.cpan.org 75523] 1.05 Wed Jul 6 22:40:06 NZST 2011 Security fix * Sanitize DNS results in Libravatar::URL 1.04 Tue Mar 29 17:47:34 NZDT 2011 New features * Added OpenID support in Libravatar::URL 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!!! http://unicornify.appspot.com/whats-this Incompatible Changes * short_keys is now the default, as per Gravatar protocol documentation Protocol Updates * Document that Gravatar has a new default option, 404. 1.01 Thu Apr 9 13:11:32 PDT 2009 Protocol Updates (The Gravatar protocol changed, so we're changing with it) * Gravatar expanded the max size to 512. [rt.cpan.org 41244] (CHISEL) * Base URL changed to http://www.gravatar.com/avatar/ * Ratings are now lower cased. Upper cased ratings still accepted, but will be lower cased. * Using new http://base/id?key=value style. * The border key has been removed from the protocol, so its use throws a deprecation warning. New Features * The short_keys flag uses short keys in the URL ("s" instead of "size", for example). 1.00 Sun Apr 27 14:12:24 PDT 2008 Bug Fixes * Gravatar IDs are insensitive to the case of the email address. Doc Fixes * Clarified how relative default URLs will be handled Dist Fixes * Added a configure_requires on Module::Build and a requires on perl 5.6. 0.01 Sat Sep 8 00:59:04 PDT 2007 First release, stealing liberally from Template::Plugin::Gravatar Gravatar-URL-1.06/MANIFEST000444000765000765 37711734325764 15457 0ustar00schwernschwern000000000000Build.PL Changes lib/Gravatar/URL.pm lib/Libravatar/URL.pm lib/Unicornify/URL.pm MANIFEST This list of files MANIFEST.SKIP META.json 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 Gravatar-URL-1.06/MANIFEST.SKIP000444000765000765 200111734325764 16226 0ustar00schwernschwern000000000000 #!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 \bSCCS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b \b_darcs\b \B\.cvsignore$ # Avoid VMS specific MakeMaker generated files \bDescrip.MMS$ \bDESCRIP.MMS$ \bdescrip.mms$ # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ \bBuild.bat$ \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.tmp$ \.# \.rej$ # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid Devel::Cover and Devel::CoverX::Covered files. \bcover_db\b \bcovered\b # Avoid MYMETA files ^MYMETA\. #!end included /Users/schwern/perl5/perlbrew/perls/perl-v5.12.2/lib/5.12.2/ExtUtils/MANIFEST.SKIP Gravatar-URL-1.06/META.json000444000765000765 321711734325764 15763 0ustar00schwernschwern000000000000{ "abstract" : "Make URLs for Gravatars from an email address", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.112621", "keywords" : [ "Gravatar" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Gravatar-URL", "prereqs" : { "build" : { "requires" : { "Test::More" : "0.4", "Test::Warn" : "0.11" } }, "configure" : { "requires" : { "Module::Build" : "0.2808" } }, "runtime" : { "requires" : { "Carp" : 0, "Digest::MD5" : 0, "Digest::SHA" : 0, "Net::DNS::Resolver" : 0, "URI::Escape" : 0, "parent" : 0, "perl" : "v5.6.0" } } }, "provides" : { "Gravatar::URL" : { "file" : "lib/Gravatar/URL.pm", "version" : "1.06" }, "Libravatar::URL" : { "file" : "lib/Libravatar/URL.pm", "version" : "1.06" }, "Unicornify::URL" : { "file" : "lib/Unicornify/URL.pm", "version" : "1.06" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Gravatar-URL" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/schwern/gravatar-url/tree/master" } }, "version" : "1.06" } Gravatar-URL-1.06/META.yml000444000765000765 170711734325764 15615 0ustar00schwernschwern000000000000--- abstract: 'Make URLs for Gravatars from an email address' author: - unknown build_requires: Test::More: 0.4 Test::Warn: 0.11 configure_requires: Module::Build: 0.2808 dynamic_config: 1 generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.112621' keywords: - Gravatar 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.06 Libravatar::URL: file: lib/Libravatar/URL.pm version: 1.06 Unicornify::URL: file: lib/Unicornify/URL.pm version: 1.06 requires: Carp: 0 Digest::MD5: 0 Digest::SHA: 0 Net::DNS::Resolver: 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.06 Gravatar-URL-1.06/SIGNATURE000644000765000765 311411734325764 15624 0ustar00schwernschwern000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.68. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 7167d0e20bd720b44dd6537748b258de132d4931 Build.PL SHA1 bd75123c13e28ada7281b6c9cce9ded20f06b56b Changes SHA1 60a6b73a12bd5d7cb88bc589aadbd9590421e0b2 MANIFEST SHA1 8ca6e2e38708e91e4bd249dc854520a142c3cafe MANIFEST.SKIP SHA1 42bff277d510bd5f2759b318afa6773048382f2a META.json SHA1 95859b05f633a09e377d0f1f3631a3173ea1dece META.yml SHA1 9656b7f3e34510e84f9e10d9d640459dea9e88cc lib/Gravatar/URL.pm SHA1 e1317787c350c56d78f1fed629b7496067a4e9ac lib/Libravatar/URL.pm SHA1 42e2aaca70e7c05e79a474783bb4fbf036bf4c17 lib/Unicornify/URL.pm SHA1 02f21c26f52380259046ea05ae9d560b8a5c5072 t/deprecated.t SHA1 8d1cd74b2e6625fdd68062ed6fb9935eded6cdd4 t/error.t SHA1 3b4f3259bb95a336b73ecd2c06bf96dd30637a0a t/id.t SHA1 c1f9d8c33601bda1bc92ca23c1904e62efb36ed2 t/libravatar.t SHA1 7bdb7b0b2b440eaade3bb2a968c4919c7c2d4666 t/unicornify.t SHA1 1b8f6257f03be54ba3e0d39973b3ff0113785afa t/url.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v2.0.18 (Darwin) iEYEARECAAYFAk9xq/QACgkQWMohlhD1Qye04gCgsiVO+Tqr87Iwc9lbT/cl2JJS WMMAn2Tj4Xl5AMEJp+O35/u+bkq4Zq1u =CXG6 -----END PGP SIGNATURE----- Gravatar-URL-1.06/lib000755000765000765 011734325764 14750 5ustar00schwernschwern000000000000Gravatar-URL-1.06/lib/Gravatar000755000765000765 011734325764 16517 5ustar00schwernschwern000000000000Gravatar-URL-1.06/lib/Gravatar/URL.pm000444000765000765 1464211734325764 17703 0ustar00schwernschwern000000000000package Gravatar::URL; use strict; use warnings; use URI::Escape qw(uri_escape); use Digest::MD5 qw(md5_hex); use Carp; our $VERSION = '1.06'; use parent 'Exporter'; our @EXPORT = qw( gravatar_id gravatar_url ); my $Gravatar_Http_Base = "http://www.gravatar.com/avatar/"; my $Gravatar_Https_Base = "https://secure.gravatar.com/avatar/"; =head1 NAME Gravatar::URL - Make URLs for Gravatars from an email address =head1 SYNOPSIS use Gravatar::URL; my $gravatar_id = gravatar_id($email); my $gravatar_url = gravatar_url(email => $email); =head1 DESCRIPTION A Gravatar is a Globally Recognized Avatar for a given email address. This allows you to have a global picture associated with your email address. You can look up the Gravatar for any email address by constructing a URL to get the image from L. This module does that. Examples of use include the author faces on L. See L for more info. =head1 Functions =head3 B # By email my $url = gravatar_url( email => $email, %options ); # By gravatar ID my $url = gravatar_url( id => $id, %options ); Constructs a URL to fetch the gravatar for a given C<$email> or C<$id>. C<$id> is a gravatar ID. See L for more information. C<%options> are optional and are... =head4 rating A user can rate how offensive the content of their gravatar is, like a movie. The ratings are g, pg, r and x. If you specify a rating it is the highest rating that will be given. rating => "r" # includes g, pg and r =head4 size Specifies the desired width and height of the gravatar (gravatars are square). Valid values are from 1 to 512 inclusive. Any size other than 80 may cause the original gravatar 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 gravatar or has none that fits your rating requirements. default => "https://secure.wikimedia.org/wikipedia/en/wiki/File:Mad30.jpg" 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", "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 for more info. If omitted, Gravatar will serve up their default image, the blue G. =head4 border B This key has been removed from the Gravatar protocol. It will be removed from future versions of Gravatar::URL. Gravatars can be requested to have a 1 pixel colored border. If you'd like that, pass in the color to border as a 3 or 6 digit hex string. border => "000000", # a black border, like my soul border => "000", # black, but in 3 digits =head4 base This is the URL of the location of the Gravatar server you wish to grab Gravatars from. Defaults to L for HTTP and L for HTTPS. =head4 short_keys If true, use short key names when constructing the URL. "s" instead of "size", "r" instead of "ratings" 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, base_http => $Gravatar_Http_Base, base_https => $Gravatar_Https_Base, https => 0, ); sub gravatar_url { my %args = @_; exists $args{id} or exists $args{email} or croak "Cannot generate a Gravatar URI without an email address or gravatar id"; exists $args{id} xor exists $args{email} or croak "Both an id and an email were given. gravatar_url() only takes one"; _apply_defaults(\%args, \%defaults); if ( exists $args{size} ) { $args{size} >= 1 and $args{size} <= 512 or croak "Gravatar size must be 1 .. 512"; } if ( exists $args{rating} ) { $args{rating} =~ /\A(?:g|pg|r|x)\Z/i or croak "Gravatar rating can only be g, pg, r, or x"; $args{rating} = lc $args{rating}; } if ( exists $args{border} ) { carp "The border key is deprecated"; $args{border} =~ /\A[0-9A-F]{3}(?:[0-9A-F]{3})?\Z/ or croak "Border must be a 3 or 6 digit hex number in caps"; } $args{gravatar_id} = $args{id} || gravatar_id($args{email}); $args{default} = uri_escape($args{default}) if $args{default}; # Use a fixed order to make testing easier my @pairs; for my $arg ( qw( rating size default border ) ) { next unless exists $args{$arg}; my $key = $arg; $key = substr($key, 0, 1) if $args{short_keys}; push @pairs, join("=", $key, $args{$arg}); } my $uri = $args{base}; $uri .= "/" unless $uri =~ m{/$}; $uri .= $args{gravatar_id}; $uri .= "?".join("&",@pairs) if @pairs; return $uri; } sub _apply_defaults { 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; } =head3 B my $id = gravatar_id($email); Converts an C<$email> address into its Gravatar C<$id>. =cut sub gravatar_id { my $email = shift; return md5_hex(lc $email); } =head1 THANKS Thanks to L for coming up with the whole idea and Ashley Pond V from whose L I took most of the original code. =head1 LICENSE Copyright 2007 - 2009, Michael G Schwern . Copyright 2011, Francois Marier . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =head1 SEE ALSO L - a Gravatar plugin for Template Toolkit L - The Gravatar web site L - The Gravatar URL implementor's guide =cut 1; Gravatar-URL-1.06/lib/Libravatar000755000765000765 011734325764 17037 5ustar00schwernschwern000000000000Gravatar-URL-1.06/lib/Libravatar/URL.pm000444000765000765 1731011734325764 20216 0ustar00schwernschwern000000000000package Libravatar::URL; use strict; use warnings; use Gravatar::URL qw(gravatar_url); use Digest::SHA qw(sha256_hex); use Carp; our $VERSION = '1.06'; 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@example.org' ); =head1 DESCRIPTION See L for more information. =head1 Functions =head3 B # By email my $url = libravatar_url( email => $email, %options ); # By OpenID my $url = libravatar_url( openid => $openid, %options ); Constructs a URL to fetch the Libravatar for the given $email address or $openid URL. C<%options> are optional. C will accept all the options of L except for C and C. 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 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 for HTTP and L 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, ); # Extract the domain component of an email address sub email_domain { my ( $email ) = @_; return undef unless $email; if ( $email =~ m/@([^@]+)$/ ) { return $1; } return undef; } # Extract the domain component of an OpenID URI sub openid_domain { my ( $openid ) = @_; return undef unless $openid; if ( $openid =~ m@^(http|https)://([^/]+)@i ) { return $2; } 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 sanitize_target { my ( $target, $port ) = @_; unless ( defined $target && $target =~ m/^[0-9a-zA-Z\-.]+$/ ) { return ( undef, undef ); } unless ( defined $port && $port =~ m/^[0-9]{1,5}$/ ) { return ( undef, undef ); } return ( $target, $port ) } sub federated_url { my %args = @_; my $domain; if ( exists $args{email} ) { $domain = email_domain($args{email}); } elsif ( exists $args{openid} ) { $domain = openid_domain($args{openid}); } 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 = $args{https} ? '_avatars-sec' : '_avatars'; my $packet = $fast_resolver->query($srv_prefix . '._tcp.' . $domain, 'SRV'); if ( $packet and $packet->answer ) { my ( $target, $port ) = sanitize_target(srv_hostname($packet->answer)); return build_url($target, $port, $args{https}); } return undef; } sub lowercase_openid { my $openid = shift; if ( $openid =~ m@^([^:]+://[^/]+)(.*)@ ) { $openid = (lc $1) . $2; } return $openid; } sub libravatar_url { my %args = @_; my $custom_base = defined $args{base}; exists $args{email} or exists $args{openid} or exists $args{id} or croak "Cannot generate a Libravatar URI without an email address, an OpenID or a gravatar id"; if ( exists $args{email} and (exists $args{openid} or exists $args{id}) or exists $args{openid} and (exists $args{email} or exists $args{id}) or exists $args{id} and (exists $args{email} or exists $args{openid}) ) { croak "Two or more identifiers (email, OpenID or gravatar id) were given. libravatar_url() only takes one"; } $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); if ( $federated_url ) { $args{base} = $federated_url; } } if ( exists $args{openid} ) { $args{id} = sha256_hex(lowercase_openid($args{openid})); undef $args{openid}; } return gravatar_url(%args); } =head1 LICENSE Copyright 2011, Francois Marier . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =head1 SEE ALSO L - The Libravatar web site L - The Libravatar API documentation =cut 1; Gravatar-URL-1.06/lib/Unicornify000755000765000765 011734325764 17075 5ustar00schwernschwern000000000000Gravatar-URL-1.06/lib/Unicornify/URL.pm000444000765000765 253411734325764 20236 0ustar00schwernschwern000000000000package Unicornify::URL; use strict; use warnings; our $VERSION = '1.06'; use Gravatar::URL qw(gravatar_url); use parent 'Exporter'; our @EXPORT = qw( unicornify_url ); my $Unicornify_Base = "http://unicornify.appspot.com/avatar/"; =head1 NAME Unicornify::URL - OMG UNICORN AVATAR! =head1 SYNOPSIS use Unicornify::URL; my $url = unicornify_url( email => 'larry@wall.org' ); =head1 DESCRIPTION Now you can have your very own generated Unicorn avatar! OMG! SQUEE! See L for more information. *heart* =head1 Functions =head3 B my $url = unicornify_url( email => $email, %options ); Constructs a URL to fetch the unicorn avatar for the given $email address. C<%options> are optional. C will accept all the options of L but as of this time only C has any effect. =head4 size Specifies the desired width and height of the avatar (they are square) in pixels. As of this writing, valid values are from 32 to 128. The default is 32. =head1 SEE ALSO L L "The Last Unicorn" =cut my %defaults = ( base => $Unicornify_Base, short_keys => 1, ); sub unicornify_url { my %args = @_; Gravatar::URL::_apply_defaults(\%args, \%defaults); return gravatar_url(%args); } "OMG! UNICORNS!"; Gravatar-URL-1.06/t000755000765000765 011734325764 14445 5ustar00schwernschwern000000000000Gravatar-URL-1.06/t/deprecated.t000444000765000765 76211734325764 17054 0ustar00schwernschwern000000000000#!/usr/bin/perl -w # Test that deprecated keys warn. use strict; use Test::More 'no_plan'; use Test::Warn; use Gravatar::URL; my $id = 'a60fc0828e808b9a6a9d50f1792240c8'; my $email = 'whatever@wherever.whichever'; my $base = 'http://www.gravatar.com/avatar'; warning_is { is gravatar_url( id => '12345', base => 'http://www.example.com/gravatar', border => "FFF" ), "http://www.example.com/gravatar/12345?b=FFF"; } {carped => "The border key is deprecated"}; Gravatar-URL-1.06/t/error.t000444000765000765 214711734325764 16124 0ustar00schwernschwern000000000000#!/usr/bin/perl -w # Test argument error handling. use strict; use Test::More 'no_plan'; BEGIN { use_ok 'Gravatar::URL' } my @tests = ( [ {}, "Cannot generate a Gravatar URI without an email address or gravatar id" ], [ { email => 'foo@bar.com', id => '12345' }, "Both an id and an email were given. gravatar_url() only takes one" ], [ { email => 'foo@bar.com', rating => 'Q' }, "Gravatar rating can only be g, pg, r, or x" ], [ { email => 'foo@bar.com', size => 0 }, "Gravatar size must be 1 .. 512" ], [ { email => 'foo@bar.com', size => 1 } ], [ { email => 'foo@bar.com', size => 512 } ], [ { email => 'foo@bar.com', size => 513 }, "Gravatar size must be 1 .. 512" ], ); for my $test (@tests) { my($args, $want) = @$test; eval { gravatar_url( %$args ) }; my $error = $@; $error =~ s/\.\n/\n/; $want = !$want ? "" : sprintf "%s at %s line %d\n", $want, $0, __LINE__ - 5; my $name = join ", ", map { "$_ => '$args->{$_}'" } keys %$args; is $error, $want, "gravatar_url($name)"; } Gravatar-URL-1.06/t/id.t000444000765000765 135111734325764 15363 0ustar00schwernschwern000000000000#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; BEGIN { use_ok "Gravatar::URL" } my %email2id = ( 'alfred@example.com' => '6ffc501bf3b215384ea3abd3b6026735', 'whatever@wherever.whichever' => 'a60fc0828e808b9a6a9d50f1792240c8', 'PHRED@cpan.org' => 'c18b1af66a7f62015ecc26707a1321b9', 'iHaveAn@email.com', => '3b3be63a4c2a439b013787725dfce802', ); for my $email (keys %email2id) { my $id = $email2id{$email}; is gravatar_id( $email ) => $id, "$email"; is gravatar_id( lc $email ) => $id, "lc $email"; is gravatar_id( uc $email ) => $id, "uc $email"; is gravatar_id( ucfirst $email ) => $id, "ucfirst $email"; } Gravatar-URL-1.06/t/libravatar.t000555000765000765 1430511734325764 17144 0ustar00schwernschwern000000000000#!/usr/bin/perl -w use Test::More; BEGIN { use_ok 'Net::DNS'; use_ok 'Libravatar::URL'; } { my @email_domain_tests = ( ['', undef, ], ['notanemail', undef, ], ['larry@example.com', 'example.com', ], ['larry@example.com@example.org', 'example.org', ], ['@example.org', 'example.org', ], ['larry@@example.com', 'example.com', ], ); for my $test (@email_domain_tests) { my ($email, $domain) = @$test; is Libravatar::URL::email_domain($email), $domain; } my @openid_domain_tests = ( ['', undef, ], ['notanopenid', undef, ], ['http://example.com', 'example.com', ], ['https://a.example.com', 'a.example.com', ], ['http://b.example.com/', 'b.example.com', ], ['http://example.org/id/larry', 'example.org', ], ['https://a.example.org/~larry/openid.html', 'a.example.org', ], ); for my $test (@openid_domain_tests) { my ($openid, $domain) = @$test; is Libravatar::URL::openid_domain($openid), $domain; } my @lowercase_openid = ( ['', '', ], ['notanopenid', 'notanopenid', ], ['http://Example.Com', 'http://example.com', ], ['HTTPS://a.example.com', 'https://a.example.com', ], ['http://b.eXample.com/', 'http://b.example.com/', ], ['http://example.ORG/ID/Larry', 'http://example.org/ID/Larry', ], ['Https://A.example.org/~Larry/OpenID.html', 'https://a.example.org/~Larry/OpenID.html', ], ); for my $test (@lowercase_openid) { my ($openid, $lc_openid) = @$test; is Libravatar::URL::lowercase_openid($openid), $lc_openid; } 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 @sanitization_tests = ( [undef, undef, [undef, undef], ], ['example.com', undef, [undef, undef], ], ['example.com', 80, ['example.com', 80], ], ['example.org', 81, ['example.org', 81], ], ); for my $test (@sanitization_tests) { my ($target, $port, $pair) = @$test; my @result = Libravatar::URL::sanitize_target($target, $port); is_deeply \@result, $pair; } 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 = @email_domain_tests + @openid_domain_tests + @lowercase_openid + @url_tests + @sanitization_tests + @srv_tests + 2; done_testing($test_count); } Gravatar-URL-1.06/t/unicornify.t000444000765000765 55311734325764 17137 0ustar00schwernschwern000000000000#!/usr/bin/perl use strict; use warnings; use Test::More tests => 2; use Unicornify::URL; is unicornify_url( email => 'yarrow@hock.com' ), 'http://unicornify.appspot.com/avatar/c5cf0e825e9757a09c43f08650f46a5f'; is unicornify_url( email => 'yarrow@hock.com', size => 128 ), 'http://unicornify.appspot.com/avatar/c5cf0e825e9757a09c43f08650f46a5f?s=128'; Gravatar-URL-1.06/t/url.t000555000765000765 660311734325764 15601 0ustar00schwernschwern000000000000#!/usr/bin/perl -w use Test::More 'no_plan'; 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@wherever.whichever'; my @tests = ( [{ email => $email }, "$base/$id", ], [{ id => $id }, "$base/$id", ], [{ 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", ], # Make sure we don't get a double slash after the base. [{ email => $email, base => 'http://example.com/gravatar/' }, "http://example.com/gravatar/$id", ], [{ default => "/local.png", email => $email }, "$base/$id?d=%2Flocal.png", ], [{ default => "/local.png", rating => 'X', email => $email, }, "$base/$id?r=x&d=%2Flocal.png", ], [{ default => "/local.png", email => $email, rating => 'R', size => 80 }, "$base/$id?r=r&s=80&d=%2Flocal.png" ], [{ default => "/local.png", rating => 'PG', size => 45, email => $email, }, "$base/$id?r=pg&s=45&d=%2Flocal.png" ], [{ default => "/local.png", rating => 'PG', size => 45, email => $email, }, "$base/$id?r=pg&s=45&d=%2Flocal.png" ], [{ default => "/local.png", rating => 'PG', size => 45, email => $email, short_keys => 1, }, "$base/$id?r=pg&s=45&d=%2Flocal.png" ], [{ default => "/local.png", rating => 'PG', size => 45, email => $email, short_keys => 0, }, "$base/$id?rating=pg&size=45&default=%2Flocal.png" ], ); # Add tests for the special defaults. for my $special ("identicon", "mm", "monsterid", "retro", "wavatar") { my $test = [{ default => $special, email => $email, }, "$base/$id?d=$special", ]; push @tests, $test; } for my $test (@tests) { my($args, $url) = @$test; is &$func( %$args ), $url, join ", ", keys %$args; } }