#!/bin/perl

use strict;                   ## Strict coding
use diagnostics;              ## Verbose messages
use LWP::Simple;              ## Easy fetch the web
use HTML::Parser;             ## To get list of links on a web page

if (! @ARGV) {
    print STDERR "Usage: %0 url\n\nWill list all links of given url\n";
    exit 1;
}

# get url
my $url = shift;
my $listing = get($url);
if (!defined($listing)) {
    print STDERR "Cannot get $url\n";
    exit 1;
}

# Init parser
my $p = HTML::Parser->new(api_version => 3,
			  start_h => [\&start_handler, "self,tagname,attr"],
			  report_tags => [qw(a)],
			  );

# Do parsing
$p->parse($listing) || die $!;
$p->eof;

# Finished
exit 0;

sub start_handler {
    my($self, $tag, $attr) = @_;
    return unless $tag eq "a";
    return unless exists $attr->{href};
    # If you want the link uncomment the following
    print myabs($attr->{href},$url) . "\n";
    $self->handler(text  => [], '@{dtext}' );
    $self->handler(end   => \&end_handler, "self,tagname");
}

sub end_handler {
    my($self, $tag) = @_;
    my $text = join("", @{$self->handler("text")});
    $text =~ s/^\s+//;
    $text =~ s/\s+$//;
    $text =~ s/\s+/ /g;
    # If you want the text uncomment the following
    # print "$text\n";
    
    $self->handler("text", undef);
    $self->handler("start", \&start_handler);
    $self->handler("end", undef);
}

# -----------------------------------------------------------------
#
# Subroutine : myabs
#
# Purpose    : Return an absolute URL
# Input      : link
#              base
#
# Comment    : This is a wrapper arounf URI::URL or URI depending on
#              libwww version.
# -----------------------------------------------------------------
sub myabs {
    #
    ## Depending of libwww version: use URI::URL or URI or do nothing...
    #
    my ($link,$base) = (@_);
    my $linkq = quotemeta($link);
    my $baseq = quotemeta($base);
    my $newlink = eval "use URI::URL; url(\"$linkq\",\"$baseq\")->abs->as_string";
    if ($@) {
        $newlink = eval "use URI; URI->new->new_abs(\"$linkq\",\"$baseq\")";
        if ($@) {
            $newlink = ($link =~ /^[\w]:\/\// ? $link : (substr($base,-1,1) eq '/' ? "$base$link" : "$base/$link"));
        }
    }
    return($newlink);
}