view release on metacpan or  search on metacpan

lib/Apache/Clickable.pm  view on Meta::CPAN

package Apache::Clickable;

use strict;
use vars qw($VERSION);
$VERSION = 0.02;

use Apache::Constants qw(:common);
use Apache::File;
use Carp ();

sub handler {
    my $r = shift;

    my $filtered = uc($r->dir_config('Filter')) eq 'ON';
    $r = $r->filter_register if $filtered;

    # only for text/html
    return DECLINED unless ($r->content_type eq 'text/html' && $r->is_main);

    my($fh, $status);
    if ($filtered) {
	($fh, $status) = $r->filter_input;
	undef $fh unless $status == OK;
    } else {
	$fh = Apache::File->new($r->filename);
    }

    return DECLINED unless $fh;

    $r->send_http_header;

    local $/;			# slurp
    my $input = <$fh>;
    my $output = make_it_clickable($r, $input);
    $r->print($output);
    return OK;
}

sub make_it_clickable {
    my($r, $input) = @_;
    my $parser = Apache::Clickable::Parser->new(apr => $r);
    $parser->parse($input);
    return $parser->{output};
}

package Apache::Clickable::Parser;

require HTML::Parser;
@Apache::Clickable::Parser::ISA = qw(HTML::Parser);

use Email::Find 0.04;
use URI::Find;

sub new {
    my($class, %args) = @_;

    my $self = $class->SUPER::new;
    $self->{apr} = $args{apr};
    $self->{currently_in_a} = 0;
    return $self;
}

sub comment {
    my($self, $comment) = @_;
    $self->{output} .= "<!--$comment-->";
}

sub declaration {
    my($self, $declaration) = @_;
    $self->{output} .= "<!$declaration>";
}

sub start {
    my($self, $tag, $attr, $attrseq, $origtext) = @_;
    if ($tag eq 'a') {
	$self->{currently_in_a}++;
    }
    $self->{output} .= $origtext;
}

sub end {
    my($self, $tag, $origtext) = @_;
    if ($tag eq 'a') {
	$self->{currently_in_a}--;
    }
    $self->{output} .= $origtext;
}

sub text {
    my($self, $origtext) = @_;
    if ($self->{currently_in_a}) {
	$self->{output} .= $origtext;
	return;
    }

    $self->{output} .= $self->replace_sub->($origtext);
}

my $sub;			# closure
sub replace_sub {
    my $self = shift;
    unless ($sub) {
	$sub = sub {
	    my $input = shift;
	    # replace URLs
	    my $target = $self->{apr}->dir_config('ClickableTarget') || undef;
	    find_uris($input, sub {
			  my($uri, $orig_uri) = @_;
			  return sprintf(qq(<a href="%s"%s>%s</a>),
					 $orig_uri,
					 ($target ? qq( target="$target") : ''),
					 $orig_uri);
		      });

	    # replace Emails
	    unless (uc($self->{apr}->dir_config('ClickableEmail')) eq 'OFF') {
		find_emails($input, sub {