Initial commit.

lib/perl5/Selima/ChkFunc.pm

@@ -0,0 +1,141 @@
+# Selima Website Content Management System
+# ChkFunc.pm: The data checkers.
+
+#  Copyright (c) 2003-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: 2003-03-24
+
+package Selima::ChkFunc;
+use 5.008;
+use strict;
+use warnings;
+use base qw(Exporter);
+use vars qw(@EXPORT @EXPORT_OK);
+BEGIN {
+@EXPORT = qw();
+push @EXPORT, qw(check_sn check_sn_in check_script check_date);
+push @EXPORT, qw(is_url_wellformed is_url_reachable);
+@EXPORT_OK = @EXPORT;
+# Prototype declaration
+sub check_sn(\$);
+sub check_sn_in(\$$);
+sub check_script($);
+sub check_date($$$);
+sub is_url_wellformed($);
+sub is_url_reachable($);
+}
+
+use LWP::UserAgent;
+use Net::Telnet;
+use Regexp::Common;
+use Time::Local qw(timelocal);
+use URI;
+
+use Selima::Cache qw(:chkfunc);
+use Selima::DataVars qw($DBH :input :requri);
+use Selima::ShortCut;
+
+use vars qw($URIRE);
+$URIRE = "(?:" . $RE{"URI"} . "|" . $RE{"URI"}{"HTTP"}{-scheme=>"https"} . ")";
+
+# check_sn: Check if a serial number is valid
+#   Rule for a serial number:
+#     An integer of 9 digits within 100000000 - 999999999
+sub check_sn(\$) {
+    local ($_, %_);
+    $_ = $_[0];
+    return 0 unless defined $$_ && $$_ =~ /^[1-9][0-9]{8}$/;
+    $$_ += 0;
+    return 1;
+}
+
+# check_sn_in: Check if a serial number exists in a table
+sub check_sn_in(\$$) {
+    local ($_, %_);
+    my ($sn, $table, $sql, $sth);
+    ($sn, $table) = @_;
+    # Check the validity of the serial number first
+    return 0 if !check_sn $$sn;
+    if ($table =~ /^(.+) AS (.+)$/) {
+        $table = $DBH->quote_identifier($1)
+            . " AS " . $DBH->quote_identifier($2);
+    } else {
+        $table = $DBH->quote_identifier($table);
+    }
+    $sql = "SELECT * FROM $table WHERE sn=$$sn;\n";
+    $sth = $DBH->prepare($sql);
+    $sth->execute;
+    return ($sth->rows == 1);
+}
+
+# check_script: Check if a script exists
+sub check_script($) {
+    local ($_, %_);
+    $_ = $_[0];
+    # Return the cache
+    return $ChkFunc_check_script{$_}
+        if exists $ChkFunc_check_script{$_};
+    # Not a CGI script
+    return ($ChkFunc_check_script{$_} = 0)
+        unless /\.(cgi|pl|plx)$/;
+    # Not exists
+    return ($ChkFunc_check_script{$_} = 0)
+        unless -x $DOC_ROOT . $_;
+    # OK
+    return ($ChkFunc_check_script{$_} = 1);
+}
+
+# check_date: Check if a date is valid
+sub check_date($$$) {
+    local ($_, %_);
+    my ($year, $month, $day);
+    ($year, $month, $day) = @_;
+    eval { $_ = timelocal(0, 0, 0, $day, $month-1, $year-1900); };
+    return undef if $@ ne "";
+    return $_;
+}
+
+# is_url_wellformed: Check if an URL is well-formed
+sub is_url_wellformed($) { $_[0] =~ /^$URIRE$/; }
+
+# is_url_reachable: Check if the target of an URL is reachable
+sub is_url_reachable($) {
+    local ($_, %_);
+    my ($uri, $UA, $r);
+    $_ = $_[0];
+    # Return the cache
+    return $ChkFunc_is_url_reachable{$_}
+        if exists $ChkFunc_is_url_reachable{$_};
+    # 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 ($ChkFunc_is_url_reachable{$_} = ($@ eq ""));
+    
+    # Use LWP::UserAgent
+    } else {
+        $UA = new LWP::UserAgent;
+        $r = $UA->get($_);
+        return ($ChkFunc_is_url_reachable{$_} = !$r->is_error);
+    }
+}
+
+return 1;