File Coverage

blib/lib/Data/Transpose/Validator/URL.pm

Criterion	Covered	Total	%
statement	15	15	100.0
branch	2	2	100.0
condition			n/a
subroutine	4	4	100.0
pod	1	1	100.0
total	22	22	100.0

package Data::Transpose::Validator::URL;

use strict;
use warnings;
use base 'Data::Transpose::Validator::Base';

=head1 NAME

Data::Transpose::Validator::URL - Validate http(s) urls

=head1 SYNOPSIS

=cut


my $urlre = qr/(https?:\/\/)[\w\-\.]+\.(\w+) # domain
	       (:\d+)* # the port
	       (\/[\w:\.,;\?'\\\+&%\$\#=~\@!\-]+)*
	      /x;


=head2 is_valid($url)

Validate the url or set an error

=cut


sub is_valid {
    my ($self, $url) = @_;
    $self->reset_errors;
    if ($url =~ m/^($urlre)$/s) {
        return $1;
    } else {
        $self->error(
                     ["badurl",
                      "URL is not correct (the protocol is required)"]);
        return undef;
    }
}