# 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;