Initial commit.

lib/perl5/Selima/urlcheck

@@ -0,0 +1,114 @@
+#! /usr/bin/perl -w
+# Selima Website Content Management System
+# urlcheck: The URL validator.
+
+#  Copyright (c) 2004-2018 imacat.
+#
+#  Licensed under the Apache License, Version 2.0 (the "License");
+#  you may not use this file except in compliance with the License.
+#  You may obtain a copy of the License at
+#
+#      http://www.apache.org/licenses/LICENSE-2.0
+#
+#  Unless required by applicable law or agreed to in writing, software
+#  distributed under the License is distributed on an "AS IS" BASIS,
+#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+#  See the License for the specific language governing permissions and
+#  limitations under the License.
+
+# Author: imacat <imacat@mail.imacat.idv.tw>
+# First written: 2004-11-06
+
+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);
+    }
+}