URI::Find - Find URIs in arbitrary text

  require URI::Find;

  my $finder = URI::Find->new(\&callback);

  $how_many_found = $finder->find(\$text);

  my @uris;
  my $finder = URI::Find->new(sub {
      my($uri) = shift;
      push @uris, $uri;
  });
  $finder->find(\$text);

  my $finder = URI::Find->new(sub {
      my($uri, $orig_uri) = @_;
      print "The text '$orig_uri' represents '$uri'\n";
      return $orig_uri;
  });
  $finder->find(\$text);

  use LWP::Simple;

  my $finder = URI::Find->new(sub {
      my($uri, $orig_uri) = @_;
      if( head $uri ) {
          print "$orig_uri is okay\n";
      }
      else {
          print "$orig_uri cannot be found\n";
      }
      return $orig_uri;
  });
  $finder->find(\$text);

  use CGI qw(escapeHTML);
  use URI::Find;

  my $finder = URI::Find->new(sub {
      my($uri, $orig_uri) = @_;
      return qq|<a href="$uri">$orig_uri</a>|;
  });
  $finder->find(\$text, \&escapeHTML);
  print "<pre>$text</pre>";

# Copyright (c) 2000, 2009 Michael G. Schwern.  All rights reserved.
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.

package URI::Find;

require 5.006;

use strict;
use base qw(Exporter);
use vars qw($VERSION @EXPORT);

$VERSION        = 20100505;
@EXPORT         = qw(find_uris);

use constant YES => (1==1);
use constant NO  => !YES;

use Carp        qw(croak);
use URI::URL;

require URI;

# URI scheme pattern without the non-alpha numerics.
# Those are extremely uncommon and interfere with the match.
my($schemeRe) = qr/[a-zA-Z][a-zA-Z0-9]*/;
my($uricSet)  = $URI::uric;

# We need to avoid picking up 'HTTP::Request::Common' so we have a
# subset of uric without a colon ("I have no colon and yet I must poop")
my($uricCheat) = __PACKAGE__->uric_set;
$uricCheat =~ tr/://d;

# Identifying characters accidentally picked up with a URI.
my($cruftSet) = q{]),.'";}; #'#

sub new {
    @_ == 2 || __PACKAGE__->badinvo;
    my($proto, $callback) = @_;
    my($class) = ref $proto || $proto;
    my $self = bless {}, $class;

    $self->{callback} = $callback;

    return $self;
}

sub find {
    @_ == 2 || @_ == 3 || __PACKAGE__->badinvo;
    my($self, $r_text, $escape_func) = @_;

    # Might be slower, but it makes the code simpler
    $escape_func ||= sub { return $_[0] };

    $self->{_uris_found} = 0;

    # Don't assume http.
    my $old_strict = URI::URL::strict(1);

    # Yes, evil.  Basically, look for something vaguely resembling a URL,
    # then hand it off to URI::URL for examination.  If it passes, throw
    # it to a callback and put the result in its place.
    local $SIG{__DIE__} = 'DEFAULT';
    my $uri_cand;
    my $uri;

    my $uriRe = sprintf '(?:%s|%s)', $self->uri_re, $self->schemeless_uri_re;

    $$r_text =~ s{ (.*?) (?:(<(?:URL:)?)(.+?)(>)|($uriRe)) | (.+?)$ }{
                my $replace = '';
                if( defined $6 ) {
                        $replace = $escape_func->($6);
                }
                else {
                        my $maybe_uri = '';

                        $replace = $escape_func->($1);

                        if( defined $2 ) {
                                $maybe_uri = $3;
                                my $is_uri = do {  # Don't alter $1...
                                        $maybe_uri =~ s/\s+//g;
                                        $maybe_uri =~ /^$uriRe/;
                                };

                                if( $is_uri ) {
                                        $replace .= $escape_func->($2);
                                        $replace .= $self->_uri_filter($maybe_uri);
                                        $replace .= $escape_func->($4);
                                }
                                else {
                                        # the whole text inside of the <...> was not a url, but
                                        # maybe it has a url (like an HTML <a> link)
                                        my $has_uri = do { # Don't alter $1...
                                                $maybe_uri = $3;
                                                $maybe_uri =~ /$uriRe/;
                                        };
                                        if( $has_uri ) {
                                                my $pre = $2;
                                                my $post = $4;
                                                do { $self->find(\$maybe_uri, $escape_func) };
                                                $replace .= $escape_func->($pre);
                                                $replace .= $maybe_uri;
                                                $replace .= $escape_func->($post);
                                        }
                                        else {
                                                $replace .= $escape_func->($2.$3.$4);
                                        }
                                }
                        }
                        else {
                                $replace .= $self->_uri_filter($5);
                        }
                }

                $replace;
        }gsex;

    URI::URL::strict($old_strict);
    return $self->{_uris_found};
}


sub _uri_filter {
    my($self, $orig_match) = @_;

    # A heuristic.  Often you'll see things like:
    # "I saw this site, http://www.foo.com, and its really neat!"
    # or "Foo Industries (at http://www.foo.com)"
    # We want to avoid picking up the trailing paren, period or comma.
    # Of course, this might wreck a perfectly valid URI, more often than
    # not it corrects a parse mistake.
    $orig_match = $self->decruft($orig_match);

    my $replacement = '';
    if( my $uri = $self->_is_uri(\$orig_match) ) {
        # It's a URI
        $self->{_uris_found}++;
        $replacement = $self->{callback}->($uri, $orig_match);
    }
    else {
        # False alarm
        $replacement = $orig_match;
    }

    # Return recrufted replacement
    return $self->recruft($replacement);
}

sub uri_re {
    @_ == 1 || __PACKAGE__->badinvo;
    my($self) = shift;
    return sprintf '%s:[%s][%s#]*', $schemeRe,
                                    $uricCheat,
                                    $self->uric_set;
}

sub schemeless_uri_re {
    @_ == 1 || __PACKAGE__->badinvo;
    my($self) = shift;
    return qr/\b\B/; # match nothing
}

sub uric_set {
    @_ == 1 || __PACKAGE__->badinvo;
    return $uricSet;
}

sub cruft_set {
    @_ == 1 || __PACKAGE__->badinvo;
    return $cruftSet;
}

sub decruft {
    @_ == 2 || __PACKAGE__->badinvo;
    my($self, $orig_match) = @_;

    $self->{start_cruft} = '';
    $self->{end_cruft} = '';

    if( $orig_match =~ s/([\Q$cruftSet\E]+)$// ) {
        # urls can end with HTML entities if found in HTML so let's put back semicolons
        # if this looks like the case
        my $cruft = $1;
        if( $cruft =~ /^;/ && $orig_match =~ /\&(\#[1-9]\d{1,3}|[a-zA-Z]{2,8})$/) {
            $orig_match .= ';';
            $cruft =~ s/^;//;
        }

        $self->{end_cruft} = $cruft if $cruft;
    }

    return $orig_match;
}

#'#

sub recruft {
    @_ == 2 || __PACKAGE__->badinvo;
    my($self, $uri) = @_;

    return $self->{start_cruft} . $uri . $self->{end_cruft};
}

sub schemeless_to_schemed {
    @_ == 2 || __PACKAGE__->badinvo;
    my($self, $uri_cand) = @_;

    $uri_cand =~ s|^(<?)ftp\.|$1ftp://ftp\.|
        or $uri_cand =~ s|^(<?)|${1}http://|;

    return $uri_cand;
}

sub is_schemed {
    @_ == 2 || __PACKAGE__->badinvo;
    my($self, $uri) = @_;
    return scalar $uri =~ /^<?$schemeRe:/;
}

sub badinvo {
    my $package = shift;
    my $level   = @_ ? shift : 0;
    my $msg     = @_ ? " (" . shift() . ")" : '';
    my $subname = (caller $level + 1)[3];
    croak "Bogus invocation of $subname$msg";
}

# Old interface.
sub find_uris (\$&) {
    @_ == 2 || __PACKAGE__->badinvo;
    my($r_text, $callback) = @_;

    my $self = __PACKAGE__->new($callback);
    return $self->find($r_text);
}

sub _is_uri {
    @_ == 2 || __PACKAGE__->badinvo;
    my($self, $r_uri_cand) = @_;

    my $uri = $$r_uri_cand;

    # Translate schemeless to schemed if necessary.
    $uri = $self->schemeless_to_schemed($uri) if
      $uri =~ $self->schemeless_uri_re   and
      $uri !~ /^<?$schemeRe:/;

    eval {
        $uri = URI::URL->new($uri);
    };

    if($@ || !defined $uri) {   # leave everything untouched, its not a URI.
        return NO;
    }
    else {                      # Its a URI.
        return $uri;
    }
}

1;