Initial commit.

lib/php/monica/urlcheck

@@ -0,0 +1,100 @@
+#! /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);
+    }
+}