Initial commit.
This commit is contained in:
351
lib/perl5/Selima/Init.pm
Normal file
351
lib/perl5/Selima/Init.pm
Normal file
@@ -0,0 +1,351 @@
|
||||
# Selima Website Content Management System
|
||||
# Init.pm: The script initializer.
|
||||
|
||||
# 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-23
|
||||
|
||||
package Selima::Init;
|
||||
use 5.008;
|
||||
use utf8;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base qw(Exporter);
|
||||
use vars qw(@EXPORT @EXPORT_OK);
|
||||
BEGIN {
|
||||
@EXPORT = qw(initvars initenv);
|
||||
@EXPORT_OK = @EXPORT;
|
||||
# Prototype declaration
|
||||
sub initvars($);
|
||||
sub initenv(%);
|
||||
sub check_spambots();
|
||||
sub block_spam($);
|
||||
}
|
||||
|
||||
use Fcntl qw(:flock);
|
||||
use File::Basename qw(basename);
|
||||
use File::Spec::Functions qw(splitpath splitdir catpath catdir catfile);
|
||||
use IO::NestedCapture qw(CAPTURE_STDOUT);
|
||||
use POSIX qw(setlocale LC_ALL);
|
||||
use Sys::Hostname qw(hostname);
|
||||
use Time::HiRes qw();
|
||||
use URI qw();
|
||||
use URI::Escape qw(uri_unescape);
|
||||
|
||||
BEGIN {
|
||||
if (exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2) {
|
||||
require Apache2::RequestRec;
|
||||
}
|
||||
}
|
||||
|
||||
use Selima::Cache qw();
|
||||
use Selima::CallForm;
|
||||
use Selima::DataVars qw(:all);
|
||||
use Selima::DBI;
|
||||
use Selima::DecForm;
|
||||
use Selima::FormFunc;
|
||||
use Selima::HTTP;
|
||||
use Selima::LastModf;
|
||||
use Selima::ListPref;
|
||||
use Selima::LogIn;
|
||||
use Selima::Logging;
|
||||
use Selima::ReqURI;
|
||||
use Selima::ScptPriv;
|
||||
use Selima::SetL10N;
|
||||
use Selima::ShortCut;
|
||||
use Selima::Session;
|
||||
use Selima::Unauth;
|
||||
|
||||
# initvars: Initialize the data variables
|
||||
sub initvars($) {
|
||||
local ($_, %_);
|
||||
my ($pkg, $r);
|
||||
$pkg = $_[0];
|
||||
|
||||
# Only run once for mod_perl
|
||||
if ($IS_MODPERL) {
|
||||
$r = $IS_MP2? Apache2::RequestUtil->request:
|
||||
Apache->request;
|
||||
# Bounce if already initialized under mod_perl
|
||||
return if defined $r->headers_in->get("X-Selima-Initialized");
|
||||
$r->headers_in->set("X-Selima-Initialized", "yes");
|
||||
# Clean-up before initialization, only for mod_perl
|
||||
Selima::DataVars::clear;
|
||||
Selima::Cache::clear;
|
||||
# Cear the site data variables
|
||||
if (defined $pkg) {
|
||||
$_ = "Selima::" . $pkg . "::DataVars";
|
||||
&$_ if defined($_ = $_->can("clear"));
|
||||
}
|
||||
}
|
||||
|
||||
# Set the default values of some variables
|
||||
# By default we use PostgreSQL, unless changed by site configuration
|
||||
$DBI_TYPE = DBI_POSTGRESQL;
|
||||
|
||||
# The script path
|
||||
%SCRIPTS = (
|
||||
FORM_USERS() => "/magicat/cgi-bin/users.cgi",
|
||||
FORM_GROUPS() => "/magicat/cgi-bin/groups.cgi",
|
||||
FORM_USERMEM() => "/magicat/cgi-bin/usermem.cgi",
|
||||
FORM_GROUPMEM() => "/magicat/cgi-bin/groupmem.cgi",
|
||||
FORM_USERPREF() => "/magicat/cgi-bin/userpref.cgi",
|
||||
FORM_SCPTPRIV() => "/magicat/cgi-bin/scpptpriv.cgi",
|
||||
FORM_PIC() => "/magicat/cgi-bin/pic.cgi",
|
||||
FORM_PAGES() => "/magicat/cgi-bin/pages.cgi",
|
||||
FORM_NEWS() => "/magicat/cgi-bin/news.cgi",
|
||||
FORM_LINKCAT() => "/magicat/cgi-bin/linkcat.cgi",
|
||||
FORM_LINKS() => "/magicat/cgi-bin/links.cgi",
|
||||
FORM_ACCTSUBJ() => "/magicat/cgi-bin/acctsubj.cgi",
|
||||
FORM_ACCTTRX() => "/magicat/cgi-bin/accttrx.cgi",
|
||||
);
|
||||
|
||||
$NOLOGIN = 0;
|
||||
|
||||
$DEFAULT_LANG = "zh-tw";
|
||||
|
||||
$PAGEBAR_RANGE = 2;
|
||||
|
||||
IO::NestedCapture->start(CAPTURE_STDOUT);
|
||||
binmode IO::NestedCapture->instance->{"STDOUT_current"}[-1], ":utf8";
|
||||
$NO_AUTO_OUTPUT = 0;
|
||||
|
||||
$LOGTIME = 0;
|
||||
$T_START = Time::HiRes::time;
|
||||
|
||||
# Load the site and host configuration
|
||||
if (defined $pkg) {
|
||||
# Load the site configuration
|
||||
$_ = "Selima::" . $pkg . "::Config";
|
||||
&$_ if defined($_ = $_->can("siteconf"));
|
||||
# Load the host-specific configuration
|
||||
$_ = "Selima::" . $pkg . "::HostConf";
|
||||
&$_ if defined($_ = $_->can("hostconf"));
|
||||
# Look for siteconf() and hostconf() imported to the caller
|
||||
} else {
|
||||
(caller 1)[0]->siteconf if (caller 1)[0]->can("siteconf");
|
||||
(caller 1)[0]->hostconf if (caller 1)[0]->can("hostconf");
|
||||
}
|
||||
|
||||
# Set $0 of the non-CGI scripts
|
||||
if (!$IS_CGI) {
|
||||
# Deal with the relative path
|
||||
require FindBin;
|
||||
if ($FindBin::Script ne "-" && $FindBin::Script ne "-e") {
|
||||
@_ = splitpath($FindBin::Bin);
|
||||
$_[1] = catdir(splitdir($_[1]));
|
||||
$_ = catpath(@_);
|
||||
$0 = catfile($_, $FindBin::Script);
|
||||
}
|
||||
}
|
||||
|
||||
# Emulate the CGI environment, if not
|
||||
if (!$IS_CGI) {
|
||||
$ENV{"GATEWAY_INTERFACE"} = "";
|
||||
$ENV{"QUERY_STRING"} = "" if !exists $ENV{"QUERY_STRING"};
|
||||
$ENV{"REMOTE_ADDR"} = "127.0.0.1" if !exists $ENV{"REMOTE_ADDR"};
|
||||
$ENV{"REMOTE_HOST"} = "localhost" if !exists $ENV{"REMOTE_HOST"};
|
||||
$ENV{"REQUEST_METHOD"} = "GET" if !exists $ENV{"REQUEST_METHOD"};
|
||||
$ENV{"SCRIPT_NAME"} = $0 if !exists $ENV{"SCRIPT_NAME"};
|
||||
$ENV{"SERVER_NAME"} = hostname if !exists $ENV{"SERVER_NAME"};
|
||||
$ENV{"SERVER_PORT"} = 80 if !exists $ENV{"SERVER_PORT"};
|
||||
$ENV{"SERVER_SOFTWARE"} = $^O if !exists $ENV{"SERVER_SOFTWARE"};
|
||||
}
|
||||
|
||||
# Try to obtain the request information
|
||||
init_request_uri;
|
||||
# Scan the parameters
|
||||
%COOKIES = fetch CGI::Cookie;
|
||||
init_forms;
|
||||
# Initialize the localization framework (gettext/Maketext)
|
||||
# This runs gettext implicitly
|
||||
set_l10n;
|
||||
decode_forms;
|
||||
# Set the path of the this processing form
|
||||
$SCRIPTS{FORM_THIS()} = form_this;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# initenv: Initialize the script environment
|
||||
sub initenv(%) {
|
||||
local ($_, %_);
|
||||
my (%param);
|
||||
my ($dbi, $session, $restricted, $lastmod);
|
||||
%param = @_;
|
||||
|
||||
# Initialize the data variables and cache
|
||||
$MAIN = (caller)[0];
|
||||
&$_ if defined($_ = $MAIN->can("siteconf"));
|
||||
initvars $PACKAGE;
|
||||
decode_forms_delay;
|
||||
# Load the script configuration
|
||||
$THIS_FILE = basename($0);
|
||||
# $MAIN was cleaned-up in initvars(), so we need to obtain it again
|
||||
$MAIN = (caller)[0];
|
||||
&$_ if defined($_ = $MAIN->can("scptconf"));
|
||||
|
||||
# Parse the arguments
|
||||
$dbi = exists $param{"-dbi"}? $param{"-dbi"}:
|
||||
defined $DBI_TYPE? $DBI_TYPE: DBI_NONE;
|
||||
$session = exists $param{"-session"}? $param{"-session"}: 1;
|
||||
$restricted = exists $param{"-restricted"}? $param{"-restricted"}: 0;
|
||||
$lastmod = exists $param{"-lastmod"}? $param{"-lastmod"}: 0;
|
||||
# Tag if we should log the processing time
|
||||
$LOGTIME = $param{"-logtime"} if exists $param{"-logtime"};
|
||||
if (exists $param{"-page_param"}) {
|
||||
$PAGE_PARAM = $param{"-page_param"};
|
||||
# Maketext now, since we have already set_l10n() in initvars()
|
||||
$$PAGE_PARAM{"keywords"} = __($$PAGE_PARAM{"keywords"})
|
||||
if exists $$PAGE_PARAM{"keywords"};
|
||||
}
|
||||
|
||||
# Block FunWebProduct
|
||||
# See http://www.networkworld.com/newsletters/web/2003/1208web2.html
|
||||
http_403(N_("Sorry, browsers with FunWebProduct plugin (Smiley, PopSwatter, Spin4Dough, My Mail Signature, My Mail Stationery, My Mail Stamp, Cursor Mania, etc.) are are not welcome. It duplicates your request and produces high load and even crashes to our server. Please remove it first before you visit us."))
|
||||
if exists $ENV{"HTTP_USER_AGENT"}
|
||||
&& $ENV{"HTTP_USER_AGENT"} =~ /FunWebProduct/;
|
||||
# Block bad-behaved e-mail crawlers
|
||||
# Some bad-behaved e-mail crawlers cannot deal with the parent
|
||||
# directory "/.." and ampersands, and attach them to the URI infinitely
|
||||
http_400(0) if $REQUEST_PATH =~ /\/\.\./ || $REQUEST_URI =~ /&/;
|
||||
# Check the request method
|
||||
$_ = exists $param{"-allowed"}? $param{"-allowed"}: [qw(GET HEAD POST)];
|
||||
if (defined $_) {
|
||||
%_ = map { $_ => 1 } @$_;
|
||||
http_405 @$_ if !exists $_{$ENV{"REQUEST_METHOD"}};
|
||||
}
|
||||
# Check and block the spambots
|
||||
check_spambots;
|
||||
|
||||
# Start the session
|
||||
$SESSION = Selima::Session->init if $session;
|
||||
|
||||
# If client has not logged in on restricted area, we can
|
||||
# bypass SQL connection to save our work
|
||||
if ($IS_CGI && $restricted) {
|
||||
if (exists $INC{"Apache/AuthDigest/API.pm"}) {
|
||||
unauth if !defined $AUTHINFO;
|
||||
} else {
|
||||
unauth if !exists $ENV{"REMOTE_USER"};
|
||||
}
|
||||
}
|
||||
|
||||
# Initialize the database connection
|
||||
if ($dbi) {
|
||||
$DBH = Selima::DBI->new($dbi) ;
|
||||
# Set the current table
|
||||
$THIS_TABLE = $param{"-this_table"} if exists $param{"-this_table"};
|
||||
}
|
||||
|
||||
# Prepare the SQL tables to lock
|
||||
if ($dbi && exists $param{"-dbi_lock"}) {
|
||||
# Read-only on non-POSTed forms
|
||||
if ($ENV{"REQUEST_METHOD"} ne "POST") {
|
||||
${$param{"-dbi_lock"}}{$_} = LOCK_SH
|
||||
foreach keys %{$param{"-dbi_lock"}};
|
||||
}
|
||||
# Supply the default locks
|
||||
if (use_users) {
|
||||
${$param{"-dbi_lock"}}{$_} = LOCK_SH
|
||||
foreach grep !exists ${$param{"-dbi_lock"}}{$_},
|
||||
(qw(users groups scptpriv userpref),
|
||||
"users AS createdby", "users AS updatedby");
|
||||
}
|
||||
}
|
||||
|
||||
# Check the last modified
|
||||
if ($lastmod) {
|
||||
my (@tables, @files);
|
||||
# Set the database tables to check
|
||||
@tables = qw();
|
||||
push @tables, @{$param{"-lmtables"}} if exists $param{"-lmtables"};
|
||||
# Add the locked tables automatically
|
||||
push @tables, keys %{$param{"-dbi_lock"}} if exists $param{"-dbi_lock"};
|
||||
# Set the files to check
|
||||
@files = qw();
|
||||
push @files, @{$param{"-lmfiles"}} if exists $param{"-lmfiles"};
|
||||
http_304 if not_modified @tables, @files;
|
||||
}
|
||||
|
||||
# Lock the SQL tables
|
||||
$DBH->lock(%{$param{"-dbi_lock"}})
|
||||
if $dbi && exists $param{"-dbi_lock"};
|
||||
|
||||
# Only available on systems with membership turned on
|
||||
if ($dbi && use_users && $session) {
|
||||
# Update the log-in information
|
||||
if (exists $INC{"Apache/AuthDigest/API.pm"}) {
|
||||
upd_login_info if defined $AUTHINFO;
|
||||
} else {
|
||||
upd_login_info if exists $ENV{"REMOTE_USER"};
|
||||
upd_login_info if !$IS_CGI;
|
||||
}
|
||||
# Check the client permission
|
||||
unauth if $restricted && !is_script_permitted;
|
||||
}
|
||||
|
||||
# Process the list preference form
|
||||
if (form_type eq "listpref") {
|
||||
my $domain;
|
||||
if ( defined($domain = $POST->param("domain"))
|
||||
&& $domain->can("new")) {
|
||||
$_ = $domain->new;
|
||||
$_->set_listpref;
|
||||
} else {
|
||||
$_ = new Selima::ListPref($POST);
|
||||
$_->main;
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# check_spambots: Check and block spam bots
|
||||
# This starts at an earlier phrase before the database initialization,
|
||||
# to decrease the server load.
|
||||
sub check_spambots() {
|
||||
local ($_, %_);
|
||||
my ($r, $method, $col);
|
||||
if ($IS_MODPERL) {
|
||||
$r = $IS_MP2? Apache2::RequestUtil->request:
|
||||
Apache->request;
|
||||
$method = $r->method;
|
||||
} else {
|
||||
$method = $ENV{"REQUEST_METHOD"};
|
||||
}
|
||||
$col = FORM_CAPTCHA;
|
||||
# Block the spam for POST forms
|
||||
if ($method eq "POST" && defined $POST->param($col)) {
|
||||
block_spam "check_spambots: captcha column \"$col\" should be empty but got \""
|
||||
. $POST->param($col) . "\"."
|
||||
if $POST->param($col) ne "";
|
||||
}
|
||||
}
|
||||
|
||||
# block_spam: Block the spam message
|
||||
sub block_spam($) {
|
||||
local ($_, %_);
|
||||
$_ = $_[0];
|
||||
spamlog $_;
|
||||
# Delay the spammer
|
||||
sleep 300;
|
||||
http_403(0);
|
||||
# No return
|
||||
}
|
||||
|
||||
no utf8;
|
||||
return 1;
|
||||
Reference in New Issue
Block a user