#! /usr/bin/perl -w
# 程式檔名: urlcheck
# 程式說明: Selima 檢查網址程式
# 程式作者: 依瑪貓 imacat <imacat@mail.imacat.idv.tw>
# 初稿日期: 2004-11-06
# 版權字樣: 版權所有 (c) 2004 依瑪貓

use 5.008;
use strict;
use warnings;
use threads;
use threads::shared;
# Prototype declaration
sub main();
sub check_urls();
sub check_urls_nonthread();
sub check_urls_in_a_thread();
sub is_reachable($);

use Config qw(%Config);
use LWP::UserAgent;
use Net::Telnet;
use URI;

our ($CURINDEX, @URLS) : shared;
$CURINDEX = 0;
@URLS = qw();


main;
exit 0;

sub main() {
    local ($_, %_);
    
    @URLS = <STDIN>;
    chomp foreach @URLS;
    check_urls;
    print join "", map "$_\n", @URLS;
    
    return;
}

# check_urls: Proform URL checks (with threading)
sub check_urls() {
    local ($_, %_);
    # Run check_urls_nonthread() if ithread is not available
    return check_urls_nonthread
        if !defined $Config{"useithreads"};
    # Start the thread workers
    for ($_ = 0, @_ = qw(); $_ < 10; $_++) {
        push @_, threads->new(\&check_urls_in_a_thread)
    }
    # Wait for everyone to end
    $_->join foreach @_;
    # Return the result
    return;
}

# check_urls_nonthread: Proform URL checks without threading
sub check_urls_nonthread() {
    local ($_, %_);
    @URLS = map is_reachable($_), @URLS;
    return;
}

# check_urls_in_a_thread: Proform URL checks in a thread
sub check_urls_in_a_thread() {
    local ($_, %_);
    # Check until the end
    while (($_ = $CURINDEX++) < @URLS) {
        $URLS[$_] = is_reachable($URLS[$_]);
    }
    return;
}

# is_reachable: Check if the target of an URL is reachable
sub is_reachable($) {
    local ($_, %_);
    my ($uri, $UA, $r);
    $_ = $_[0];
    # Check if it is available
    # LWP::UserAgent cannot handle telnet.  We check it with Net::Telnet.
    if (/^telnet:\/\//) {
        $uri = new URI($_);
        %_ = (
            Host    => $uri->host,
            Port    => $uri->port,
        );
        eval { new Net::Telnet(%_) };
        return ($@ eq ""? 1: 0);
    
    # Use LWP::UserAgent
    } else {
        $UA = new LWP::UserAgent;
        $UA->timeout(20);
        $r = $UA->get($_);
        return (!$r->is_error? 1: 0);
    }
}