File Coverage

blib/lib/URL/Search.pm

Criterion	Covered	Total	%
statement	24	24	100.0
branch	2	4	50.0
condition			n/a
subroutine	6	6	100.0
pod	2	2	100.0
total	34	36	94.4

package URL::Search;
use strict;
use warnings;
use v5.10.0;  # recursive regex subgroups

use Exporter 5.57 qw(import);

our $VERSION = '0.06';

our @EXPORT_OK = qw(
    $URL_SEARCH_RE
    extract_urls
    partition_urls
);

our $URL_SEARCH_RE = do {
    my $general_unicode = qr{
        [^\p{ASCII}\p{Control}\p{Space}\p{Punct}]
    |
        [\x{2010}\x{2011}\x{2012}\x{2013}\x{2014}\x{2015}]
        # HYPHEN, NON-BREAKING HYPHEN,
        # FIGURE DASH, EN DASH, EM DASH, HORIZONTAL BAR
    }xms;

    my $protocol = qr{
        [Hh][Tt][Tt][Pp] [Ss]?
    }xms;

    my $unreserved_subdelims_colon = qr{
        [a-zA-Z0-9\-._~!\$&'()*+,;=:]
    }xms;

    my $pct_enc = qr{ % [[:xdigit:]]{2} }xms;

    my $userinfo = qr{
        $unreserved_subdelims_colon*
        (?: $pct_enc $unreserved_subdelims_colon* )*
    }xms;

    my $host = do {
        my $dec_octet = qr{
            25[0-5]
        |
            2[0-4][0-9]
        |
            1[0-9][0-9]
        |
            [1-9][0-9]
        |
            [0-9]
        }xms;

        my $ipv4_addr = qr{
            $dec_octet (?: \. $dec_octet ){3}
        }xms;

        my $h16 = qr{ [[:xdigit:]]{1,4} }xms;
        my $ls32 = qr{ $h16 : $h16 | $ipv4_addr }xms;

        my $ipv6_addr = qr{
                                             (?: $h16 : ){6} $ls32
        |
                                          :: (?: $h16 : ){5} $ls32
        |
            (?: $h16                   )? :: (?: $h16 : ){4} $ls32
        |
            (?: $h16 (?: : $h16 ){0,1} )? :: (?: $h16 : ){3} $ls32
        |
            (?: $h16 (?: : $h16 ){0,2} )? :: (?: $h16 : ){2} $ls32
        |
            (?: $h16 (?: : $h16 ){0,3} )? ::     $h16 :      $ls32
        |
            (?: $h16 (?: : $h16 ){0,4} )? ::                 $ls32
        |
            (?: $h16 (?: : $h16 ){0,5} )? ::                 $h16
        |
            (?: $h16 (?: : $h16 ){0,6} )? ::
        }xms;

        my $ipvfuture = qr{
            v [[:xdigit:]]+ \. $unreserved_subdelims_colon+
        }xms;

        my $ip_literal = qr{
            \[ (?: $ipv6_addr | $ipvfuture ) \]
        }xms;

        my $hostname = do {
            my $alnum = qr{
                [a-zA-Z0-9]
            |
                $general_unicode
            }xms;
            my $label = qr {
                $alnum+ (?: -+ $alnum+ )*
            }xms;
            qr{
                $label (?: \. $label )* \.?
            }xms
        };

        qr{
            $hostname
        |
            $ip_literal
        }xms
    };

    my $path = qr{
        /
        (
            (?:
                [a-zA-Z0-9\-._~!\$&'*+,;=:\@/]
            |
                $pct_enc
            |
                \( (?-1) \)
            |
                $general_unicode
            )*
        )
    }xms;

    my $query = qr{
        (
            (?:
                [a-zA-Z0-9\-._~!\$&'*+,;=:\@/?\\{}]
            |
                $pct_enc
            |
                \( (?-1) \)
            |
                \[ (?-1) \]
            |
                $general_unicode
            )*
        )
    }xms;

    my $fragment = $query;

    qr{
        $protocol ://
        (?: $userinfo \@ )?
        $host (?: : [0-9]+ )?
        $path?
        (?: \? $query )?
        (?: \# $fragment )?

        (?
    }xms
};

sub extract_urls {
    my ($text) = @_;
    my @urls;
    push @urls, $1 while $text =~ /($URL_SEARCH_RE)/g;
    @urls
}

sub partition_urls {
    my ($text) = @_;
    my @parts;
    my $pos_prev = 0;
    while ($text =~ /($URL_SEARCH_RE)/g) {
        push @parts, [TEXT => substr $text, $pos_prev, $-[0] - $pos_prev]
            if $pos_prev < $-[0];
        push @parts, [URL => $1];
        $pos_prev = $+[0];
    }
    push @parts, [TEXT => substr $text, $pos_prev]
        if $pos_prev < length $text;
    @parts
}

'ok'

__END__