File Coverage

blib/lib/HTML/StickyQuery.pm

Criterion	Covered	Total	%
statement	101	109	92.6
branch	35	42	83.3
condition	8	9	88.8
subroutine	14	15	93.3
pod	8	10	80.0
total	166	185	89.7

package HTML::StickyQuery;
# $Id: StickyQuery.pm,v 1.10 2003/10/08 09:46:55 ikebe Exp $
use strict;
use parent qw(HTML::Parser);
use URI;
use vars qw($VERSION);

$VERSION = '0.13';

sub new {
    my $class = shift;
    _croak("odd number of " . __PACKAGE__ . "->new arguments") if @_ % 2;
    my %args = @_;
    my $self = bless {
	keep_original => 1,
	abs => 0,
	regexp => undef,
    }, $class;
    foreach my $key(qw(keep_original abs regexp)) {
	$self->{$key} = $args{$key} if exists $args{$key};
    }
    # backward compat
    $self->{keep_original} = !$args{override} if $args{override};
    $self->SUPER::init;
    $self->boolean_attribute_value('__BOOLEAN__');
    $self;
}

sub sticky {
    my $self = shift;
    my %args = @_;
    if (ref $args{param} eq 'HASH') {
	$self->{param} = $args{param}
    }
    elsif ($args{param}->can("param")) {
	my %data = ();
	for my $key($args{param}->param) {
	    my @val = $args{param}->param($key);
	    $data{$key} = scalar(@val) > 1 ? \@val : $val[0];
	}
	$self->{param} = \%data;
    }

    if ($args{sticky_keys}) {
	my %sticky = map { $_ => 1 } @{$args{sticky_keys}};
	my %new;
	while (my($k, $v) = each %{$self->{param}}) {
	    $new{$k} = $v if $sticky{$k}
	}
	$self->{param} = \%new;
    }

    $self->{output} = "";
    if ($args{file}) {
	$self->parse_file($args{file});
    }
    elsif ($args{scalarref}) {
	$self->parse(${$args{scalarref}});
    }
    elsif ($args{arrayref}) {
	foreach my $line(@{$args{arrayref}}) {
	    $self->parse($line);
	}
    }
    return $self->{output};
}

sub output {
    my $self = shift;
    return $self->{output};
}

sub start {
    my ($self, $tagname, $attr, $attrseq, $orig) = @_;
    if ($tagname ne 'a') {
	$self->{output} .= $orig;
	return;
    }
    else {
	unless(exists $attr->{href}) {
	    $self->{output} .= $orig;
	    return;
	}
	my $u = URI->new($attr->{href});

	# skip absolute URI
	if (!$self->{abs} && $u->scheme) {
	    $self->{output} .= $orig;
	    return;
	}
	# when URI has other scheme (ie. mailto ftp ..)
	if(defined($u->scheme) && $u->scheme !~ m/^https?/) {
	    $self->{output} .= $orig;
	    return;
	}
	else {
	    if (!$self->{regexp} || $u->path =~ m/$self->{regexp}/) {
		if ($self->{keep_original}) {
		    my %original;
		    my @original = $u->query_form;
		    while (my ($key, $val) = splice(@original, 0, 2)) {
			if (exists $original{$key}) {
			    if (ref $original{$key} eq 'ARRAY') {
				push @{$original{$key}}, $val;
			    }
			    else {
				$original{$key} = [ $original{$key}, $val ];
			    }
			}
			else {
			    $original{$key} = $val;
			}
		    }
		    my %merged = (%original, %{$self->{param}});
		    $u->query_form(%merged);
		}
		else {
		    $u->query_form(%{$self->{param}});
		}
		$self->{output} .= qq{<$tagname};
		# save attr order.
		foreach my $key(@$attrseq) {
		    if ($key eq "href"){
			$self->{output} .= sprintf(qq{ href="%s"},
						   $self->escapeHTML($u->as_string));
		    }
		    elsif ($attr->{$key} eq '__BOOLEAN__') {
			$self->{output} .= " $key";
		    }
		    else {
			$self->{output} .= sprintf(qq{ $key="%s"},
						   $self->escapeHTML($attr->{$key}));
		    }
		}
		$self->{output} .= '>';
		return;
	    }
	    $self->{output} .= $orig;
	}
    }
}

sub process {
    my($self, $text, $orig) = @_;
    $self->{output} .= $orig;
}

sub end {
    my ($self, $tagname, $orig) = @_;
    $self->{output} .= $orig;
}

sub text {
    my ($self, $orig) = @_;
    $self->{output} .= $orig;
}

sub comment {
    my ($self, $orig) = @_;
    $self->{output} .= qq//;
}

sub declaration {
    my ($self, $orig) = @_;
    $self->{output} .= qq//;
}

sub _croak {
    require Carp;
    Carp::croak(@_);
}

sub escapeHTML {
    my $self = shift;
    my $text = shift;
    $text =~ s/&/&/g;
    $text =~ s/"/"/g;
    $text =~ s/
    $text =~ s/>/>/g;
    return $text;
}

1;

__END__