142 lines
3.9 KiB
Perl
142 lines
3.9 KiB
Perl
# 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;
|