# $Id: URI.pm 2481 2008-01-06 20:29:50Z comdog $
package Test::URI;
use strict;
use base qw(Exporter);
use vars qw(@EXPORT $VERSION);
use URI;
use Exporter;
use Test::Builder;
my $Test = Test::Builder->new();
@EXPORT = qw(uri_scheme_ok uri_host_ok uri_port_ok uri_fragment_ok
uri_path_ok);
$VERSION = 1.08;
=head1 NAME
Test::URI - Check Uniform Resource Identifiers
=head1 SYNOPSIS
use Test::More tests => 5;
use Test::URI;
# http://www.example.com:8080/index.html#name
uri_scheme_ok( $uri, 'http' );
uri_host_ok( $uri, 'www.example.com' );
uri_port_ok( $uri, '8080' );
uri_path_ok( $uri, '/index.html' );
uri_fragment_ok( $uri, 'name' );
=head1 DESCRIPTION
Check various parts of Uniform Resource Locators
=head1 FUNCTIONS
=over 4
=item uri_scheme_ok( STRING|URI, SCHEME )
Ok is the STRING is a valid URI, in any format that
URI accepts, and the URI uses the same SCHEME (i.e.
protocol: http, ftp, ...). SCHEME is not case
sensitive.
STRING can be an URI object.
=cut
sub uri_scheme_ok($$)
{
my $string = shift;
my $scheme = lc shift;
my $uri = ref $string ? $string : URI->new( $string );
unless( UNIVERSAL::isa( $uri, 'URI' ) )
{
$Test->ok(0);
$Test->diag("URI [$string] does not appear to be valid");
}
elsif( $uri->scheme ne $scheme )
{
$Test->ok(0);
$Test->diag("URI [$string] does not have the right scheme\n",
"\tExpected [$scheme]\n",
"\tGot [" . $uri->scheme . "]\n",
);
}
else
{
$Test->ok(1);
}
}
=item uri_host_ok( STRING|URI, HOST )
Ok is the STRING is a valid URI, in any format that
URI accepts, and the URI uses the same HOST. HOST
is not case sensitive.
Not Ok is the URI scheme does not have a host portion.
STRING can be an URI object.
=cut
sub uri_host_ok($$)
{
_methodx_ok( $_[0], $_[1], 'host' );
}
=item uri_port_ok( STRING|URI, PORT )
Ok is the STRING is a valid URI, in any format that
URI accepts, and the URI uses the same PORT.
Not Ok is the URI scheme does not have a port portion.
STRING can be an URI object.
=cut
my %Portless = map { $_, $_ } qw(mailto file);
sub uri_port_ok($$)
{
_methodx_ok( $_[0], $_[1], 'port' );
}
=item uri_canonical_ok
UNIMPLEMENTED. I'm not sure why I thought this should be a test.
If anyone else knows, I'll implement it.
=cut
sub uri_canonical_ok($$)
{
}
=item uri_path_ok( STRING|URI, PATH )
Ok is the STRING is a valid URI, in any format that
URI accepts, and the URI has the path PATH. Remember
that paths start with a /, even if it doesn't look
like there is anything after the host parts.
STRING can be an URI object.
=cut
sub uri_path_ok($$)
{
_methodx_ok( $_[0], $_[1], 'path' );
}
=item uri_fragment_ok( STRING|URI, FRAGMENT )
Ok is the STRING is a valid URI, in any format that
URI accepts, and the URI has the fragment FRAGMENT.
STRING can be an URI object.
=cut
sub uri_fragment_ok($$)
{
_methodx_ok( $_[0], $_[1], 'fragment' );
}
sub _methodx_ok($$$)
{
my $string = shift;
my $expected = shift;
my $methodx = lc shift;
my $uri = ref $string ? $string : URI->new( $string );
unless( UNIVERSAL::isa( $uri, 'URI' ) )
{
$Test->ok(0);
$Test->diag("URI [$string] does not appear to be valid");
}
elsif( not $uri->can( $methodx ) )
{
$Test->ok(0);
my $scheme = $uri->scheme;
$Test->diag("$scheme schemes do not have a $methodx");
}
elsif( $uri->$methodx ne $expected )
{
$Test->ok(0);
$Test->diag("URI [$string] does not have the right fragment\n",
"\tExpected [$expected]\n",
"\tGot [" . $uri->$methodx . "]\n",
);
}
else
{
$Test->ok(1);
}
}
sub _same_thing_exactly { $_[0] eq $_[1] }
sub _same_thing_caseless { _same_think_exactly( map { lc } @_ ) }
=back
=head1 TO DO
* add methods: uri_canonical_ok, uri_query_string_ok
=head1 SOURCE AVAILABILITY
This source is part of a SourceForge project which always has the
latest sources in CVS, as well as all of the previous releases.
http://sourceforge.net/projects/brian-d-foy/
If, for some reason, I disappear from the world, one of the other
members of the project can shepherd this module appropriately.
=head1 AUTHOR
brian d foy, C<< <bdfoy@cpan.org> >>
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2004-2007 brian d foy. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;