#============================================================= -*-perl-*-
#
# t/url.t
#
# Test the Badger::URL module.
#
# Run with -h option for help.
#
# Written by Andy Wardley <abw@wardley.org>.
#
# This is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
#========================================================================
use strict;
use warnings;
use lib qw( t/core/lib ./lib ../lib ../../lib );
use Badger::Test
debug => 'Badger::URL',
args => \@ARGV,
tests => 46;
use Badger::URL 'URL';
my $SCHEME = 'http';
my $USER = 'badger';
my $HOST = 'badgerpower.com';
my $PORT = 8080;
my $AUTHORITY = "$USER\@$HOST:$PORT";
my $PATH = '/over/there';
my $QUERY = 'animal=badger';
my $FRAGMENT = 'nose';
my $SERVER = "$SCHEME://$AUTHORITY";
my $SERVICE = "$SERVER$PATH";
my $REQUEST = "$SERVICE?$QUERY";
my $URL = "$REQUEST#$FRAGMENT";
my $url = URL->new($URL);
ok( $url, 'created a URL object' );
is( $url, $URL, 'returns source URL on stringification' );
$url = URL($URL);
ok( $url, 'created a URL object from constructor function' );
is( $url, $URL, 'also returns source URL on stringification' );
#------------------------------------------------------------------------
# test accessors to read various parts of the URL
#------------------------------------------------------------------------
is( $url->scheme, $SCHEME, "scheme is $SCHEME" );
is( $url->authority, $AUTHORITY,"authority is $AUTHORITY" );
is( $url->user, $USER, "user is $USER" );
is( $url->host, $HOST, "host is $HOST" );
is( $url->port, $PORT, "port is $PORT" );
is( $url->path, $PATH, "path is $PATH" );
is( $url->query, $QUERY, "query is $QUERY" );
is( $url->fragment, $FRAGMENT, "fragment is $FRAGMENT" );
is( $url->server, $SERVER, "server is $SERVER" );
is( $url->service, $SERVICE, "service is $SERVICE" );
is( $url->request, $REQUEST, "request is $REQUEST" );
my $params = $url->params;
ok( $params, 'got params' );
is( $params->{ animal }, 'badger', 'animal is a badger' );
my $copy = $url->copy;
ok( $copy, 'got a copy' );
$copy->params( friend => 'ferret', food => 'berries' );
is($copy, "$SERVICE?animal=badger&food=berries&friend=ferret#nose", 'new url with params' );
#------------------------------------------------------------------------
# now use same methods as mutators to change parts of the URL
#------------------------------------------------------------------------
$copy = $url->copy;
ok( $copy, 'got another copy' );
is( $copy->scheme('ftp'), 'ftp', 'set scheme to ftp' );
is( $copy, "ftp://$AUTHORITY$PATH?$QUERY#$FRAGMENT",
'changed scheme' );
is( $copy->user('ferret'), 'ferret', 'set user to ferret' );
is( $copy, "ftp://ferret\@$HOST:$PORT$PATH?$QUERY#$FRAGMENT",
'changed user' );
is( $copy->host('example.com'), 'example.com', 'set host to example.com' );
is( $copy, "ftp://ferret\@example.com:$PORT$PATH?$QUERY#$FRAGMENT",
'changed host' );
is( $copy->port(1234), 1234, 'set port to 1234' );
is( $copy, "ftp://ferret\@example.com:1234$PATH?$QUERY#$FRAGMENT",
'changed port' );
is( $copy->path('/right/here'), '/right/here', 'set path to /right/here' );
is( $copy, "ftp://ferret\@example.com:1234/right/here?$QUERY#$FRAGMENT",
'changed path' );
is( $copy->query('animal=ferret'), 'animal=ferret', 'set query to animal=ferret' );
is( $copy, "ftp://ferret\@example.com:1234/right/here?animal=ferret#$FRAGMENT",
'changed query' );
is( $copy->fragment('feet'), 'feet', 'set fragment to feet' );
is( $copy, "ftp://ferret\@example.com:1234/right/here?animal=ferret#feet",
'changed fragment' );
#-----------------------------------------------------------------------
# test relative URLs
#-----------------------------------------------------------------------
is( $url->relative('foo'),
"$SERVER/over/there/foo?$QUERY#$FRAGMENT",
'set relative path: foo'
);
is( $url->relative('/foo'),
"$SERVER/foo?$QUERY#$FRAGMENT",
'set relative path: /foo'
);
is( $url->absolute('bar'),
"$SERVER/bar?$QUERY#$FRAGMENT",
'set absolute path: bar'
);
is( $url->absolute('/bar'),
"$SERVER/bar?$QUERY#$FRAGMENT",
'set absolute path: /bar'
);
# original URL should not be changed
is( $url->url, $URL, 'url is unchanged' );
#-----------------------------------------------------------------------
# test constructor with separate elements
#-----------------------------------------------------------------------
$url = URL->new(
scheme => 'http',
user => 'Mr.T',
host => 'badgerpower.com',
port => '8081',
path => '/somewhere/else',
query => 'animal=badger',
fragment => 'stripe',
);
ok( $url, 'created url from params' );
is( $url->authority, 'Mr.T@badgerpower.com:8081', 'got params authority' );
is( $url->server, 'http://Mr.T@badgerpower.com:8081', 'got params server' );
is( $url->service, 'http://Mr.T@badgerpower.com:8081/somewhere/else', 'got params service' );
is( $url->request, 'http://Mr.T@badgerpower.com:8081/somewhere/else?animal=badger', 'got params request' );
$url = URL->new('http://badgerpower.com/');
$url->port('8080');
$url->path('/under/ground');
$url->query('animal=badger');
is($url, 'http://badgerpower.com:8080/under/ground?animal=badger', 'new url' );
$url->params( friend => 'ferret', food => 'berries' );
is($url, 'http://badgerpower.com:8080/under/ground?animal=badger&food=berries&friend=ferret', 'new url with params' );
__END__
# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4: