imacat/selima-perl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit.

Browse Source
This commit is contained in:
依瑪貓
2026-03-10 21:25:26 +08:00
commit 78739bf725
3089 changed files with 472990 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

171
lib/perl5/Selima.pm Normal file
View File

@@ -0,0 +1,171 @@
# Selima Website Content Management System
# Selima.pm: Selima Website Content Management System
# 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-04-23
package Selima;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw($VERSION @EXPORT @EXPORT_OK);
$VERSION = "3.10";
@EXPORT = qw();
# Import the subroutines
use Selima::A2HTML;
push @EXPORT, @Selima::A2HTML::EXPORT;
use Selima::AbsURI;
push @EXPORT, @Selima::AbsURI::EXPORT;
use Selima::Accounting;
push @EXPORT, @Selima::Accounting::EXPORT;
use Selima::AddGet;
push @EXPORT, @Selima::AddGet::EXPORT;
use Selima::AltLang;
push @EXPORT, @Selima::AltLang::EXPORT;
use Selima::Array;
push @EXPORT, @Selima::Array::EXPORT;
use Selima::Cache qw();
push @EXPORT, @Selima::Cache::EXPORT;
use Selima::CallForm;
push @EXPORT, @Selima::CallForm::EXPORT;
use Selima::ChkFunc;
push @EXPORT, @Selima::ChkFunc::EXPORT;
use Selima::ChkPriv;
push @EXPORT, @Selima::ChkPriv::EXPORT;
use Selima::ChkWrite;
push @EXPORT, @Selima::ChkWrite::EXPORT;
use Selima::CommText;
push @EXPORT, @Selima::CommText::EXPORT;
use Selima::CopyYear;
push @EXPORT, @Selima::CopyYear::EXPORT;
use Selima::Country;
push @EXPORT, @Selima::Country::EXPORT;
use Selima::DataVars qw(:all);
push @EXPORT, @Selima::DataVars::EXPORT_OK;
use Selima::DBILogin;
push @EXPORT, @Selima::DBILogin::EXPORT;
use Selima::DecForm;
push @EXPORT, @Selima::DecForm::EXPORT;
use Selima::EchoForm;
push @EXPORT, @Selima::EchoForm::EXPORT;
use Selima::Encrypt;
push @EXPORT, @Selima::Encrypt::EXPORT;
use Selima::ErrMsg;
push @EXPORT, @Selima::ErrMsg::EXPORT;
use Selima::FetchRec;
push @EXPORT, @Selima::FetchRec::EXPORT;
use Selima::FormFunc;
push @EXPORT, @Selima::FormFunc::EXPORT;
use Selima::Format;
push @EXPORT, @Selima::Format::EXPORT;
use Selima::GeoIP;
push @EXPORT, @Selima::GeoIP::EXPORT;
use Selima::GetLang;
push @EXPORT, @Selima::GetLang::EXPORT;
use Selima::Guest;
push @EXPORT, @Selima::Guest::EXPORT;
use Selima::Guestbook;
push @EXPORT, @Selima::Guestbook::EXPORT;
use Selima::HTTP;
push @EXPORT, @Selima::HTTP::EXPORT;
use Selima::HTTPS;
push @EXPORT, @Selima::HTTPS::EXPORT;
use Selima::Init;
push @EXPORT, @Selima::Init::EXPORT;
use Selima::Links;
push @EXPORT, @Selima::Links::EXPORT;
use Selima::ListFunc;
push @EXPORT, @Selima::ListFunc::EXPORT;
use Selima::ListPref;
push @EXPORT, @Selima::ListPref::EXPORT;
use Selima::LnInfo;
push @EXPORT, @Selima::LnInfo::EXPORT;
use Selima::Logging;
push @EXPORT, @Selima::Logging::EXPORT;
use Selima::LogIn;
push @EXPORT, @Selima::LogIn::EXPORT;
use Selima::LogOut;
push @EXPORT, @Selima::LogOut::EXPORT;
use Selima::LastModf;
push @EXPORT, @Selima::LastModf::EXPORT;
use Selima::MarkAbbr;
push @EXPORT, @Selima::MarkAbbr::EXPORT;
use Selima::MkAllDir;
push @EXPORT, @Selima::MkAllDir::EXPORT;
use Selima::MungAddr;
push @EXPORT, @Selima::MungAddr::EXPORT;
use Selima::NewSN;
push @EXPORT, @Selima::NewSN::EXPORT;
use Selima::PageFunc;
push @EXPORT, @Selima::Page::EXPORT;
use Selima::Page2Rel;
push @EXPORT, @Selima::Page2Rel::EXPORT;
use Selima::Passwd;
push @EXPORT, @Selima::Passwd::EXPORT;
use Selima::Picture;
push @EXPORT, @Selima::Picture::EXPORT;
use Selima::Preview;
push @EXPORT, @Selima::Preview::EXPORT;
use Selima::Query;
push @EXPORT, @Selima::Query::EXPORT;
use Selima::RelURI;
push @EXPORT, @Selima::RelURI::EXPORT;
use Selima::RemoHost;
push @EXPORT, @Selima::RemoHost::EXPORT;
use Selima::ReqURI;
push @EXPORT, @Selima::ReqURI::EXPORT;
use Selima::ScptPriv;
push @EXPORT, @Selima::ScptPriv::EXPORT;
use Selima::SetL10N;
push @EXPORT, @Selima::SetL10N::EXPORT;
use Selima::Server;
push @EXPORT, @Selima::Server::EXPORT;
use Selima::ShortCut;
push @EXPORT, @Selima::ShortCut::EXPORT;
use Selima::Unauth;
push @EXPORT, @Selima::Unauth::EXPORT;
use Selima::Unicode;
push @EXPORT, @Selima::Unicode::EXPORT;
use Selima::UserName;
push @EXPORT, @Selima::UserName::EXPORT;
use Selima::UserPref;
push @EXPORT, @Selima::UserPref::EXPORT;
use Selima::XFileIO;
push @EXPORT, @Selima::XFileIO::EXPORT;
# Pre-load :flock symbles
use Fcntl qw(:flock);
push @EXPORT, qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN);
@EXPORT_OK = @EXPORT;
# Load the classes
use Selima::AddCol;
use Selima::L10N;
use Selima::List;
use Selima::Checker;
use Selima::DBI;
use Selima::Destroy;
use Selima::Form;
use Selima::Mail;
use Selima::Page;
use Selima::Processor;
use Selima::Session;
return 1;

101
lib/perl5/Selima/A2HTML.pm Normal file
View File

@@ -0,0 +1,101 @@
# Selima Website Content Management System
# A2HTML.pm: The text to HTML converter.
# 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::A2HTML;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(a2html);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub a2html($);
}
use Email::Find qw();
use URI::Find qw();
use Selima::MarkAbbr;
use Selima::MungAddr;
use Selima::ShortCut;
use Selima::Unicode;
use vars qw(%SUBST $TEXT $uri_finder $email_finder);
$uri_finder = new URI::Find( \&uri_subst );
$email_finder = new Email::Find( \&email_subst );
# a2html: Convert a textarea input into HTML content
sub a2html($) {
local ($_, %_);
$TEXT = $_[0];
# Clear the registry
%SUBST = qw();
# Strip the URLs
$uri_finder->find(\$TEXT);
# Strip the e-mails
$email_finder->find(\$TEXT);
# Escape the HTML characters and mark the abbreviation
$TEXT = h_abbr($TEXT);
# Return the substitutied URLs and e-mails as links
$TEXT =~ s/(\[subst:(\d{9})\])/exists $SUBST{$2}? $SUBST{$2}: $1;/ge;
# Normal text-to-HTML substitution
$TEXT =~ s/^ /&nbsp;/mg;
$TEXT =~ s/ /&nbsp; /g;
$TEXT =~ s/\n/<br \/>\n/g;
return $TEXT;
}
# uri_subst: Substitute an URL in the content
sub uri_subst {
local ($_, %_);
my ($uri, $uritext);
($uri, $uritext) = @_;
do {
# Generate a random serial number
$_ = 100000000 + int rand 900000000;
} until $TEXT !~ /\[subst:$_\]/;
# Register this URI
$SUBST{$_} = "<a href=\"" . h($uri) . "\"><samp>"
. mung_email_span(h($uritext)) . "</samp></a>";
# Return the substitution
return "[subst:$_]";
}
# email_subst: Substitute an e-mail in the content
sub email_subst {
local ($_, %_);
my ($email, $emailtext);
($email, $emailtext) = @_;
do {
# Generate a random serial number
$_ = 100000000 + int rand 900000000;
} until $TEXT !~ /\[subst:$_\]/;
# Register this URI
$SUBST{$_} = "<a href=\"mailto:" . h($email->format) . "\"><samp>"
. mung_email_span(h($emailtext)) . "</samp></a>";
# Return the substitution
return "[subst:$_]";
}
return 1;

57
lib/perl5/Selima/AbsURI.pm Normal file
View File

@@ -0,0 +1,57 @@
# Selima Website Content Management System
# AbsURI.pm: The converter to turn all URIs to absolute URIs.
# 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-26
package Selima::AbsURI;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(absuri);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub absuri($;$$);
}
use URI qw();
use Selima::DataVars qw(:requri);
# absuri: Convert and colonicalize to an absolute URI
sub absuri($;$$) {
local ($_, %_);
my ($uri, $base, $skip_fragment);
($uri, $base, $skip_fragment) = @_;
# Default base to $REQUEST_FULLURI
$base = defined $base? new URI($base): $REQUEST_FULLURI;
# Skip the fragment
return $uri if $skip_fragment && $uri =~ /^#/;
# Absolute path -- add the root difference
$uri = "$ROOT_DIFF$uri" if $uri =~ /^\//;
$uri = new URI($uri);
# Obtain the absolute URI
$uri = $uri->abs($base);
return $uri->canonical;
}
return 1;

294
lib/perl5/Selima/Accounting.pm Normal file
View File

@@ -0,0 +1,294 @@
# Selima Website Content Management System
# Accounting.pm: The accounting subroutines.
# Copyright (c) 2007-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: 2007-09-20
package Selima::Accounting;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw();
push @EXPORT, qw(acctsubj_title acctsubj_code acctsubj_sn);
push @EXPORT, qw(acctsubj_recent_options accttrx_id accttrxid_compose);
push @EXPORT, qw(accttrx_maxord);
push @EXPORT, qw(ACCTSUBJ_CASH ACCTSUBJ_INCOME_ACUM ACCTSUBJ_INCOME_CUR);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub acctsubj_title($);
sub acctsubj_code($);
sub acctsubj_sn($);
sub acctsubj_recent_options($);
sub accttrx_id($);
sub accttrxid_compose($$);
sub accttrx_maxord(;$$);
}
use Selima::Cache qw(:account);
use Selima::ChkFunc;
use Selima::CommText;
use Selima::DataVars qw($DBH :l10n :lninfo);
use Selima::EchoForm;
use Selima::GetLang;
use Selima::LnInfo;
# Certain subjects
use constant ACCTSUBJ_CASH => 1111; # 1111 庫存現金
use constant ACCTSUBJ_INCOME_ACUM => 3351; # 3351 累積盈虧
use constant ACCTSUBJ_INCOME_CUR => 3353; # 3353 本期損益
# acctsubj_title: Obtain an accounting subject title
sub acctsubj_title($) {
local ($_, %_);
my ($sn, $sql, $sth, $col);
$sn = $_[0];
# Bounce if there is any problem with $sn
return t_notset if !defined $sn;
# Return the cache
return $Account_acctsubj_title{$sn} if exists $Account_acctsubj_title{$sn};
# Check the serial number first
return ($Account_acctsubj_title{$sn} = t_na)
if !check_sn $sn;
# Query
# Unilingual
if (@ALL_LINGUAS == 1) {
$col = "acctsubj_codetitle($sn) AS title";
# Multilingual
} else {
$_ = getlang;
$col = "acctsubj_codetitle('$_', $sn) AS title";
}
$sql = "SELECT $col;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
# Not found
return ($Account_acctsubj_title{$sn} = t_na)
unless $sth->rows == 1;
# Found
return ($Account_acctsubj_title{$sn} = ${$sth->fetch}[0]);
}
# acctsubj_code: Obtain an accounting subject code
sub acctsubj_code($) {
local ($_, %_);
my ($sn, $sql, $sth, $col);
$sn = $_[0];
# Bounce if there is any problem with $sn
return t_notset if !defined $sn;
# Return the cache
return $Account_acctsubj_code{$sn} if exists $Account_acctsubj_code{$sn};
# Check the serial number first
return ($Account_acctsubj_code{$sn} = t_na)
if !check_sn $sn;
# Query
$sql = "SELECT code FROM acctsubj WHERE sn=$sn;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
# Not found
return ($Account_acctsubj_code{$sn} = t_na)
unless $sth->rows == 1;
# Found
return ($Account_acctsubj_code{$sn} = ${$sth->fetch}[0]);
}
# acctsubj_sn: Obtain an accounting subject S/N
sub acctsubj_sn($) {
local ($_, %_);
my ($code, $sql, $sth, $col);
$code = $_[0];
# Bounce if there is any problem with $code
return t_notset if !defined $code;
# Return the cache
return $Account_acctsubj_sn{$code} if exists $Account_acctsubj_sn{$code};
# Query
$sql = "SELECT sn FROM acctsubj"
. " WHERE code=" . $DBH->quote($code) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
# Not found
return ($Account_acctsubj_sn{$code} = t_na)
unless $sth->rows == 1;
# Found
return ($Account_acctsubj_sn{$code} = ${$sth->fetch}[0]);
}
# acctsubj_recent_options: Obtain a recently-used accounting subject options list
sub acctsubj_recent_options($) {
local ($_, %_);
my ($value, $sql, $content);
my ($sth, $count, $row, @opts, $hascur, $optlist);
$value = $_[0];
# Obtain the recently-used options
# Unilingual
if (@ALL_LINGUAS == 1) {
$content = "acctsubj_codetitle(subj) AS content";
# Multilingual
} else {
$_ = getlang;
$content = "acctsubj_codetitle('$_', subj) AS content";
}
$sql = "SELECT subj AS value, $content FROM acctrecs"
. " GROUP BY subj"
. " ORDER BY acctsubj_recent(subj) DESC;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @opts = qw(), $hascur = 0; $i < $count; $i++) {
$row = $sth->fetchrow_hashref;
push @opts, {
"value" => $$row{"value"},
"content" => $$row{"content"},
};
$hascur = 1 if defined $value && $$row{"value"} eq $value;
}
undef $sth;
# Prepend the currently selected option if available
if (!$hascur && defined $value && check_sn $value) {
# Unilingual
if (@ALL_LINGUAS == 1) {
$content = "acctsubj_codetitle($value) AS content";
# Multilingual
} else {
$_ = getlang;
$content = "acctsubj_codetitle('$_', $value) AS content";
}
$sql = "SELECT $content;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
if ($sth->rows > 0) {
$row = $sth->fetchrow_hashref;
@opts = ({
"value" => $value,
"content" => $$row{"content"},
}, @opts);
}
undef $sth;
}
# Obtain the HTML
$optlist = opt_list_array @opts;
return preselect_options $optlist, $value;
}
# accttrx_id: Obtain the accounting transaction ID.
sub accttrx_id($) {
local ($_, %_);
my ($sn, $sql, $sth, $col, $row);
$sn = $_[0];
# Bounce if there is any problem with $sn
return t_notset if !defined $sn;
# Return the cache
return $Account_accttrx_id{$sn} if exists $Account_accttrx_id{$sn};
# Check the serial number first
return ($Account_accttrx_id{$sn} = t_na)
if !check_sn $sn;
# Query
$sql = "SELECT date, ord FROM accttrx WHERE sn=$sn;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
# Not found
return ($Account_accttrx_id{$sn} = t_na)
unless $sth->rows == 1;
# Found
$row = $sth->fetchrow_hashref;
return ($Account_accttrx_id{$sn} = accttrxid_compose $$row{"date"}, $$row{"ord"});
}
# accttrxid_compose: Compose the accounting transaction ID
sub accttrxid_compose($$) {
local ($_, %_);
my ($date, $ord);
($date, $ord) = @_;
# In timestamp
if ($date =~ /^\d+$/) {
@_ = localtime $date;
$_[5] += 1900;
$_[4]++;
return sprintf "%04d%02d%02d%02d", @_[5,4,3], $ord;
}
# In ISO date YYYY-MM-DD format
return sprintf "%04d%02d%02d%02d", $1, $2, $3, $ord
if $date =~ /^(\d{4})-(\d{2})-(\d{2})$/;
# Invalid date
return undef;
}
# accttrx_maxord: Obtain the default accounting transaction order
sub accttrx_maxord(;$$) {
local ($_, %_);
my ($date, $sn, $sql, $sth, $row);
($date, $sn) = @_;
$date = time if !defined $date;
$sn = -1 if @_ < 2;
# In timestamp
if ($date =~ /^\d+$/) {
@_ = localtime $date;
$_[5] += 1900;
$_[4]++;
$date = sprintf "%04d-%02d-%02d", @_[5,4,3];
# In ISO date YYYY-MM-DD format
} elsif ($date =~ /^(\d{4})-(\d{2})-(\d{2})$/) {
# Invalid date
} else {
return 99;
}
# Bounce if there is any problem with $sn
return 99 if !defined $sn;
# Return the cache
$Account_accttrx_id{$date} = {} if !exists $Account_accttrx_id{$date};
return ${$Account_accttrx_id{$date}}{$sn}
if exists ${$Account_accttrx_id{$date}}{$sn};
# Check the serial number first
return (${$Account_accttrx_id{$date}}{$sn} = 99)
if $sn != -1 && !check_sn $sn;
# Query
@_ = qw();
push @_, "date=" . $DBH->quote($date);
push @_, "sn!=$sn" if $sn != -1;
$sql = "SELECT count(*) AS count FROM accttrx"
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$row = $sth->fetchrow_hashref;
return (${$Account_accttrx_id{$date}}{$sn} = $$row{"count"} + 1);
}
return 1;

872
lib/perl5/Selima/AddCol.pm Normal file
View File

@@ -0,0 +1,872 @@
# Selima Website Content Management System
# AddCol.pm: The data collector/handler for SQL/XML/CSV data output ("Model").
# 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-09-26
package Selima::AddCol;
use 5.008;
use strict;
use warnings;
use Date::Parse qw(str2time);
use Digest::MD5 qw(md5_hex);
use Encode qw(encode decode is_utf8 FB_CROAK);
use Selima::Array;
use Selima::DataVars qw($DBH :addcol :input :lninfo);
use Selima::Format;
use Selima::GetLang;
use Selima::LogIn;
use Selima::Picture;
use Selima::ShortCut;
use constant TYPE_NULL => 0;
use constant TYPE_NUM => 1;
use constant TYPE_STR => 2;
use constant TYPE_DATE => 3;
use constant TYPE_IPADDR => 4;
use constant TYPE_FILE => 5;
use constant TYPE_BOOL => 6;
use constant TYPE_EXPR => 7;
# Prototype declaration
sub valout_sql($);
sub valout_xml($);
sub valout_csv($);
# new: Initialize the columns deposit
sub new : method {
local ($_, %_);
my ($class, $table, $optype, $self);
($class, $table, $optype) = @_;
$optype = ADDCOL_UPDATE if !defined $optype;
$self = bless {}, $class;
$self->{"cols"} = [];
$self->{"table"} = $table;
$self->{"optype"} = $optype;
if (defined $DBH) {
$self->{"allcols"} = [$DBH->cols($table)];
$self->{"mlcols"} = [$DBH->cols_ml($table)];
} else {
$self->{"allcols"} = [];
$self->{"mlcols"} = [];
}
return $self;
}
# addstr: Add a modified string column to the columns deposit
# Input: $name: The column name.
# $val: The column value.
# $curval: The current value to be compared.
sub addstr : method {
local ($_, %_);
my ($self, $name, $val, $curval, $cur_exists, %col);
($self, $name, $val, $curval) = @_;
$cur_exists = (scalar(@_) == 4);
$curval = decode("UTF-8", $curval, FB_CROAK) if !defined $DBH;
# Adjust the column name for multi-lingual columns
$name .= "_" . getlang LN_DATABASE
if in_array($name, @{$self->{"mlcols"}});
# The new column value
%col = qw();
$col{"name"} = $name;
$col{"mod"} = 0;
# No value is supplied
if (!defined $val || $val eq "") {
$col{"type"} = TYPE_NULL;
$col{"value"} = undef;
# A valid value
} else {
$col{"type"} = TYPE_STR;
$col{"value"} = $val;
}
# Check if we should set it
if ($self->{"optype"} == ADDCOL_INSERT) {
# Always set the value for INSERT
$col{"mod"} = 1;
} else {
# A current value is supplied
if ($cur_exists) {
# This column had a value previously
if (defined $curval) {
# It has no value now. Remove it.
if ($col{"type"} == TYPE_NULL) {
$col{"mod"} = 1;
# A different new value. Modify it.
} elsif ($col{"value"} ne $curval) {
$col{"mod"} = 1;
}
# This column had no value previously
} else {
# But it has a value now.
if ($col{"type"} != TYPE_NULL) {
$col{"mod"} = 1;
}
}
# No current value to compare with.
} else {
# Set it anyway
$col{"mod"} = 1;
}
}
# Check if we should set it
# Add this column
push @{$self->{"cols"}}, {%col};
return;
}
# addstr_empty: Add a modified string column to the columns deposit,
# where empty string is allowed
# Input: $name: The column name.
# $val: The column value.
# $curval: The current value to be compared.
sub addstr_empty : method {
local ($_, %_);
my ($self, $name, $val, $curval, $cur_exists, %col);
($self, $name, $val, $curval) = @_;
$cur_exists = (scalar(@_) == 4);
$curval = decode("UTF-8", $curval, FB_CROAK) if !defined $DBH;
# Adjust the column name for multi-lingual columns
$name .= "_" . getlang LN_DATABASE
if in_array($name, @{$self->{"mlcols"}});
# The new column value
%col = qw();
$col{"name"} = $name;
$col{"mod"} = 0;
# No value is supplied
if (!defined $val) {
$col{"type"} = TYPE_NULL;
$col{"value"} = undef;
# A valid value
} else {
$col{"type"} = TYPE_STR;
$col{"value"} = $val;
}
# Check if we should set it
if ($self->{"optype"} == ADDCOL_INSERT) {
# Always set the value for INSERT
$col{"mod"} = 1;
} else {
# A current value is supplied
if ($cur_exists) {
# This column had a value previously
if (defined $curval) {
# It has no value now. Remove it.
if ($col{"type"} == TYPE_NULL) {
$col{"mod"} = 1;
# A different new value. Modify it.
} elsif ($col{"value"} ne $curval) {
$col{"mod"} = 1;
}
# This column had no value previously
} else {
# But it has a value now.
if ($col{"type"} != TYPE_NULL) {
$col{"mod"} = 1;
}
}
# No current value to compare with.
} else {
# Set it anyway
$col{"mod"} = 1;
}
}
# Check if we should set it
# Add this column
push @{$self->{"cols"}}, {%col};
return;
}
# addurl: Add a modified URL to the columns deposit,
# where "http://" also means empty
# Input: $name: The column name.
# $val: The column value.
# $curval: The current value to be compared.
sub addurl : method {
local ($_, %_);
my ($self, $name, $val, $curval, $cur_exists, %col);
($self, $name, $val, $curval) = @_;
$cur_exists = (scalar(@_) == 4);
$curval = decode("UTF-8", $curval, FB_CROAK) if !defined $DBH;
# Adjust the column name for multi-lingual columns
$name .= "_" . getlang LN_DATABASE
if in_array($name, @{$self->{"mlcols"}});
# The new column value
%col = qw();
$col{"name"} = $name;
$col{"mod"} = 0;
# No value is supplied
if (!defined $val || $val eq "" || $val eq "http://") {
$col{"type"} = TYPE_NULL;
$col{"value"} = undef;
# A valid value
} else {
$col{"type"} = TYPE_STR;
$col{"value"} = $val;
}
# Check if we should set it
if ($self->{"optype"} == ADDCOL_INSERT) {
# Always set the value for INSERT
$col{"mod"} = 1;
} else {
# A current value is supplied
if ($cur_exists) {
# This column had a value previously
if (defined $curval) {
# It has no value now. Remove it.
if ($col{"type"} == TYPE_NULL) {
$col{"mod"} = 1;
# A different new value. Modify it.
} elsif ($col{"value"} ne $curval) {
$col{"mod"} = 1;
}
# This column had no value previously
} else {
# But it has a value now.
if ($col{"type"} != TYPE_NULL) {
$col{"mod"} = 1;
}
}
# No current value to compare with.
} else {
# Set it anyway
$col{"mod"} = 1;
}
}
# Add this column
push @{$self->{"cols"}}, {%col};
return;
}
# addpass: Add a modified password to the columns deposit,
# where "" means "not changed". Passwords are never empty.
# Input: $name: The column name.
# $purge: If we should purge the password.
# $val: The column value.
# $curval: The current value to be compared.
sub addpass : method {
local ($_, %_);
my ($self, $name, $purge, $val, $curval, $cur_exists, %col);
($self, $name, $purge, $val, $curval) = @_;
$cur_exists = (@_ == 5);
$curval = decode("UTF-8", $curval, FB_CROAK) if !defined $DBH;
# Adjust the column name for multi-lingual columns
$name .= "_" . getlang LN_DATABASE
if in_array($name, @{$self->{"mlcols"}});
# The new column value
%col = qw();
$col{"name"} = $name;
$col{"mod"} = 0;
# Purge the password with a dummy one
if ($purge) {
$col{"type"} = TYPE_STR;
$col{"value"} = "x" x 32;
# No value is supplied
} elsif (!defined $val || $val eq "") {
$col{"type"} = TYPE_NULL;
$col{"value"} = undef;
# A valid value
} else {
$col{"type"} = TYPE_STR;
%_ = map { ${$_}{"name"} => $_ } @{$self->{"cols"}};
$col{"value"} = md5_hex(${$_{"id"}}{"value"} . ":magicat:" . $val);
}
# Check if we should set it
if ($self->{"optype"} == ADDCOL_INSERT) {
# Always set the value for INSERT
$col{"mod"} = 1;
} else {
# A current value is supplied
if ($cur_exists) {
# A different new value. Modify it.
if ($col{"type"} != TYPE_NULL && $col{"value"} ne $curval) {
$col{"mod"} = 1;
}
# No current value to compare with.
} else {
# Set it anyway
$col{"mod"} = 1;
}
}
# Add this column
push @{$self->{"cols"}}, {%col};
return;
}
# addpic: Add a picture to the columns deposit
# Input: $name: The column name.
# $val: The column value.
# $curval: The current value to be compared.
sub addpic : method {
local ($_, %_);
my ($self, $name, $val, $curval, $cur_exists, %col, $PICS);
($self, $name, $val, $curval) = @_;
$cur_exists = (scalar(@_) == 4);
$curval = decode("UTF-8", $curval, FB_CROAK) if !defined $DBH;
$PICS = pic_deposit;
# Set the 3rd argument as the current value
if ($cur_exists) {
# Get the picture content
$curval = ${$$PICS{$curval}}{"content"}
if defined $curval;
}
# Adjust the column name for multi-lingual columns
$name .= "_" . getlang LN_DATABASE
if in_array($name, @{$self->{"mlcols"}});
# The new column value
%col = qw();
$col{"name"} = $name;
$col{"mod"} = 0;
# No value is supplied
if (!defined $val) {
$col{"type"} = TYPE_NULL;
$col{"value"} = undef;
# A valid value
} else {
$col{"type"} = TYPE_FILE;
$col{"value"} = ${$$PICS{$val}}{"content"}
}
# Check if we should set it
if ($self->{"optype"} == ADDCOL_INSERT) {
# Always set the value for INSERT
$col{"mod"} = 1;
} else {
# A current value is supplied
if ($cur_exists) {
# This column had a value previously
if (defined $curval) {
# It has no value now. Remove it.
if ($col{"type"} == TYPE_NULL) {
$col{"mod"} = 1;
# A different new value. Modify it.
} elsif ($col{"value"} ne $curval) {
$col{"mod"} = 1;
}
# This column had no value previously
} else {
# But it has a value now.
if ($col{"type"} != TYPE_NULL) {
$col{"mod"} = 1;
}
}
# No current value to compare with.
} else {
# Set it anyway
$col{"mod"} = 1;
}
}
# Add this column
push @{$self->{"cols"}}, {%col};
return;
}
# addnum: Add a modified numeric column to the columns deposit
# Input: $name: The column name.
# $val: The column value.
# $curval: The current value to be compared.
sub addnum : method {
local ($_, %_);
my ($self, $name, $val, $curval, $cur_exists, %col);
($self, $name, $val, $curval) = @_;
$cur_exists = (scalar(@_) == 4);
$curval = decode("UTF-8", $curval, FB_CROAK) if !defined $DBH;
# Adjust the column name for multi-lingual columns
$name .= "_" . getlang LN_DATABASE
if in_array($name, @{$self->{"mlcols"}});
# The new column value
%col = qw();
$col{"name"} = $name;
$col{"mod"} = 0;
# No value is supplied
if (!defined $val || $val eq "") {
$col{"type"} = TYPE_NULL;
$col{"value"} = undef;
# A valid value
} else {
$col{"type"} = TYPE_NUM;
$col{"value"} = $val;
}
# Check if we should set it
if ($self->{"optype"} == ADDCOL_INSERT) {
# Always set the value for INSERT
$col{"mod"} = 1;
} else {
# A current value is supplied
if ($cur_exists) {
# This column had a value previously
if (defined $curval) {
# It has no value now. Remove it.
if ($col{"type"} == TYPE_NULL) {
$col{"mod"} = 1;
# A different new value. Modify it.
} elsif ($col{"value"} != $curval) {
$col{"mod"} = 1;
}
# This column had no value previously
} else {
# But it has a value now.
if ($col{"type"} != TYPE_NULL) {
$col{"mod"} = 1;
}
}
# No current value to compare with.
} else {
# Set it anyway
$col{"mod"} = 1;
}
}
# Add this column
push @{$self->{"cols"}}, {%col};
return;
}
# adddate: Add a modified date column to the columns deposit
# Mostly the same as addstr(). Different when out.
# Input: $name: The column name.
# $val: The column value.
# $curval: The current value to be compared.
sub adddate : method {
local ($_, %_);
my ($self, $name, $val, $curval, $cur_exists, %col);
($self, $name, $val, $curval) = @_;
$cur_exists = (scalar(@_) == 4);
$curval = decode("UTF-8", $curval, FB_CROAK) if !defined $DBH;
# Adjust the column name for multi-lingual columns
$name .= "_" . getlang LN_DATABASE
if in_array($name, @{$self->{"mlcols"}});
# The new column value
%col = qw();
$col{"name"} = $name;
$col{"mod"} = 0;
# No value is supplied
if (!defined $val || $val eq "") {
$col{"type"} = TYPE_NULL;
$col{"value"} = undef;
# A valid value
} else {
$col{"type"} = TYPE_DATE;
$col{"value"} = $val;
}
# Check if we should set it
if ($self->{"optype"} == ADDCOL_INSERT) {
# Always set the value for INSERT
$col{"mod"} = 1;
} else {
# A current value is supplied
if ($cur_exists) {
# This column had a value previously
if (defined $curval) {
# It has no value now. Remove it.
if ($col{"type"} == TYPE_NULL) {
$col{"mod"} = 1;
# A different new value. Modify it.
} elsif (str2time($col{"value"}) != $curval) {
$col{"mod"} = 1;
}
# This column had no value previously
} else {
# But it has a value now.
if ($col{"type"} != TYPE_NULL) {
$col{"mod"} = 1;
}
}
# No current value to compare with.
} else {
# Set it anyway
$col{"mod"} = 1;
}
}
# Add this column
push @{$self->{"cols"}}, {%col};
return;
}
# addipaddr: Add a modified IP address column to the columns deposit
# Mostly the same as addstr(). Different when out.
# Input: $name: The column name.
# $val: The column value.
# $curval: The current value to be compared.
sub addipaddr : method {
local ($_, %_);
my ($self, $name, $val, $curval, $cur_exists, %col);
($self, $name, $val, $curval) = @_;
$cur_exists = (scalar(@_) == 4);
$curval = decode("UTF-8", $curval, FB_CROAK) if !defined $DBH;
# Adjust the column name for multi-lingual columns
$name .= "_" . getlang LN_DATABASE
if in_array($name, @{$self->{"mlcols"}});
# The new column value
%col = qw();
$col{"name"} = $name;
$col{"mod"} = 0;
# No value is supplied
if (!defined $val || $val eq "") {
$col{"type"} = TYPE_NULL;
$col{"value"} = undef;
# A valid value
} else {
$col{"type"} = TYPE_IPADDR;
$col{"value"} = $val;
}
# Check if we should set it
if ($self->{"optype"} == ADDCOL_INSERT) {
# Always set the value for INSERT
$col{"mod"} = 1;
} else {
# A current value is supplied
if ($cur_exists) {
# This column had a value previously
if (defined $curval) {
# It has no value now. Remove it.
if ($col{"type"} == TYPE_NULL) {
$col{"mod"} = 1;
# A different new value. Modify it.
} elsif ($col{"value"} ne $curval) {
$col{"mod"} = 1;
}
# This column had no value previously
} else {
# But it has a value now.
if ($col{"type"} != TYPE_NULL) {
$col{"mod"} = 1;
}
}
# No current value to compare with.
} else {
# Set it anyway
$col{"mod"} = 1;
}
}
# Add this column
push @{$self->{"cols"}}, {%col};
return;
}
# addbool: Add a modified boolean column to the columns deposit
# Input: $name: The column name.
# $val: The column value.
# $curval: The current value to be compared.
sub addbool : method {
local ($_, %_);
my ($self, $name, $val, $curval, $cur_exists, %col);
($self, $name, $val, $curval) = @_;
$cur_exists = (scalar(@_) == 4);
$curval = decode("UTF-8", $curval, FB_CROAK) if !defined $DBH;
# Adjust the column name for multi-lingual columns
$name .= "_" . getlang LN_DATABASE
if in_array($name, @{$self->{"mlcols"}});
# The new column value
%col = qw();
$col{"name"} = $name;
$col{"mod"} = 0;
# No value supplied means "false"
$col{"type"} = TYPE_BOOL;
$col{"value"} = defined $val && $val;
# Check if we should set it
if ($self->{"optype"} == ADDCOL_INSERT) {
# Always set the value for INSERT
$col{"mod"} = 1;
} else {
# A current value is supplied
if ($cur_exists) {
# This column is previously true
if ($curval) {
# New value is false. Disable it.
if (!$col{"value"}) {
$col{"mod"} = 1;
}
# The current value is false
} else {
# But it is true now.
if ($col{"value"}) {
$col{"mod"} = 1;
}
}
# No current value to compare with.
} else {
# Set it anyway
$col{"mod"} = 1;
}
}
# Add this column
push @{$self->{"cols"}}, {%col};
return;
}
# addexpr: Add a expression column value to the columns deposit
# Input: $name: The column name.
# $val: The column value.
sub addexpr : method {
local ($_, %_);
my ($self, $name, $val, %col);
($self, $name, $val) = @_;
# Adjust the column name for multi-lingual columns
$name .= "_" . getlang LN_DATABASE
if in_array($name, @{$self->{"mlcols"}});
# The new column value
# Always set it, since it is not possible to compare the current value
%col = qw();
$col{"name"} = $name;
$col{"mod"} = 1;
$col{"type"} = TYPE_EXPR;
$col{"value"} = $val;
# Add this column
push @{$self->{"cols"}}, {%col};
return;
}
# modified: Return if this record is modified
sub modified : method {
local ($_, %_);
my $self;
$self = $_[0];
# Find any column that is modified
foreach my $col (@{$self->{"cols"}}) {
return 1 if ${$col}{"mod"};
}
return 0;
}
# ret: Retrieve the columns deposit as an SQL statement
# Input: $timestamp: Whether we should record timestamps or not
# Log in forms should not update their timestamps.
# Output: An SQL statement in the corresponding query type.
sub ret : method {
local ($_, %_);
my ($self, $timestamp);
($self, $timestamp) = @_;
$timestamp = 1 if !defined $timestamp;
# Set the login user
if ($timestamp) {
$self->{"login"} = get_login_sn
if !exists $self->{"login"};
}
if ($self->{"optype"} == ADDCOL_INSERT) {
my (@names, @vals);
@names = qw();
@vals = qw();
foreach my $col (@{$self->{"cols"}}) {
# Skip columns that are not modified
next unless ${$col}{"mod"};
push @names, $DBH->quote_identifier(${$col}{"name"});
push @vals, valout_sql($col);
}
# Add the timestamp
if ($timestamp) {
if (in_array("created", @{$self->{"allcols"}})) {
push @names, $DBH->quote_identifier("created");
push @vals, "now()";
}
if (in_array("createdby", @{$self->{"allcols"}})) {
push @names, $DBH->quote_identifier("createdby");
push @vals, $self->{"login"};
}
if (in_array("updated", @{$self->{"allcols"}})) {
push @names, $DBH->quote_identifier("updated");
push @vals, "now()";
}
if (in_array("updatedby", @{$self->{"allcols"}})) {
push @names, $DBH->quote_identifier("updatedby");
push @vals, $self->{"login"};
}
}
# Decode from UTF-8, for easier post-processing
return decode("UTF-8", "(" . join(", ", @names) . ")"
. " VALUES (" . join(", ", @vals) . ")");
} else {
my @phrases;
@phrases = qw();
foreach my $col (@{$self->{"cols"}}) {
# Skip columns that are not modified
next unless ${$col}{"mod"};
push @phrases, $DBH->quote_identifier(${$col}{"name"}) . "="
. valout_sql($col);
}
# Add the timestamp
if ($timestamp) {
if (in_array("updated", @{$self->{"allcols"}})) {
push @phrases, $DBH->quote_identifier("updated") . "=now()";
}
if (in_array("updatedby", @{$self->{"allcols"}})) {
$_ = get_login_sn;
$_ = $POST->param("sn") if !defined $_;
push @phrases, $DBH->quote_identifier("updatedby") . "=$_";
}
}
# Decode from UTF-8, for easier post-processing
return decode("UTF-8", "SET " . join(", ", @phrases));
}
}
# retxml: Retrieve the columns deposit as an XML record.
# Input: None.
# Output: An XML record.
sub retxml : method {
local ($_, %_);
my ($self, @vals, $user);
$self = $_[0];
# XML has no engine. Output the whole record anyway,
# no matter updated or not.
@vals = map valout_xml($_), @{$self->{"cols"}};
# Add the updated information
if ($self->{"optype"} == ADDCOL_UPDATE) {
$user = (exists $ENV{"REMOTE_USER"} && $ENV{"REMOTE_USER"} ne "")?
$ENV{"REMOTE_USER"}: "(" . $ENV{"REMOTE_ADDR"} . ")";
push @vals, "<col name=\"updated\" type=\"date\">" . h(fmttime) . "</col>\n";
push @vals, "<col name=\"updatedby\">" . h($user) . "</col>\n";
}
return encode("UTF-8", "<record>\n" . join("", @vals) . "</record>\n", FB_CROAK);
}
# retcsv: Retrieve the columns deposit as a CSV row.
# Input: None.
# Output: A CSV row.
sub retcsv : method {
local ($_, %_);
my $self;
$self = $_[0];
# CSV has no engine. Output the whole record anyway,
# no matter updated or not.
return join(",", map valout_csv($_), @{$self->{"cols"}}) . "\n";
}
###########################
# Private subroutines, not to be called as methods
###########################
# valout_sql: Output a value in a proper SQL format.
sub valout_sql($) {
local ($_, %_);
my ($col, $val);
$col = $_[0];
# Encode first. $DBH->quote() does encode() anyway
if (defined $$col{"value"}) {
$val = $$col{"value"};
$val = encode("UTF-8", $val) if is_utf8($val);
}
return "NULL"
if $$col{"type"} == TYPE_NULL;
return $val
if $$col{"type"} == TYPE_NUM;
return $DBH->quote($val)
if $$col{"type"} == TYPE_STR;
return "'" . $val . "'"
if $$col{"type"} == TYPE_DATE;
return $DBH->quote_blob($val)
if $$col{"type"} == TYPE_FILE;
return "'" . $val . "'"
if $$col{"type"} == TYPE_IPADDR;
return $val? "TRUE": "FALSE"
if $$col{"type"} == TYPE_BOOL;
return $val
if $$col{"type"} == TYPE_EXPR;
}
# valout_xml: Output a value in a proper XML format.
sub valout_xml($) {
local ($_, %_);
$_ = $_[0];
return ""
if $$_{"type"} == TYPE_NULL;
return "<col name=\"" . h($$_{"name"}) . "\">"
. h($$_{"value"}) . "</col>\n"
if $$_{"type"} == TYPE_NUM;
return "<col name=\"" . h($$_{"name"}) . "\">"
. h($$_{"value"}) . "</col>\n"
if $$_{"type"} == TYPE_STR;
return "<col name=\"" . h($$_{"name"}) . "\" type=\"date\">"
. h(fmttime $$_{"value"}) . "</col>\n"
if $$_{"type"} == TYPE_DATE;
return "<col name=\"" . h($$_{"name"}) . "\">"
. h(fmttime $$_{"value"}) . "</col>\n"
if $$_{"type"} == TYPE_FILE;
return "<col name=\"" . h($$_{"name"}) . "\">"
. h($$_{"value"}) . "</col>\n"
if $$_{"type"} == TYPE_IPADDR;
return "<col name=\"" . h($$_{"name"}) . "\">"
. h($$_{"value"}? "TRUE": "FALSE") . "</col>\n"
if $$_{"type"} == TYPE_BOOL;
# XML has no engine. The following is emulated.
if ($$_{"type"} == TYPE_EXPR) {
return "<col name=\"" . h($$_{"name"}) . "\" type=\"date\">"
. h(fmttime) . "</col>\n"
if lc $$_{"value"} eq "now" || lc $$_{"value"} eq "now()";
}
}
# valout_csv: Output a value in a proper CSV format.
sub valout_csv($) {
local ($_, %_);
$_ = $_[0];
return "NULL"
if $$_{"type"} == TYPE_NULL;
return $$_{"value"}
if $$_{"type"} == TYPE_NUM;
if ($$_{"type"} == TYPE_STR) {
$_ = $$_{"value"};
s/\\/\\\\/g;
s/"/\\"/g;
s/\n/\\n/g;
s/\r/\\r/g;
s/\t/\\t/g;
s/\0/\\0/g;
return "\"" . $_ . "\"";
}
return "\"" . $$_{"value"} . "\""
if $$_{"type"} == TYPE_DATE;
return "\"" . $$_{"value"} . "\""
if $$_{"type"} == TYPE_IPADDR;
return $$_{"value"}? "TRUE": "FALSE"
if $$_{"type"} == TYPE_BOOL;
# CSV has no engine. The following is emulated.
if ($$_{"type"} == TYPE_EXPR) {
return "\"" . fmttime() . "\""
if $$_{"value"} =~ /^now(?:\(\))?$/i;
}
}
return 1;

101
lib/perl5/Selima/AddGet.pm Normal file
View File

@@ -0,0 +1,101 @@
# Selima Website Content Management System
# AddGet.pm: The subroutines to manipulate the arguments in an URL.
# 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-30
package Selima::AddGet;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(DUP_OK DUP_NO add_get_arg rem_get_arg);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub add_get_arg($$$;$);
sub rem_get_arg($@);
}
use URI::Escape qw(uri_escape);
# Constant symbols
use constant DUP_OK => 1;
use constant DUP_NO => 0;
# add_get_arg: Add a get argument to the end of an url
sub add_get_arg($$$;$) {
local ($_, %_);
my ($url, $name, $value, $if_dup, $script);
($url, $name, $value, $if_dup) = @_;
$if_dup = DUP_NO if !defined $if_dup;
# Escape the name and value first
$name = uri_escape($name);
$value = uri_escape($value);
# No current arguments are appended yet
return "$url?$name=$value" if $url !~ /\?/;
# It is OK to have duplicated same arguments
return "$url&$name=$value" if $if_dup == DUP_OK;
# Have arguments already. We need to check if there is already
# a duplicated one and replace it if exists.
# Split the arguments
$url =~ /^(.*?)\?(.*)$/;
($script, $_) = ($1, $2);
@_ = split /&/, $_;
# Remove the matched ones
@_ = grep !/^$name=/, @_;
# Add our argument
push @_, "$name=$value";
return "$script?" . join("&", @_);
}
# rem_get_arg: Remove a get argument from the end of an url
sub rem_get_arg($@) {
local ($_, %_);
my ($url, @names, $script, $name);
($url, @names) = @_;
# No current arguments are appended yet
return $url if $url !~ /\?/;
# Escape the names
for ($_ = 0; $_ < @names; $_++) {
# Encode the name first
$names[$_] = uri_escape($names[$_]);
}
# Have arguments already. We need to check if there is already
# a duplicated one and remove it if exists.
# Split the arguments
$url =~ /^(.*?)\?(.*)$/;
($script, $_) = ($1, $2);
@_ = split /&/, $_;
# Check one by one
foreach $name (@names) {
@_ = grep !/^$name=/, @_;
}
# No arguments left
return $script if scalar(@_) == 0;
return "$script?" . join("&", @_);
}
return 1;

145
lib/perl5/Selima/AltLang.pm Normal file
View File

@@ -0,0 +1,145 @@
# Selima Website Content Management System
# AltLang.pm: The subroutines to obtain the URLs of the alternative language versions.
# 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-04-03
package Selima::AltLang;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(altlang set_altlang_urls);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub altlang($$);
sub set_altlang_urls($);
}
use Data::Dumper qw();
use URI::Escape qw(uri_escape);
use Selima::AddGet;
use Selima::DataVars qw(:input :lninfo :requri);
use Selima::EchoForm;
use Selima::LnInfo;
use Selima::Session;
use Selima::Unicode;
use vars qw(%ALT_LANG %IS_SCRIPT);
# altlang: Obtain the URL of an alternative language version
sub altlang($$) {
local ($_, %_);
my ($lang, $args);
($lang, $args) = @_;
set_altlang_urls $args;
# Return it
return ${$$args{"altlang"}}{$lang};
}
# set_altlang_urls: Set the URLs of the language variants
sub set_altlang_urls($) {
local ($_, %_);
my ($args, $path, $langfile, %urls);
my ($args0, @argkeys0, $need_charset);
$args = $_[0];
# Return if already obtained
return if exists $$args{"altlang"};
# Set the page path
$path = $$args{"path"};
$path .= "index.html" if $path =~ /\/$/;
# Set the URL parameter
if ($$args{"static"}) {
$langfile = ln $$args{"lang"}, LN_FILENAME;
$path =~ s/\.$langfile$//;
$path .= ".%s";
} else {
#$args0 = $USER_INPUT{"GET_UTF8"};
eval Data::Dumper->Dump([$USER_INPUT{"GET_UTF8"}], [qw($args0)]);
@argkeys0 = @{$USER_INPUT{"GET_KEYS"}};
%_ = map { $_ => 1 } @argkeys0;
# Whether we need to specify the character set
$need_charset = !is_usascii_printable($args0->Vars);
# Remove the session ID
if (exists $_{$Selima::Session::NAME}) {
$args0->delete($Selima::Session::NAME);
@argkeys0 = grep $_ ne $Selima::Session::NAME, @argkeys0;
}
# Non-ASCII -- specify the character set
if ($need_charset) {
if (!exists $_{"charset"}) {
$args0->param("charset", "");
push @argkeys0, "charset";
}
# US-ASCII -- we do not need to specify the character set
} else {
if (exists $_{"charset"}) {
$args0->delete("charset");
@argkeys0 = grep $_ ne "charset", @argkeys0;
}
}
# Append the referer
if (auto_keep_referer) {
$args0->param("referer", $ENV{"HTTP_REFERER"});
push @argkeys0, "referer";
}
# Append the language
if (!exists $_{"lang"}) {
$args0->param("lang", "");
push @argkeys0, "lang";
}
}
# Deal with each language
%urls = qw();
foreach my $lang (@{$$args{"all_linguas"}}) {
if ($$args{"static"}) {
$urls{$lang} = sprintf $path, ln($lang, LN_FILENAME);
} else {
my ($args1, @argkeys1, $charset1);
# Make a copy of the variables
eval Data::Dumper->Dump([$args0], [qw($args1)]);
@argkeys1 = @argkeys0;
$charset1 = ln $lang, LN_CHARSET;
$args1->param("lang", $lang);
@_ = qw();
# We need to specify the character set
$args1->param("charset", $charset1)
if $need_charset;
foreach (@argkeys1) {
foreach my $val ($args1->param($_)) {
push @_, uri_escape(h_encode($_, $charset1))
. "=" . uri_escape(h_encode($val, $charset1))
}
}
$urls{$lang} = $REQUEST_FILE . "?" . join "&", @_;
}
$urls{$lang} = $urls{$lang};
}
# Record it
$$args{"altlang"} = \%urls;
return;
}
return 1;

84
lib/perl5/Selima/Array.pm Normal file
View File

@@ -0,0 +1,84 @@
# Selima Website Content Management System
# Array.pm: The array-related subroutines.
# 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-09-12
package Selima::Array;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(in_array keys_ml keys_nl);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub in_array($@);
sub keys_ml(\%);
sub keys_nl(\%);
}
use Selima::DataVars qw(:lninfo);
use Selima::GetLang;
# in_array: If something is in an array
sub in_array($@) {
local ($_, %_);
my ($item, @array);
($item, @array) = @_;
%_ = map { $_ => 1 } @array;
return exists $_{$item};
}
# keys_ml: Return a list of multi-lingual keys in a hash
sub keys_ml(\%) {
local ($_, %_);
my ($hash, $lndb);
$hash = $_[0];
$lndb = getlang LN_DATABASE;
@_ = qw();
foreach (keys %$hash) {
# it has a language suffix
push @_, $_ if s/_$lndb$//;
}
return @_;
}
# keys_nl: Return a list of keys without their multi-lingual in a hash
sub keys_nl(\%) {
local ($_, %_);
my ($hash, %mlkeys);
$hash = $_[0];
%mlkeys = map { $_ => 1 } keys_ml %$hash;
%_ = qw();
foreach (keys %$hash) {
# No suffix
if (!/^(.+)_[^_]+$/) {
$_{$_} = 1;
# The prefix is one of the language columns
} elsif (exists $mlkeys{$1}) {
$_{$1} = 1;
# An ordinary prefix
} else {
$_{$_} = 1;
}
}
return keys %_;
}
return 1;

152
lib/perl5/Selima/AuthDig.pm Normal file
View File

@@ -0,0 +1,152 @@
# Selima Website Content Management System
# AuthDig.pm: The mod_perl HTTP digest authentication handler.
# 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-09-12
package Selima::AuthDig;
use 5.008;
use strict;
use warnings;
use Apache::AuthDigest::API qw();
use CGI qw();
use Fcntl qw(:flock);
use File::Spec::Functions qw(catfile);
use Selima::Checker::LogIn;
use Selima::DataVars qw($AUTHINFO $IS_MP2 :db :input);
use Selima::DBI;
use Selima::HTTP;
use Selima::Init;
use Selima::LogIn;
use Selima::Session;
BEGIN {
if ($IS_MP2) {
require Apache2::Const;
import Apache2::Const qw(OK AUTH_REQUIRED);
} else {
require Apache::Constants;
import Apache::Constants qw(OK AUTH_REQUIRED);
}
}
# Full HTTP Digest Authentication is specified in RFC 2617
# handler: Handle the HTTP digest authentication
sub handler {
local ($_, %_);
my ($r, $rd, $d, $status, $response, $pkg);
my ($form, $checker);
$r = $_[0];
$rd = Apache::AuthDigest::API->new($r);
$d = new Selima::AuthDig::Destroy($rd);
# Retrieve the authentication information
($status, $response) = $rd->get_digest_auth_response;
# No authentication information available
return $status unless $status == OK;
# Initialize the environemnt
$pkg = $r->dir_config("PACKAGE");
initvars($pkg);
# Logged out
if ( defined($_ = $GET->param("logout"))
&& -e ($_ = catfile($Selima::Session::DIR, "logout_$_"))) {
unlink $_;
$rd->note_digest_auth_failure;
return AUTH_REQUIRED;
}
# Connect to the database
$DBH = Selima::DBI->new($DBI_TYPE);
%_ = ("users" => LOCK_EX, "groups" => LOCK_SH, "usermem" => LOCK_SH);
$DBH->lock(%_);
# Check the password digest
$form = new CGI("");
$form->param("id", $rd->user);
$checker = new Selima::Checker::LogIn($form);
$checker->{"rd"} = $rd;
$checker->{"response"} = $response;
$checker->{"login"} = 1;
$_ = $checker->check(qw(id authdig));
# Failed
if (defined $_) {
$rd->note_digest_auth_failure;
return AUTH_REQUIRED;
}
# Let $d->DESTROY release the database lock
# We do not update user information here. Updating user information
# requires initiating the session and set the session cookie SID.
# But cookies cannot be set under HTTP 304 Not Modified. We are
# protecting the whole directory, where there are a lot of static
# contents, including the Magicat home index.html. HTTP 304 occurs
# all the time, from the beginning of Magicat home entrance.
# Failing to set session cookie SID causes new sessions be
# reinitialited for every request. The user visits accounting
# would become non-sense. That accounting is important!
# We update user information at the script executing phrase, where
# we have more control over the output, including the cookies
# and the HTTP 304 status.
$AUTHINFO = $checker->{"row"};
return OK;
}
# Selima::AuthDig::Destroy: Object to remove program data
package Selima::AuthDig::Destroy;
use 5.008;
use strict;
use warnings;
use Selima::DataVars qw($DBH);
# new: Initialize the destroyer
sub new : method {
local ($_, %_);
my ($class, $rd, $self);
($class, $rd) = @_;
$self = bless {}, $class;
$self->{"rd"} = $rd;
return $self;
}
# DESTROY: Release the acquired locks
sub DESTROY : method {
local ($_, %_);
my ($self, $rd, $headers);
$self = $_[0];
$rd = $self->{"rd"};
# Disconnect database handle
if (defined $DBH) {
$DBH->disconnect;
undef $DBH;
}
# Destroy myself
$self->SUPER::DESTROY if $self->can("SUPER::DESTROY");
# I cannot really undefine myself ($_[0]) after all
return;
}
return 1;

168
lib/perl5/Selima/Cache.pm Normal file
View File

@@ -0,0 +1,168 @@
# Selima Website Content Management System
# Cache.pm: The data cache.
# 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::Cache;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT %EXPORT_TAGS @EXPORT_OK);
BEGIN {
@EXPORT = qw();
%EXPORT_TAGS = (
account => [qw(%Account_acctsubj_title %Account_acctsubj_code
%Account_acctsubj_sn %Account_accttrx_id %Account_accttrx_maxord)],
callform=> [qw($CallForm_form_this %Callform_retrieve_form)],
chkfunc => [qw(%ChkFunc_check_script %ChkFunc_is_url_reachable)],
chkpriv => [qw(%ChkPriv_is_admin %ChkPriv_is_su
%ChkPriv_user_parent_groups)],
copyyear=> [qw($CopyYear_copyyear)],
country => [qw(%Country_ctname)],
echoform=> [qw(%EchoForm_opt_list)],
formfunc=> [qw($FormFunc_get_or_post $FormFunc_curform $FormFunc_isform
$FormFunc_formtype)],
getlang => [qw($GetLang_lang $GetLang_charset @GetLang_all_charsets)],
guest => [qw(%Guest_is_guest)],
links => [qw(%Links_linkcat_title %Links_link_title %Links_link_url
%Links_link_tree %Links_link_tree_full)],
listfunc=> [qw($ListFunc_listtype)],
login => [qw($LogIn_use_users)],
https => [qw($HTTPS_https_process $HTTPS_fqdn)],
mail => [qw(%Mail_MSGIDS)],
picture => [qw(%Picture_pic_deposit)],
remohost=> [qw($RemoHost_remote)],
scptpriv=> [qw(%ScptPriv_is_script_permitted %ScptPriv_is_admin_script)],
setl10n => [qw(%SetL10N_checked)],
username=> [qw(%UserName_username %UserName_userid %UserName_groupid
%UserName_groupdsc %UserName_groupsn $UserName_su_group_sn)],
userpref=> [qw(%UserPref_userpref)],
);
@EXPORT_OK = qw();
my %seen;
%seen = qw();
foreach my $tag (keys %EXPORT_TAGS) {
push @EXPORT_OK, grep !$seen{$_}++, @{$EXPORT_TAGS{$tag}};
}
# Prototype declaration
sub clear();
}
use vars qw(%Account_acctsubj_title %Account_acctsubj_code);
use vars qw(%Account_acctsubj_sn %Account_accttrx_id);
use vars qw(%Account_accttrx_maxord);
use vars qw($CallForm_form_this %Callform_retrieve_form);
use vars qw(%ChkFunc_check_script %ChkFunc_is_url_reachable);
use vars qw(%ChkPriv_is_admin %ChkPriv_is_su);
use vars qw(%ChkPriv_user_parent_groups);
use vars qw($CopyYear_copyyear);
use vars qw(%Country_ctname);
use vars qw(%EchoForm_opt_list);
use vars qw($FormFunc_get_or_post $FormFunc_curform $FormFunc_isform);
use vars qw($FormFunc_formtype);
use vars qw($GetLang_lang $GetLang_charset @GetLang_all_charsets);
use vars qw(%Guest_is_guest);
use vars qw(%Links_linkcat_title %Links_link_title %Links_link_url);
use vars qw(%Links_link_tree %Links_link_tree_full);
use vars qw($ListFunc_listtype);
use vars qw($LogIn_use_users);
use vars qw($HTTPS_https_process $HTTPS_fqdn);
use vars qw(%Mail_MSGIDS);
use vars qw(%Picture_pic_deposit);
use vars qw($RemoHost_remote);
use vars qw(%SetL10N_checked);
use vars qw(%ScptPriv_is_script_permitted %ScptPriv_is_admin_script);
use vars qw(%UserName_username %UserName_userid %UserName_groupid);
use vars qw(%UserName_groupdsc %UserName_groupsn $UserName_su_group_sn);
use vars qw(%UserPref_userpref);
# clear: Clear the cache (for mod_perl)
sub clear() {
local ($_, %_);
%Account_acctsubj_title = qw();
%Account_acctsubj_code = qw();
%Account_acctsubj_sn = qw();
%Account_accttrx_id = qw();
%Account_accttrx_maxord = qw();
undef $CallForm_form_this;
%Callform_retrieve_form = qw();
%ChkFunc_check_script = qw();
%ChkFunc_is_url_reachable = qw();
%ChkPriv_is_admin = qw();
%ChkPriv_is_su = qw();
%ChkPriv_user_parent_groups = qw();
undef $CopyYear_copyyear;
%Country_ctname = qw();
%EchoForm_opt_list = qw();
undef $FormFunc_get_or_post;
undef $FormFunc_curform;
undef $FormFunc_isform;
undef $FormFunc_formtype;
undef $GetLang_lang;
undef $GetLang_charset;
@GetLang_all_charsets = qw();
%Guest_is_guest = qw();
%Links_linkcat_title = qw();
%Links_link_title = qw();
%Links_link_url = qw();
%Links_link_tree = qw();
%Links_link_tree_full = qw();
undef $ListFunc_listtype;
undef $LogIn_use_users;
$HTTPS_https_process = 0;
undef $HTTPS_fqdn;
%Mail_MSGIDS = qw();
%Picture_pic_deposit = qw();
undef $RemoHost_remote;
%ScptPriv_is_script_permitted = qw();
%ScptPriv_is_admin_script = qw();
%SetL10N_checked = qw();
%UserName_username = qw();
%UserName_userid = qw();
%UserName_groupid = qw();
%UserName_groupdsc = qw();
%UserName_groupsn = qw();
undef $UserName_su_group_sn;
%UserPref_userpref = qw();
return;
}
return 1;

465
lib/perl5/Selima/CallForm.pm Normal file
View File

@@ -0,0 +1,465 @@
# Selima Website Content Management System
# CallForm.pm: The subroutines to transfer between a form and its subform.
# 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::CallForm;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw();
push @EXPORT, qw(call_form error_redirect success_redirect);
push @EXPORT, qw(suspend_form retrieve_form suspend_status retrieve_status);
push @EXPORT, qw(is_called_form form_this);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub call_form($;$$);
sub proc_status_redirect($);
sub error_redirect($);
sub success_redirect($);
sub suspend_form(;$);
sub retrieve_form(;$);
sub suspend_status($);
sub retrieve_status(;$);
sub is_called_form();
sub new_formid();
sub new_statid();
sub form_this();
}
use CGI qw();
use Data::Dumper qw();
use File::Spec::Functions qw(catfile);
use Fcntl qw(:flock);
use URI::Escape qw(uri_escape);
use Selima::AddGet;
use Selima::Cache qw(:callform);
use Selima::DataVars qw($SESSION :env :forms :requri :scptconf);
use Selima::FormFunc;
use Selima::HTTP;
use Selima::Session;
use Selima::XFileIO;
use vars qw(%SAVESTATS);
# Settings
# The length of the ID
use constant ID_LEN => 9;
# call_form: Suspend the current form and call another selection form
sub call_form($;$$) {
local ($_, %_);
my ($form, @args, $import_func, $FORM, $formid);
($form, $_, $import_func) = @_;
@args = defined $_? @$_: qw();
# Only work for defined forms
http_500 "Calling undefined form \"$form\".\n"
if !exists $SCRIPTS{$form};
# Record the selection import function
if (defined $import_func) {
# Obtain the form
$FORM = get_or_post;
$FORM->param("import_func", $import_func);
}
# Suspend the current form
$formid = suspend_form $FORM;
# Add the caller
$_ = $REQUEST_PATH;
$_ =~ s/^$ROOT_DIFF//;
push @args, "caller=" . uri_escape($_);
# Add the caller form ID
push @args, "cformid=" . uri_escape($formid);
# Redirect
http_303 $SCRIPTS{$form} . "?" . join("&", @args);
# No need to return
exit;
}
# proc_status_redirect: Save the form status, suspend and redirect the form
sub proc_status_redirect($) {
local ($_, %_);
my ($status, $url, $FORM, $formid, $statid, $method);
$status = $_[0];
# Obtain the form
$FORM = get_or_post;
# No more form
if ( defined $status
&& exists $$status{"isform"}
&& !$$status{"isform"}) {
# Find the referring script
# Specified
if (exists $$status{"nextstep"}) {
$url = $$status{"nextstep"};
} elsif (defined $FORM->param("referer2")) {
$url = $FORM->param("referer2");
# Back to the user home on the calling site
} elsif (defined $FORM->param("hostport")) {
# To be done
$url = $FORM->param("hostport") . "/magicat/";
# Default to the current URL
} else {
$url = $REQUEST_FILE;
}
# Do not affect the previous form
delete $$status{"isform"};
# Default to this same script
} else {
$url = form_this;
# Suspend the current form
$formid = suspend_form $FORM;
$url = add_get_arg $url, "formid", $formid;
}
# Add the status
if (defined $status) {
$statid = suspend_status $status;
$url = add_get_arg $url, "statid", $statid;
}
# Redirect
$method = $IS_MODPERL? ($IS_MP2?
Apache2::RequestUtil->request->method: Apache->request->method):
$ENV{"REQUEST_METHOD"};
if ($method eq "POST") {
http_303 $url;
} else {
http_307 $url;
}
# No need to return
exit;
}
# error_redirect: Shortcut to redirect the error form
sub error_redirect($) {
local ($_, %_);
my $status;
$status = $_[0];
$$status{"status"} = "error" if defined $status;
proc_status_redirect $status;
# No need to return
exit;
}
# success_redirect: Shortcut to redirect the success form
sub success_redirect($) {
local ($_, %_);
my $status;
$status = $_[0];
$$status{"status"} = "success" if defined $status;
proc_status_redirect $status;
# No need to return
exit;
}
# suspend_form: Suspend the current form
sub suspend_form(;$) {
local ($_, %_);
my ($FORM, $formid, $dumper, $origumask);
$FORM = $_[0];
# Obtain the form
$FORM = get_or_post if !defined $FORM;
# Using session is better
if (defined $SESSION) {
# Initialize the form deposit
$$SESSION{"saveforms"} = {}
if !exists $$SESSION{"saveforms"};
# Do not use existing form ID
$formid = new_formid;
# Save the current form
${$$SESSION{"saveforms"}}{$formid} = $FORM;
# Save the form ID
${$$SESSION{"saveforms"}}{$formid}->param("formid", $formid);
${$$SESSION{"saveforms"}}{$formid}->param("ownerscript", $REQUEST_PATH);
$SESSION->flush;
# Not using session
} else {
# Do not use existing form ID
$formid = new_formid;
# Dump the form
$dumper = new Data::Dumper([$FORM], [qw($_)]);
$dumper->Indent(1);
$dumper->Sortkeys(1);
$_ = $dumper->Dump;
# Write to the file
$origumask = umask 0077;
xfwrite(catfile($Selima::Session::DIR, "saveform_$formid"), $_);
umask $origumask;
}
return $formid;
}
# retrieve_form: Retrieve a previously suspended form
# Return empty array instead of empty, to be merged directly
sub retrieve_form(;$) {
local ($_, %_);
my ($formid, $CUR_FORM, $file, $cache);
$formid = $_[0];
$cache = \%Callform_retrieve_form;
# Return the cache
if (!defined $formid) {
# $cache[0] is the default (previous form)
return $$cache{0} if exists $$cache{0};
} else {
return $$cache{$formid} if exists $$cache{$formid};
}
# Using session is better
if (defined $SESSION) {
# Initialize the form deposit
if (!exists $$SESSION{"saveforms"}) {
$$SESSION{"saveforms"} = {};
if (!defined $formid) {
return ($$cache{0} = new CGI(""));
} else {
return ($$cache{$formid} = new CGI(""));
}
}
# Obtain the previous suspended form if form not specified
if (!defined $formid) {
# Obtain the form
$CUR_FORM = get_or_post;
# Return empty if not set
return ($$cache{0} = new CGI(""))
if !defined $CUR_FORM->param("formid");
$formid = $CUR_FORM->param("formid");
# There is no such previously suspended form
if (!exists ${$$SESSION{"saveforms"}}{$formid}) {
$$cache{$formid} = new CGI("");
$$cache{0} = $$cache{$formid};
return $$cache{0};
}
$$cache{$formid} = ${$$SESSION{"saveforms"}}{$formid};
$$cache{0} = $$cache{$formid};
} else {
# There is no such previously suspended form
return ($$cache{$formid} = new CGI(""))
if !exists ${$$SESSION{"saveforms"}}{$formid};
$$cache{$formid} = ${$$SESSION{"saveforms"}}{$formid};
}
# Not using session
} else {
# Obtain the previous suspended form if form not specified
if (!defined $formid) {
# Obtain the form
$CUR_FORM = get_or_post;
# Return empty if not set
return ($$cache{0} = new CGI(""))
if !defined $CUR_FORM->param("formid");
$formid = $CUR_FORM->param("formid");
# Compose the save form file name
$file = catfile($Selima::Session::DIR, "saveform_$formid");
# There is no such previously suspended form
if (!-f $file || !-r $file || !-s $file) {
$$cache{$formid} = new CGI("");
$$cache{0} = $$cache{$formid};
return $$cache{0};
}
$$cache{$formid} = eval xfread($file);
$$cache{0} = $$cache{$formid};
} else {
# Compose the save form file name
$file = catfile($Selima::Session::DIR, "saveform_$formid");
# There is no such previously suspended form
return ($$cache{$formid} = new CGI(""))
if !-f $file || !-r $file || !-s $file;
$$cache{$formid} = eval xfread($file);
}
}
# Import the selection if needed
&$_($$cache{$formid})
if defined($_ = $$cache{$formid}->param("import_func"))
&& defined($_ = $MAIN->can($_));
# Return the form
return $$cache{$formid};
}
# suspend_status: Suspend the current status
sub suspend_status($) {
local ($_, %_);
my ($status, $statid, $dumper, $origumask);
$status = $_[0];
# Using session is better
if (defined $SESSION) {
# Initialize the status deposit
$$SESSION{"savestats"} = {}
if !exists $$SESSION{"savestats"};
# Do not use existing status ID
$statid = new_statid;
# Save the current status
${$$SESSION{"savestats"}}{$statid} = $status;
# Save the status ID
${${$$SESSION{"savestats"}}{$statid}}{"statid"} = $statid;
${${$$SESSION{"savestats"}}{$statid}}{"ownerscript"} = $REQUEST_PATH;
$SESSION->flush;
# Not using session
} else {
# Do not use existing status ID
$statid = new_statid;
# Dump the status
$dumper = new Data::Dumper([$status], [qw($_)]);
$dumper->Indent(1);
$dumper->Sortkeys(1);
$_ = $dumper->Dump;
# Write to the file
$origumask = umask 0077;
xfwrite(catfile($Selima::Session::DIR, "savestat_$statid"), $_);
umask $origumask;
}
return $statid;
}
# retrieve_status: Retrieve a previously suspended status
# Return empty array instead of empty, to be merged directly
sub retrieve_status(;$) {
local ($_, %_);
my ($statid, $CUR_FORM, $file);
$statid = $_[0];
if (!defined $statid) {
# Obtain the form
$CUR_FORM = get_or_post;
# Return nothing if there is no status ID to retrieve
return if !defined $CUR_FORM->param("statid");
$statid = $CUR_FORM->param("statid");
}
# Using session is better
if (defined $SESSION) {
return if !exists $$SESSION{"savestats"};
return if !exists ${$$SESSION{"savestats"}}{$statid};
return ${$$SESSION{"savestats"}}{$statid};
# Not using session
} else {
# Compose the save status file name
$file = catfile($Selima::Session::DIR, "savestat_$statid");
# Check if this status is available
if (!-f $file || !-r $file || !-s $file) {
# Remove expired cache
delete $SAVESTATS{$file} if exists $SAVESTATS{$file};
return;
}
# Parse the status
$SAVESTATS{$statid} = eval xfread($file)
if !exists $SAVESTATS{$statid};
# Return the status
return $SAVESTATS{$statid};
}
}
# is_called_form: If this is a called form
sub is_called_form() {
local ($_, %_);
$_ = curform;
return (defined $_->param("caller") && defined $_->param("cformid"));
}
# new_formid: Generate a new random form ID number
sub new_formid() {
local ($_, %_);
my ($min, $max, $int, $formid);
$min = 10 ** (ID_LEN - 1); # 100000000
$max = (10 ** ID_LEN) - 1; # 999999999
$int = $max - $min + 1;
# Using session is better
if (defined $SESSION) {
do {
# Generate a random serial number
$formid = $min + int rand $int;
} until !exists ${$$SESSION{"saveforms"}}{$formid};
# Not using session
} else {
do {
# Generate a random serial number
$formid = $min + int rand $int;
} until !-e catfile($Selima::Session::DIR, "saveform_$formid");
}
return $formid;
}
# new_statid: Generate a new random status ID number
sub new_statid() {
local ($_, %_);
my ($min, $max, $int, $statid);
$min = 10 ** (ID_LEN - 1); # 100000000
$max = (10 ** ID_LEN) - 1; # 999999999
$int = $max - $min + 1;
# Using session is better
if (defined $SESSION) {
do {
# Generate a random serial number
$statid = $min + int rand $int;
} until !exists ${$$SESSION{"savestats"}}{$statid};
# Not using session
} else {
do {
# Generate a random serial number
$statid = $min + int rand $int;
} until !-e catfile($Selima::Session::DIR, "savestat_$statid");
}
return $statid;
}
# form_this: Find the processing script
sub form_this() {
local ($_, %_);
return $CallForm_form_this if defined $CallForm_form_this;
$_ = get_or_post;
return ($CallForm_form_this = $_)
if defined($_ = $_->param("referer"));
return ($CallForm_form_this = $REQUEST_FILE);
}
return 1;

800
lib/perl5/Selima/Checker.pm Normal file
View File

@@ -0,0 +1,800 @@
# Selima Website Content Management System
# Checker.pm: The base form checker.
# 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-09-25
package Selima::Checker;
use 5.008;
use strict;
use warnings;
use Encode::HanConvert qw(trad_to_simp simp_to_trad);
use Regexp::Common::URI::RFC2396 qw();
use URI::Escape qw(uri_escape);
use Selima::AddGet;
use Selima::Array;
use Selima::CallForm;
use Selima::ChkFunc;
use Selima::ChkWrite;
use Selima::DataVars qw($DBH FORM_CAPTCHA :dataman :forms :l10n
:lninfo :requri);
use Selima::FormFunc;
use Selima::GetLang;
use Selima::HTTP;
use Selima::LnInfo;
use Selima::Logging;
use Selima::Picture;
use Selima::ShortCut;
# Load these classes
use Selima::Checker::User;
use Selima::Checker::Group;
use Selima::Checker::UserMem;
use Selima::Checker::GroupMem;
use Selima::Checker::UserPref;
use Selima::Checker::ScptPriv;
use Selima::Checker::LogIn;
use Selima::Checker::ListPref;
use Selima::Checker::Guestbook;
use Selima::Checker::Guestbook::Public;
use Selima::Checker::Page;
use Selima::Checker::LinkCat;
use Selima::Checker::Link;
use Selima::Checker::LinkCatz;
use Selima::Checker::Rebuild;
use Selima::Checker::MailTo;
use Selima::Checker::AcctSubj;
use Selima::Checker::AcctTrx;
use Selima::Checker::AcctRec;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $form, $table, $checker);
($class, $form, $table) = @_;
$checker = bless {}, $class;
$checker->{"form"} = $form;
if (defined $table) {
$checker->{"table"} = $table;
$checker->{"maxlens"} = { $DBH->col_lens($table) };
}
$checker->{"minlens"} = {};
${$checker->{"minlens"}}{"id"} = 3;
$checker->{"iscur"} = (keys %CURRENT > 0)? 1: 0;
$checker->{"sn"} = $form->param("sn")
if $checker->{"iscur"} && defined $form->param("sn");
return $checker;
}
# check: Run a list of checks
sub check : method {
local ($_, %_);
my ($self, @cols, $error);
($self, @cols) = @_;
# Check the list itself first
@_ = qw();
foreach my $col (@cols) {
http_500 "Called an undefined check \"$col\""
if !defined($_ = $self->can("_check_$col"));
push @_, $_;
}
# Run each checker
foreach (@_) {
$error = &$_($self);
return $error if defined $error;
}
return;
}
# redir: Redirect to another form
sub redir : method {
local ($_, %_);
my ($self, @cols);
($self, @cols) = @_;
# Check the list itself first
@_ = qw();
foreach my $col (@cols) {
http_500 "Called an undefined redirection \"$col\""
if !defined($_ = $self->can("_redir_$col"));
push @_, $_;
}
# Check each redirection
&$_($self) foreach @_;
return;
}
#
# Private column checkers. Do not call them directly.
# Add or override the column checkers when needed.
# Method names must be in the following format:
# sub _check_{column} : method { ... }
# Columns started with underlines are reserved for internal use, as usual.
#
# _check_usr: The default user checker
sub _check_usr : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("usr");
return $error if defined $error;
# Regularize it
$self->_trim("usr");
# Check if it is filled
return {"msg"=>N_("Please select a user.")}
if $form->param("usr") eq "";
# Check if this user exists
return {"msg"=>N_("This user does not exist anymore. Please select another one.")}
if !check_sn_in ${$form->param_fetch("usr")}[0], "users";
# OK
return;
}
# _check_grp: The default group checker
sub _check_grp : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("grp");
return $error if defined $error;
# Regularize it
$self->_trim("grp");
# Check if it is filled
return {"msg"=>N_("Please select a group.")}
if $form->param("grp") eq "";
# Check if the group exists
return {"msg"=>N_("This group does not exist anymore. Please select another one.")}
if !check_sn_in ${$form->param_fetch("grp")}[0], "groups";
# OK
return;
}
# _check_script: The default script checker
sub _check_script : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("script");
return $error if defined $error;
# Regularize it
$self->_trim("script");
# Check if it is filled
return {"msg"=>N_("Please fill in the script.")}
if $form->param("script") eq "";
# Check the length
return {"msg"=>N_("This script is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"script"}]}
if length $form->param("script") > ${$self->{"maxlens"}}{"script"};
# Check if this script exists
return {"msg"=>N_("This script is not a valid script. Please specify another one.")}
if !check_script($form->param("script"));
# OK
return;
}
# _check_author: The default author checker
sub _check_author : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("author");
return $error if defined $error;
# Regularize it
$self->_trim("author");
# Check if it is filled
return {"msg"=>N_("Please fill in the author.")}
if $form->param("author") eq "";
# Check the length
return {"msg"=>N_("This author is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"author"}]}
if length $form->param("author") > ${$self->{"maxlens"}}{"author"};
# OK
return;
}
# _check_body: The default content body checker
sub _check_body : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("body");
return $error if defined $error;
# Regularize it
$self->_trimtext("body");
# Check if it is filled
$form->param("body", "")
if $form->param("body") eq C_("Fill in the content here.");
return {"msg"=>N_("Please fill in the content.")}
if $form->param("body") eq "";
# Check the length
return {"msg"=>N_("This content is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"body"}]}
if length $form->param("body") > ${$self->{"maxlens"}}{"body"};
# OK
return;
}
# _check_date: Check the date
sub _check_date : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("date");
return $error if defined $error;
# Regularize it
$self->_trim("date");
# Check if it is filled
return {"msg"=>N_("Please fill in a date.")}
if $form->param("date") eq "";
# Check the length
return {"msg"=>N_("Please fill in a valid date in YYYY-MM-DD format.")}
if length $form->param("date") > ${$self->{"maxlens"}}{"date"};
# Check the date format
return {"msg"=>N_("Please fill in a valid date in YYYY-MM-DD format.")}
if $form->param("date") !~ /^(\d{4})-(\d{2})-(\d{2})$/;
return {"msg"=>N_("Please fill in a valid date in YYYY-MM-DD format.")}
if !check_date $1, $2, $3;
# OK
return;
}
# _check_dsc: The default description checker
sub _check_dsc : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("dsc");
return $error if defined $error;
# Regularize it
$self->_trimtext("dsc");
# Check if it is filled
$form->param("dsc", "")
if $form->param("dsc") eq C_("Fill in the description here.");
return {"msg"=>N_("Please fill in the description.")}
if $form->param("dsc") eq "";
# Check the length
return {"msg"=>N_("This description is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"dsc"}]}
if length $form->param("dsc") > ${$self->{"maxlens"}}{"dsc"};
# OK
return;
}
# _check_id: The default ID. checker
sub _check_id : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("id");
return $error if defined $error;
# Regularize it
$self->_trim("id");
# Check if it is filled
return {"msg"=>N_("Please fill in the ID.")}
if $form->param("id") eq "";
# Check the length
return {"msg"=>N_("This ID. is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"id"}]}
if length $form->param("id") > ${$self->{"maxlens"}}{"id"};
return {"msg"=>N_("This ID. is too short. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"id"}]}
if length $form->param("id") < ${$self->{"minlens"}}{"id"};
# Check if the characters used are valid
return {"msg"=>N_("Only lower-case English letters, numbers and underscores are allowed for the ID.")}
unless $form->param("id") =~ /^[a-z][a-z0-9_]*$/;
# OK
return;
}
# _check_kw: The default keyword list checker
sub _check_kw : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("kw");
return $error if defined $error;
# Regularize it
$self->_trim("kw");
# Check if it is filled
return {"msg"=>N_("Please fill in the keywords.")}
if $form->param("kw") eq "";
# Check the length
return {"msg"=>N_("This keyword list is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"kw"}]}
if length $form->param("kw") > ${$self->{"maxlens"}}{"kw"};
# OK
return;
}
# _check_message: The default message checker
sub _check_message : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("message");
return $error if defined $error;
# Regularize it
$self->_trimtext("message");
# Check if it is filled
$form->param("message", "")
if $form->param("message") eq C_("Fill in the message here.");
return {"msg"=>N_("Please fill in the message.")}
if $form->param("message") eq "";
# Check the length
return {"msg"=>N_("This message is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"message"}]}
if length $form->param("message") > ${$self->{"maxlens"}}{"message"};
# OK
return;
}
# _check_ord: The default order checker
sub _check_ord : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("ord");
return $error if defined $error;
# Regularize it
$self->_trim("ord");
# Check if it is filled
return {"msg"=>N_("Please fill in the order.")}
if $form->param("ord") eq "";
# Check the length
return {"msg"=>N_("This order is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"ord"}]}
if length $form->param("ord") > ${$self->{"maxlens"}}{"ord"};
# Check if it is a valid positive integer
return {"msg"=>N_("Please fill in a positive integer order.")}
unless $form->param("ord") =~ /^\d+$/;
# Set to an integer
$_ = $form->param("ord");
$_ += 0;
$form->param("ord", $_);
# OK
return;
}
# _check_path: The default page path checker
sub _check_path : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("path");
return $error if defined $error;
# Regularize it
$self->_trim("path");
# Remove the trailing excess "index.html"
$_ = $form->param("path");
s/\/index\.html?$/\//;
$form->param("path", $_);
# Check if it is filled
return {"msg"=>N_("Please fill in the page path.")}
if $form->param("path") eq "";
# Check the length
return {"msg"=>N_("This page path is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"path"}]}
if length $form->param("path") > ${$self->{"maxlens"}}{"path"};
# Check if this item is duplicated
@_ = qw();
push @_, "path=" . $DBH->quote($form->param("path"));
push @_, "sn!=" . $self->{"sn"} if $self->{"iscur"};
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This page already exists. You cannot create a duplicated one.")}
if $sth->rows > 0;
# Check if the path is absolute
return {"msg"=>N_("Please fill in an absolute page path.")}
if $form->param("path") !~ /^\//;
# Check if the path is legal
return {"msg"=>N_("Please fill in a valid page path.")}
if $form->param("path") !~ /^\/$Regexp::Common::URI::RFC2396::path_segments$/;
# Check if it is the cover home page
return {"msg"=>N_("You cannot overwrite the cover home page.")}
if $form->param("path") eq "";
# Check if it is *.html
return {"msg"=>N_("You can only fill in an HTML page path (*.html).")}
if $form->param("path") !~ /(?:\/|\.html)$/;
# Check if we are permitted to write files there
if (@ALL_LINGUAS > 1) {
$_ = $DOC_ROOT . $form->param("path");
$_ =~ s/\/$/\/index.html/;
$_ .= ".%s.xhtml";
foreach my $ln (@ALL_LINGUAS) {
$error = check_writable sprintf $_, ln $ln, LN_FILENAME;
return $error if defined $error;
}
} else {
$error = check_writable $DOC_ROOT . $form->param("path") . ".xhtml";
return $error if defined $error;
}
# OK
return;
}
# _check_pic: The default picture checker
sub _check_pic : method {
local ($_, %_);
my ($self, $form, $error, $PICS);
$self = $_[0];
$form = $self->{"form"};
# Skip if there is no picture to check
return if $self->_missing("pic");
# Check if this picture exists
return {"msg"=>N_("This picture does not exist anymore. Please upload another one.")}
if !pic_exists ${$form->param_fetch("pic")}[0];
# Check the length
$PICS = pic_deposit;
return {"msg"=>N_("This picture is too large. Please upload another one. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"pic"}]}
if length ${$$PICS{$form->param("pic")}}{"content"} > ${$self->{"maxlens"}}{"pic"};
# OK
return;
}
# _check_piccap: default picture caption checker
sub _check_piccap : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Skip if there is no picture now
if ($self->_missing("pic")) {
$form->delete("piccap");
return;
}
# Check if it exists
$error = $self->_missing("piccap");
return $error if defined $error;
# Regularize it
$self->_trim("piccap");
# Check if it is filled
return {"msg"=>N_("Please fill in the picture caption.")}
if $form->param("piccap") eq "";
# Check the length
return {"msg"=>N_("This picture caption is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"piccap"}]}
if length $form->param("piccap") > ${$self->{"maxlens"}}{"piccap"};
# OK
return;
}
# _check_picpos: default picture position checker
sub _check_picpos : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Skip if there is no picture now
if ($self->_missing("pic")) {
$form->delete("picpos");
return;
}
# Check if it exists
$error = $self->_missing("picpos");
return $error if defined $error;
# Regularize it
$self->_trim("picpos");
# Check if the picture position is legal
return {"msg"=>N_("This picture position is invalid. Please choose a proper picture position.")}
if !in_array($form->param("picpos"), @PIC_VALID_POS);
# OK
return;
}
# _check_title: The default title checker
sub _check_title : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("title");
return $error if defined $error;
# Regularize it
$self->_trim("title");
# Check if it is filled
return {"msg"=>N_("Please fill in the title.")}
if $form->param("title") eq "";
# Check the length
return {"msg"=>N_("This title is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"title"}]}
if length $form->param("title") > ${$self->{"maxlens"}}{"title"};
# OK
return;
}
# _check_title_en: The default English title checker
sub _check_title_en : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("title_en");
return $error if defined $error;
# Regularize it
$self->_trim("title_en");
# Check if it is filled
return {"msg"=>N_("Please fill in the English title.")}
if $form->param("title_en") eq "";
# Check the length
return {"msg"=>N_("This English title is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"title_en"}]}
if length $form->param("title_en") > ${$self->{"maxlens"}}{"title_en"};
# OK
return;
}
#
# Spam Checkers:
# There are a series of checks for spam here. _check_spam() called each of them.
# Moved to Selima::Init. It starts at an early phrase before database initialization.
#
# _check_spam: Check the spam
sub _check_spam : method {
local ($_, %_);
# Check the CAPTCHA
$_[0]->_check_captcha;
# Check the local content filter
$_[0]->_checkspam_local if $_[0]->can("_checkspam_local");
# OK
return;
}
# _check_captcha: The default CAPTCHA checker
sub _check_captcha : method {
local ($_, %_);
my ($self, $form, $col, $error);
$self = $_[0];
$form = $self->{"form"};
$col = FORM_CAPTCHA;
# Check if it exists
$error = $self->_missing($col);
return $error if defined $error;
$self->_block_spam("_check_captcha: captcha column \"$col\" should be empty but got \""
. $form->param($col) . "\".")
if $form->param($col) ne "";
# OK
return;
}
# _block_spam: Block the spam message
sub _block_spam : method {
local ($_, %_);
my ($self, $msg);
($self, $msg) = @_;
spamlog $msg;
# Disconnect now. Leave resources for meaningful requests
$DBH->rollback;
$DBH->disconnect;
undef $DBH;
# Delay the spammer
sleep 300;
http_403(0);
# No return
}
#
# Private form redirectors. Do not call them directly.
# Add redirector definitions here.
# Method names must be in the following format:
# sub _redir_{column} : method { ... }
# Columns started with underlines are reserved for internal use, as usual.
#
# _redir_del: Suspend and move to the deletion form
sub _redir_del : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("del");
# Skip if S/N does not exist
return if $self->_missing("sn");
@_ = qw();
push @_, "form=del";
push @_, "sn=" . uri_escape($self->{"form"}->param("sn"));
call_form FORM_THIS, [@_];
}
# _redir_zhsync: Synchronize Chinese columns
sub _redir_zhsync : method {
local ($_, %_);
my ($self, $form, $lndb);
$self = $_[0];
$form = $self->{"form"};
# Skip if not requested
return if $self->_missing("zhsync");
%_ = map { $_ => 1 } @ALL_LINGUAS;
$_ = getlang;
# We are at a subordinary language
if ($_ ne $DEFAULT_LANG) {
# We are in Simplified Chinese and there is Traditional Chinese
if ($_ eq "zh-cn" && exists $_{"zh-tw"}) {
$lndb = ln "zh-tw", LN_DATABASE;
# Convert the form
$form->param($_, trad_to_simp($CURRENT{$_ . "_$lndb"}))
foreach grep s/_$lndb$//, keys %CURRENT;
# We are in Traditional Chinese and there is Simplified Chinese
} elsif ($_ eq "zh-tw" && exists $_{"zh-cn"}) {
$lndb = ln "zh-cn", LN_DATABASE;
# Convert the form
$form->param($_, simp_to_trad($CURRENT{$_ . "_$lndb"}))
foreach grep s/_$lndb$//, keys %CURRENT;
}
}
# Show the form again
success_redirect undef;
}
# _redir_cancel: Cancel the form and return to the originator
sub _redir_cancel : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("cancel");
# A calling form -- return to the caller
if (!$self->_missing("caller", "cformid")) {
$_ = $self->{"form"}->param("caller");
$_ = $self->{"form"}->param("hostport") . $_
if !$self->_missing("hostport");
$_ = add_get_arg($_, "formid", $self->{"form"}->param("cformid"));
if ($ENV{"REQUEST_METHOD"} eq "POST") {
http_303 $_;
} else {
http_307 $_;
}
}
# Referer2 specified -- return to referer2
if (!$self->_missing("referer2")) {
$_ = $self->{"form"}->param("referer2");
# Return to the hostport
} elsif (!$self->_missing("hostport")) {
$_ = $self->{"form"}->param("hostport") . "/magicat/";
} else {
$_ = "/magicat/";
}
if ($ENV{"REQUEST_METHOD"} eq "POST") {
http_303 $_;
} else {
http_307 $_;
}
}
# _redir_selgrp: Suspend and move to the group selection form
sub _redir_selgrp : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if !defined $self->{"form"}->param("selgrp");
call_form FORM_GROUPS, undef, "import_selgrp";
}
# _redir_delgrp: Remove the group
sub _redir_delgrp : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if !defined $self->{"form"}->param("delgrp");
$self->{"form"}->delete("grp");
success_redirect undef;
}
# _redir_selparent: Suspend and move to the parent selection form
sub _redir_selparent : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("selparent");
call_form FORM_THIS, undef, "import_selparent";
}
# _redir_delparent: Remove the parent
sub _redir_delparent : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("delparent");
$self->{"form"}->delete("parent");
success_redirect undef;
}
#
# Private utility methods. Do not override them.
#
# _missing: Check if certain columns are submitted
sub _missing : method {
local ($_, %_);
my ($self, @cols);
($self, @cols) = @_;
%_ = map { $_ => 1 } $self->{"form"}->param;
foreach (@cols) {
return {"msg"=>N_("The following field was not received: \"[_1]\"."),
"margs"=>[$_],
"isform"=>0}
if !exists $_{$_};
}
# OK
return;
}
# _trim: Trim spaces from both sides of a field
sub _trim : method {
local ($_, %_);
my ($self, @cols);
($self, @cols) = @_;
foreach my $col (@cols) {
s/^\s*(.*?)\s*$/$1/s foreach @{$self->{"form"}->param_fetch($col)}
}
return;
}
# _trimtext: Trim spaces and blank lines from both sides of a text
sub _trimtext : method {
local ($_, %_);
my ($self, @cols);
($self, @cols) = @_;
foreach my $col (@cols) {
foreach (@{$self->{"form"}->param_fetch($col)}) {
# Trim blank lines
s/^(?:\s*\n)?(.*?)\s*$/$1/s;
# Trim the trailing spaces of each line
s/[^\S\n]+\n/\n/g;
}
}
return;
}
return 1;

210
lib/perl5/Selima/Checker/AcctRec.pm Normal file
View File

@@ -0,0 +1,210 @@
# Selima Website Content Management System
# AcctRec.pm: The accounting record form checker.
# Copyright (c) 2007-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: 2007-09-22
package Selima::Checker::AcctRec;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::CallForm;
use Selima::ChkFunc;
use Selima::ShortCut;
use Selima::DataVars qw($DBH :forms);
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $self);
($class, @_) = @_;
$_[1] = "acctrecs" if scalar(@_) < 2 || !defined $_[1];
$self = $class->SUPER::new(@_);
${$self->{"maxlens"}}{"amount"} = 9;
return $self;
}
# _check_trx: Check the transaction
sub _check_trx : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("trx");
return $error if defined $error;
# Regularize it
$self->_trim("trx");
# Check if it is filled
return {"msg"=>N_("Please select a accounting transaction.")}
if $form->param("trx") eq "";
# Check if the transaction exists
return {"msg"=>N_("This accounting transaction does not exist anymore. Please select another one.")}
if !check_sn_in ${$form->param_fetch("trx")}[0], "accttrx";
# OK
return;
}
# _check_type: Check the type
sub _check_type : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("type");
return $error if defined $error;
# Regularize it
$self->_trim("type");
# Check the option value
return {"msg"=>N_("This option is invalid. Please select a proper type.")}
unless $form->param("type") =~ /^(?:debit|credit)$/;
# OK
return;
}
# _check_ord: Check the order
# Use the default order checker
# _check_subj: Check the subject
sub _check_subj : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("subj");
return $error if defined $error;
# Regularize it
$self->_trim("subj");
# Check if it is filled
return {"msg"=>N_("Please select a accounting subject.")}
if $form->param("subj") eq "";
# Check if the subject exists
return {"msg"=>N_("This accounting subject does not exist anymore. Please select another one.")}
if !check_sn_in ${$form->param_fetch("subj")}[0], "acctsubj";
# Check if this is the last level subject
$sql = "SELECT * FROM acctsubj"
. " WHERE parent=" . $form->param("subj") . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("Only a last-level accounting subject is allowed for an accounting subject.")}
if $sth->rows > 0;
# OK
return;
}
# _check_summary: Check the summary
sub _check_summary : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("summary");
return $error if defined $error;
# Regularize it
$self->_trim("summary");
# Skip if it is not filled
return if $form->param("summary") eq "";
# Check the length
return {"msg"=>N_("This summary is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"summary"}]}
if length $form->param("summary") > ${$self->{"maxlens"}}{"summary"};
# OK
return;
}
# _check_amount: Check the amount
sub _check_amount : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("amount");
return $error if defined $error;
# Regularize it
$self->_trim("amount");
$_ = $form->param("amount");
s/NT\$ ?//;
s/,//g;
s/\.0+$//;
$form->param("amount", $_);
# Check if it is filled
return {"msg"=>N_("Please fill in the amount.")}
if $form->param("amount") eq "";
# Check the length
return {"msg"=>N_("This amount is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"amount"}]}
if length $form->param("amount") > ${$self->{"maxlens"}}{"amount"};
# Check if it is a valid positive integer
return {"msg"=>N_("Please fill in a positive integer amount.")}
unless $form->param("amount") =~ /^\d+$/ && $form->param("amount") > 0;
# Set to an integer
$_ = $form->param("amount");
$_ += 0;
$form->param("amount", $_);
# OK
return;
}
# _redir_seltrx: Suspend and move to the transaction selection form
sub _redir_seltrx : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if !defined $self->{"form"}->param("seltrx");
call_form FORM_ACCTTRX, undef, "import_seltrx";
}
# _redir_deltrx: Remove the transaction
sub _redir_deltrx : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if !defined $self->{"form"}->param("deltrx");
$self->{"form"}->delete("trx");
success_redirect undef;
}
# _redir_selsubj: Suspend and move to the accounting subject selection form
sub _redir_selsubj : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if !defined $self->{"form"}->param("selsubj");
call_form FORM_ACCTSUBJ, ["list=lastlv"], "import_selsubj";
}
# _redir_delsubj: Remove the accounting subject
sub _redir_delsubj : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if !defined $self->{"form"}->param("delsubj");
$self->{"form"}->delete("subj");
success_redirect undef;
}
return 1;

147
lib/perl5/Selima/Checker/AcctSubj.pm Normal file
View File

@@ -0,0 +1,147 @@
# Selima Website Content Management System
# AcctSubj.pm: The accounting subject form checker.
# Copyright (c) 2007-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: 2007-08-23
package Selima::Checker::AcctSubj;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::CallForm;
use Selima::FetchRec;
use Selima::ShortCut;
use Selima::DataVars qw($DBH);
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $self);
($class, @_) = @_;
$_[1] = "acctsubj" if scalar(@_) < 2 || !defined $_[1];
$self = $class->SUPER::new(@_);
return $self;
}
# _check_code: Check the code
sub _check_code : method {
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("code");
return $error if defined $error;
# Regularize it
$self->_trim("code");
# Check if it is filled
return {"msg"=>N_("Please fill in the code.")}
if $form->param("code") eq "";
# Check the length
return {"msg"=>N_("This code is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"code"}]}
if length $form->param("code") > ${$self->{"maxlens"}}{"code"};
# Check if the characters used are valid
return {"msg"=>N_("Only numbers are allowed for the code.")}
unless $form->param("code") =~ /^\d+$/;
# Check if this item is duplicated
@_ = qw();
push @_, "code=" . $DBH->quote($form->param("code"));
push @_, "sn!=" . $self->{"sn"} if $self->{"iscur"};
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This accounting subject already exists. You cannot create a duplicated one.")}
if $sth->rows > 0;
# Check if its parent code exists
if (length $form->param("code") > 1) {
$_ = substr $form->param("code"), 0, -1;
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE code=" . $DBH->quote($_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("Accounting subject [_1] does not exist. You cannot create a subject under that."),
"margs"=>[$_]}
if $sth->rows == 0;
}
# OK
return;
}
# _check_parent: Check the parent subject
sub _check_parent : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql, %row);
$self = $_[0];
$form = $self->{"form"};
# "topmost not set" has a different form context
return {"msg"=>N_("Please select a parent accounting subject.")}
if $self->_missing("topmost");
# Regularize it
$self->_trim("topmost");
# Check the option value
return {"msg"=>N_("This option is invalid. Please select a proper parent accounting subject.")}
unless $form->param("topmost") =~ /^(?:true|false)$/;
# Check the parent subject if not a topmost subject
if ($form->param("topmost") eq "false") {
# Check if our code says we are topmost
if (!$self->_missing("code")) {
$self->_trim("code");
return {"msg"=>N_("An accounting subject having its code with a single digit must not have a parent.")}
if length $form->param("code") < 2;
}
# Check if it exists
$error = $self->_missing("parent");
return $error if defined $error;
# Regularize it
$self->_trim("parent");
# Check if it is filled
return {"msg"=>N_("Please select a parent accounting subject.")}
if $form->param("parent") eq "";
# Check if the parent subject is itself
return {"msg"=>N_("An accounting subject cannot belong to itself. Please select another one.")}
if $self->{"iscur"} && $form->param("parent") == $self->{"sn"};
# Check if this subject exists
%row = fetchrec ${$form->param_fetch("parent")}[0], "acctsubj";
return {"msg"=>N_("This parent accounting subject does not exist anymore. Please select another one.")}
if keys %row == 0;
# Check if the parent matches our code
if (!$self->_missing("code")) {
$_ = substr $form->param("code"), 0, -1;
return {"msg"=>N_("The parent accounting subject of accounting subject [_1] must be of code [_2], not [_3]."),
"margs"=>[$form->param("code"), $_, $row{"code"}]}
if $row{"code"} ne $_;
}
# Check the parent subject if a topmost subject
} else {
# Check if our code says we are not topmost
if (!$self->_missing("code")) {
$self->_trim("code");
return {"msg"=>N_("An accounting subject having its code with more than one digit must have a parent.")}
if length $form->param("code") > 1;
}
}
# OK
return;
}
# _check_title: Check the title
# Use the default title checker
return 1;

268
lib/perl5/Selima/Checker/AcctTrx.pm Normal file
View File

@@ -0,0 +1,268 @@
# Selima Website Content Management System
# AcctTrx.pm: The accounting transaction form checker.
# Copyright (c) 2007-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: 2007-09-22
package Selima::Checker::AcctTrx;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::Accounting;
use Selima::CallForm;
use Selima::ChkFunc;
use Selima::FetchRec;
use Selima::ShortCut;
use Selima::DataVars qw($DBH :forms);
use Selima::Checker::AcctRec;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $self);
($class, @_) = @_;
$_[1] = "accttrx" if scalar(@_) < 2 || !defined $_[1];
$self = $class->SUPER::new(@_);
# Regularize the form subtype
$self->_trim("formsub") if !$self->_missing("formsub");
# Record the form subtype
$self->{"subtype"} = $self->{"form"}->param("formsub");
return $self;
}
# _check_date: Check the date
# Use the default date checker
# _check_ord: Check the order
# Use the default order checker
# _check_recs: Check the records
sub _check_recs : method {
local ($_, %_);
my ($self, $form, $error, $debtcount, $crdtcount);
$self = $_[0];
$form = $self->{"form"};
# Check the subtype
# Check if it exists
$error = $self->_missing("formsub");
return $error if defined $error;
# Check the option value
return {"msg"=>N_("This form suptype is invalid. Please specify a proper user.")}
unless $self->{"subtype"} =~ /^(?:expense|income|trans)$/;
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
$crdtcount = 0;
} else {
# Find the last-used credit record
for ( $_ = 0;
defined $form->param("crdt$_" . "subj")
&& defined $form->param("crdt$_" . "summary")
&& defined $form->param("crdt$_" . "amount"); $_++) {};
if ($_ > 0) {
for ( $_--;
$_ >= 0
&& $form->param("crdt$_" . "subj") eq ""
&& $form->param("crdt$_" . "summary") eq ""
&& $form->param("crdt$_" . "amount") eq ""; $_--) {};
}
$crdtcount = $_ + 1;
if ($crdtcount == 0) {
return {"msg"=>N_("Please fill in the credit side of the accounting transaction.")}
if $self->{"subtype"} eq "trans";
return {"msg"=>N_("Please fill in the accounting transaction content.")};
}
}
# A form to fill in a cash income transaction
if ($self->{"subtype"} eq "income") {
$debtcount = 0;
} else {
# Find the last-used debit record
for ( $_ = 0;
defined $form->param("debt$_" . "subj")
&& defined $form->param("debt$_" . "summary")
&& defined $form->param("debt$_" . "amount"); $_++) {};
if ($_ > 0) {
for ( $_--;
$_ >= 0
&& $form->param("debt$_" . "subj") eq ""
&& $form->param("debt$_" . "summary") eq ""
&& $form->param("debt$_" . "amount") eq ""; $_--) {};
}
$debtcount = $_ + 1;
if ($debtcount == 0) {
return {"msg"=>N_("Please fill in the debit side of the accounting transaction.")}
if $self->{"subtype"} eq "trans";
return {"msg"=>N_("Please fill in the accounting transaction content.")};
}
}
# Check the debit records
for ($_ = 0; $_ < $debtcount; $_++) {
my ($subform, $checker, $error);
# Regularize it
$self->_trim("debt$_" . "subj");
$self->_trim("debt$_" . "summary");
$self->_trim("debt$_" . "amount");
# Skip if it is not filled
next if $form->param("debt$_" . "subj") eq ""
&& $form->param("debt$_" . "summary") eq ""
&& $form->param("debt$_" . "amount") eq "";
# Check with the subform checker
$subform = new CGI("");
$subform->param("trx", $self->{"sn"}) if $self->{"iscur"};
$subform->param("subj", $form->param("debt$_" . "subj"));
$subform->param("summary", $form->param("debt$_" . "summary"));
$subform->param("amount", $form->param("debt$_" . "amount"));
$checker = new Selima::Checker::AcctRec($subform);
$error = $checker->check("subj", "summary", "amount");
return $error if defined $error;
$form->param("debt$_" . "subj", $subform->param("subj"));
$form->param("debt$_" . "summary", $subform->param("summary"));
$form->param("debt$_" . "amount", $subform->param("amount"));
}
# Check the credit records
for ($_ = 0; $_ < $crdtcount; $_++) {
my ($subform, $checker, $error);
# Regularize it
$self->_trim("crdt$_" . "subj");
$self->_trim("crdt$_" . "summary");
$self->_trim("crdt$_" . "amount");
# Skip if it is not filled
next if $form->param("crdt$_" . "subj") eq ""
&& $form->param("crdt$_" . "summary") eq ""
&& $form->param("crdt$_" . "amount") eq "";
# Check with the subform checker
$subform = new CGI("");
$subform->param("trx", $self->{"sn"}) if $self->{"iscur"};
$subform->param("subj", $form->param("crdt$_" . "subj"));
$subform->param("summary", $form->param("crdt$_" . "summary"));
$subform->param("amount", $form->param("crdt$_" . "amount"));
$checker = new Selima::Checker::AcctRec($subform);
$error = $checker->check("subj", "summary", "amount");
return $error if defined $error;
$form->param("crdt$_" . "subj", $subform->param("subj"));
$form->param("crdt$_" . "summary", $subform->param("summary"));
$form->param("crdt$_" . "amount", $subform->param("amount"));
}
# Check the balance
if ($self->{"subtype"} eq "trans") {
my ($sumdebit, $sumcredit);
for ($_ = 0, $sumdebit = 0; $_ < $debtcount; $_++) {
# Skip if it is not filled
next if $form->param("debt$_" . "amount") eq "";
$sumdebit += $form->param("debt$_" . "amount");
}
for ($_ = 0, $sumcredit = 0; $_ < $crdtcount; $_++) {
# Skip if it is not filled
next if $form->param("crdt$_" . "amount") eq "";
$sumcredit += $form->param("crdt$_" . "amount");
}
return {"msg"=>N_("The total amounts of the debit side and the credit side are not balanced (debit [_1], credit [_2]."),
"margs"=>[$sumdebit, $sumcredit]}
if $sumdebit != $sumcredit;
}
return;
}
# _check_note: Check the note
sub _check_note : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("note");
return $error if defined $error;
# Regularize it
$self->_trimtext("note");
# Skip if it is not filled
$form->param("note", "")
if $form->param("note") eq C_("Fill in the note here.");
return if $form->param("note") eq "";
# Check the length
return {"msg"=>N_("This note is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"note"}]}
if length $form->param("note") > ${$self->{"maxlens"}}{"note"};
# OK
return;
}
# _redir_cnvttrans: Convert to a transfer transaction
sub _redir_cnvttrans : method {
local ($_, %_);
my ($self, $form, $sum);
$self = $_[0];
$form = $self->{"form"};
# Skip if not requested
return if $self->_missing("cnvttrans");
# Skip if the form subtype not supplied
return if !defined $self->{"subtype"};
# Skip if it is not an cash expense/income transaction
return if $self->{"subtype"} !~ /^(?:expense|income)$/;
# Set to a transfer transaction
$form->param("formsub", "trans");
# Set the other side
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
$form->param("crdt0subj", acctsubj_sn(ACCTSUBJ_CASH));
$form->param("crdt0summary", undef);
$sum = 0;
foreach (grep /^debt\d+amount$/, $form->param) {
$self->_trim($_);
$_ = $form->param($_);
s/NT\$ ?//;
s/,//g;
s/\.0+$//;
$sum += $_ if /^\d+$/;
}
$form->param("crdt0amount", $sum);
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
$form->param("debt0subj", acctsubj_sn(ACCTSUBJ_CASH));
$form->param("debt0summary", undef);
$sum = 0;
foreach (grep /^crdt\d+amount$/, $form->param) {
$self->_trim($_);
$_ = $form->param($_);
s/NT\$ ?//;
s/,//g;
s/\.0+$//;
$sum += $_ if /^\d+$/;
}
$form->param("debt0amount", $sum);
}
# Show the form again
success_redirect undef;
}
# _redir_selsubj: Suspend and move to the accounting subject selection form
sub _redir_selsubj : method {
local ($_, %_);
my $self;
$self = $_[0];
@_ = sort grep /^sel(?:debt|crdt)\d+subj$/, $self->{"form"}->param;
# Skip if not requested
return if @_ == 0;
# Record the hit button
$_[0] =~ /^sel((?:debt|crdt)\d+)subj$/;
$self->{"form"}->param("caller_index", $1);
call_form FORM_ACCTSUBJ, ["list=lastlv"], "import_selsubj";
}
return 1;

218
lib/perl5/Selima/Checker/Group.pm Normal file
View File

@@ -0,0 +1,218 @@
# Selima Website Content Management System
# Group.pm: The account group form checker.
# 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-10-12
package Selima::Checker::Group;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::CallForm;
use Selima::ChkPriv;
use Selima::DataVars qw($DBH :forms);
use Selima::ShortCut;
use Selima::UserName;
use Selima::Checker::UserMem;
use Selima::Checker::GroupMem;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my $class;
($class, @_) = @_;
$_[1] = "groups" if scalar(@_) < 2 || !defined $_[1];
return $class->SUPER::new(@_);
}
# _check_id: Check the group ID.
sub _check_id : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# Skip for a non-super-user editing a super-user group
return if $self->{"iscur"} && !is_su && $self->{"sn"} == su_group_sn;
# Check if it exists
$error = $self->_missing("id");
return $error if defined $error;
# Regularize it
$self->_trim("id");
# Check if it is filled
return {"msg"=>N_("Please fill in the group ID.")}
if $form->param("id") eq "";
# Check the length
return {"msg"=>N_("This group ID. is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"id"}]}
if length $form->param("id") > ${$self->{"maxlens"}}{"id"};
return {"msg"=>N_("This group ID. is too short. (Min. length [#,_1])"),
"margs"=>[${$self->{"minlens"}}{"id"}]}
if length $form->param("id") < ${$self->{"minlens"}}{"id"};
# Check if the characters used are valid
return {"msg"=>N_("Only lower-case English letters, numbers and underscores are allowed for the group ID.")}
unless $form->param("id") =~ /^[a-z][a-z0-9_]*$/;
# Check if this item is duplicated
@_ = qw();
push @_, "id=" . $DBH->quote($form->param("id"));
push @_, "sn!=" . $self->{"sn"} if $self->{"iscur"};
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This group already exists. You cannot create a duplicated one.")}
if $sth->rows > 0;
# OK
return;
}
# _check_dsc: Check the group description
sub _check_dsc : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("id");
return $error if defined $error;
# Regularize it
$self->_trim("dsc");
# Check if it is filled
return {"msg"=>N_("Please fill in the privilege description.")}
if $form->param("dsc") eq "";
# Check the length
return {"msg"=>N_("This privilege description is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"dsc"}]}
if length $form->param("dsc") > ${$self->{"maxlens"}}{"dsc"};
# OK
return;
}
# _check_subuser: Check the user members
sub _check_subuser : method {
local ($_, %_);
my ($self, $form, $error, $subform, $checker);
$self = $_[0];
$form = $self->{"form"};
# Skip for a non-super-user editing a super-user group
return if $self->{"iscur"} && !is_su && $self->{"sn"} == su_group_sn;
# Get the selected items
@_ = map $_ . "sn",
grep /^subuser\d+/ && defined $form->param($_ . "sn"), $form->param;
# Regularize them
$self->_trim(@_);
# Merge the duplicates
%_ = map { ($form->param($_))[0] => 1 } @_;
$subform = new CGI("");
$subform->param("grp", $self->{"sn"}) if $self->{"iscur"};
foreach (keys %_) {
$subform->param("member", $_);
$checker = new Selima::Checker::UserMem($subform);
$error = $checker->check("member");
return $error if defined $error;
}
# OK
return;
}
# _check_subgroup: Check the group members
sub _check_subgroup : method {
local ($_, %_);
my ($self, $form, $error, $subform, $checker);
$self = $_[0];
$form = $self->{"form"};
# Skip for a non-super-user editing a super-user group
return if $self->{"iscur"} && !is_su && $self->{"sn"} == su_group_sn;
# Get the selected items
@_ = map $_ . "sn",
grep /^subgroup\d+/ && defined $form->param($_ . "sn"), $form->param;
# Regularize them
$self->_trim(@_);
# Merge the duplicates
%_ = map { ($form->param($_))[0] => 1 } @_;
$subform = new CGI("");
$subform->param("grp", $self->{"sn"}) if $self->{"iscur"};
foreach (keys %_) {
$subform->param("member", $_);
$checker = new Selima::Checker::GroupMem($subform);
$error = $checker->check("member");
return $error if defined $error;
}
# OK
return;
}
# _check_supgroup: Check the belonging groups
sub _check_supgroup : method {
local ($_, %_);
my ($self, $form, $error, $subform, $checker);
$self = $_[0];
$form = $self->{"form"};
# Skip for a non-super-user editing a super-user group
return if $self->{"iscur"} && !is_su && $self->{"sn"} == su_group_sn;
# Get the selected items
@_ = map $_ . "sn",
grep /^supgroup\d+/ && defined $form->param($_ . "sn"), $form->param;
# Regularize them
$self->_trim(@_);
# Merge the duplicates
%_ = map { ($form->param($_))[0] => 1 } @_;
$subform = new CGI("");
$subform->param("member", $self->{"sn"}) if $self->{"iscur"};
foreach (keys %_) {
$subform->param("grp", $_);
$checker = new Selima::Checker::GroupMem($subform);
$error = $checker->check("grp");
return $error if defined $error;
}
# OK
return;
}
# _redir_selsubuser: Suspend and move to the subordinate user selection form
sub _redir_selsubuser : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("selsubuser");
call_form FORM_USERS, undef, "import_selsubuser";
}
# _redir_selsubgroup: Suspend and move to the subordinate group selection form
sub _redir_selsubgroup : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("selsubgroup");
call_form FORM_GROUPS, undef, "import_selsubgroup";
}
# _redir_selsupgroup: Suspend and move to the superordinate group selection form
sub _redir_selsupgroup : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("selsupgroup");
call_form FORM_GROUPS, undef, "import_selsupgroup";
}
return 1;

143
lib/perl5/Selima/Checker/GroupMem.pm Normal file
View File

@@ -0,0 +1,143 @@
# Selima Website Content Management System
# GroupMem.pm: The group-to-group membership form checker.
# 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-10-13
package Selima::Checker::GroupMem;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::ChkFunc;
use Selima::CallForm;
use Selima::DataVars qw($DBH :forms);
use Selima::ShortCut;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my $class;
($class, @_) = @_;
$_[1] = "groupmem" if scalar(@_) < 2 || !defined $_[1];
return $class->SUPER::new(@_);
}
# check: Run a list of checks
sub check : method {
local ($_, %_);
my ($self, $error, @cols);
($self, @cols) = @_;
# Run the parent method first
$error = $self->SUPER::check(@cols);
return $error if defined $error;
# See if we need to check the duplicates. Check it in the end.
%_ = map { $_ => 1 } @cols;
if (exists $_{"grp"} && exists $_{"member"}) {
$error = $self->__check_dup();
return $error if defined $error;
}
return;
}
# _check_grp: Check the group
sub _check_grp : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Run the default group checker
$error = $self->SUPER::_check_grp;
return $error if defined $error;
# Check if the group and the member are different
return {"msg"=>N_("Please select a different belonging group.")}
if !$self->_missing("member")
&& $form->param("member") ne ""
&& $form->param("grp") == $form->param("member");
# OK
return;
}
# _check_member: Check the member
sub _check_member : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("member");
return $error if defined $error;
# Regularize it
$self->_trim("member");
# Check if it is filled
return {"msg"=>N_("Please select a member.")}
if $form->param("member") eq "";
# Check if this group exists
return {"msg"=>N_("This member does not exist anymore. Please select another one.")}
if !check_sn_in ${$form->param_fetch("member")}[0], "groups AS grpmembers";
# Check if the group and the member are different
return {"msg"=>N_("Please select a different group member.")}
if !$self->_missing("grp")
&& $form->param("grp") ne ""
&& $form->param("grp") == $form->param("member");
# OK
return;
}
# __check_dup: Check if this item is duplicated
sub __check_dup : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
@_ = qw();
push @_, "grp=" . $form->param("grp");
push @_, "member=" . $form->param("member");
push @_, "sn!=" . $self->{"sn"}
if $self->{"iscur"};
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This membership record already exists. You cannot create a duplicated one.")}
if $sth->rows > 0;
return;
}
# _redir_selmember: Suspend and move to the member selection form
sub _redir_selmember : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("selmember");
call_form FORM_GROUPS, undef, "import_selmember";
}
# _redir_delmember: Remove the member
sub _redir_delmember : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("delmember");
$self->{"form"}->delete("member");
success_redirect undef;
}
return 1;

157
lib/perl5/Selima/Checker/Guestbook.pm Normal file
View File

@@ -0,0 +1,157 @@
# Selima Website Content Management System
# Guestbook.pm: The base administrative guestbook form checker.
# 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-10-14
package Selima::Checker::Guestbook;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::ShortCut;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $self);
($class, @_) = @_;
$_[1] = "guestbook" if scalar(@_) < 2 || !defined $_[1];
$self = $class->SUPER::new(@_);
${$self->{"maxlens"}}{"message"} = 10240;
return $self;
}
# _check_name: Check the name
sub _check_name : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("name");
return $error if defined $error;
# Regularize it
$self->_trim("name");
# Check the length
return {"msg"=>N_("This signature is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"name"}]}
if length $form->param("name") > ${$self->{"maxlens"}}{"name"};
# OK
return;
}
# _check_name_req: Check the name (required)
sub _check_name_req : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("name");
return $error if defined $error;
# Regularize it
$self->_trim("name");
# Check if it is filled
return {"msg"=>N_("Please fill in the signature.")}
if $form->param("name") eq "";
# Check the length
return {"msg"=>N_("This signature is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"name"}]}
if length $form->param("name") > ${$self->{"maxlens"}}{"name"};
# OK
return;
}
# _check_identity: Check the identity
sub _check_identity : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("identity");
return $error if defined $error;
# Regularize it
$self->_trim("identity");
# Check the length
return {"msg"=>N_("This identity is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"identity"}]}
if length $form->param("identity") > ${$self->{"maxlens"}}{"identity"};
# OK
return;
}
# _check_location: Check the location
sub _check_location : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("location");
return $error if defined $error;
# Regularize it
$self->_trim("location");
# Check the length
return {"msg"=>N_("This location is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"location"}]}
if length $form->param("location") > ${$self->{"maxlens"}}{"location"};
# OK
return;
}
# _check_email: Check the e-mail
sub _check_email : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("email");
return $error if defined $error;
# Regularize it
$self->_trim("email");
# Check the length
return {"msg"=>N_("This e-mail is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"email"}]}
if length $form->param("email") > ${$self->{"maxlens"}}{"email"};
# OK
return;
}
# _check_url: Check the URL
sub _check_url : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("url");
return $error if defined $error;
# Regularize it
$self->_trim("url");
# Check the length
return {"msg"=>N_("This website URL is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"url"}]}
if length $form->param("url") > ${$self->{"maxlens"}}{"url"};
# OK
return;
}
return 1;

224
lib/perl5/Selima/Checker/Guestbook/Public.pm Normal file
View File

@@ -0,0 +1,224 @@
# Selima Website Content Management System
# Public.pm: The base guestbook form checker.
# 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-10-23
package Selima::Checker::Guestbook::Public;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker::Guestbook);
use URI::Find qw();
use Selima::DataVars qw($DBH :lninfo);
use Selima::GetLang;
use Selima::HTTP;
use Selima::ShortCut;
use vars qw($uri_finder);
# _check_name: Check the name
sub _check_name : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("name");
return $error if defined $error;
# Regularize it
$self->_trim("name");
# Skip if it is not filled
return if $form->param("name") eq "";
# Check the length
return {"msg"=>N_("Your signature is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"name"}]}
if length $form->param("name") > ${$self->{"maxlens"}}{"name"};
# OK
return;
}
# _check_name_req: Check the name (required)
sub _check_name_req : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("name");
return $error if defined $error;
# Regularize it
$self->_trim("name");
# Check if it is filled
return {"msg"=>N_("Please fill in your signature.")}
if $form->param("name") eq "";
# Check the length
return {"msg"=>N_("Your signature is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"name"}]}
if length $form->param("name") > ${$self->{"maxlens"}}{"name"};
# OK
return;
}
# _check_identity: Check the identity
sub _check_identity : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("identity");
return $error if defined $error;
# Regularize it
$self->_trim("identity");
# Skip if it is not filled
return if $form->param("identity") eq "";
# Check the length
return {"msg"=>N_("Your identity is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"identity"}]}
if length $form->param("identity") > ${$self->{"maxlens"}}{"identity"};
# OK
return;
}
# _check_location: Check the location
sub _check_location : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("location");
return $error if defined $error;
# Regularize it
$self->_trim("location");
# Skip if it is not filled
return if $form->param("location") eq "";
# Check the length
return {"msg"=>N_("Your location is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"location"}]}
if length $form->param("location") > ${$self->{"maxlens"}}{"location"};
# OK
return;
}
# _check_email: Check the e-mail
sub _check_email : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("email");
return $error if defined $error;
# Regularize it
$self->_trim("email");
# Skip if it is not filled
return if $form->param("email") eq "";
# Check the length
return {"msg"=>N_("Your e-mail is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"email"}]}
if length $form->param("email") > ${$self->{"maxlens"}}{"email"};
# OK
return;
}
# _check_url: Check the URL
sub _check_url : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("url");
return $error if defined $error;
# Regularize it
$self->_trim("url");
# Skip if it is not filled
return if $form->param("url") eq "";
# Check the length
return {"msg"=>N_("Your website URL is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"url"}]}
if length $form->param("url") > ${$self->{"maxlens"}}{"url"};
# OK
return;
}
# _check_message: The default message checker
sub _check_message : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("message");
return $error if defined $error;
# Regularize it
$self->_trimtext("message");
# Check if it is filled
$form->param("message", "")
if $form->param("message") eq C_("Fill in your message here.");
return {"msg"=>N_("Please fill in your message.")}
if $form->param("message") eq "";
# Check the length
return {"msg"=>N_("Your message is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"message"}]}
if length $form->param("message") > ${$self->{"maxlens"}}{"message"};
# OK
return;
}
# _check_flood: Check the flooding attack
sub _check_flood : method {
local ($_, %_);
my ($self, $form, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# At most 5 posts/hours from a single IP
$sql = "SELECT count(*) AS count FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE created > now() - cast('1 hour' AS interval)"
. " AND ip='" . $ENV{"REMOTE_ADDR"} . "';\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("You can post at most 5 messages in 1 hour.")}
if ${$sth->fetch}[0] > 5;
# OK
return;
}
# _check_dup: Check the duplicated message
sub _check_dup : method {
local ($_, %_);
my ($self, $form, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# No duplicated message in the recent 5 posts
$sql = "SELECT message FROM " . $DBH->quote_identifier($self->{"table"})
. " ORDER BY created DESC LIMIT 5;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
for ($_ = 0; $_ < $sth->rows; $_++) {
return {"msg"=>N_("Your message is already posted.")}
if ${$sth->fetch}[0] eq $form->param("message");
}
# OK
return;
}
return 1;

252
lib/perl5/Selima/Checker/Link.pm Normal file
View File

@@ -0,0 +1,252 @@
# Selima Website Content Management System
# Link.pm: The related-link form checker.
# 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-10-24
package Selima::Checker::Link;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Email::Valid;
use Selima::ChkFunc;
use Selima::DataVars qw($DBH);
use Selima::ShortCut;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $self);
($class, @_) = @_;
$_[1] = "links" if scalar(@_) < 2 || !defined $_[1];
$self = $class->SUPER::new(@_);
${$self->{"minlens"}}{"email"} = 5;
return $self;
}
# _check_addr: Check the address
sub _check_addr : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("addr");
return $error if defined $error;
# Regularize it
$self->_trim("addr");
# Skip if it is not filled
return if $form->param("addr") eq "";
# Check the length
return {"msg"=>N_("This address is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"addr"}]}
if length $form->param("addr") > ${$self->{"maxlens"}}{"addr"};
# OK
return;
}
# _check_cats: Check the categories list
sub _check_cats : method {
local ($_, %_);
my ($self, $form, $error, $val);
$self = $_[0];
$form = $self->{"form"};
# Loop each category
for ($_ = 0, %_ = qw(); !$self->_missing("cat$_"); $_++) {
# Regularize it
$self->_trim("cat$_");
# Skip if it is not filled
next if $form->param("cat$_") eq "";
# Check if this selection is duplicated
return {"msg"=>N_("This category is duplicated. You cannot set duplicated ones.")}
if exists $_{$form->param("cat$_")};
# Check if the category exists
return {"msg"=>N_("This category does not exist anymore. Please select another one.")}
if !check_sn_in ${$form->param_fetch("cat$_")}[0], "linkcat";
$_{$form->param("cat$_")} = 1;
}
# Check if there is any category selected
return {"msg"=>N_("Please select a category.")}
if scalar(keys %_) == 0;
# OK
return;
}
# _check_email: Check the e-mail
sub _check_email : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("email");
return $error if defined $error;
# Regularize it
$self->_trim("email");
# Skip if it is not filled
return if $form->param("email") eq "";
# Check the length
return {"msg"=>N_("This e-mail is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"email"}]}
if length $form->param("email") > ${$self->{"maxlens"}}{"email"};
return {"msg"=>N_("This e-mail is too short. (Min. length [#,_1])"),
"margs"=>[${$self->{"minlens"}}{"email"}]}
if length $form->param("email") < ${$self->{"minlens"}}{"email"};
# Check the e-mail validity
return {"msg"=>N_("Please fill in a valid e-mail address.")}
if !Email::Valid->rfc822($form->param("email"));
return {"msg"=>N_("The domain of this e-mail does not exists. Check if there is any typo in it.")}
if $self->_missing("hid")
&& !Email::Valid->mx($form->param("email"));
# OK
return;
}
# _check_fax: Check the facsimile number
sub _check_fax : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("fax");
return $error if defined $error;
# Regularize it
$self->_trim("fax");
# Skip if it is not filled
return if $form->param("fax") eq "";
# Check the length
return {"msg"=>N_("This facsimile number is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"fax"}]}
if length $form->param("fax") > ${$self->{"maxlens"}}{"fax"};
# OK
return;
}
# _check_icon: Check the link icon
sub _check_icon : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("icon");
return $error if defined $error;
# Regularize it
$self->_trim("icon");
# Skip if it is not filled
return if $form->param("icon") eq "" || $form->param("icon") eq "http://";
# Check the length
return {"msg"=>N_("This link icon URL is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"icon"}]}
if length $form->param("icon") > ${$self->{"maxlens"}}{"icon"};
# Check its format
return {"msg"=>N_("Please fill in a valid link icon URL.")}
if !is_url_wellformed $form->param("icon");
# Check if it is available
return {"msg"=>N_("This link icon URL is not reachable. Check if there is any typo in it.")}
if $self->_missing("hid")
&& !is_url_reachable $form->param("icon");
# OK
return;
}
# _check_tel: Check the telephone number
sub _check_tel : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("tel");
return $error if defined $error;
# Regularize it
$self->_trim("tel");
# Skip if it is not filled
return if $form->param("tel") eq "";
# Check the length
return {"msg"=>N_("This telephone number is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"tel"}]}
if length $form->param("tel") > ${$self->{"maxlens"}}{"tel"};
# OK
return;
}
# _check_title_2ln: The 2nd language title checker
sub _check_title_2ln : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("title_2ln");
return $error if defined $error;
# Regularize it
$self->_trim("title_2ln");
# Skip if it is not filled
return if $form->param("title_2ln") eq "";
# Check the length
return {"msg"=>N_("This 2nd language title is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"title_2ln"}]}
if length $form->param("title_2ln") > ${$self->{"maxlens"}}{"title_2ln"};
# OK
return;
}
# _check_url: The URL checker
sub _check_url : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("url");
return $error if defined $error;
# Regularize it
$self->_trim("url");
# Check if it is filled
return {"msg"=>N_("Please fill in the URL.")}
if $form->param("url") eq "" || $form->param("url") eq "http://";
# Check the length
return {"msg"=>N_("This URL is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"url"}]}
if length $form->param("url") > ${$self->{"maxlens"}}{"url"};
# Check its format
return {"msg"=>N_("Please fill in a valid URL.")}
if !is_url_wellformed $form->param("url");
# Check if this item is duplicated
@_ = qw();
push @_, "url=" . $DBH->quote($form->param("url"));
push @_, "sn!=" . $self->{"sn"} if $self->{"iscur"};
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This related link already exists. You cannot create a duplicated one.")}
if $sth->rows > 0;
# Check if it is available
return {"msg"=>N_("This URL is not reachable. Check if there is any typo in it.")}
if $self->_missing("hid")
&& !is_url_reachable $form->param("url");
# OK
return;
}
return 1;

121
lib/perl5/Selima/Checker/LinkCat.pm Normal file
View File

@@ -0,0 +1,121 @@
# Selima Website Content Management System
# LinkCat.pm: The related-link category form checker.
# 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-10-24
package Selima::Checker::LinkCat;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::CallForm;
use Selima::ChkFunc;
use Selima::DataVars qw($DBH :forms);
use Selima::ShortCut;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $self);
($class, @_) = @_;
$_[1] = "linkcat" if scalar(@_) < 2 || !defined $_[1];
$self = $class->SUPER::new(@_);
${$self->{"maxlens"}}{"ord"} = 2;
${$self->{"minlens"}}{"id"} = 2;
return $self;
}
# _check_id: Check the ID.
sub _check_id : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# Run the default ID. checker
$error = $self->SUPER::_check_id;
return $error if defined $error;
# ID. cannot be "index" to avoid overriding index.html
return {"msg"=>N_("\"index\" is dedicated to the index file index.html. You cannot set the ID. as \"index\".")}
if $form->param("id") eq "index";
# Check if this item is duplicated
if (!$self->_missing("topmost", "parent")) {
@_ = qw();
push @_, "id=" . $DBH->quote($form->param("id"));
push @_, "sn!=" . $self->{"sn"} if $self->{"iscur"};
if ($form->param("topmost") eq "true") {
push @_, "parent IS NULL";
} else {
push @_, "parent=" . $DBH->quote($form->param("parent"));
}
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This category already exists. You cannot create a duplicated one.")}
if $sth->rows > 0;
}
# OK
return;
}
# _check_parent: Check the parent category
sub _check_parent : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# "topmost not set" has a different form context
return {"msg"=>N_("Please select a parent category.")}
if $self->_missing("topmost");
# Regularize it
$self->_trim("topmost");
# Check the option value
return {"msg"=>N_("This option is invalid. Please select a proper parent category.")}
unless $form->param("topmost") =~ /^(?:true|false)$/;
# Check the parent category if not a topmost category
if ($form->param("topmost") eq "false") {
# Check if it exists
$error = $self->_missing("parent");
return $error if defined $error;
# Regularize it
$self->_trim("parent");
# Check if it is filled
return {"msg"=>N_("Please select a parent category.")}
if $form->param("parent") eq "";
# Check if this category exists
return {"msg"=>N_("This parent category does not exist anymore. Please select another one.")}
if !check_sn_in ${$form->param_fetch("parent")}[0], "linkcat";
if ($self->{"iscur"}) {
# Check if the parent category is itself
return {"msg"=>N_("A category cannot belong to itself. Please select another one.")}
if $form->param("parent") == $self->{"sn"};
# Check if the parent directory is its descendant
$sql = "SELECT linkcat_ischild(" . $self->{"sn"} . ", "
. $form->param("parent") . ") AS is_child;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("A category cannot belong to its descendant. Please select another one.")}
if ${$sth->fetchrow_hashref}{"is_child"};
}
}
# OK
return;
}
return 1;

162
lib/perl5/Selima/Checker/LinkCatz.pm Normal file
View File

@@ -0,0 +1,162 @@
# Selima Website Content Management System
# LinkCatz.pm: The related-link category membership form checker.
# 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-03
package Selima::Checker::LinkCatz;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::ChkFunc;
use Selima::CallForm;
use Selima::DataVars qw($DBH :forms);
use Selima::ShortCut;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my $class;
($class, @_) = @_;
$_[1] = "linkcatz" if scalar(@_) < 2 || !defined $_[1];
return $class->SUPER::new(@_);
}
# check: Run a list of checks
sub check : method {
local ($_, %_);
my ($self, $error, @cols);
($self, @cols) = @_;
# Run the parent method first
$error = $self->SUPER::check(@cols);
return $error if defined $error;
# See if we need to check the duplicates. Check it in the end.
%_ = map { $_ => 1 } @cols;
if (exists $_{"cat"} && exists $_{"link"}) {
$error = $self->__check_dup();
return $error if defined $error;
}
return;
}
# _check_cat: Check the category
sub _check_cat : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("cat");
return $error if defined $error;
# Regularize it
$self->_trim("cat");
# Check if it is filled
return {"msg"=>N_("Please select a category.")}
if $form->param("cat") eq "";
# Check if the category exists
return {"msg"=>N_("This category does not exist anymore. Please select another one.")}
if !check_sn_in ${$form->param_fetch("cat")}[0], "linkcat";
# OK
return;
}
# _check_link: Check the related link
sub _check_link : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("link");
return $error if defined $error;
# Regularize it
$self->_trim("link");
# Check if it is filled
return {"msg"=>N_("Please select a related link.")}
if $form->param("link") eq "";
# Check if this link exists
return {"msg"=>N_("This related link does not exist anymore. Please select another one.")}
if !check_sn_in ${$form->param_fetch("link")}[0], "links";
# OK
return;
}
# __check_dup: Check if this item is duplicated
sub __check_dup : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
@_ = qw();
push @_, "cat=" . $form->param("cat");
push @_, "link=" . $form->param("link");
push @_, "sn!=" . $self->{"sn"}
if $self->{"iscur"};
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This categorization record already exists. You cannot create a duplicated one.")}
if $sth->rows > 0;
return;
}
# _redir_selcat: Suspend and move to the category selection form
sub _redir_selcat : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("selcat");
call_form FORM_LINKCAT, undef, "import_selcat";
}
# _redir_delcat: Remove the category
sub _redir_delcat : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("delcat");
$self->{"form"}->delete("cat");
success_redirect undef;
}
# _redir_sellink: Suspend and move to the related link selection form
sub _redir_sellink : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("sellink");
call_form FORM_LINKS, undef, "import_sellink";
}
# _redir_dellink: Remove the related link
sub _redir_dellink : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("dellink");
$self->{"form"}->delete("link");
success_redirect undef;
}
return 1;

132
lib/perl5/Selima/Checker/ListPref.pm Normal file
View File

@@ -0,0 +1,132 @@
# Selima Website Content Management System
# ListPref.pm: The list preference form checker.
# 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-10-14
package Selima::Checker::ListPref;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::CallForm;
use Selima::ChkFunc;
use Selima::DataVars qw($DBH :forms);
use Selima::HTTP;
use Selima::ShortCut;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $self);
($class, @_) = @_;
$_[1] = "userpref" if scalar(@_) < 2 || !defined $_[1];
$self = $class->SUPER::new(@_);
${$self->{"maxlens"}}{"listsize"} = 4;
return $self;
}
# _check_domain: Check the preference domain
sub _check_domain : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("domain");
return $error if defined $error;
# Regularize it
$self->_trim("domain");
# Check if it is filled
return {"msg"=>N_("Please fill in the preference domain.")}
if $form->param("domain") eq "";
# Check the length
return {"msg"=>N_("This preference domain is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"domain"}]}
if length $form->param("domain") > ${$self->{"maxlens"}}{"domain"};
# OK
return;
}
# _check_listcols: Check the list columns
sub _check_listcols : method {
local ($_, %_);
my ($self, $listcols, $errmsg);
$self = $_[0];
# No need to check the validility. Invalids are simply ignored.
@_ = grep s/^listcols_//, $self->{"form"}->param;
# Obtain the preference value
$listcols = join " ", @_;
# Skip if it is not filled
return if $listcols eq "";
# Check the length
if (length "listcols" > ${$self->{"maxlens"}}{"name"}) {
$errmsg = sprintf "Maximum preference name length too short (%d for \"%s\" %d)",
${$self->{"maxlens"}}{"name"}, "listcols", length "listcols";
http_500 $errmsg;
}
if (length $listcols > ${$self->{"maxlens"}}{"value"}) {
$errmsg = sprintf "Maximum preference value length too short (%d for \"%s\" %d)",
${$self->{"maxlens"}}{"name"}, "listcols", length $listcols;
http_500 $errmsg;
}
# OK
return;
}
# _check_listsize: Check the list size
sub _check_listsize : method {
local ($_, %_);
my ($self, $form, $error, $errmsg);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("listsize");
return $error if defined $error;
# Regularize it
$self->_trim("listsize");
# Check if it is filled
return {"msg"=>N_("Please fill in the number of rows per page.")}
if $form->param("listsize") eq "";
# If there is any non-digit character
return {"msg"=>N_("Please fill in a positive integer number of rows per page.")}
unless $form->param("listsize") =~ /^[1-9][0-9]*$/;
# Set to an integer
$_ = $form->param("listsize");
$_ += 0;
$form->param("listsize", $_);
# Check the length
return {"msg"=>N_("This number of rows per page is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"listsize"}]}
if length $form->param("listsize") > ${$self->{"maxlens"}}{"listsize"};
# Check the length
if (length "listsize" > ${$self->{"maxlens"}}{"name"}) {
$errmsg = sprintf "Maximum preference name length too short (%d for \"%s\" %d)",
${$self->{"maxlens"}}{"name"}, "listsize", length "listsize";
http_500 $errmsg;
}
if (length $form->param("listsize") > ${$self->{"maxlens"}}{"value"}) {
$errmsg = sprintf "Maximum preference value length too short (%d for \"%s\" %d)",
${$self->{"maxlens"}}{"name"}, "listsize", length $form->param("listsize");
http_500 $errmsg;
}
# OK
return;
}
return 1;

238
lib/perl5/Selima/Checker/LogIn.pm Normal file
View File

@@ -0,0 +1,238 @@
# Selima Website Content Management System
# LogIn.pm: The log-in form checker.
# 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-09-26
package Selima::Checker::LogIn;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker::User);
use Digest::MD5 qw(md5_hex);
use Selima::Array;
use Selima::ChkPriv;
use Selima::DataVars qw($DBH :hostconf);
use Selima::Guest;
use Selima::HTTP;
use Selima::Logging;
use Selima::ShortCut;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $self);
($class, @_) = @_;
$_[1] = "users" if scalar(@_) < 2 || !defined $_[1];
$self = $class->SUPER::new(@_);
$self->{"row"} = undef;
$self->{"allcols"} = [ $DBH->cols($self->{"table"}) ];
return $self;
}
# check: Run a list of checks
sub check : method {
local ($_, %_);
my ($self, $error, @cols);
($self, @cols) = @_;
# See if a log in is attemped.
%_ = map { $_ => 1 } @cols;
$self->{"login"} = exists $_{"id"} && exists $_{"passwd"}
if !exists $self->{"login"};
# Run the parent method first
$error = $self->SUPER::check(@cols);
return $error if defined $error;
return;
}
# _check_id: Check the user ID
sub _check_id : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("id");
return $error if defined $error;
# Regularize it
$self->_trim("id");
# Check if it is filled
return {"msg"=>N_("Please fill in your user ID.")}
if $form->param("id") eq "";
# Check the length
if (length $form->param("id") > ${$self->{"maxlens"}}{"id"}) {
actlog("Log in failed for user " . $form->param("id")
. " because user ID is too long.")
if $self->{"login"};
return {"msg"=>N_("Log in failed. Either your user ID or your password is incorrect.")};
}
if (length $form->param("id") < ${$self->{"minlens"}}{"id"}) {
actlog("Log in failed for user " . $form->param("id")
. " because user ID is too short.")
if $self->{"login"};
return {"msg"=>N_("Log in failed. Either your user ID or your password is incorrect.")};
}
# Check if this user exists
@_ = qw();
push @_, "id=" . $DBH->quote($form->param("id"));
push @_, "NOT deleted" if in_array("deleted", @{$self->{"allcols"}});
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
if ($sth->rows != 1) {
actlog("Log in failed for user " . $form->param("id")
. " because user ID does not exist.")
if $self->{"login"};
return {"msg"=>N_("Log in failed. Either your user ID or your password is incorrect.")};
}
# Save it for further reference
$self->{"row"} = $sth->fetchrow_hashref;
$self->{"sn"} = ${$self->{"row"}}{"sn"};
# Check if log-in is closed
if ($NOLOGIN && !is_su $self->{"sn"}) {
actlog("Log in failed for user " . $form->param("id")
. " because website is temporarily closed.")
if $self->{"login"};
# This message is duplicated
return {};
}
# Check if this user is disabled
if (${$self->{"row"}}{"disabled"}) {
actlog("Log in failed for user " . $form->param("id")
. " because account is disabled.")
if $self->{"login"};
return {"msg"=>N_("Your account is disabled. Contact our system administrator for assistence.")};
}
# OK
return;
}
# _check_passwd: Check the user password
sub _check_passwd : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Skip password checks for guests
return if exists $self->{"sn"} && is_guest $self->{"sn"};
# Check if it exists
$error = $self->_missing("passwd");
return $error if defined $error;
# Regularize it
$self->_trim("passwd");
# Check if it is filled
return {"msg"=>N_("Please fill in your password.")}
if $form->param("passwd") eq "";
# Check the length
if (length $form->param("passwd") > ${$self->{"maxlens"}}{"passwd"}) {
actlog("Log in failed for user " . $form->param("id")
. " because password is too long.")
if $self->{"login"};
return {"msg"=>N_("Log in failed. Either your user ID or your password is incorrect.")};
}
if (length $form->param("passwd") < ${$self->{"minlens"}}{"passwd"}) {
actlog("Log in failed for user " . $form->param("id")
. " because password is too short.")
if $self->{"login"};
return {"msg"=>N_("Log in failed. Either your user ID or your password is incorrect.")};
}
# Check if the password is correct
if ( defined $self->{"row"}
&& md5_hex($form->param("id") . ":magicat:"
. $form->param("passwd")) eq ${$self->{"row"}}{"passwd"}) {
actlog("Log in failed for user " . $form->param("id")
. " because password is incorrect.")
if $self->{"login"};
return {"msg"=>N_("Log in failed. Either your user ID or your password is incorrect.")};
}
# OK
return;
}
# _check_authdig: Check the user credential using HTTP Digest Authentication
sub _check_authdig : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Skip credential checks for guests
return if exists $self->{"sn"} && is_guest $self->{"sn"};
# Check if it exists
http_500 "Apache::AuthDigest::API \"rd\" not supplied"
if !exists $self->{"rd"};
http_500 "client response \"response\" not supplied"
if !exists $self->{"response"};
http_500 "\"id\" did not checked before \"authdig\""
if !defined $self->{"row"};
# Check if the credential is correct
if ( !$self->{"rd"}->compare_digest_response($self->{"response"},
${$self->{"row"}}{"passwd"})) {
actlog("Log in failed for user " . $form->param("id")
. " because password is incorrect.")
if $self->{"login"};
return {"msg"=>N_("Log in failed. Either your user ID or your password is incorrect.")};
}
# OK
return;
}
# _check_admin: Check if the user is an administrator
sub _check_admin : method {
local ($_, %_);
my ($self, $form);
$self = $_[0];
$form = $self->{"form"};
# Skip checking for guests
return if is_guest $self->{"sn"};
# Skip checking for super users
return if is_su $self->{"sn"};
# Check if this user is an administrator
if (!is_admin $self->{"sn"}) {
actlog("Log in failed for user " . $form->param("id")
. " because user is not an administrator.")
if $self->{"login"};
return {"msg"=>N_("You are not an administrator and cannot log into here.")};
}
# OK
return;
}
# _check_nonadmin: Check if the user is not an administrator
sub _check_nonadmin : method {
local ($_, %_);
my ($self, $form);
$self = $_[0];
$form = $self->{"form"};
# Skip checking for guests
return if is_guest $self->{"sn"};
# Check if this user is an administrator
if (is_admin $self->{"sn"}) {
actlog("Log in failed for user " . $form->param("id")
. " because user is an administrator.")
if $self->{"login"};
return {"msg"=>N_("You are an administrator and cannot log into here.")};
}
# OK
return;
}
return 1;

58
lib/perl5/Selima/Checker/MailTo.pm Normal file
View File

@@ -0,0 +1,58 @@
# Selima Website Content Management System
# MailTo.pm: The e-mail hyperlink redirection form checker.
# 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-10-25
package Selima::Checker::MailTo;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Email::Valid qw();
use Selima::ShortCut;
# _check_email: Check the submitted e-mail
sub _check_email : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("email");
return $error if defined $error;
# Regularize it
$self->_trim("email");
# Check if it is filled
return {"msg"=>N_("Please fill in the e-mail.")}
if $form->param("email") eq "";
# Un-mung e-mail to its original format
$_ = $form->param("email");
s/ at /\@/;
$form->param("email", $_);
# Check the e-mail validity
return {"msg"=>N_("Please fill in a valid e-mail address.")}
if !Email::Valid->rfc822($form->param("email"));
return {"msg"=>N_("The domain of this e-mail does not exists. Check if there is any typo in it.")}
if !Email::Valid->mx($form->param("email"));
# OK
return;
}
return 1;

52
lib/perl5/Selima/Checker/Page.pm Normal file
View File

@@ -0,0 +1,52 @@
# Selima Website Content Management System
# Page.pm: The base web page form checker.
# Copyright (c) 2005-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: 2005-02-28
package Selima::Checker::Page;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $self);
($class, @_) = @_;
$_[1] = "pages" if scalar(@_) < 2 || !defined $_[1];
$self = $class->SUPER::new(@_);
return $self;
}
# _check_path: Check the page path
# Use the default page path checker
# _check_ord: Check the order
# Use the default order checker
# _check_title: Check the title
# Use the default title checker
# _check_body: Check the content
# Use the default content checker
# _check_kw: Check the keywords list
# Use the default keywords list checker
return 1;

51
lib/perl5/Selima/Checker/Rebuild.pm Normal file
View File

@@ -0,0 +1,51 @@
# Selima Website Content Management System
# Rebuild.pm: The web page rebuild form checker.
# Copyright (c) 2006-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: 2006-04-04
package Selima::Checker::Rebuild;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::DataVars qw(:scptconf);
use Selima::ShortCut;
# _check_type: Check the page type
sub _check_type : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("type");
return $error if defined $error;
# Regularize it
$self->_trim("addr");
# Check if it is filled
return {"msg"=>N_("Please select the type.")}
if $form->param("type") eq "";
# Check if this link exists
return {"msg"=>N_("This type does not exist anymore. Please select another one.")}
unless defined $MAIN->can("rebuild_" . $form->param("type"));
# OK
return;
}
return 1;

82
lib/perl5/Selima/Checker/ScptPriv.pm Normal file
View File

@@ -0,0 +1,82 @@
# Selima Website Content Management System
# ScptPriv.pm: The script privilege form checker.
# 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-10-14
package Selima::Checker::ScptPriv;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::DataVars qw($DBH);
use Selima::ShortCut;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my $class;
($class, @_) = @_;
$_[1] = "scptpriv" if scalar(@_) < 2 || !defined $_[1];
return $class->SUPER::new(@_);
}
# check: Run a list of checks
sub check : method {
local ($_, %_);
my ($self, $error, @cols);
($self, @cols) = @_;
# Run the parent method first
$error = $self->SUPER::check(@cols);
return $error if defined $error;
# See if we need to check the duplicates. Check it in the end.
%_ = map { $_ => 1 } @cols;
if (exists $_{"grp"} && exists $_{"member"}) {
$error = $self->__check_dup();
return $error if defined $error;
}
return;
}
# _check_script: Check the script
# Use the default script checker
# _check_grp: Check the group
# Use the default group checker
# __check_dup: Check if this item is duplicated
sub __check_dup : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
@_ = qw();
push @_, "script=" . $form->param("script");
push @_, "grp=" . $form->param("grp");
push @_, "sn!=" . $self->{"sn"}
if $self->{"iscur"};
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This script privilege record already exists. You cannot create a duplicated one.")}
if $sth->rows > 0;
return;
}
return 1;

296
lib/perl5/Selima/Checker/User.pm Normal file
View File

@@ -0,0 +1,296 @@
# Selima Website Content Management System
# User.pm: The user account form checker.
# 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-09-26
package Selima::Checker::User;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Crypt::Cracklib qw(fascist_check);
use Email::Valid qw();
$Crypt::Cracklib::DICT = "/usr/share/dict/pw_dict";
use Selima::Array;
use Selima::ChkPriv;
use Selima::DataVars qw($DBH :groups);
use Selima::LogIn;
use Selima::UserName;
use Selima::Passwd;
use Selima::ShortCut;
use Selima::Checker::UserMem;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my ($class, $self);
($class, @_) = @_;
$_[1] = "users" if scalar(@_) < 2 || !defined $_[1];
$self = $class->SUPER::new(@_);
${$self->{"maxlens"}}{"passwd"} = 16;
${$self->{"minlens"}}{"passwd"} = 6;
${$self->{"minlens"}}{"email"} = 5;
return $self;
}
# check: Run a list of checks
sub check : method {
local ($_, %_);
my ($self, @cols, $error);
($self, @cols) = @_;
# Check the guest flag first
$self->_is_guest;
# Run the parent method
return $self->SUPER::check(@cols);
}
# _is_guest: If the user being edited is a guest
sub _is_guest : method {
local ($_, %_);
my ($self, $form);
$self = $_[0];
$form = $self->{"form"};
# Checked before
return $form->param("_is_guest") if !$self->_missing("_is_guest");
%_ = map { $_ => 1 } $form->param;
for ($_ = 0; exists $_{"supgroup$_" . "sn"}; $_++) {
# Skip unselected groups
next if !exists $_{"supgroup$_"};
# Check if this is the guest group
return $form->param("_is_guest", 1)
if groupid($form->param("supgroup$_" . "sn")) eq GUEST_GROUP;
}
# No guest group was found
return $form->param("_is_guest", 0);
}
# _check_id: Check the user ID.
sub _check_id : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
# Skip for a non-super-user editing a super-user
return if $self->{"iscur"} && !is_su && is_su $self->{"sn"};
# Check if it exists
$error = $self->_missing("id");
return $error if defined $error;
# Regularize it
$self->_trim("id");
# Check if it is filled
return {"msg"=>N_("Please fill in the user ID.")}
if $form->param("id") eq "";
# Check the length
return {"msg"=>N_("This user ID. is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"id"}]}
if length $form->param("id") > ${$self->{"maxlens"}}{"id"};
return {"msg"=>N_("This user ID. is too short. (Min. length [#,_1])"),
"margs"=>[${$self->{"minlens"}}{"id"}]}
if length $form->param("id") < ${$self->{"minlens"}}{"id"};
# Check if the characters used are valid
return {"msg"=>N_("Only English letters, numbers, at-signs, dots, dashes and underscores are allowed for the user ID.")}
unless $form->param("id") =~ /^[a-z][a-z0-9@\.\-_]*$/;
# Check if this item is duplicated
@_ = qw();
push @_, "id=" . $DBH->quote($form->param("id"));
push @_, "sn!=" . $self->{"sn"} if $self->{"iscur"};
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This user already has an account. You cannot create a duplicated one.")}
if $sth->rows > 0;
# OK
return;
}
# _check_passwd: Check the user password
sub _check_passwd : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Skip for a non-super-user editing a super-user
return if $self->{"iscur"} && !is_su && is_su $self->{"sn"};
# Set the passwords with the password registry
sync_saved_passwd($form, "*" x ${$self->{"maxlens"}}{"passwd"});
# Skip password checking for guests
return if $self->_is_guest;
# Check if it exists
$error = $self->_missing("passwd", "passwd2");
return $error if defined $error;
# Regularize it
$self->_trim("passwd", "passwd2");
# Check if it is filled
return {"msg"=>N_("Please fill in the password.")}
if !$self->{"iscur"} && $form->param("passwd") eq "";
return {"msg"=>N_("Please confirm the password.")}
if $form->param("passwd") ne "" && $form->param("passwd2") eq "";
# Check the length
return {"msg"=>N_("This password is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"passwd"}]}
if length $form->param("passwd") > ${$self->{"maxlens"}}{"passwd"};
return {"msg"=>N_("This password is too short. (Min. length [#,_1])"),
"margs"=>[${$self->{"minlens"}}{"passwd"}]}
if $form->param("passwd") ne ""
&& length $form->param("passwd") < ${$self->{"minlens"}}{"passwd"};
# Check if two passwords are consistent
return {"msg"=>N_("The 2 passwords are different. Please fill in the password again.")}
if $form->param("passwd") ne $form->param("passwd2");
if ($form->param("passwd") ne "") {
# Check the password strength with cracklib
if (($_ = fascist_check($form->param("passwd"))) ne "ok") {
# See the message from cracklib/fscist.c
# FascistGecos()
#return {"msg"=>N_("You are not registered.")}
# if $_ eq "you are not registered in the password file";
return {"msg"=>N_("This password is based on the user ID.")}
if $_ eq "it is based on your username";
#return {"msg"=>N_("This password is based upon the personal information.")}
# if $_ eq "it is based upon your password entry";
#return {"msg"=>N_("This password is derived from the personal information.")}
# if $_ eq "it is derived from your password entry"
# || $_ eq "it's derived from your password entry";
#return {"msg"=>N_("This password is derivable from the personal information.")}
# if $_ eq "it is derivable from your password entry"
# || $_ eq "it's derivable from your password entry";
# FascistLook()
#return {"msg"=>N_("This password is too short. (Min. length [#,_1])"),
# "margs"=>[${$self->{"minlens"}}{"passwd"}]}
# if $_ eq "it's WAY too short"
# || $_ eq "it is too short";
return {"msg"=>N_("This password does not contain enough different characters.")}
if $_ eq "it does not contain enough DIFFERENT characters";
#return {"msg"=>N_("This password is all whitespace.")}
# if $_ eq "it is all whitespace";
return {"msg"=>N_("This password is too simplistic/systematic.")}
if $_ eq "it is too simplistic/systematic";
#return {"msg"=>N_("This password looks like a National Insurance number.")}
# if $_ eq "it looks like a National Insurance number";
return {"msg"=>N_("This password is based on a dictionary word.")}
if $_ eq "it is based on a dictionary word";
return {"msg"=>N_("This password is based on a (reversed) dictionary word.")}
if $_ eq "it is based on a (reversed) dictionary word";
return {"msg"=>N_("This password is too simple.")};
}
return {"msg"=>$_}
if ($_ = fascist_check($form->param("passwd"))) ne "ok";
# Check if the group and the member are different
return {"msg"=>N_("You cannot use a password that is based on your user ID.")}
if defined($_ = $form->param("id"))
&& $form->param("passwd") =~ /$_/i;
}
# OK
return;
}
# _check_name: Check the user name
sub _check_name : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("name");
return $error if defined $error;
# Regularize it
$self->_trim("name");
# Check if it is filled
return {"msg"=>N_("Please fill in the name.")}
if $form->param("name") eq "";
# Check the length
return {"msg"=>N_("This name is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"name"}]}
if length $form->param("name") > ${$self->{"maxlens"}}{"name"};
# OK
return;
}
# _check_email: Check the user e-mail
sub _check_email : method {
local ($_, %_);
my ($self, $form, $error, $col);
($self, $col) = @_;
$form = $self->{"form"};
$col = "email" if !defined $col;
# Check if it exists
$error = $self->_missing($col);
return $error if defined $error;
# Regularize it
$self->_trim($col);
# Check if it is filled
return {"msg"=>N_("Please fill in the e-mail.")}
if $form->param($col) eq "";
# Check the length
return {"msg"=>N_("This e-mail is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{$col}]}
if length $form->param($col) > ${$self->{"maxlens"}}{$col};
return {"msg"=>N_("This e-mail is too short. (Min. length [#,_1])"),
"margs"=>[${$self->{"minlens"}}{$col}]}
if length $form->param($col) < ${$self->{"minlens"}}{$col};
# Check the e-mail validity
return {"msg"=>N_("Please fill in a valid e-mail address.")}
if !Email::Valid->rfc822($form->param($col));
return {"msg"=>N_("The domain of this e-mail does not exists. Check if there is any typo in it.")}
if !Email::Valid->mx($form->param($col));
# OK
return;
}
# _check_supgroup: Check the belonging groups
sub _check_supgroup : method {
local ($_, %_);
my ($self, $form, $error, %items);
$self = $_[0];
$form = $self->{"form"};
# Skip for a non-super-user editing herself
return if $self->{"iscur"} && !is_su && $self->{"sn"} == get_login_sn;
for (my $i = 0, %items = qw(); !$self->_missing("supgroup$i" . "sn"); $i++) {
my ($subform, $checker);
# Skip unselected ones
next if $self->_missing("supgroup$i");
# Regularize it
$self->_trim("supgroup$i" . "sn");
# Check if this selection is duplicated
return {"msg"=>N_("This belonging group is duplicated. You cannot set duplicated ones.")}
if exists $items{$form->param("supgroup$i" . "sn")};
$items{$form->param("supgroup$i" . "sn")} = 1;
# Check with the subform checker
$subform = new CGI("");
$subform->param("grp", $form->param("supgroup$i" . "sn"));
$subform->param("member", $self->{"sn"}) if $self->{"iscur"};
$checker = new Selima::Checker::UserMem($subform);
$error = $checker->check("grp");
return $error if defined $error;
# Check if a special group is submitted
$_ = groupid($form->param("supgroup$i" . "sn"));
return {"msg"=>N_("You cannot submit the super-user group along with other groups.")}
if $_ eq SU_GROUP;
return {"msg"=>N_("You cannot set the administrators group.")}
if $_ eq ADMIN_GROUP;
return {"msg"=>N_("You cannot set the all-users group.")}
if $_ eq ALLUSERS_GROUP;
}
# OK
return;
}
return 1;

123
lib/perl5/Selima/Checker/UserMem.pm Normal file
View File

@@ -0,0 +1,123 @@
# Selima Website Content Management System
# UserMem.pm: The user-to-group membership form checker.
# 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-10-10
package Selima::Checker::UserMem;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::ChkFunc;
use Selima::CallForm;
use Selima::DataVars qw($DBH :forms);
use Selima::ShortCut;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my $class;
($class, @_) = @_;
$_[1] = "usermem" if scalar(@_) < 2 || !defined $_[1];
return $class->SUPER::new(@_);
}
# check: Run a list of checks
sub check : method {
local ($_, %_);
my ($self, $error, @cols);
($self, @cols) = @_;
# Run the parent method first
$error = $self->SUPER::check(@cols);
return $error if defined $error;
# See if we need to check the duplicates. Check it in the end.
%_ = map { $_ => 1 } @cols;
if (exists $_{"grp"} && exists $_{"member"}) {
$error = $self->__check_dup();
return $error if defined $error;
}
return;
}
# _check_grp: Check the group
# Use the default group checker
# _check_member: Check the member
sub _check_member : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("member");
return $error if defined $error;
# Regularize it
$self->_trim("member");
# Check if it is filled
return {"msg"=>N_("Please select a member.")}
if $form->param("member") eq "";
# Check if this user exists
return {"msg"=>N_("This member does not exist anymore. Please select another one.")}
if !check_sn_in ${$form->param_fetch("member")}[0], "users AS usrmembers";
# OK
return;
}
# __check_dup: Check if this item is duplicated
sub __check_dup : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
@_ = qw();
push @_, "grp=" . $form->param("grp");
push @_, "member=" . $form->param("member");
push @_, "sn!=" . $self->{"sn"}
if $self->{"iscur"};
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This membership record already exists. You cannot create a duplicated one.")}
if $sth->rows > 0;
return;
}
# _redir_selmember: Suspend and move to the member selection form
sub _redir_selmember : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("selmember");
call_form FORM_USERS, undef, "import_selmember";
}
# _redir_delmember: Remove the member
sub _redir_delmember : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("delmember");
$self->{"form"}->delete("member");
success_redirect undef;
}
return 1;

207
lib/perl5/Selima/Checker/UserPref.pm Normal file
View File

@@ -0,0 +1,207 @@
# Selima Website Content Management System
# UserPref.pm: The user preference form checker.
# 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-10-14
package Selima::Checker::UserPref;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Checker);
use Selima::CallForm;
use Selima::DataVars qw($DBH :forms);
use Selima::ShortCut;
# new: Initialize the checker
sub new : method {
local ($_, %_);
my $class;
($class, @_) = @_;
$_[1] = "userpref" if scalar(@_) < 2 || !defined $_[1];
return $class->SUPER::new(@_);
}
# check: Run a list of checks
sub check : method {
local ($_, %_);
my ($self, $error, @cols);
($self, @cols) = @_;
# Run the parent method first
$error = $self->SUPER::check(@cols);
return $error if defined $error;
# See if we need to check the duplicates. Check it in the end.
%_ = map { $_ => 1 } @cols;
if (exists $_{"usr"} && exists $_{"domain"} && exists $_{"name"}) {
$error = $self->__check_dup();
return $error if defined $error;
}
return;
}
# _check_usr: Check the user
sub _check_usr : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# "everyone not set" has a different form context
return {"msg"=>N_("Please select the user.")}
if $self->_missing("everyone");
# Regularize it
$self->_trim("everyone");
# Check the option value
return {"msg"=>N_("This option is invalid. Please select a proper user.")}
unless $form->param("everyone") =~ /^(?:true|false)$/;
# Check the user if not everyone
if ($form->param("everyone") eq "false") {
$error = $self->SUPER::_check_usr;
return $error if defined $error;
}
# OK
return;
}
# _check_domain: Check the domain
sub _check_domain : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# "everywhere not set" has a different form context
return {"msg"=>N_("Please set the preference domain.")}
if $self->_missing("everywhere");
# Regularize it
$self->_trim("everywhere");
# Check the option value
return {"msg"=>N_("This option is invalid. Please set a proper preference domain.")}
unless $form->param("everywhere") =~ /^(?:true|false)$/;
# Check the domain if not everywhere
if ($form->param("everywhere") eq "false") {
# Check if it exists
$error = $self->_missing("domain");
return $error if defined $error;
# Regularize it
$self->_trim("domain");
# Check if it is filled
return {"msg"=>N_("Please fill in the preference domain.")}
if $form->param("domain") eq "";
# Check the length
return {"msg"=>N_("This preference domain is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"domain"}]}
if length $form->param("domain") > ${$self->{"maxlens"}}{"domain"};
}
# OK
return;
}
# _check_name: Check the preference name
sub _check_name : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("name");
return $error if defined $error;
# Regularize it
$self->_trim("name");
# Check if it is filled
return {"msg"=>N_("Please fill in the preference name.")}
if $form->param("name") eq "";
# Check the length
return {"msg"=>N_("This preference name is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"name"}]}
if length $form->param("name") > ${$self->{"maxlens"}}{"name"};
# OK
return;
}
# _check_value: Check the preference value
sub _check_value : method {
local ($_, %_);
my ($self, $form, $error);
$self = $_[0];
$form = $self->{"form"};
# Check if it exists
$error = $self->_missing("value");
return $error if defined $error;
# Regularize it
$self->_trim("value");
# Check if it is filled
return {"msg"=>N_("Please fill in the preference value.")}
if $form->param("value") eq "";
# Check the length
return {"msg"=>N_("This preference value is too long. (Max. length [#,_1])"),
"margs"=>[${$self->{"maxlens"}}{"value"}]}
if length $form->param("value") > ${$self->{"maxlens"}}{"value"};
# OK
return;
}
# __check_dup: Check if this item is duplicated
sub __check_dup : method {
local ($_, %_);
my ($self, $form, $error, $sth, $sql);
$self = $_[0];
$form = $self->{"form"};
@_ = qw();
if ($form->param("everyone") eq "true") {
push @_, "usr IS NULL";
} else {
push @_, "usr=" . $form->param("usr");
}
if ($form->param("everywhere") eq "true") {
push @_, "domain IS NULL";
} else {
push @_, "domain=" . $DBH->quote($form->param("domain"));
}
push @_, "name=" . $DBH->quote($form->param("name"));
push @_, "sn!=" . $self->{"sn"}
if $self->{"iscur"};
$sql = "SELECT * FROM " . $DBH->quote_identifier($self->{"table"})
. " WHERE " . join(" AND ", @_) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return {"msg"=>N_("This user preference already exists. You cannot create a duplicated one.")}
if $sth->rows > 0;
return;
}
# _redir_selusr: Suspend and move to the user selection form
sub _redir_selusr : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("selusr");
call_form FORM_USERS, undef, "import_selusr";
}
# _redir_delusr: Remove the user
sub _redir_delusr : method {
local ($_, %_);
my $self;
$self = $_[0];
# Skip if not requested
return if $self->_missing("delusr");
$self->{"form"}->delete("usr");
success_redirect undef;
}
return 1;

141
lib/perl5/Selima/ChkFunc.pm Normal file
View File

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

133
lib/perl5/Selima/ChkPriv.pm Normal file
View File

@@ -0,0 +1,133 @@
# Selima Website Content Management System
# ChkPriv.pm: The privilege checkers.
# 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-09-26
package Selima::ChkPriv;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(is_admin is_su user_parent_groups);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub is_admin(;$);
sub is_su(;$);
sub user_parent_groups($);
}
use Selima::Array;
use Selima::Cache qw(:chkpriv);
use Selima::ChkFunc;
use Selima::DataVars qw($DBH :groups);
use Selima::LogIn;
use Selima::UserName;
# is_admin: If the user is an administrator (by user sn)
sub is_admin(;$) {
local ($_, %_);
$_ = $_[0];
# Default to the current logged-in user
return is_su || in_array(ADMIN_GROUP, get_login_groups)
if !defined $_ || (defined get_login_sn && $_ == get_login_sn);
# Return the cache
return $ChkPriv_is_admin{$_} if exists $ChkPriv_is_admin{$_};
# Super user is always an administrator
return ($ChkPriv_is_admin{$_} = 1) if is_su($_);
# Check the groups
return ($ChkPriv_is_admin{$_} =
in_array(ADMIN_GROUP, user_parent_groups($_)));
}
# is_su: If the user is a super user
sub is_su(;$) {
local ($_, %_);
$_ = $_[0];
# Default to the current logged-in user
return in_array(SU_GROUP, get_login_groups)
if !defined $_ || (defined get_login_sn && $_ == get_login_sn);
# Return the cache
return $ChkPriv_is_su{$_} if exists $ChkPriv_is_su{$_};
# Check the groups
return ($ChkPriv_is_admin{$_} =
in_array(SU_GROUP, user_parent_groups($_)));
}
# user_parent_groups: Return the full list of groups a user belongs to
sub user_parent_groups($) {
local ($_, %_);
my ($sn, $sth, $sql, $count, %current, $group);
$sn = $_[0];
# Bounce for null
return if !defined $sn;
# Return the cache
return @{$ChkPriv_user_parent_groups{$sn}}
if exists $ChkPriv_user_parent_groups{$sn};
# Check the validity of the user first
if (defined get_login_sn && $sn != get_login_sn) {
if (!check_sn_in $sn, "users") {
$ChkPriv_user_parent_groups{$sn} = [];
return;
}
}
# Find the direct parent groups
$sql = "SELECT grp FROM usermem"
. " WHERE member=$sn"
. " ORDER BY grp;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
# Obtain the direct parent groups
for ($_ = 0, %current = qw(); $_ < $count; $_++) {
$current{${$sth->fetch}[0]} = 1;
}
# ALLUSERS_GROUP is automatically added to all the valid users
$current{groupsn(ALLUSERS_GROUP)} = 1;
# Trace all their ancester groups
while (1) {
$sql = "SELECT grp FROM groupmem"
. " WHERE " . join(" OR ", map "member=$_", keys %current)
. " GROUP BY grp ORDER BY grp;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for ($_ = 0, @_ = qw(); $_ < $count; $_++) {
push @_, ${$sth->fetch}[0];
}
@_ = grep !exists $current{$_}, @_;
last if scalar(@_) == 0;
$current{$_} = 1 foreach @_;
}
# Find their ID
$sql = "SELECT id FROM groups"
. " WHERE " . join(" OR ", map "sn=$_", keys %current)
. " ORDER BY id;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for ($_ = 0, @_ = qw(); $_ < $count; $_++) {
push @_, ${$sth->fetch}[0];
}
# Cache it
$ChkPriv_user_parent_groups{$sn} = [@_];
return @_;
}
return 1;

80
lib/perl5/Selima/ChkWrite.pm Normal file
View File

@@ -0,0 +1,80 @@
# Selima Website Content Management System
# ChkWrite.pm: The write-permission checker.
# Copyright (c) 2005-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: 2005-02-28
package Selima::ChkWrite;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(check_writable);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub check_writable($);
}
use File::Basename qw(dirname);
use Selima::ShortCut;
# check_writable: Check the permission to write to a file.
# Input: File full pathname $file.
# Output: true if success, false if failed.
sub check_writable($) {
local ($_, %_);
my ($file, $parent);
$file = $_[0];
# Standardize it
# File exists.
if (-e $file) {
# If it is a file
return {"msg"=>N_("[_1]: It is not a file."),
"margs"=>[$file]}
if !-f $file;
# If it is writable
return {"msg"=>N_("[_1]: You have no permission to overwrite this file."),
"margs"=>[$file]}
if !-w $file;
# Not an existing file. See if we can create it.
} else {
$parent = $file;
# Find the nearest existing parent
$parent = dirname($parent)
while $parent ne "" && !-e $parent;
# Creat files from root --- You are insane
return {"msg"=>N_("[_1]: You cannot create anything under the root directory."),
"margs"=>[$file]}
if $parent eq "";
# This parent is not a directory
return {"msg"=>N_("[_1]: One of the parents of this file ([_2]) is not a directory. You cannot create any new file inside."),
"margs"=>[$file, $parent]}
if !-d $parent;
# If it is possible to create entries in this directory
return {"msg"=>N_("[_1]: You have no permission to create any file under [_2]."),
"margs"=>[$file, $parent]}
if !-w $parent;
}
# OK
return;
}
return 1;

42
lib/perl5/Selima/CommText.pm Normal file
View File

@@ -0,0 +1,42 @@
# Selima Website Content Management System
# CommText.pm: The core common text messages.
# 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-04-03
package Selima::CommText;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(t_notset t_none t_na);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub t_notset();
sub t_none();
sub t_na();
}
use Selima::ShortCut;
sub t_notset() { C_("(not set)"); }
sub t_none() { C_("(none)"); }
sub t_na() { C_("(N/A)"); }
return 1;

51
lib/perl5/Selima/CopyYear.pm Normal file
View File

@@ -0,0 +1,51 @@
# Selima Website Content Management System
# CopyYear.pm: The copyright year text generator.
# 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-10-17
package Selima::CopyYear;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(copyyear);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub copyyear($);
}
use Selima::Cache qw(:copyyear);
use Selima::DataVars qw(:proctime);
# copyyear: Return the copyright year
sub copyyear($) {
local ($_, %_);
my ($startyear, $thisyear);
$startyear = $_[0];
# Return the cache
return $CopyYear_copyyear if defined $CopyYear_copyyear;
$thisyear = (localtime $T_START)[5] + 1900;
$CopyYear_copyyear = $startyear;
$CopyYear_copyyear .= "-" . $thisyear
if $thisyear != $startyear;
return $CopyYear_copyyear;
}
return 1;

101
lib/perl5/Selima/Country.pm Normal file
View File

@@ -0,0 +1,101 @@
# Selima Website Content Management System
# Country.pm: The subroutines to query the country name from the database.
# 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-10-17
package Selima::Country;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(ctname ctname_zhtw);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub ctname($);
sub ctname_zhtw($);
}
use Selima::Cache qw(:country);
use Selima::CommText;
use Selima::DataVars qw($DBH :lninfo);
use Selima::GetLang;
use Selima::LnInfo;
# The default language here is always English
use constant DEFAULT_LANG => "en";
use constant TRAD_CHINESE => "zh-tw";
# ctname: Obtain a country name
sub ctname($) {
local ($_, %_);
my ($id, $name, $col, $defcol, $sql, $sth);
$id = $_[0];
# Bounce if there is any problem with $id
return t_notset unless defined $id;
# Return the cache
return $Country_ctname{$id} if exists $Country_ctname{$id};
# Default language
if (getlang eq DEFAULT_LANG) {
$name = "name_" . getlang(LN_DATABASE) . " AS name";
# Fall back to the default language
} else {
$col = "name_" . getlang LN_DATABASE;
$defcol = "name_" . ln DEFAULT_LANG, LN_DATABASE;
$name= "COALESCE($col, $defcol) AS name";
}
# Query
$sql = "SELECT $name FROM country"
. " WHERE id=" . $DBH->quote($id) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
# Found
return ($Country_ctname{$id} = ${$sth->fetch}[0])
if $sth->rows == 1;
# Not found
return ($Country_ctname{$id} = t_na);
}
# ctname_zhtw: Obtain a country name in Traditional Chinese
sub ctname_zhtw($) {
local ($_, %_);
my ($id, $name, $col, $defcol, $sql, $sth);
$id = $_[0];
# Bounce if there is any problem with $id
return t_notset unless defined $id;
# Fall back to the default language
$col = "name_" . ln TRAD_CHINESE, LN_DATABASE;
$defcol = "name_" . ln DEFAULT_LANG, LN_DATABASE;
$name= "COALESCE($col, $defcol) AS name";
# Query
$sql = "SELECT $name FROM country"
. " WHERE id=" . $DBH->quote($id) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
# Found
return ${$sth->fetch}[0] if $sth->rows == 1;
# Not found
return t_na;
}
return 1;

454
lib/perl5/Selima/DBD/Pg.pm Normal file
View File

@@ -0,0 +1,454 @@
# Selima Website Content Management System
# Pg.pm: The extended PostgreSQL database driver.
# 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-09-08
package Selima::DBD::Pg;
use 5.008;
use strict;
use warnings;
use MIME::Base64 qw(decode_base64);
use Term::ReadKey qw(ReadMode);
use Selima::DataVars qw(:db :env :siteconf :scptconf);
use Selima::DBILogin;
use Selima::HTTP;
#use vars qw($DBHC $PGDATABASE $PGHOST $PGPORT $PGUSER $PGPASSWORD);
use vars qw($DBHC);
# new: Connect and establish a new PostgreSQL database source
sub new : method {
local ($_, %_);
my ($class, $dbiclass, $dbh);
$class = ref($_[0]) || $_[0];
$dbiclass = (caller)[0];
# Login with from SQLLOGIN environment variable as a web application
if ($IS_CGI) {
my ($dsn, %r);
# Prepare the connection information
%r = get_dbi_login_info DBI_POSTGRESQL;
# Return the available cached handle and clear the cache
if (defined $DBHC && $DBHC->{"Name"} eq $r{"PGDATABASE"} && $DBHC->ping) {
$dbh = $DBHC;
# Clear the cache to remove static reference to the database handle,
# to avoid leaving dead handles that owns table locks
undef $DBHC;
return $dbh;
}
# Clear the cache
undef $DBHC if defined $DBHC;
# Compose the DSN
@_ = qw();
push @_, "host=" . $r{"PGHOST"} . ";" if defined $r{"PGHOST"};
push @_, "dbname=" . $r{"PGDATABASE"} . ";" if defined $r{"PGDATABASE"};
$dsn = "dbi:Pg:" . join "", @_;
# Try to log in, handling the failure later
%_ = ( "PrintError" => 0 );
$dbh = $dbiclass->connect($dsn, $r{"PGUSER"}, $r{"PGPASSWORD"}, {%_});
# Login failed
http_500 $dbiclass->errstr if !defined $dbh;
# Ask the password from the console
} else {
my ($dsn, $subseq, $user, $passwd);
$dsn = "dbi:Pg:dbname=$PACKAGE;";
$subseq = 0;
# Try to log in
while (!defined($dbh = $dbiclass->connect($dsn, $user, $passwd, { PrintError => 0 }))) {
$_ = DBI->errstr;
if ($subseq) {
print STDERR $_;
sleep 5;
}
$subseq = 1;
# Obtain the current login user
$user = $1 if !defined $user && / failed for user "(.+?)"/;
# Disable console echo
ReadMode 2;
print STDERR defined $user? "PostgreSQL password for $user: ":
"PostgreSQL password: ";
$passwd = <STDIN>;
print STDERR "\n";
die "$THIS_FILE: Failed connecting to the PostgreSQL server\n"
if !defined $passwd;
chomp $passwd;
# Restore console echo status
ReadMode 0;
}
}
# Bless the object, name it as the current class
$dbh = bless $dbh, $dbiclass . "::db";
# Set the client encoding to UTF-8
$_ = "SET NAMES 'utf8';\n";
$dbh->do($_);
return $dbh;
}
# park_handle: Suspend the database handle for further use (mod_perl)
sub park_handle : method { $DBHC = $_[1]; }
# Selima::DBD::Pg::db: The database-handler driver class
package Selima::DBD::Pg::db;
use 5.008;
use strict;
use warnings;
use Fcntl qw(:flock);
use Selima::GetLang;
use Selima::HTTP;
use Selima::DataVars qw(:db :lninfo);
# support: Return if a DBI feature is supported
sub support : method {
local ($_, %_);
my ($self, $feature);
($self, $feature) = @_;
# PostgreSQL has VIEWs.
return 1 if $feature eq DBI_FEATHER_VIEW;
# Default to yes. We assume everyone is a good guy.
return 1;
}
# lock: PostgreSQL table-locking handler
# PostgreSQL has no unlock
# Input:
# %locks: A hash table, where its keys are the tables to lock,
# and its values can be one of the following:
# LOCK_SH: Request a read lock
# LOCK_EX: Request a write lock
# LOCK_UN: No effect
# Return: None. Errors are directed to error handlers
sub lock : method {
local ($_, %_);
my ($self, %locks, @reads, @writes, $sth);
($self, %locks) = @_;
# Bounce for nothing
return if scalar(keys %locks) == 0;
# Remove the table aliases -- compatibility with stupid MySQL
%_ = qw();
foreach my $table (keys %locks) {
# Remove the table aliases
$_ = $table;
s/\s+AS\s+.+?$//i;
# No override previous write lock
next if exists $_{$_} && $_{$_} == LOCK_EX;
# Set the lock
$_{$_} = $locks{$table};
}
%locks = %_;
# Split into different lock modes
@reads = qw();
@writes = qw();
foreach (keys %locks) {
if ($locks{$_} == LOCK_SH) {
push @reads, $_;
} elsif ($locks{$_} == LOCK_EX) {
push @writes, $_;
} else {
http_500 "Bad SQL lock request: \"" . $locks{$_} . "\""
. " on table \"$_\".";
}
}
# Start the transaction
$self->begin_work if $self->{"AutoCommit"};
# Request the locks
if (@reads > 0) {
$_ = "LOCK TABLE " . join(", ", @reads)
. " IN SHARE MODE;\n";
$self->do($_);
}
if (@writes > 0) {
$_ = "LOCK TABLE " . join(", ", @writes)
. " IN ACCESS EXCLUSIVE MODE;\n";
$self->do($_);
}
return;
}
# tables: Return the tables and views
sub tables : method {
local ($_, %_);
my ($self, $schema, $cache, $sth, @tables);
($self, $schema) = @_;
# Default schema
$schema = $self->current_schema if !defined $schema;
# Initialize the cache
${$self->{"private_selima"}}{"tables"} = {}
if !exists ${$self->{"private_selima"}}{"tables"};
$cache = ${$self->{"private_selima"}}{"tables"};
# Return the cache
return @{${$cache}{$schema}} if exists ${$cache}{$schema};
# Get the tables list
$sth = $self->table_info(undef, $schema, "%", "%")
or http_500 $self->errstr;
@tables = qw();
push @tables, ${$_}{"TABLE_NAME"}
while defined($_ = $sth->fetchrow_hashref);
# Cache it
${$cache}{$schema} = [@tables];
return @tables;
}
# cols: Return the columns of a table (or view)
sub cols : method {
local ($_, %_);
my ($self, $table, $schema, $cache, $sth, @cols);
($self, $table, $schema) = @_;
# Default schema
$schema = $self->current_schema if !defined $schema;
# Initialize the cache
${$self->{"private_selima"}}{"cols"} = {}
if !exists ${$self->{"private_selima"}}{"cols"};
${${$self->{"private_selima"}}{"cols"}}{$schema} = {}
if !exists ${${$self->{"private_selima"}}{"cols"}}{$schema};
$cache = ${${$self->{"private_selima"}}{"cols"}}{$schema};
# Return the cache
return @{${$cache}{$table}} if exists ${$cache}{$table};
# Get the columns list
$sth = $self->column_info(undef, $schema, $table, "%")
or http_500 $self->errstr;
@cols = qw();
push @cols, ${$_}{"COLUMN_NAME"}
while defined($_ = $sth->fetchrow_hashref);
s/^"(.+)"/$1/ foreach @cols;
# Cache it
${$cache}{$table} = [@cols];
return @cols;
}
# col_lens: Obtain the column lengths of a table
sub col_lens : method {
local ($_, %_);
my ($self, $table, $schema, $cache, $sth, $sql, $count, %lens, $lndb);
($self, $table, $schema) = @_;
# Default schema
$schema = $self->current_schema if !defined $schema;
# Initialize the cache
${$self->{"private_selima"}}{"col_lens"} = {}
if !exists ${$self->{"private_selima"}}{"col_lens"};
${${$self->{"private_selima"}}{"col_lens"}}{$schema} = {}
if !exists ${${$self->{"private_selima"}}{"col_lens"}}{$schema};
$cache = ${${$self->{"private_selima"}}{"col_lens"}}{$schema};
# Return the cache
return %{${$cache}{$table}} if exists ${$cache}{$table};
# Query
$sql = "SELECT pg_attribute.attname AS col,"
. " pg_type.typname AS type,"
. " pg_attribute.attlen AS len,"
. " pg_attribute.atttypmod AS typmod"
. " FROM pg_attribute"
. " INNER JOIN pg_class ON pg_attribute.attrelid=pg_class.oid"
. " INNER JOIN pg_type ON pg_attribute.atttypid=pg_type.oid"
. " INNER JOIN pg_namespace ON pg_class.relnamespace=pg_namespace.oid"
. " WHERE pg_namespace.nspname=" . $self->quote($schema)
. " AND pg_class.relname=" . $self->quote($table)
. " AND pg_class.relkind='r'"
. " AND pg_attribute.attnum>0"
. " ORDER BY pg_attribute.attnum;\n";
$sth = $self->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, %lens = qw(); $i < $count; $i++) {
%_ = %{$sth->fetchrow_hashref};
# Integer -- Digits of the largest number - 1
if ($_{"type"} =~ /^int[248]$/) {
$lens{$_{"col"}} = int(log(256**$_{"len"})/log 10);
# Refer to typmod for char and varchar
} elsif ($_{"type"} =~ /^(?:var|bp)char$/) {
$lens{$_{"col"}} = $_{"typmod"} - 4;
# Set text and bytea to 4294967296 (2^32) (infinite actually)
} elsif ($_{"type"} =~ /^(?:text|bytea)$/) {
$lens{$_{"col"}} = 4294967296;
# Set timestamp to 19
} elsif ($_{"type"} eq "timestamp" || $_{"type"} eq "timestamptz") {
$lens{$_{"col"}} = 19;
# Set date to 10
} elsif ($_{"type"} eq "date") {
$lens{$_{"col"}} = 10;
# Set time to 8
} elsif ($_{"type"} eq "time") {
$lens{$_{"col"}} = 8;
# Set numeric to precision + 1 decimal point
# Refer to http://archives.postgresql.org/pgsql-hackers/1999-01/msg00127.php
} elsif ($_{"type"} eq "numeric") {
my ($typmod, $scale, $precision);
$typmod = $_{"typmod"} - 4;
$scale = $typmod & 0xFFFF;
$precision = $typmod >> 16;
$lens{$_{"col"}} = $precision + 1;
# Set boolean to 1
} elsif ($_{"type"} eq "bool") {
$lens{$_{"col"}} = 1;
# Set inet to 18 (nnn.nnn.nnn.nnn/nn)
} elsif ($_{"type"} eq "inet") {
$lens{$_{"col"}} = 18;
# Bounce for unknown columns
} else {
http_500 "Unknown column type " . $_{"type"}
. " for table $table.\n";
}
}
# Hash the multi-lingual columns
$lndb = getlang(LN_DATABASE);
$lens{$_} = $lens{$_ . "_$lndb"} foreach $self->cols_ml($table);
# Cache it
${$cache}{$table} = {%lens};
return %lens;
}
# quote_blob: Quote a piece of BLOB octet
sub quote_blob : method {
local ($_, %_);
my ($self, $octet, $sth, $sql);
($self, $octet) = @_;
$sql = "SELECT ?;\n";
$sth = $self->prepare($sql);
$sth->bind_param(1, $octet, { pg_type => DBD::Pg::PG_BYTEA() })
or http_500 $sql . $sth->errstr;
$sth->execute;
return "'" . ${$sth->fetch}[0] . "'";
}
# strcat: Concatenate strings
sub strcat : method {
local ($_, %_);
my ($self, @strings);
($self, @strings) = @_;
return join " || ", @strings;
}
# lastupd: Obtain the last updated time of a list of tables
sub lastupd : method {
local ($_, %_);
my ($self, @tables, $sql, $sth);
($self, @tables) = @_;
# Bounce if no tables supplied
return if scalar(@tables) == 0;
# Remove table aliases
s/^(\S+) AS \S+$/$1/ foreach @tables;
# Remove duplicates
%_ = map { $_ => 1 } @tables;
@tables = keys %_;
# Query
$sql = "SELECT mtime FROM mtime"
. " WHERE " . join(" OR ", map "tabname=" . $self->quote($_), @tables)
. " ORDER BY mtime DESC LIMIT 1;\n";
$sth = $self->prepare($sql);
$sth->execute;
# Bounce if no data found
return if $sth->rows != 1;
# Return the result
return ${$sth->fetchrow_hashref}{"mtime"};
}
# current_schema: Obtain the current schema
sub current_schema : method {
local ($_, %_);
my ($self, $sth, $sql);
$self = $_[0];
# Return the cache
return ${$self->{"private_selima"}}{"current_schema"}
if exists ${$self->{"private_selima"}}{"current_schema"};
$sql = "SELECT current_schema();\n";
$sth = $self->prepare($sql);
$sth->execute;
$_ = ${$sth->fetch}[0];
# Cache it
${$self->{"private_selima"}}{"current_schema"} = $_;
return $_;
}
# Selima::DBD::Pg::st: The statement-handler driver class
package Selima::DBD::Pg::st;
use 5.008;
use strict;
use warnings;
# typecols: Return the list of columns in specific types
sub typecols : method {
local ($_, %_);
my ($self, $types, %cols);
$self = $_[0];
$types = $self->{"pg_type"};
%cols = (
"date" => [],
"num" => [],
"bigint" => [],
"numeric" => [],
"text" => [],
);
for ($_ = 0; $_ < @$types; $_++) {
if ($$types[$_] =~ /^(?:date|timestamp)$/) {
push @{$cols{"date"}}, $_;
} elsif ($$types[$_] =~ /^(?:int2|int4|float4|float8)$/) {
push @{$cols{"num"}}, $_;
} elsif ($$types[$_] eq "int8") {
push @{$cols{"bigint"}}, $_;
} elsif ($$types[$_] eq "numeric") {
push @{$cols{"numeric"}}, $_;
} elsif ($$types[$_] =~ /^(?:varchar|text)$/) {
push @{$cols{"text"}}, $_;
}
}
return \%cols;
}
return 1;

301
lib/perl5/Selima/DBD/mysql.pm Normal file
View File

@@ -0,0 +1,301 @@
# Selima Website Content Management System
# mysql.pm: The extended MySQL database driver.
# 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-09-23
package Selima::DBD::mysql;
use 5.008;
use strict;
use warnings;
use MIME::Base64 qw(decode_base64);
use Term::ReadKey qw(ReadMode);
use Selima::DataVars qw(:db :env :siteconf :scptconf);
use Selima::DBILogin;
use Selima::HTTP;
#use vars qw(%DBH $MYSQL_HOST $MYSQL_TCP_PORT $MYSQL_UNIX_PORT $MYSQL_DB $MYSQL_USER $MYSQL_PWD);
use vars qw(%DBH);
# new: Connect and establish a new MySQL database source
sub new : method {
local ($_, %_);
my ($class, $dbiclass, $dbh);
$class = ref($_[0]) || $_[0];
# Login with from SQLLOGIN environment variable as a web application
if ($IS_CGI) {
my ($dsn, %r);
# Prepare the connection information
%r = get_dbi_login_info DBI_MYSQL;
# Compose the DSN
@_ = qw();
push @_, "host=" . $r{"MYSQL_HOST"} . ";" if defined $r{"MYSQL_HOST"};
$dsn = "dbi:mysql:" . join "", @_;
# Return the available cached handle and clear the cache
if (exists $DBH{$dsn} && $DBH{$dsn}->ping) {
# Obtain the cached database handle
$dbh = $DBH{$dsn};
# Clear the cache to remove static reference to the database handle,
# to avoid leaving dead handles that owns table locks
delete $DBH{$dsn};
# New connection
} else {
$dbiclass = (caller)[0];
# Try to log in, handling the failure later
%_ = ( "PrintError" => 0 );
$dbh = $dbiclass->connect($dsn, $r{"MYSQL_USER"}, $r{"MYSQL_PWD"}, {%_});
# Login failed
http_500 $dbiclass->errstr if !defined $dbh;
# Bless the object, name it as the current class
$dbh = bless $dbh, $dbiclass . "::db";
# Set the client encoding to UTF-8
$_ = "SET NAMES 'utf8';\n";
$dbh->do($_);
}
# Set the database
$_ = "USE " . $r{"MYSQL_DB"} . ";\n";
$dbh->do($_);
# Ask the password from the console
} else {
my ($dsn, $subseq, $user, $passwd);
$dsn = "dbi:mysql:database=$PACKAGE;";
$subseq = 0;
# Try to log in
while (!defined($dbh = DBI->connect($dsn, $user, $passwd, { PrintError => 0 }))) {
$_ = DBI->errstr;
if ($subseq) {
print STDERR "$_\n";
sleep 5;
}
$subseq = 1;
# Obtain the current login user
$user = $1 if !defined $user && / denied for user: '(.+?)\@.+?'/;
# Disable console echo
ReadMode 2;
print STDERR defined $user? "MySQL password for $user: ":
"MySQL password: ";
$passwd = <STDIN>;
print STDERR "\n";
die "$THIS_FILE: Failed connecting to the MySQL server\n"
if !defined $passwd;
chomp $passwd;
# Restore console echo status
ReadMode 0;
}
}
return $dbh;
}
# park_handle: Suspend the database handle for further use (mod_perl)
sub park_handle : method { $DBH{"dbi:mysql:" . $_[1]->{"Name"}} = $_[1]; }
# Selima::DBD::mysql::db: The database-handler driver class
package Selima::DBD::mysql::db;
use 5.008;
use strict;
use warnings;
use Fcntl qw(:flock);
use Selima::GetLang;
use Selima::HTTP;
use Selima::DataVars qw(:db :lninfo);
# support: Return if a DBI feature is supported
sub support : method {
local ($_, %_);
my ($self, $feature);
($self, $feature) = @_;
# MySQL has VIEW since 5.0
return 1 if $feature eq DBI_FEATHER_VIEW;
# Default to yes. We assume everyone is a good guy.
return 1;
}
# tables: Return the tables
sub tables : method {
local ($_, %_);
my ($self, $sth, $cache, @tables);
$self = $_[0];
# Initialize the cache
$cache = $self->{"private_selima"};
# Return the cache
return @{${$cache}{"tables"}} if exists ${$cache}{"tables"};
# Get the tables list
$sth = $self->table_info(undef, undef, "%", undef)
or http_500 $self->errstr;
@tables = qw();
push @tables, $$_{"TABLE_NAME"}
while defined($_ = $sth->fetchrow_hashref);
# Cache it
${$cache}{"tables"} = [@tables];
return @tables;
}
# cols: Return the columns of a table
sub cols : method {
local ($_, %_);
my ($self, $table, $cache, $sth, @cols);
($self, $table) = @_;
# Initialize the cache
${$self->{"private_selima"}}{"cols"} = {}
if !exists ${$self->{"private_selima"}}{"cols"};
$cache = ${$self->{"private_selima"}}{"cols"};
# Return the cache
return @{${$cache}{$table}} if exists ${$cache}{$table};
# Get the columns list
$sth = $self->column_info(undef, undef, $table, "%")
or http_500 $self->errstr;
@cols = qw();
push @cols, $_ while defined($_ = $sth->fetchrow_hashref);
@cols = map $$_{"COLUMN_NAME"},
sort { ${$a}{"ORDINAL_POSITION"} <=> ${$b}{"ORDINAL_POSITION"} } @cols;
# Cache it
${$cache}{$table} = [@cols];
return @cols;
}
# col_lens: Obtain the column lengths of a table
sub col_lens : method {
local ($_, %_);
my ($self, $table, $cache, $sth, $sql, $count, %lens, $lndb);
($self, $table) = @_;
# Initialize the cache
${$self->{"private_selima"}}{"col_lens"} = {}
if !exists ${$self->{"private_selima"}}{"col_lens"};
$cache = ${$self->{"private_selima"}}{"col_lens"};
# Return the cache
return %{${$cache}{$table}} if exists ${$cache}{$table};
# Use column_info here
$sth = $self->column_info(undef, undef, $table, "%")
or http_500 $self->errstr;
%_ = qw();
$_{$$_{"COLUMN_NAME"}} = $$_{"COLUMN_SIZE"}
while defined($_ = $sth->fetchrow_hashref);
# Hash the multi-lingual columns
$lndb = getlang(LN_DATABASE);
$lens{$_} = $lens{$_ . "_$lndb"} foreach $self->cols_ml($table);
# Cache it
${$cache}{"tables"} = {%_};
return %_;
}
# quote_blob: Quote a piece of BLOB octet
sub quote_blob : method {
local ($_, %_);
my ($self, $octet);
($self, $octet) = @_;
return $self->quote($octet);
}
# strcat: Concatenate strings
sub strcat : method {
local ($_, %_);
my ($self, @strings);
($self, @strings) = @_;
return "CONCAT(" . join(", ", @strings) . ")";
}
# lastupd: Obtain the last updated time of a list of tables
sub lastupd : method {
local ($_, %_);
my ($self, @tables, $sql, $sth);
($self, @tables) = @_;
# Bounce if no tables supplied
return if scalar(@tables) == 0;
# Remove duplicates
%_ = map { $_ => 1 } @tables;
@tables = keys %_;
# Query
$sql = "SELECT mtime FROM mtime"
. " WHERE " . join(" OR ", map "tabname=" . $self->quote($_), @tables)
. " ORDER BY mtime DESC LIMIT 1;\n";
$sth = $self->prepare($sql);
$sth->execute;
# Bounce if no data found
return if $sth->rows != 1;
# Return the result
return ${$sth->fetchrow_hashref}{"mtime"};
}
# Selima::DBD::mysql::st: The statement-handler driver class
package Selima::DBD::mysql::st;
use 5.008;
use strict;
use warnings;
# typecols: Return the list of columns in specific types
sub typecols : method {
local ($_, %_);
my ($self, $types, %cols);
$self = $_[0];
$types = $self->{"mysql_type_name"};
%cols = (
"date" => [],
"num" => [],
"bigint" => [],
"numeric" => [],
"text" => [],
);
for ($_ = 0; $_ < @$types; $_++) {
if ($$types[$_] =~ /^(?:date|datetime|timestamp)$/) {
push @{$cols{"date"}}, $_;
} elsif ($$types[$_] =~ /^(?:tinyint|smallint|middleint|integer|float|double)$/) {
push @{$cols{"num"}}, $_;
} elsif ($$types[$_] eq "bigint") {
push @{$cols{"bigint"}}, $_;
} elsif ($$types[$_] eq "decimal") {
push @{$cols{"numeric"}}, $_;
} elsif ($$types[$_] =~ /^(?:varchar|blob)$/) {
push @{$cols{"text"}}, $_;
}
}
return \%cols;
}
return 1;

440
lib/perl5/Selima/DBI.pm Normal file
View File

@@ -0,0 +1,440 @@
# Selima Website Content Management System
# DBI.pm: The extended DBI (database interface).
# 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-09-09
package Selima::DBI;
use 5.008;
use strict;
use warnings;
use base qw(DBI);
use Selima::DataVars qw(:db);
# new: Connect and establish a new database source
sub new : method {
local ($_, %_);
my ($type, $dbh, $class, $methods);
$type = $_[1];
# PostgreSQL
if ($type eq DBI_POSTGRESQL) {
require Selima::DBD::Pg;
$dbh = Selima::DBD::Pg->new;
# MySQL
} elsif ($type eq DBI_MYSQL) {
require Selima::DBD::mysql;
$dbh = Selima::DBD::mysql->new;
}
# Keep the imported methods for cached DBH (mod_perl)
undef $methods;
$methods = ${$dbh->{"private_selima"}}{"methods"}
if exists $dbh->{"private_selima"}
&& exists ${$dbh->{"private_selima"}}{"methods"};
# Initialize the private attributes
$dbh->{"private_selima"} = {};
# Import the methods
if (defined $methods) {
${$dbh->{"private_selima"}}{"methods"} = $methods ;
} else {
$dbh->import_methods;
}
return $dbh;
}
# Selima::DBI::db: The database-handler class
package Selima::DBI::db;
use 5.008;
use strict;
use warnings;
use base qw(DBI::db);
use vars qw($METHODS_DEFINED @IMPORT_METHODS);
$METHODS_DEFINED = 0;
@IMPORT_METHODS = qw(support lock tables cols col_lens quote_blob
strcat lastupd current_schema);
use Encode qw(encode);
use Selima::DataVars qw(:env :lninfo);
use Selima::HTTP;
use Selima::GetLang;
use Selima::Guest;
# import_methods: Import our own methods
sub import_methods : method {
local ($_, %_);
my ($self, $methods, $class, $driver);
$self = $_[0];
# Initialize the methods pool and the class and driver name
${$self->{"private_selima"}}{"methods"} = {};
$class = ref($self);
$driver = $class;
$driver =~ s/::DBI::db$//;
$driver .= "::DBD::" . $self->{"Driver"}->{"Name"} . "::db";
# Define the methods once
if (!$METHODS_DEFINED) {
# Short-cut to the methods pool
$methods = "\${\$_[0]->{\"private_selima\"}}{\"methods\"}";
foreach (@IMPORT_METHODS) {
eval << "EOT";
*$_ = sub { return \&{\${$methods}{"$_"}}(\@_); }
EOT
}
$METHODS_DEFINED = 1;
}
# Short-cut to the methods pool
$methods = ${$self->{"private_selima"}}{"methods"};
# Import each method
foreach my $func (@IMPORT_METHODS) {
if (defined($_ = $driver->can($func))) {
${$methods}{$func} = $_;
} elsif (defined($_ = $class->can("SUPER::$func"))) {
${$methods}{$func} = $_;
} else {
${$methods}{$func} = sub {};
}
}
return;
}
# do: run SUPER::do() and handle errors
sub do : method {
local ($_, %_);
my ($self, $sql, $rv);
($self, $sql, @_) = @_;
# $sql should always be a decoded text
$sql = encode("UTF-8", $sql);
# Run and handle errors
$rv = $self->SUPER::do($sql, @_)
or http_500 $sql . $self->errstr;
# Update the mtime
if ($sql =~ /^(?:INSERT\s+INTO|UPDATE|DELETE\s+FROM)\s+(\S+)/i) {
my ($table, $sql, $sth);
$table = $1;
$table =~ s/^"(.+?)"$/$1/;
$table = $self->quote($table);
$sql = "SELECT * FROM mtime WHERE tabname=$table;\n";
$sth = $self->prepare($sql);
$sth->execute;
# Found
if ($sth->rows == 1) {
# Update the mtime
$sql = "UPDATE mtime SET mtime=now() WHERE tabname=$table;\n";
$self->SUPER::do($sql);
# Not found
} else {
# Set the mtime
$sql = "INSERT INTO mtime (tabname, mtime) VALUES ($table, now());\n";
$self->SUPER::do($sql);
}
}
return $rv;
}
# gdo: only run do() when user is not a guest
sub gdo : method {
local ($_, %_);
my $self;
($self, @_) = @_;
# Skip for guests
return 1 if is_guest;
return $self->do(@_);
}
# prepare: run SUPER::prepare, handle errors and import our extension methods
sub prepare : method {
local ($_, %_);
my ($self, $sql, $sth);
($self, $sql, @_) = @_;
# Run and handle errors
$sth = $self->SUPER::prepare($sql, @_)
or http_500 $sql . $self->errstr;
# Import our extension methods
$sth->{"private_selima"} = {};
$sth->import_methods;
return $sth;
}
# begin_work, commit, rollback do not need to handle their errors.
# errors can be silently ignored. See DBI(3) for more details.
#
# Methods below are driver-indepedent. Override is not required.
#
# cols_ml: Return the multi-lingual columns list of a table (or view)
sub cols_ml : method {
local ($_, %_);
my ($self, $table, $sth, @cols, @cols_ml, $suf);
($self, $table) = @_;
$self->{"private_cols_ml"} = {}
if !exists $self->{"private_cols_ml"};
# Return the cache
return @{${$self->{"private_cols_ml"}}{$table}}
if exists ${$self->{"private_cols_ml"}}{$table};
@cols = $self->cols($table);
@cols_ml = qw();
$suf = "_" . getlang LN_DATABASE;
foreach (@cols) {
push @cols_ml, $_ if $_ =~ s/$suf$//;
}
# Cache it
${$self->{"private_cols_ml"}}{$table} = [@cols_ml];
return @cols_ml;
}
# is_ml_table: Check if a table is multi-lingual
sub is_ml_table : method {
local ($_, %_);
my ($self, $table);
($self, $table) = @_;
return scalar($self->cols_ml($table)) > 0;
}
# esclike: Escape a phrase by the LIKE matching rule
# Double quote should never be used, according to
# the column name rules in the SQL standard.
sub esclike : method {
local ($_, %_);
my $self;
($self, $_) = @_;
s/\\/\\\\\\\\/g;
s/%/\\\\%/g;
s/_/\\\\_/g;
# By the SQL standard
s/'/''/g; # ' gettext
# Non-standard, but this also works for most SQL DBMS
#s/'/\\\\\\'/g;
return $_;
}
# disconnect: Disconnect from the database server
sub disconnect : method {
local ($_, %_);
my ($self, $class);
$self = $_[0];
$class = ref($self);
$class =~ s/::DBI::db$//;
$class .= "::DBD::" . $self->{"Driver"}->{"Name"};
# Rollback the changes that are not committed and unlock the tables
$self->rollback if !$self->{"AutoCommit"};
# mod_perl: Suspend the database handle for further use, but not
# really disconnect it.
# Disabled. Save system from server load too high.
#if ($IS_MODPERL) {
# return $class->park_handle($self);
#} else {
$_ = $self->SUPER::disconnect or http_500 $self->errstr;
return $_;
#}
}
# Selima::DBI::st: The statement-handler class
package Selima::DBI::st;
use 5.008;
use strict;
use warnings;
use base qw(DBI::st);
use vars qw($METHODS_DEFINED @IMPORT_METHODS);
$METHODS_DEFINED = 0;
@IMPORT_METHODS = qw(typecols);
use DBI qw(:sql_types);
use Encode qw(decode_utf8 FB_CROAK is_utf8);
use Date::Parse qw(str2time);
use Selima::HTTP;
# import_methods: Import our own methods
sub import_methods : method {
local ($_, %_);
my ($self, $methods, $class, $driver);
$self = $_[0];
# Initialize the methods pool and the class and driver name
${$self->{"private_selima"}}{"methods"} = {};
$class = ref($self);
$driver = $class;
$driver =~ s/::DBI::st$//;
$driver .= "::DBD::" . $self->{"Database"}->{"Driver"}->{"Name"} . "::st";
# Define the methods once
if (!$METHODS_DEFINED) {
# Short-cut to the methods pool
$methods = "\${\$_[0]->{\"private_selima\"}}{\"methods\"}";
foreach (@IMPORT_METHODS) {
eval << "EOT";
*$_ = sub { return \&{\${$methods}{"$_"}}(\@_); }
EOT
}
$METHODS_DEFINED = 1;
}
# Short-cut to the methods pool
$methods = ${$self->{"private_selima"}}{"methods"};
# Import each method
foreach my $func (@IMPORT_METHODS) {
if (defined($_ = $driver->can($func))) {
${$methods}{$func} = $_;
} elsif (defined($_ = $class->can("SUPER::$func"))) {
${$methods}{$func} = $_;
} else {
${$methods}{$func} = sub {};
}
}
return;
}
# execute: run SUPER::execute and handle errors
sub execute : method {
local ($_, %_);
my $self;
($self, @_) = @_;
# Run and handle errors
$_ = $self->SUPER::execute(@_)
or http_500 $self->{"Statement"} . $self->errstr;
return $_;
}
# fetch: fetch and decode from UTF-8
# DBI::st returns a same array reference each time, with
# only the values changed. Then, after the first fetch,
# the values returned are all tagged as "wide characters"
# (decoded) and cannot be decode()ed again. To avoid this
# problem, we make a different copy of the returned values
# and decode that copy, instead of decoding those in the
# original array reference returned.
sub fetch : method {
local ($_, %_);
my ($self, @args, $row, $types);
($self, @args) = @_;
# Fetch the row first
$row = $self->SUPER::fetch(@args);
# No record found or some error occurs
return undef if !defined $row;
# Not called from within fetchrow_hashref()
if (exists $self->{"TYPE"}) {
# Make a copy of the record
$row = [@$row];
# Obtain the type classes
${$self->{"private_selima"}}{"types"} = $self->typecols
if !exists ${$self->{"private_selima"}}{"types"};
$types = ${$self->{"private_selima"}}{"types"};
# Convert the date/datetime columns
foreach (@{$$types{"date"}}) {
$$row[$_] = str2time $$row[$_]
if defined $$row[$_];
}
# Convert the numeric columns
foreach (@{$$types{"num"}}) {
$$row[$_] = $$row[$_] + 0
if defined $$row[$_];
}
# Decode the text columns
foreach (@{$$types{"text"}}) {
$$row[$_] = decode_utf8($$row[$_], FB_CROAK)
if defined $$row[$_] && !is_utf8($$row[$_]);
}
}
return $row;
}
# fetchrow_hashref: fetch and read some fields
sub fetchrow_hashref : method {
local ($_, %_);
my ($self, @args, $row, $types);
($self, @args) = @_;
# Fetch the row first
$row = $self->SUPER::fetchrow_hashref(@args);
# No record found or some error occurs
return undef if !defined $row;
# Make a copy of the record
$row = {%$row};
# Obtain the type classes
${$self->{"private_selima"}}{"types"} = $self->typecols
if !exists ${$self->{"private_selima"}}{"types"};
$types = ${$self->{"private_selima"}}{"types"};
# Convert the date/datetime columns
foreach (@{$$types{"date"}}) {
$$row{${$self->{"NAME"}}[$_]} = str2time $$row{${$self->{"NAME"}}[$_]}
if defined $$row{${$self->{"NAME"}}[$_]};
}
# Convert the numeric columns
foreach (@{$$types{"num"}}) {
$$row{${$self->{"NAME"}}[$_]} = $$row{${$self->{"NAME"}}[$_]} + 0
if defined $$row{${$self->{"NAME"}}[$_]};
}
# Decode the text columns
foreach (@{$$types{"text"}}) {
$$row{${$self->{"NAME"}}[$_]} = decode_utf8($$row{${$self->{"NAME"}}[$_]}, FB_CROAK)
if defined $$row{${$self->{"NAME"}}[$_]} && !is_utf8($$row{${$self->{"NAME"}}[$_]});
}
return $row;
}
# fetchrow_arrayref: fetch and read some fields
sub fetchrow_arrayref : method {
local ($_, %_);
my ($self, @args, $row, $types);
($self, @args) = @_;
# Fetch the row first
$row = $self->SUPER::fetchrow_arrayref(@args);
# No record found or some error occurs
return undef if !defined $row;
# Make a copy of the record
$row = [@$row];
# Obtain the type classes
${$self->{"private_selima"}}{"types"} = $self->typecols
if !exists ${$self->{"private_selima"}}{"types"};
$types = ${$self->{"private_selima"}}{"types"};
# Convert the date/datetime columns
foreach (@{$$types{"date"}}) {
$$row[$_] = str2time $$row[$_]
if defined $$row[$_];
}
# Convert the numeric columns
foreach (@{$$types{"num"}}) {
$$row[$_] = $$row[$_] + 0
if defined $$row[$_];
}
# Decode the text columns
foreach (@{$$types{"text"}}) {
$$row[$_] = decode_utf8($$row[$_], FB_CROAK)
if defined $$row[$_];
}
return $row;
}
return 1;

93
lib/perl5/Selima/DBILogin.pm Normal file
View File

@@ -0,0 +1,93 @@
# Selima Website Content Management System
# DBILogin.pm: The subroutine to extract the database log in information.
# Copyright (c) 2006-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: 2006-02-02
package Selima::DBILogin;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(get_dbi_login_info);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub get_dbi_login_info($;$$);
}
use MIME::Base64 qw(decode_base64);
use Selima::DataVars qw(:db :siteconf);
# get_dbi_login_info: Obtain the DBI log-in information
sub get_dbi_login_info($;$$) {
local ($_, %_);
my ($type, $host, $user, @names, %login);
($type, $host, $user) = @_;
# DBMS naming convensions
if ($type eq DBI_POSTGRESQL) {
@names = qw(PGHOST PGUSER PGPASSWORD PGDATABASE);
} elsif ($type eq DBI_MYSQL) {
@names = qw(MYSQL_HOST MYSQL_USER MYSQL_PW MYSQL_DB);
}
# Initialize the return values
%login = (
$names[0] => undef,
$names[1] => undef,
$names[2] => undef,
$names[3] => "test",
);
# Obtain the DBI log-in information from the environment
if (exists $ENV{"SQLLOGIN"}) {
# Parse the DBI log-in information
# The first matched line is used, so put the default first
foreach my $line (split /\n/, decode_base64($ENV{"SQLLOGIN"})) {
@_ = split /\t/, $line;
# Skip malformed lines
next unless @_ == 4;
# Not this type
next if $_[0] ne $type;
# Not this host
next if defined $host && $_[1] ne $host;
# Not this user
next if defined $user && $_[2] ne $user;
# Found
# Deal with null values
foreach (@_) {
undef $_ if $_ eq "null";
}
$login{$names[0]} = $_[1];
$login{$names[1]} = $_[2];
$login{$names[2]} = $_[3];
$login{$names[3]} = $PACKAGE if defined $PACKAGE;
last;
}
}
# Alternative information set in %DBILOGIN
foreach (keys %DBILOGIN) {
$login{$_} = $DBILOGIN{$_} if exists $login{$_};
}
return %login;
}
return 1;

243
lib/perl5/Selima/DataVars.pm Normal file
View File

@@ -0,0 +1,243 @@
# Selima Website Content Management System
# DataVars.pm: The core constants and variables.
# Copyright (c) 2003-2020 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::DataVars;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT %EXPORT_TAGS @EXPORT_OK);
BEGIN {
@EXPORT = qw();
%EXPORT_TAGS = (
absuri => [qw(ABSURI_SKIP_FRAGMENT)],
addcol => [qw(ADDCOL_INSERT ADDCOL_UPDATE ADDCOL_NOTIMESTAMP)],
author => [qw($AUTHOR $COPYRIGHT)],
db => [qw($DBH $DBI_TYPE DBI_NONE DBI_POSTGRESQL DBI_MYSQL
DBI_FEATHER_VIEW %DBILOGIN)],
dataman => [qw($THIS_TABLE %CURRENT %REQUEST %PREVIEW)],
env => [qw($IS_CGI $IS_MODPERL $IS_MP2 $IS_PERLIS)],
forms => [qw(%SCRIPTS FORM_THIS FORM_USERS FORM_GROUPS FORM_USERMEM
FORM_GROUPMEM FORM_USERPREF FORM_SCPTPRIV FORM_PIC FORM_PAGES
FORM_NEWS FORM_LINKCAT FORM_LINKS FORM_ACCTSUBJ FORM_ACCTTRX
FORM_CAPTCHA)],
groups => [qw(SU_GROUP ADMIN_GROUP ALLUSERS_GROUP GUEST_GROUP)],
hostconf=> [qw($VIRTUAL_HOST $HTTPS_HOST $NOLOGIN)],
input => [qw(%USER_INPUT $POST $GET $UPLOAD %COOKIES $SESSION $AUTHINFO)],
l10n => [qw($DEFAULT_LANG @ALL_LINGUAS $LH $CLH $ALH
$LOCALEDIR COMMON_DOMAIN COMMON_LOCALEDIR)],
lastmod => [qw($LAST_MODIFIED)],
libdir => [qw($SITE_LIBDIR COMMON_LIBDIR)],
list => [qw($PAGEBAR_RANGE)],
lninfo => [qw(LN_NAME LN_CHARSET LN_FILENAME LN_LOCALE LN_DATABASE
LN_HTMLID LN_SPACE_BREAK LN_COUNTRY_FIRST
LN_DESC LN_DESC_CURLC LN_DESC_SELFLC LN_SWITCH_TITLE)],
mail => [qw(SMTP_HOST)],
output => [qw($CONTENT_TYPE $NO_AUTO_OUTPUT %NEWCOOKIES %HTTP_HEADERS
$PAGE_PARAM $ALT_PAGE_PARAM)],
proctime=> [qw($LOGTIME $T_START)],
rebuild => [qw(@REBUILD_TABLES %REBUILD_LABELS)],
requri => [qw($DOC_ROOT $ROOT_DIFF $REQUEST_PATH $REQUEST_FILE
$REQUEST_URI $REQUEST_FILEQS $REQUEST_SCHEME $REQUEST_HOST
$REQUEST_HOSTPORT $REQUEST_HOSTPATH $REQUEST_FULLURI)],
scptconf=> [qw($THIS_FILE $MAIN)],
siteconf=> [qw($PACKAGE $WEBMASTER $SITENAME_ABBR)],
user => [qw(%USERPREF)],
);
@EXPORT_OK = qw();
my %seen;
%seen = qw();
foreach my $tag (keys %EXPORT_TAGS) {
push @EXPORT_OK, grep !$seen{$_}++, @{$EXPORT_TAGS{$tag}};
}
$EXPORT_TAGS{"all"} = [@EXPORT_OK];
# Prototype declaration
sub clear();
}
use vars qw($AUTHOR $COPYRIGHT);
use vars qw($DBH $DBI_TYPE %DBILOGIN);
use vars qw($THIS_TABLE %CURRENT %REQUEST);
use vars qw($IS_CGI $IS_MODPERL $IS_MP2 $IS_PERLIS);
use vars qw(%SCRIPTS);
use vars qw($VIRTUAL_HOST $HTTPS_HOST $NOLOGIN);
use vars qw(%USER_INPUT $POST $GET $UPLOAD %COOKIES $SESSION $AUTHINFO);
use vars qw($DEFAULT_LANG @ALL_LINGUAS $LH $CLH $ALH);
use vars qw($LOCALEDIR);
use vars qw($LAST_MODIFIED);
use vars qw($SITE_LIBDIR);
use vars qw($PAGEBAR_RANGE);
use vars qw($CONTENT_TYPE $NO_AUTO_OUTPUT %NEWCOOKIES %HTTP_HEADERS);
use vars qw($PAGE_PARAM $ALT_PAGE_PARAM);
use vars qw($LOGTIME $T_START);
use vars qw(@REBUILD_TABLES %REBUILD_LABELS);
use vars qw($DOC_ROOT $ROOT_DIFF $REQUEST_PATH $REQUEST_FILE);
use vars qw($REQUEST_URI $REQUEST_FILEQS $REQUEST_SCHEME $REQUEST_HOST);
use vars qw($REQUEST_HOSTPORT $REQUEST_HOSTPATH $REQUEST_FULLURI);
use vars qw($THIS_FILE $MAIN);
use vars qw($PACKAGE $WEBMASTER $SITENAME_ABBR);
use vars qw(%USERPREF);
use constant ABSURI_SKIP_FRAGMENT => 1;
use constant ADDCOL_INSERT => 0;
use constant ADDCOL_UPDATE => 1;
use constant ADDCOL_NOTIMESTAMP => 0;
use constant DBI_NONE => "";
use constant DBI_POSTGRESQL => "PostgreSQL";
use constant DBI_MYSQL => "MySQL";
use constant DBI_FEATHER_VIEW => "view";
use constant FORM_THIS => 0;
use constant FORM_USERS => 1;
use constant FORM_GROUPS => 2;
use constant FORM_USERPRIV => 3;
use constant FORM_USERMEM => 4;
use constant FORM_GROUPMEM => 5;
use constant FORM_USERPREF => 6;
use constant FORM_SCPTPRIV => 7;
use constant FORM_PIC => 8;
use constant FORM_PAGES => 9;
use constant FORM_NEWS => 10;
use constant FORM_LINKCAT => 11;
use constant FORM_LINKS => 12;
use constant FORM_ACCTSUBJ => 13;
use constant FORM_ACCTTRX => 14;
# The column name of the CAPTCHA
# This is used to deceive the spambots
use constant FORM_CAPTCHA => "lastname";
use constant SU_GROUP => "root";
use constant ADMIN_GROUP => "admin";
use constant ALLUSERS_GROUP => "users";
use constant GUEST_GROUP => "guests";
use constant COMMON_DOMAIN => "selima";
use constant COMMON_LOCALEDIR => $ENV{"DOCUMENT_ROOT"} . "/../../locale";
use constant COMMON_LIBDIR => $ENV{"DOCUMENT_ROOT"} . "/../../lib/perl5";
use constant LN_NAME => 0;
use constant LN_CHARSET => 1;
use constant LN_FILENAME => 2;
use constant LN_LOCALE => 3;
use constant LN_DATABASE => 4;
use constant LN_HTMLID => 5;
use constant LN_SPACE_BREAK => 6;
#use constant LN_IGNORE_CASE => 7;
use constant LN_COUNTRY_FIRST => 8;
use constant LN_DESC => 9;
use constant LN_DESC_CURLC => 10;
use constant LN_DESC_SELFLC => 11;
use constant LN_SWITCH_TITLE => 12;
use constant SMTP_HOST => "localhost";
# Check the environment type in advance. These variables does not change
# at all even under mod_perl.
# GATEWAY_INTERFACE is not available yet when this script is loaded
$IS_CGI = exists $ENV{"GATEWAY_INTERFACE"} || exists $ENV{"MOD_PERL"};
$IS_MODPERL = exists $ENV{"MOD_PERL"};
$IS_MP2 = exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2;
$IS_PERLIS = exists $ENV{"PERLXS"} && $ENV{"PERLXS"} eq "PerlIS";
# clear: Clear the data variables
sub clear() {
local ($_, %_);
# Reset all the data variables
undef $AUTHINFO;
undef $AUTHOR;
undef $COPYRIGHT;
undef $DBH;
undef $DBI_TYPE;
%DBILOGIN = qw();
undef $THIS_TABLE;
%CURRENT = qw();
%REQUEST = qw();
%SCRIPTS = qw();
undef $VIRTUAL_HOST;
undef $HTTPS_HOST;
undef $NOLOGIN;
%USER_INPUT = qw();
undef $POST;
undef $GET;
undef $UPLOAD;
%COOKIES = qw();
undef $DEFAULT_LANG;
@ALL_LINGUAS = qw();
undef $LH;
undef $CLH;
undef $ALH;
undef $LOCALEDIR;
undef $LAST_MODIFIED;
undef $SITE_LIBDIR;
undef $PAGEBAR_RANGE;
undef $CONTENT_TYPE;
undef $NO_AUTO_OUTPUT;
%NEWCOOKIES = qw();
%HTTP_HEADERS = qw();
undef $PAGE_PARAM;
undef $ALT_PAGE_PARAM;
undef $LOGTIME;
undef $T_START;
@REBUILD_TABLES = qw();
%REBUILD_LABELS = qw();
undef $DOC_ROOT;
undef $ROOT_DIFF;
undef $REQUEST_PATH;
undef $REQUEST_FILE;
undef $REQUEST_URI;
undef $REQUEST_FILEQS;
undef $REQUEST_SCHEME;
undef $REQUEST_HOST;
undef $REQUEST_HOSTPORT;
undef $REQUEST_HOSTPATH;
undef $REQUEST_FULLURI;
undef $SESSION;
undef $THIS_FILE;
undef $MAIN;
undef $PACKAGE;
undef $WEBMASTER;
undef $SITENAME_ABBR;
%USERPREF = qw();
return;
}
return 1;

443
lib/perl5/Selima/DecForm.pm Normal file
View File

@@ -0,0 +1,443 @@
# Selima Website Content Management System
# DecForm.pm: The subroutines to decode the the input form from various character sets.
# 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-09-10
package Selima::DecForm;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(init_forms decode_forms decode_forms_delay);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub init_forms();
sub decode_forms();
sub decode_forms_delay();
sub try_decode_form($$);
sub split_upload($);
}
use Encode qw(decode FB_CROAK);
use URI::Escape qw(uri_escape);
use HTML::Entities qw(%entity2char);
use Selima::DataVars qw(:env :input :l10n :lninfo);
use Selima::GetLang;
use Selima::HTTP;
use Selima::LnInfo;
use Selima::Unicode;
use vars qw(@TRY);
@TRY = qw(US-ASCII Big5 GB2312 Shift-JIS UTF-8 ISO-8859-1 ISO-8859-15);
# init_forms: Initialize the user-input form data
sub init_forms() {
local ($_, %_);
my ($r, $rawget, $rawpost, $postdelay);
# Do not redo
return if scalar(keys %USER_INPUT) > 0;
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Scan the GET query
$rawget = $IS_MODPERL? (defined $r->args? $r->args: ""):
(exists $ENV{"QUERY_STRING"}? $ENV{"QUERY_STRING"}: "");
$GET = new CGI($rawget);
# Scan the POST form
$postdelay = 0;
if (($IS_MODPERL? $r->method: $ENV{"REQUEST_METHOD"}) eq "POST") {
if ($IS_MODPERL) {
# Ordinary POST form
if ( !defined($_ = $r->headers_in->get("Content-Type"))
|| $_ eq "application/x-www-form-urlencoded") {
if ($IS_MP2) {
$r->read($rawpost, $r->headers_in->get("Content-Length"));
} else {
$rawpost = $r->content;
}
$POST = new CGI($rawpost);
$r->headers_in->set("X-Selima-POST", $rawpost);
# Others (file uploads, etc) and CGI environment is ready
# - parse with CGI.pm default parser
} elsif (exists $ENV{"SERVER_SOFTWARE"}) {
$POST = new CGI;
@_ = qw();
foreach my $name ($POST->param) {
foreach my $val ($POST->param($name)) {
push @_, uri_escape($name) . "=" . uri_escape($val);
}
}
$rawpost = join "&", @_;
# Others (file uploads, etc) and CGI environment is not ready yet
# - delay the parsing
} else {
$rawpost = "";
$POST = new CGI($rawpost);
$postdelay = 1;
}
} else {
# POST form was obtained by mod_perl handler before
if (exists $ENV{"HTTP_X_SELIMA_POST"}) {
$rawpost = $ENV{"HTTP_X_SELIMA_POST"};
$POST = new CGI($rawpost);
# Ordinary POST form -- parse the STDIN
} elsif ( !exists $ENV{"HTTP_CONTENT_TYPE"}
|| $ENV{"HTTP_CONTENT_TYPE"} eq "application/x-www-form-urlencoded") {
$rawpost = <STDIN>;
$POST = new CGI($rawpost);
# Others (file uploads, etc) - parse with CGI.pm default parser
} else {
$POST = new CGI;
@_ = qw();
foreach my $name ($POST->param) {
foreach my $val ($POST->param($name)) {
push @_, uri_escape($name) . "=" . uri_escape($val);
}
}
$rawpost = join "&", @_;
}
}
} else {
$rawpost = "";
$POST = new CGI($rawpost);
}
# Split the uploaded files
($POST, $UPLOAD) = split_upload $POST;
# Initialize the data deposit
%USER_INPUT = (
"GET_RAW" => $GET,
"GET_UTF8" => $GET,
"GET_CHARSET" => undef,
"GET_CSERR" => 1,
"GET_RAWDATA" => $rawget,
"GET_KEYS" => [ $GET->param ],
"POST_RAW" => $POST,
"POST_UTF8" => $POST,
"POST_CHARSET" => undef,
"POST_CSERR" => 1,
"POST_RAWDATA" => $rawpost,
"POST_DELAY" => $postdelay,
"UPLOAD" => $UPLOAD,
);
return;
}
# decode_forms: Decode user FORM input from some character set
sub decode_forms() {
local ($_, %_);
my (@charsets, @charsets_site);
# The possible character sets of this website
@charsets_site = map ln($_, LN_CHARSET), @ALL_LINGUAS;
# The GET arguments
# The character set candidates
@_ = qw();
push @_, $GET->param("charset") if defined $GET->param("charset");
push @_, getlang LN_CHARSET;
push @_, @charsets_site;
push @_, @TRY;
@charsets = qw();
%_ = qw();
foreach (@_) {
if (lc $_ eq "big5") {
if (!exists $_{"Big5-ETen"}) {
push @charsets, "Big5-ETen";
$_{"Big5-ETen"} = 1;
}
if (!exists $_{"Big5"}) {
push @charsets, "Big5";
$_{"Big5"} = 1;
}
if (!exists $_{"CP950"}) {
push @charsets, "CP950";
$_{"CP950"} = 1;
}
if (!exists $_{"Big5-HKSCS"}) {
push @charsets, "Big5-HKSCS";
$_{"Big5-HKSCS"} = 1;
}
} elsif (lc $_ eq "big5-hkscs") {
if (!exists $_{"Big5-HKSCS"}) {
push @charsets, "Big5-HKSCS";
$_{"Big5-HKSCS"} = 1;
}
} elsif (lc $_ eq "gb2312" || lc $_ eq "gb18030") {
if (!exists $_{"GB2312"}) {
push @charsets, "GB2312";
$_{"GB2312"} = 1;
}
if (!exists $_{"GB18030"}) {
push @charsets, "GB18030";
$_{"GB18030"} = 1;
}
} else {
if (!exists $_{$_}) {
push @charsets, $_;
$_{$_} = 1;
}
}
}
# Check each character set
foreach my $charset (@charsets) {
$_ = $USER_INPUT{"GET_RAW"};
# In this character set
if (defined($_ = try_decode_form $_, $charset)) {
$GET = $_;
$USER_INPUT{"GET_UTF8"} = $_;
$USER_INPUT{"GET_CHARSET"} = $charset;
$USER_INPUT{"GET_CSERR"} = 0;
$USER_INPUT{"GET_KEYS"} = [ $_->param ];
last;
}
}
# The POSTed form
# The character set candidates
@_ = qw();
push @_, $POST->param("charset") if defined $POST->param("charset");
push @_, getlang LN_CHARSET;
push @_, @charsets_site;
push @_, @TRY;
@charsets = qw();
%_ = qw();
foreach (@_) {
if (lc $_ eq "big5") {
if (!exists $_{"Big5-ETen"}) {
push @charsets, "Big5-ETen";
$_{"Big5-ETen"} = 1;
}
if (!exists $_{"Big5"}) {
push @charsets, "Big5";
$_{"Big5"} = 1;
}
if (!exists $_{"CP950"}) {
push @charsets, "CP950";
$_{"CP950"} = 1;
}
if (!exists $_{"Big5-HKSCS"}) {
push @charsets, "Big5-HKSCS";
$_{"Big5-HKSCS"} = 1;
}
} elsif (lc $_ eq "big5-hkscs") {
if (!exists $_{"Big5-HKSCS"}) {
push @charsets, "Big5-HKSCS";
$_{"Big5-HKSCS"} = 1;
}
} elsif (lc $_ eq "gb2312" || lc $_ eq "gb18030") {
if (!exists $_{"GB2312"}) {
push @charsets, "GB2312";
$_{"GB2312"} = 1;
}
if (!exists $_{"GB18030"}) {
push @charsets, "GB18030";
$_{"GB18030"} = 1;
}
} else {
if (!exists $_{$_}) {
push @charsets, $_;
$_{$_} = 1;
}
}
}
# Check each character set
foreach my $charset (@charsets) {
$_ = $USER_INPUT{"POST_RAW"};
# In this character set
if (defined($_ = try_decode_form $_, $charset)) {
$POST = $_;
$USER_INPUT{"POST_UTF8"} = $_;
$USER_INPUT{"POST_CHARSET"} = $charset;
$USER_INPUT{"POST_CSERR"} = 0;
last;
}
}
# No valid character set was found
http_500 "Unable to detect the character set of your submitted information. Please specify the input character set with charset= parameter."
if $USER_INPUT{"GET_CSERR"} || $USER_INPUT{"POST_CSERR"};
return;
}
# decode_forms_delay: Initialize and decode multipart/form-data (uploads)
# for mod_perl. We cannot obtain it before the CGI environment is ready.
sub decode_forms_delay() {
local ($_, %_);
my ($r, $rawpost, @charsets, @charsets_site);
# Parsing not delayed
return unless $USER_INPUT{"POST_DELAY"};
# Obtain the POST form
$POST = new CGI;
@_ = qw();
foreach my $name ($POST->param) {
foreach my $val ($POST->param($name)) {
push @_, uri_escape($name) . "=" . uri_escape($val);
}
}
$rawpost = join "&", @_;
# Split the uploaded files
($POST, $UPLOAD) = split_upload $POST;
# Record it
$USER_INPUT{"POST_RAW"} = $POST;
$USER_INPUT{"POST_UTF8"} = $POST;
$USER_INPUT{"POST_CHARSET"} = undef;
$USER_INPUT{"POST_CSERR"} = 1;
$USER_INPUT{"POST_RAWDATA"} = $rawpost;
$USER_INPUT{"UPLOAD"} = $UPLOAD;
# The character set candidates
@_ = qw();
push @_, $POST->param("charset") if defined $POST->param("charset");
push @_, getlang LN_CHARSET;
push @_, map ln($_, LN_CHARSET), @ALL_LINGUAS;
push @_, @TRY;
@charsets = qw();
%_ = qw();
foreach (@_) {
if (lc $_ eq "big5") {
if (!exists $_{"Big5-ETen"}) {
push @charsets, "Big5-ETen";
$_{"Big5-ETen"} = 1;
}
if (!exists $_{"Big5"}) {
push @charsets, "Big5";
$_{"Big5"} = 1;
}
if (!exists $_{"CP950"}) {
push @charsets, "CP950";
$_{"CP950"} = 1;
}
if (!exists $_{"Big5-HKSCS"}) {
push @charsets, "Big5-HKSCS";
$_{"Big5-HKSCS"} = 1;
}
} elsif (lc $_ eq "big5-hkscs") {
if (!exists $_{"Big5-HKSCS"}) {
push @charsets, "Big5-HKSCS";
$_{"Big5-HKSCS"} = 1;
}
} elsif (lc $_ eq "gb2312" || lc $_ eq "gb18030") {
if (!exists $_{"GB2312"}) {
push @charsets, "GB2312";
$_{"GB2312"} = 1;
}
if (!exists $_{"GB18030"}) {
push @charsets, "GB18030";
$_{"GB18030"} = 1;
}
} else {
if (!exists $_{$_}) {
push @charsets, $_;
$_{$_} = 1;
}
}
}
# Check each character set
foreach my $charset (@charsets) {
$_ = $USER_INPUT{"POST_RAW"};
# In this character set
if (defined($_ = try_decode_form $_, $charset)) {
$POST = $_;
$USER_INPUT{"POST_UTF8"} = $_;
$USER_INPUT{"POST_CHARSET"} = $charset;
$USER_INPUT{"POST_CSERR"} = 0;
last;
}
}
# No valid character set was found
http_500 "Unable to detect the character set of your submitted information. Please specify the input character set with charset= parameter."
if $USER_INPUT{"GET_CSERR"} || $USER_INPUT{"POST_CSERR"};
return;
}
# try_decode_form: Try to decode a CGI form with a specific character set
sub try_decode_form($$) {
local ($_, %_);
my ($SOURCE, $charset, $RESULT, $name, $is_upload);
($SOURCE, $charset) = @_;
# Obtain a copy of the converted result
$RESULT = new CGI("");
$is_upload = 0;
foreach $name ($SOURCE->param) {
@_ = $SOURCE->param($name);
return if !defined($name = hcref_decode($charset, $name));
foreach (@_) {
s/\x00//g;
return if !defined($_ = hcref_decode($charset, $_));
}
$RESULT->param($name, @_);
}
return $RESULT;
}
# split_upload: Split the uploaded files from the POST form
sub split_upload($) {
local ($_, %_);
my ($FORM, $UPLOAD, $name);
$FORM = $_[0];
$UPLOAD = $FORM;
$FORM = new CGI("");
foreach $name ($UPLOAD->param) {
my (@valp, @valu);
@valp = qw();
@valu = qw();
foreach ($UPLOAD->param($name)) {
# A scalar value
if (ref $_ eq "") {
push @valp, $_;
# Others (file uploads Fh, etc.)
} else {
push @valu, $_;
}
}
# Some scalar found
if (@valp > 0) {
# Move to the POST form
$FORM->param($name, @valp);
# There are some uploaded files for this column
if (@valu > 0) {
$UPLOAD->param($name, @valu);
# No uploaded file for this column
} else {
$UPLOAD->delete($name);
}
}
}
return ($FORM, $UPLOAD);
}
return 1;

226
lib/perl5/Selima/Destroy.pm Normal file
View File

@@ -0,0 +1,226 @@
# Selima Website Content Management System
# Destroy.pm: The script-environment cleaner.
# 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-09-27
package Selima::Destroy;
use 5.008;
use strict;
use warnings;
use CGI qw(header);
use HTTP::Date qw(time2str);
use IO::NestedCapture qw(CAPTURE_STDOUT);
use Time::HiRes qw();
BEGIN {
if (exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2) {
require Apache2::Response;
}
}
use Selima::AltLang;
use Selima::Cache qw();
use Selima::DataVars qw($DBH $SESSION :env :input :l10n :lastmod
:lninfo :output :proctime :requri :scptconf :siteconf);
use Selima::GetLang;
use Selima::HTTP;
use Selima::Logging;
use Selima::LogIn;
use Selima::Page2Rel;
use Selima::PageFunc;
use Selima::Unicode;
use Selima::XHTML;
# new: Initialize the object
sub new : method { bless {}, $_[0]; }
# DESTROY: Clean all the variables
sub DESTROY : method {
local ($_, %_);
my ($self, $html);
$self = $_[0];
# Disconnect the database handle
if (defined $DBH) {
$DBH->disconnect;
undef $DBH;
}
# Flush, close and release the session and its lock
if (defined $SESSION) {
$SESSION->close;
undef $SESSION;
}
# Output the content
if (!$NO_AUTO_OUTPUT) {
my ($type, $r, $charset, $is_html, $is_text);
# Obtain the output
$html = "";
while ( exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0) {
my $FD;
IO::NestedCapture->stop(CAPTURE_STDOUT);
$FD = IO::NestedCapture->get_last_out;
$html .= join "", <$FD>;
}
# No content -- HTTP 204
http_204 if $html eq "";
$type = defined $CONTENT_TYPE? $CONTENT_TYPE: xhtml_content_type;
$is_html = ($type =~ /^(?:text\/html|application\/xhtml\+xml)\b/)? 1: 0;
$is_text = ($type =~ /^(?:text\/plain|text\/csv)\b/)? 1: 0;
# Do the run-time replacements
if ( ($is_text || $is_html)
&& defined($_ = $MAIN->can("page_replacements"))) {
%_ = %{&$_};
$html =~ s/<!--selima:$_-->/${$_{$_}}{"content"}/g
foreach keys %_;
}
# Fix the HTML output
if ($is_html) {
if ($type =~ /; charset=([^ ;]+)/) {
$charset = $1;
} else {
$charset = getlang(LN_CHARSET);
$type .= "; charset=$charset";
}
# Convert the URLs to relative
$html = page2rel($html, $REQUEST_PATH);
# Encode the e-mail at-signs (@)
$html =~ s/@/&#64;/g;
# Decode the e-mail at-signs (@) of spamtrap
$html =~ s/spamtrap&#64;/spamtrap@/g;
# Convert to the desired character set
$html = page_encode($html, $charset);
# Fix the plain text output
} elsif ($is_text) {
if ($type =~ /; charset=([^ ;]+)/) {
$charset = $1;
} else {
$charset = "UTF-8";
$type .= "; charset=$charset";
}
# Encode the e-mail at-signs (@)
$html =~ s/@/-at-/g;
# Decode the e-mail at-signs (@) of spamtrap
$html =~ s/spamtrap-at-/spamtrap@/g;
# Convert to the desired character set
$html = page_encode($html, $charset);
}
# Only output headers to CGI
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
$r = $IS_MP2? Apache2::RequestUtil->request:
Apache->request;
$r->content_type($type);
if ($IS_MP2) {
$r->set_content_length(length $html);
} else {
$r->headers_out->set("Content-Length"=>length $html);
}
$r->headers_out->set("Accept-Ranges"=>"none");
$r->content_languages([getlang LN_NAME])
if $type =~ /^text\// || $is_html;
# Client cache
if (defined $LAST_MODIFIED) {
if (defined get_login_sn) {
$r->headers_out->set("Cache-Control"=>"private");
} else {
$r->headers_out->set("Cache-Control"=>"public");
}
$r->headers_out->set("Last-Modified"=>time2str($LAST_MODIFIED));
} else {
$r->headers_out->set("Cache-Control"=>"no-cache");
}
# Content negotiation, see HTTP/1.1 section 13.6
if ( @ALL_LINGUAS > 1
&& $r->method ne "POST"
&& $r->method ne "PUT"
&& !defined $GET->param("lang")) {
$r->headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->headers_out->set("Vary"=>"accept-language,cookie");
}
$r->headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
$r->headers_out->add($_=>$HTTP_HEADERS{$_})
foreach keys %HTTP_HEADERS;
$r->send_http_header if !$IS_MP2;
# Ordinary CGI
} else {
my %h;
%h = ( -type=>$type,
-Content_Length=>length $html,
-Accept_Ranges=>"none");
$h{"-Content_Language"} = getlang LN_NAME
if $type =~ /^text\// || $is_html;
# Content negotiation, see HTTP/1.1 section 13.6
if ( @ALL_LINGUAS > 1
&& $ENV{"REQUEST_METHOD"} ne "POST"
&& $ENV{"REQUEST_METHOD"} ne "PUT"
&& !defined $GET->param("lang")) {
$h{"-Content_Location"} = altlang getlang, page_param;
$h{"-Vary"} = "accept-language,cookie";
}
# Client cache
if (defined $LAST_MODIFIED) {
if (defined get_login_sn) {
$h{"-Cache_Control"} = "private";
} else {
$h{"-Cache_Control"} = "public";
}
$h{"-Last_Modified"} = time2str($LAST_MODIFIED);
} else {
$h{"-Cache_Control"} = "no-cache";
}
$h{"-cookie"} = [values %NEWCOOKIES];
$h{$_} = $HTTP_HEADERS{$_} foreach keys %HTTP_HEADERS;
print header(%h);
}
}
# Print the page body
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Print the processing time for debugging purpose
log_warn "Process time: " . (Time::HiRes::time - $T_START) . " sec.\n"
if $LOGTIME;
# Clear the data variables
$_ = "Selima::" . $PACKAGE . "::Config";
&$_ if defined($_ = $_->can("clear"));
Selima::DataVars::clear;
# Clear the cache
Selima::Cache::clear;
# Run the parent DESTROY method
$self->SUPER::DESTROY if $self->can("SUPER::DESTROY");
# I cannot really undefine myself ($_[0]) after all
return;
}
return 1;

99
lib/perl5/Selima/EchoForm.pm Normal file
View File

@@ -0,0 +1,99 @@
# Selima Website Content Management System
# EchoForm.pm: The subroutines to output various form elements.
# 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-30
package Selima::EchoForm;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw();
push @EXPORT, qw(auto_keep_referer);
push @EXPORT, qw(opt_list opt_list_array preselect_options);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub opt_list($$);
sub opt_list_array(\@);
sub preselect_options($$);
sub auto_keep_referer();
}
use Selima::Cache qw(:echoform);
use Selima::CommText;
use Selima::DataVars qw($DBH);
use Selima::ShortCut;
use Selima::Unicode;
# opt_list: Return an options list
sub opt_list($$) {
local ($_, %_);
my ($sql, $curval, $sth, $count, $html);
($sql, $curval) = @_;
# Not cached yet
if (!exists $EchoForm_opt_list{$sql}) {
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for ($_ = 0, @_ = qw(); $_ < $count; $_++) {
push @_, $sth->fetchrow_hashref;
}
$EchoForm_opt_list{$sql} = opt_list_array @_;
}
return preselect_options($EchoForm_opt_list{$sql}, $curval);
}
# opt_list_array: Return an options list from an array
sub opt_list_array(\@) {
local ($_, %_);
my ($opts, $html);
$opts = $_[0];
# Obtain the HTML
$html = " <option value=\"\">"
. h(t_notset) . "</option>\n";
foreach (@$opts) {
$html .= " <option value=\""
. h($$_{"value"}) . "\">"
. h($$_{"content"}) . "</option>\n";
}
return $html;
}
# preselect_options: Presect an option in an option list
sub preselect_options($$) {
local ($_, %_);
my ($html, $value);
($html, $value) = @_;
# Not selected if value not set
return $html if !defined $value;
$value = h_encode($value);
$html =~ s/<(option value="$value")>/<$1 selected="selected">/;
return $html;
}
# auto_keep_referer: If we should keep the referer information
# To be done
sub auto_keep_referer() {
local ($_, %_);
# False for now;
return 0;
}
return 1;

62
lib/perl5/Selima/Encrypt.pm Normal file
View File

@@ -0,0 +1,62 @@
# Selima Website Content Management System
# Encrypt.pm: The simple symmetric encrypter/decrypter.
# 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-09-26
package Selima::Encrypt;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(encrypt decrypt);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub encrypt($);
sub decrypt($);
}
use Crypt::Rijndael qw();
use MIME::Base64 qw(encode_base64 decode_base64);
use vars qw($cipher);
$cipher = new Crypt::Rijndael(decode_base64("MDkxcTc3dGNvMkRZTTYxM0dqRmZ2R2xvQmNLcUZkNVo="));
# This use symmetric encryption/decryption. It is not safe.
# Nothing is exported. Use it by the full package name.
# encrypt: Encrypt
sub encrypt($) {
local ($_, %_);
$_ = $_[0];
$_ = length($_) . " " . $_;
# Pad with US-ASCII printable characters
$_ .= chr(32 + int rand 95) while length($_) % 16 != 0;
return encode_base64($cipher->encrypt($_));
}
# decrypt: Decrypt
sub decrypt($) {
local ($_, %_);
$_ = $cipher->decrypt(decode_base64($_[0]));
s/^(\d+) //;
return substr $_, 0, $1;
}
return 1;

57
lib/perl5/Selima/ErrMsg.pm Normal file
View File

@@ -0,0 +1,57 @@
# Selima Website Content Management System
# ErrMsg.pm: The Maketext error message composer.
# 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::ErrMsg;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(err2msg);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub err2msg($);
}
use Selima::DataVars qw(:l10n :lninfo);
use Selima::LnInfo;
use Selima::ShortCut;
# err2msg: Compose the error message from the $error hash reference
sub err2msg($) {
local (%_, $_);
my $status;
$status = $_[0];
# Empty string
return "" if !exists $$status{"msg"};
$_ = $$status{"msg"};
@_ = qw();
@_ = @{$$status{"margs"}} if exists $$status{"margs"};
foreach (@_) {
if ($_ eq "_DEFAULT_LANG") {
$_ = h(ln $DEFAULT_LANG, LN_DESC_CURLC);
}
}
# Maketext
return F_($_, @_);
}
return 1;

56
lib/perl5/Selima/FetchRec.pm Normal file
View File

@@ -0,0 +1,56 @@
# Selima Website Content Management System
# FetchRec.pm: The subroutine to fetch a record from a database table.
# 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-09-28
package Selima::FetchRec;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(fetchrec);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub fetchrec(\$$);
}
use Selima::ChkFunc;
use Selima::DataVars qw($DBH :lninfo);
use Selima::GetLang;
# fetchrec: Try to fetch a record by its serial number
sub fetchrec(\$$) {
local ($_, %_);
my ($sn, $table, $sth, $sql, %row);
($sn, $table) = @_;
return if !check_sn $$sn;
$sql = "SELECT * FROM " . $DBH->quote_identifier($table)
. " WHERE sn=$$sn;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
return if $sth->rows != 1;
%row = %{$sth->fetchrow_hashref};
# Hash the multi-lingual columns
$row{$_} = $row{$_ . "_" . getlang LN_DATABASE}
foreach $DBH->cols_ml($table);
return %row;
}
return 1;

2657
lib/perl5/Selima/Form.pm Normal file
View File

File diff suppressed because it is too large Load Diff

179
lib/perl5/Selima/Form/AcctRec.pm Normal file
View File

@@ -0,0 +1,179 @@
# Selima Website Content Management System
# AcctRec.pm: The accounting record form.
# Copyright (c) 2007-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: 2007-09-23
package Selima::Form::AcctRec;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::Accounting;
use Selima::FormFunc;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "acctrecs"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this accounting record")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new accounting record.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to edit a current accounting record.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete an accounting record.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(trx type ord subj summary amount)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn trx type ord subj summary amount
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add a New Accounting Record");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Edit a Current Accounting Record");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete an Accounting Record");
}
}
$self = $class->SUPER::new($status, $args);
return $self;
}
# _html_col_trx: The accounting transaction
sub _html_col_trx : method {
$_[0]->_html_coltmpl_call("trx", h_abbr(C_("Accounting transaction:")), \&accttrx_id);
}
# _html_col_type: The type
sub _html_col_type : method {
local ($_, %_);
my ($self, @opts);
$self = $_[0];
@opts = ( { "val" => "debit",
"title" => C_("Debit"), },
{ "val" => "credit",
"title" => C_("Credit"), }, );
return $self->_html_coltmpl_radio("type", h_abbr(C_("Type:")), \@opts, undef, 1);
}
# _html_col_subj: The accounting subject
sub _html_col_subj : method {
local ($_, %_);
my ($self, $form, $current, $label, $choose, $mark, $colspan);
my ($cur, $orig, $new);
$self = $_[0];
$form = $self->{"form"};
$current = $self->{"cur"};
$label = h_abbr(C_("Accounting subject:"));
$choose = h_abbr(C_("Choose"));
$mark = $self->_mark("subj");
$colspan = $self->_colspan;
# A form to create a new item
if ($self->{"type"} eq "new") {
print << "EOT";
<tr>
<th class="th" scope="row"><label for="subj">$mark$label</label></th>
<td$colspan><select id="subj" name="subj">
EOT
print acctsubj_recent_options $form->param("subj");
print << "EOT";
</select>
<input id="selsubj" type="submit" name="selsubj" value="$choose" />
</td>
</tr>
EOT
# A form to edit a current item
} elsif ($self->{"type"} eq "cur") {
$cur = h(acctsubj_title $current->param("subj"));
$orig = h_abbr(C_("Original:"));
$new = h_abbr(C_("New:"));
print << "EOT";
<tr>
<th class="th" rowspan="2" scope="row"><label for="subj">$mark$label</label></th>
<th class="oldnew" scope="row">$orig</th>
<td$colspan>$cur</td>
</tr>
<tr>
<th class="oldnew" scope="row"><label for="subj">$new</label></th>
<td$colspan><select id="subj" name="subj">
EOT
print acctsubj_recent_options $form->param("subj");
print << "EOT";
</select>
<input id="selsubj" type="submit" name="selsubj" value="$choose" />
</td>
</tr>
EOT
# A form to delete a current item
} elsif ($self->{"type"} eq "del") {
$cur = h(acctsubj_title $current->param("subj"));
print << "EOT";
<tr>
<th class="th" scope="row">$mark$label</th>
<td$colspan>$cur</td>
</tr>
EOT
}
return;
}
# _html_col_summary: The summary
sub _html_col_summary : method {
$_[0]->_html_coltmpl_text("summary", h_abbr(C_("Summary:")));
}
# _html_col_amount: The amount
sub _html_col_amount : method {
$_[0]->_html_coltmpl_text("amount", h_abbr(C_("Amount:")));
}
return 1;

143
lib/perl5/Selima/Form/AcctSubj.pm Normal file
View File

@@ -0,0 +1,143 @@
# Selima Website Content Management System
# AcctSubj.pm: The accounting subject form.
# Copyright (c) 2007-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: 2007-08-23
package Selima::Form::AcctSubj;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::CommText;
use Selima::DataVars qw(:requri :scptconf);
use Selima::FormFunc;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "acctsubj"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this accounting subject")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new accounting subject.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to edit a current accounting subject.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete an accounting subject.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(parent code title)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn parent code title ssubs
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add a New Accounting Subject");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Edit a Current Accounting Subject");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete an Accounting Subject");
}
}
$self = $class->SUPER::new($status, $args);
if ($self->{"type"} eq "cur") {
if (defined $self->{"cur"}->param("ssubcount") && $self->{"cur"}->param("ssubcount") > 0) {
$self->{"nodelete"} = 1;
push @{$self->{"prefmsg"}}, C_("This accounting subject has [numerate,_1,an accounting sub-subject,accounting sub-subjects]. It cannot be deleted. To delete the accounting subject, [numerate,_1,its accounting sub-subject,all of its accounting sub-subjects] must first be deleted.", $self->{"cur"}->param("ssubcount"));
}
if (defined $self->{"cur"}->param("reccount") && $self->{"cur"}->param("reccount") > 0) {
$self->{"nodelete"} = 1;
push @{$self->{"prefmsg"}}, C_("This accounting subject has [numerate,_1,an accounting record,accounting records]. It cannot be deleted. To delete the accounting subject, [numerate,_1,its accounting record,all of its accounting records] must first be deleted.", $self->{"cur"}->param("reccount"));
}
}
return $self;
}
# _html_col_code: The code
sub _html_col_code : method {
$_[0]->_html_coltmpl_text("code", h_abbr(C_("Code:")), undef,
${$_[0]->{"maxlens"}}{"code"});
}
# _html_col_parent: The parent
sub _html_col_parent : method {
$_[0]->_html_coltmpl_call_null("parent", h_abbr(C_("Parent subject:")),
"topmost", h_abbr(C_("At the very top")), $MAIN->can($_[0]->{"table"} . "_title"));
}
# _html_col_ssubs: The sub-subjects
sub _html_col_ssubs : method {
local ($_, %_);
my ($self, $form, $current, $label, $url, $mark, $colspan, $thclass, $thcolspan);
$self = $_[0];
$form = $self->{"form"};
$current = $self->{"cur"};
$mark = $self->_mark("ssubs");
$colspan = $self->_colspan;
$label = h_abbr(C_("[numerate,_1,Sub-subject,Sub-subjects]:", $current->param("ssubcount")));
# A current form span for 2 columns
$thclass = $self->{"type"} ne "cur"? " class=\"th\"": "";
$thcolspan = $self->{"type"} eq "cur"? " colspan=\"2\"": "";
print << "EOT";
<tr>
<th$thclass$thcolspan scope="row">$mark$label</th>
EOT
print " <td$colspan>";
@_ = qw();
for ($_ = 0; $_ < $current->param("ssubcount"); $_++) {
push @_, sprintf(" <li><a href=\"%1\$s\">%2\$s</a></li>\n",
h($REQUEST_FILE . "?form=cur&sn=" . $current->param("ssub$_" . "sn")),
h($current->param("ssub$_" . "title")));
}
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
EOT
}
return 1;

819
lib/perl5/Selima/Form/AcctTrx.pm Normal file
View File

@@ -0,0 +1,819 @@
# Selima Website Content Management System
# AcctTrx.pm: The accounting transaction form.
# Copyright (c) 2007-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: 2007-09-20
package Selima::Form::AcctTrx;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::Accounting;
use Selima::AddGet;
use Selima::CommText;
use Selima::DataVars qw($DBH :requri :scptconf);
use Selima::FormFunc;
use Selima::Format;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "accttrx"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this accounting transaction")
if !exists $$args{"deltext"};
# The hidden columns
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new accounting transaction.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to edit a current accounting transaction.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete an accounting transaction.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(date ord recs note)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn date ord recs note
created createdby updated updatedby)];
}
}
$self = $class->SUPER::new($status, $args);
${$self->{"maxlens"}}{"ord"} = 2;
# Set the subform type
if ($$args{"type"} eq "new") {
$_ = curform;
$self->{"subtype"} = $_->param("formsub");
} elsif ($$args{"type"} eq "cur") {
$self->{"subtype"} = $self->{"form"}->param("formsub");
} elsif ($$args{"type"} eq "del") {
$self->{"subtype"} = $self->{"cur"}->param("formsub");
}
# Only expense, income or trans are allowed
http_500 "invalid form sub-type: " . $self->{"type"}
if $self->{"subtype"} !~ /^(?:expense|income|trans)$/;
if ($self->{"subtype"} eq "expense" || $self->{"subtype"} eq "income") {
$self->{"colspan"} = 3;
} else {
$self->{"colspan"} = 6;
}
$self->{"hidcols"} = [] if !exists $self->{"hidcols"};
push @{$self->{"hidcols"}}, {
"name" => "formsub",
"value" => $self->{"subtype"},
};
if ($self->{"type"} eq "cur" && $self->{"subtype"} ne "trans") {
$self->{"header_buttons"} = [
{ "name" => undef, "value" => h(C_("Submit")) },
{ "name" => "confirm", "value" => h(C_("Save")) },
{ "name" => "del", "value" => h($self->{"deltext"}) },
{ "name" => "cnvttrans", "value" => h(C_("Convert to a transfer transaction")) }, ];
$self->{"footer_buttons"} = [
{ "name" => undef, "value" => h(C_("Submit")) },
{ "name" => "confirm", "value" => h(C_("Save")) },
{ "name" => "del", "value" => h($self->{"deltext"}) },
{ "name" => "cnvttrans", "value" => h(C_("Convert to a transfer transaction")) }, ];
}
# A form to create a new item
if ($self->{"type"} eq "new") {
if ($self->{"subtype"} eq "expense") {
$self->{"title"} = C_("Add a New Cache Expense Transaction");
} elsif ($self->{"subtype"} eq "income") {
$self->{"title"} = C_("Add a New Cache Income Transaction");
} elsif ($self->{"subtype"} eq "trans") {
$self->{"title"} = C_("Add a New Transfer Transaction");
}
# A form to edit a current item
} elsif ($self->{"type"} eq "cur") {
if ($self->{"subtype"} eq "expense") {
$self->{"title"} = C_("Edit a Current Cache Expense Transaction");
} elsif ($self->{"subtype"} eq "income") {
$self->{"title"} = C_("Edit a Current Cache Income Transaction");
} elsif ($self->{"subtype"} eq "trans") {
$self->{"title"} = C_("Edit a Current Transfer Transaction");
}
# A form to delete a current item
} elsif ($self->{"type"} eq "del") {
if ($self->{"subtype"} eq "expense") {
$self->{"title"} = C_("Delete a Cache Expense Transaction");
} elsif ($self->{"subtype"} eq "income") {
$self->{"title"} = C_("Delete a Cache Income Transaction");
} elsif ($self->{"subtype"} eq "trans") {
$self->{"title"} = C_("Delete a Transfer Transaction");
}
}
%_ = $DBH->col_lens("acctrec");
${$self->{"maxlens"}}{"recsubj"} = $_{"subj"};
${$self->{"maxlens"}}{"recsummary"} = $_{"summary"};
${$self->{"maxlens"}}{"recamount"} = $_{"amount"};
return $self;
}
# _html_coltmpl_ro_loop_rec: Display a read-only record row column
sub _html_coltmpl_ro_loop_rec : method {
local ($_, %_);
local ($_, %_);
my ($self, $i, $current, $rowhdrs);
my ($curlsubj, $curlsummary, $curlamount);
my ($curbsubj, $curbsummary, $curbamount);
($self, $i) = @_;
$current = $self->{"cur"};
$rowhdrs = "threcs";
$rowhdrs .= " thold" if $self->{"type"} eq "cur";
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
$curlsubj = defined($_ = $current->param("debt$i" . "subj"))?
h_abbr(acctsubj_title $_): "";
$curlsummary = defined($_ = $current->param("debt$i" . "summary"))?
h_abbr($_): "";
$curlamount = defined($_ = $current->param("debt$i" . "amount"))?
h_abbr(fmtntamount $_): "";
print << "EOT";
<tr>
<td headers="$rowhdrs thcdsubj">$curlsubj</td>
<td headers="$rowhdrs thcdsummary">$curlsummary</td>
<td class="amount" headers="$rowhdrs thcdamount">$curlamount</td>
</tr>
EOT
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
$curbsubj = defined($_ = $current->param("crdt$i" . "subj"))?
h_abbr(acctsubj_title $_): "";
$curbsummary = defined($_ = $current->param("crdt$i" . "summary"))?
h_abbr($_): "";
$curbamount = defined($_ = $current->param("crdt$i" . "amount"))?
h_abbr(fmtntamount $_): "";
print << "EOT";
<tr>
<td headers="$rowhdrs thccsubj">$curbsubj</td>
<td headers="$rowhdrs thccsummary">$curbsummary</td>
<td class="amount" headers="$rowhdrs thccamount">$curbamount</td>
</tr>
EOT
# A form to fill in a transfer transaction
} elsif ($self->{"subtype"} eq "trans") {
$curlsubj = defined($_ = $current->param("debt$i" . "subj"))?
h_abbr(acctsubj_title $_): "";
$curlsummary = defined($_ = $current->param("debt$i" . "summary"))?
h_abbr($_): "";
$curlamount = defined($_ = $current->param("debt$i" . "amount"))?
h_abbr(fmtntamount $_): "";
$curbsubj = defined($_ = $current->param("crdt$i" . "subj"))?
h_abbr(acctsubj_title $_): "";
$curbsummary = defined($_ = $current->param("crdt$i" . "summary"))?
h_abbr($_): "";
$curbamount = defined($_ = $current->param("crdt$i" . "amount"))?
h_abbr(fmtntamount $_): "";
print << "EOT";
<tr>
<td headers="$rowhdrs thcdsubj">$curlsubj</td>
<td headers="$rowhdrs thcdsummary">$curlsummary</td>
<td class="amount" headers="$rowhdrs thcdamount">$curlamount</td>
<td headers="$rowhdrs thccsubj">$curbsubj</td>
<td headers="$rowhdrs thccsummary">$curbsummary</td>
<td class="amount" headers="$rowhdrs thccamount">$curbamount</td>
</tr>
EOT
}
return;
}
# _html_coltmpl_loop_rec: Display a record row column
sub _html_coltmpl_loop_rec : method {
local ($_, %_);
my ($self, $i, $form, $choose, $rowhdrs);
my ($coldsubj, $coldsummary, $valdsummary, $coldamount, $valdamount);
my ($colcsubj, $colcsummary, $valcsummary, $colcamount, $valcamount);
($self, $i) = @_;
$form = $self->{"form"};
$choose = h_abbr(C_("Choose"));
$rowhdrs = "threcs";
$rowhdrs .= " thnew" if $self->{"type"} eq "cur";
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
$coldsubj = "debt$i" . "subj";
$coldsubj = h($coldsubj);
$coldsummary = "debt$i" . "summary";
$valdsummary = $self->_val_text($coldsummary, "recsummary");
$coldsummary = h($coldsummary);
$coldamount = "debt$i" . "amount";
$valdamount = $self->_val_text($coldamount, "recamount");
$coldamount = h($coldamount);
print << "EOT";
<tr>
<td headers="$rowhdrs thdsubj"><select id="$coldsubj" name="$coldsubj" onchange="setAutoSummary(this);">
EOT
print acctsubj_recent_options $form->param($coldsubj);
print << "EOT";
</select>
<input id="sel$coldsubj" type="submit" name="sel$coldsubj" value="$choose" />
</td>
<td headers="$rowhdrs thdsummary"><input id="$coldsummary" type="text" name="$coldsummary" size="15"$valdsummary /></td>
<td headers="$rowhdrs thdamount"><input id="$coldamount" class="amount" type="text" name="$coldamount" size="10"$valdamount onchange="calcTotal(this);" /></td>
</tr>
EOT
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
$colcsubj = "crdt$i" . "subj";
$colcsubj = h($colcsubj);
$colcsummary = "crdt$i" . "summary";
$valcsummary = $self->_val_text($colcsummary, "recsummary");
$colcsummary = h($colcsummary);
$colcamount = "crdt$i" . "amount";
$valcamount = $self->_val_text($colcamount, "recamount");
$colcamount = h($colcamount);
print << "EOT";
<tr>
<td headers="$rowhdrs thcsubj"><select id="$colcsubj" name="$colcsubj" onchange="setAutoSummary(this);">
EOT
print acctsubj_recent_options $form->param($colcsubj);
print << "EOT";
</select>
<input id="sel$colcsubj" type="submit" name="sel$colcsubj" value="$choose" />
</td>
<td headers="$rowhdrs thcsummary"><input id="$colcsummary" type="text" name="$colcsummary" size="15"$valcsummary /></td>
<td headers="$rowhdrs thcamount"><input id="$colcamount" class="amount" type="text" name="$colcamount" size="10"$valcamount onchange="calcTotal(this);" /></td>
</tr>
EOT
# A form to fill in a transfer transaction
} elsif ($self->{"subtype"} eq "trans") {
$coldsubj = "debt$i" . "subj";
$coldsubj = h($coldsubj);
$coldsummary = "debt$i" . "summary";
$valdsummary = $self->_val_text($coldsummary, "recsummary");
$coldsummary = h($coldsummary);
$coldamount = "debt$i" . "amount";
$valdamount = $self->_val_text($coldamount, "recamount");
$coldamount = h($coldamount);
$colcsubj = "crdt$i" . "subj";
$colcsubj = h($colcsubj);
$colcsummary = "crdt$i" . "summary";
$valcsummary = $self->_val_text($colcsummary, "recsummary");
$colcsummary = h($colcsummary);
$colcamount = "crdt$i" . "amount";
$valcamount = $self->_val_text($colcamount, "recamount");
$colcamount = h($colcamount);
print << "EOT";
<tr>
<td headers="$rowhdrs thdebit thdsubj"><select id="$coldsubj" name="$coldsubj" onchange="setAutoSummary(this);">
EOT
print acctsubj_recent_options $form->param($coldsubj);
print << "EOT";
</select>
<input id="sel$coldsubj" type="submit" name="sel$coldsubj" value="$choose" />
</td>
<td headers="$rowhdrs thdebit thdsummary"><input id="$coldsummary" type="text" name="$coldsummary" size="15"$valdsummary /></td>
<td headers="$rowhdrs thdebit thdamount"><input id="$coldamount" class="amount" type="text" name="$coldamount" size="10"$valdamount onchange="calcTotal(this);" /></td>
<td headers="$rowhdrs thcredit thcsubj"><select id="$colcsubj" name="$colcsubj" onchange="setAutoSummary(this);">
EOT
print acctsubj_recent_options $form->param($colcsubj);
print << "EOT";
</select>
<input id="sel$colcsubj" type="submit" name="sel$colcsubj" value="$choose" />
</td>
<td headers="$rowhdrs thcredit thcsummary"><input id="$colcsummary" type="text" name="$colcsummary" size="15"$valcsummary /></td>
<td headers="$rowhdrs thcredit thcamount"><input id="$colcamount" class="amount" type="text" name="$colcamount" size="10"$valcamount onchange="calcTotal(this);" /></td>
</tr>
EOT
}
return;
}
# _html_col_ord: The order
sub _html_col_ord : method {
local ($_, %_);
my ($self, $form);
$self = $_[0];
$form = $self->{"form"};
# Set the default order to maximum
$form->param("ord", 99)
if $self->{"is_first_form"} && $self->{"type"} eq "new";
$self->_html_coltmpl_text("ord", h_abbr(C_("Order:")), undef,
${$self->{"maxlens"}}{"ord"});
}
# _html_col_recs: The accounting records
sub _html_col_recs : method {
local ($_, %_);
my ($self, $form, $current, $label, $mark, $orig, $new);
my ($labeldebit, $labelcredit, $labelsubj, $labelsummary, $labelamount);
my ($labelsum, $sumdebit, $sumcredit);
my ($count_new, $rows_new, $count_cur, $rows_cur, $rowspan);
$self = $_[0];
$form = $self->{"form"};
$current = $self->{"cur"};
$mark = $self->_mark("recs");
$labeldebit = h_abbr(C_("Debit"));
$labelcredit = h_abbr(C_("Credit"));
$labelsubj = h_abbr(C_("Accounting subject"));
$labelsummary = h_abbr(C_("Summary"));
$labelamount = h_abbr(C_("Amount"));
$labelsum = h_abbr(C_("Total"));
# A form to create a new item
if ($self->{"type"} eq "new") {
# Find the total number of records
$count_new = 0;
# Find the last-used debit record
for ( $_ = 0;
defined $form->param("debt$_" . "subj")
|| defined $form->param("debt$_" . "summary")
|| defined $form->param("debt$_" . "amount"); $_++) {};
if ($_ > 0) {
for ( $_--;
$_ >= 0
&& $form->param("debt$_" . "subj") eq ""
&& $form->param("debt$_" . "summary") eq ""
&& $form->param("debt$_" . "amount") eq ""; $_--) {};
$_++;
}
$count_new = $_ if $count_new < $_;
# Find the last-used credit record
for ( $_ = 0;
defined $form->param("crdt$_" . "subj")
|| defined $form->param("crdt$_" . "summary")
|| defined $form->param("crdt$_" . "amount"); $_++) {};
if ($_ > 0) {
for ( $_--;
$_ >= 0
&& $form->param("crdt$_" . "subj") eq ""
&& $form->param("crdt$_" . "summary") eq ""
&& $form->param("crdt$_" . "amount") eq ""; $_--) {};
$_++;
}
$count_new = $_ if $count_new < $_;
# We need at least 5 blank records
$count_new += 5;
$_ = $count_new + 2;
$_++ if $self->{"subtype"} eq "trans";
$rows_new = " rowspan=\"" . h($_) . "\"";
$rows_new = "" if $_ == 1;
$label = h_abbr(C_("[numerate,_1,Content]:", 0));
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
print << "EOT";
<tr>
<th id="threcs" class="th"$rows_new scope="row"><label for="debt0subj">$mark$label</label></th>
<th id="thdsubj"><label for="debt0subj">$labelsubj</label></th>
<th id="thdsummary"><label for="debt0summary">$labelsummary</label></th>
<th id="thdamount"><label for="debt0amount">$labelamount</label></th>
</tr>
EOT
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
print << "EOT";
<tr>
<th id="threcs" class="th"$rows_new scope="row"><label for="crdt0subj">$mark$label</label></th>
<th id="thcsubj"><label for="crdt0subj">$labelsubj</label></th>
<th id="thcsummary"><label for="crdt0summary">$labelsummary</label></th>
<th id="thcamount"><label for="crdt0amount">$labelamount</label></th>
</tr>
EOT
# A form to fill in a transfer transaction
} elsif ($self->{"subtype"} eq "trans") {
print << "EOT";
<tr>
<th id="threcs" class="th"$rows_new scope="row"><label for="debt0subj">$mark$label</label></th>
<th id="thdebit" colspan="3"><label for="debt0subj">$labeldebit</label></th>
<th id="thcredit" colspan="3"><label for="crdt0subj">$labelcredit</label></th>
</tr>
<tr>
<th id="thdsubj"><label for="debt0subj">$labelsubj</label></th>
<th id="thdsummary"><label for="debt0summary">$labelsummary</label></th>
<th id="thdamount"><label for="debt0amount">$labelamount</label></th>
<th id="thcsubj"><label for="crdt0subj">$labelsubj</label></th>
<th id="thcsummary"><label for="crdt0summary">$labelsummary</label></th>
<th id="thcamount"><label for="crdt0amount">$labelamount</label></th>
</tr>
EOT
}
for ($_ = 0, @_ = qw(); $_ < $count_new; $_++) {
$self->_html_coltmpl_loop_rec($_);
}
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
for (my $i = 0, $sumdebit = 0; $i < $count_new; $i++) {
$sumdebit += $_
if defined($_ = $form->param("debt$i" . "amount"))
&& /^\d+$/;
}
print << "EOT";
<tr>
<th id="thdsum" colspan="2"><label for="debttotal">$labelsum</label></th>
<td headers="threcs thdsum"><input id="debttotal" class="amount" type="text" name="debttotal" size="10" value="$sumdebit" disabled="disabled" /></td>
</tr>
EOT
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
for (my $i = 0, $sumcredit = 0; $i < $count_new; $i++) {
$sumcredit += $_
if defined($_ = $current->param("crdt$i" . "amount"))
&& /^\d+$/;
}
print << "EOT";
<tr>
<th id="thcsum" colspan="2"><label for="crdttotal">$labelsum</label></th>
<td headers="threcs thcsum"><input id="crdttotal" class="amount" type="text" name="crdttotal" size="10" value="$sumcredit" disabled="disabled" /></td>
</tr>
EOT
# A form to fill in a transfer transaction
} elsif ($self->{"subtype"} eq "trans") {
for (my $i = 0, $sumdebit = 0, $sumcredit = 0; $i < $count_new; $i++) {
$sumdebit += $_
if defined($_ = $current->param("debt$i" . "amount"))
&& /^\d+$/;
$sumcredit += $_
if defined($_ = $current->param("crdt$i" . "amount"))
&& /^\d+$/;
}
print << "EOT";
<tr>
<th id="thdsum" colspan="2"><label for="debttotal">$labelsum</label></th>
<td headers="threcs thdebit thdsum"><input id="debttotal" class="amount" type="text" name="debttotal" size="10" value="$sumdebit" disabled="disabled" /></td>
<th id="thcsum" colspan="2"><label for="crdttotal">$labelsum</label></th>
<td headers="threcs thcredit thcsum"><input id="crdttotal" class="amount" type="text" name="crdttotal" size="10" value="$sumcredit" disabled="disabled" /></td>
</tr>
EOT
}
# A form to edit a current item
} elsif ($self->{"type"} eq "cur") {
$count_cur = 0;
$count_cur = $current->param("debtcount")
if $count_cur < $current->param("debtcount");
$count_cur = $current->param("crdtcount")
if $count_cur < $current->param("crdtcount");
$_ = $count_cur + 2;
$_++ if $self->{"subtype"} eq "trans";
$rows_cur = " rowspan=\"" . h($_) . "\"";
$rows_cur = "" if $_ == 1;
# Find the total number of records
$count_new = 0;
# Find the last-used debit record
for ( $_ = 0;
defined $form->param("debt$_" . "subj")
|| defined $form->param("debt$_" . "summary")
|| defined $form->param("debt$_" . "amount"); $_++) {};
if ($_ > 0) {
for ( $_--;
$_ > 0
&& $form->param("debt$_" . "subj") eq ""
&& $form->param("debt$_" . "summary") eq ""
&& $form->param("debt$_" . "amount") eq ""; $_--) {};
}
$_++;
$count_new = $_ if $count_new < $_;
# Find the last-used credit record
for ( $_ = 0;
defined $form->param("crdt$_" . "subj")
|| defined $form->param("crdt$_" . "summary")
|| defined $form->param("crdt$_" . "amount"); $_++) {};
if ($_ > 0) {
for ( $_--;
$_ > 0
&& $form->param("crdt$_" . "subj") eq ""
&& $form->param("crdt$_" . "summary") eq ""
&& $form->param("crdt$_" . "amount") eq ""; $_--) {};
}
$_++;
$count_new = $_ if $count_new < $_;
# We need at least 5 blank records
$count_new += 5;
$_ = $count_new + 2;
$_++ if $self->{"subtype"} eq "trans";
$rows_new = " rowspan=\"" . h($_) . "\"";
$rows_new = "" if $_ == 1;
$_ = $count_cur + $count_new + 4;
$_ += 2 if $self->{"subtype"} eq "trans";
$rowspan = " rowspan=\"" . h($_) . "\"";
$rowspan = "" if $_ == 1;
$label = h_abbr(C_("[numerate,_1,Content]:", 0));
$orig = h_abbr(C_("Original:"));
$new = h_abbr(C_("New:"));
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
print << "EOT";
<tr>
<th id="threcs" class="th"$rowspan scope="row">$mark$label</th>
<th id="thold" class="oldnew"$rows_cur>$orig</th>
<th id="thcdsubj">$labelsubj</th>
<th id="thcdsummary">$labelsummary</th>
<th id="thcdamount">$labelamount</th>
</tr>
EOT
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
print << "EOT";
<tr>
<th id="threcs" class="th"$rowspan scope="row">$mark$label</th>
<th id="thold" class="oldnew"$rows_cur>$orig</th>
<th id="thccsubj">$labelsubj</th>
<th id="thccsummary">$labelsummary</th>
<th id="thccamount">$labelamount</th>
</tr>
EOT
# A form to fill in a transfer transaction
} elsif ($self->{"subtype"} eq "trans") {
print << "EOT";
<tr>
<th id="threcs" class="th"$rowspan scope="row">$mark$label</th>
<th id="thold" class="oldnew"$rows_cur>$orig</th>
<th id="thcdebit" colspan="3">$labeldebit</th>
<th id="thccredit" colspan="3">$labelcredit</th>
</tr>
<tr>
<th id="thcdsubj">$labelsubj</th>
<th id="thcdsummary">$labelsummary</th>
<th id="thcdamount">$labelamount</th>
<th id="thccsubj">$labelsubj</th>
<th id="thccsummary">$labelsummary</th>
<th id="thccamount">$labelamount</th>
</tr>
EOT
}
for ($_ = 0, @_ = qw(); $_ < $count_cur; $_++) {
$self->_html_coltmpl_ro_loop_rec($_);
}
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
for (my $i = 0, $sumdebit = 0; $i < $count_cur; $i++) {
$sumdebit += $_
if defined($_ = $current->param("debt$i" . "amount"));
}
$sumdebit = h_abbr(fmtntamount $sumdebit);
print << "EOT";
<tr>
<th id="thcdsum" colspan="2">$labelsum</th>
<td class="amount" headers="threcs thold thcdsum">$sumdebit</td>
</tr>
EOT
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
for (my $i = 0, $sumcredit = 0; $i < $count_cur; $i++) {
$sumcredit += $_
if defined($_ = $current->param("crdt$i" . "amount"));
}
$sumcredit = h_abbr(fmtntamount $sumcredit);
print << "EOT";
<tr>
<th id="thccsum" colspan="2">$labelsum</th>
<td class="amount" headers="threcs thold thccsum">$sumcredit</td>
</tr>
EOT
# A form to fill in a transfer transaction
} elsif ($self->{"subtype"} eq "trans") {
for (my $i = 0, $sumdebit = 0, $sumcredit = 0; $i < $count_cur; $i++) {
$sumdebit += $_
if defined($_ = $current->param("debt$i" . "amount"));
$sumcredit += $_
if defined($_ = $current->param("crdt$i" . "amount"));
}
$sumdebit = h_abbr(fmtntamount $sumdebit);
$sumcredit = h_abbr(fmtntamount $sumcredit);
print << "EOT";
<tr>
<th id="thcdsum" colspan="2">$labelsum</th>
<td class="amount" headers="threcs thold thcdebit thcdsum">$sumdebit</td>
<th id="thccsum" colspan="2">$labelsum</th>
<td class="amount" headers="threcs thold thccredit thccsum">$sumcredit</td>
</tr>
EOT
}
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
print << "EOT";
<tr>
<th id="thnew" class="oldnew"$rows_new>$new</th>
<th id="thdsubj"><label for="debt0subj">$labelsubj</label></th>
<th id="thdsummary"><label for="debt0summary">$labelsummary</label></th>
<th id="thdamount"><label for="debt0amount">$labelamount</label></th>
</tr>
EOT
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
print << "EOT";
<tr>
<th id="thnew" class="oldnew"$rows_new>$new</th>
<th id="thcsubj"><label for="crdt0subj">$labelsubj</label></th>
<th id="thcsummary"><label for="crdt0summary">$labelsummary</label></th>
<th id="thcamount"><label for="crdt0amount">$labelamount</label></th>
</tr>
EOT
# A form to fill in a transfer transaction
} elsif ($self->{"subtype"} eq "trans") {
print << "EOT";
<tr>
<th id="thnew" class="oldnew"$rows_new>$new</th>
<th id="thdebit" colspan="3"><label for="debt0subj">$labeldebit</label></th>
<th id="thcredit" colspan="3"><label for="crdt0subj">$labelcredit</label></th>
</tr>
<tr>
<th id="thdsubj"><label for="debt0subj">$labelsubj</label></th>
<th id="thdsummary"><label for="debt0summary">$labelsummary</label></th>
<th id="thdamount"><label for="debt0amount">$labelamount</label></th>
<th id="thcsubj"><label for="crdt0subj">$labelsubj</label></th>
<th id="thcsummary"><label for="crdt0summary">$labelsummary</label></th>
<th id="thcamount"><label for="crdt0amount">$labelamount</label></th>
</tr>
EOT
}
for ($_ = 0, @_ = qw(); $_ < $count_new; $_++) {
$self->_html_coltmpl_loop_rec($_);
}
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
for (my $i = 0, $sumdebit = 0; $i < $count_new; $i++) {
$sumdebit += $_
if defined($_ = $form->param("debt$i" . "amount"))
&& /^\d+$/;
}
print << "EOT";
<tr>
<th id="thdsum" colspan="2"><label for="debttotal">$labelsum</label></th>
<td headers="threcs thdsum"><input id="debttotal" class="amount" type="text" name="debttotal" size="10" value="$sumdebit" disabled="disabled" /></td>
</tr>
EOT
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
for (my $i = 0, $sumcredit = 0; $i < $count_new; $i++) {
$sumcredit += $_
if defined($_ = $current->param("crdt$i" . "amount"))
&& /^\d+$/;
}
print << "EOT";
<tr>
<th id="thcsum" colspan="2"><label for="crdttotal">$labelsum</label></th>
<td headers="threcs thcsum"><input id="crdttotal" class="amount" type="text" name="crdttotal" size="10" value="$sumcredit" disabled="disabled" /></td>
</tr>
EOT
# A form to fill in a transfer transaction
} elsif ($self->{"subtype"} eq "trans") {
for (my $i = 0, $sumdebit = 0, $sumcredit = 0; $i < $count_new; $i++) {
$sumdebit += $_
if defined($_ = $current->param("debt$i" . "amount"))
&& /^\d+$/;
$sumcredit += $_
if defined($_ = $current->param("crdt$i" . "amount"))
&& /^\d+$/;
}
print << "EOT";
<tr>
<th id="thdsum" colspan="2"><label for="debttotal">$labelsum</label></th>
<td headers="threcs thdebit thdsum"><input id="debttotal" class="amount" type="text" name="debttotal" size="10" value="$sumdebit" disabled="disabled" /></td>
<th id="thcsum" colspan="2"><label for="crdttotal">$labelsum</label></th>
<td headers="threcs thcredit thcsum"><input id="crdttotal" class="amount" type="text" name="crdttotal" size="10" value="$sumcredit" disabled="disabled" /></td>
</tr>
EOT
}
# A form to delete a current item
} elsif ($self->{"type"} eq "del") {
$count_cur = 0;
$count_cur = $current->param("debtcount")
if $count_cur < $current->param("debtcount");
$count_cur = $current->param("crdtcount")
if $count_cur < $current->param("crdtcount");
$_ = $count_cur + 2;
$_++ if $self->{"subtype"} eq "trans";
$rows_cur = " rowspan=\"" . h($_) . "\"";
$rows_cur = "" if $_ == 1;
$label = h_abbr(C_("[numerate,_1,Content]:", $count_cur));
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
print << "EOT";
<tr>
<th id="threcs" class="th"$rows_cur scope="row">$mark$label</th>
<th id="thcdsubj">$labelsubj</th>
<th id="thcdsummary">$labelsummary</th>
<th id="thcdamount">$labelamount</th>
</tr>
EOT
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
print << "EOT";
<tr>
<th id="threcs" class="th"$rows_cur scope="row">$mark$label</th>
<th id="thccsubj">$labelsubj</th>
<th id="thccsummary">$labelsummary</th>
<th id="thccamount">$labelamount</th>
</tr>
EOT
# A form to fill in a transfer transaction
} elsif ($self->{"subtype"} eq "trans") {
print << "EOT";
<tr>
<th id="threcs" class="th"$rows_cur scope="row">$mark$label</th>
<th id="thcdebit" colspan="3">$labeldebit</th>
<th id="thccredit" colspan="3">$labelcredit</th>
</tr>
<tr>
<th id="thcdsubj">$labelsubj</th>
<th id="thcdsummary">$labelsummary</th>
<th id="thcdamount">$labelamount</th>
<th id="thccsubj">$labelsubj</th>
<th id="thccsummary">$labelsummary</th>
<th id="thccamount">$labelamount</th>
</tr>
EOT
}
for ($_ = 0, @_ = qw(); $_ < $count_cur; $_++) {
$self->_html_coltmpl_ro_loop_rec($_);
}
# A form to fill in a cash expense transaction
if ($self->{"subtype"} eq "expense") {
for (my $i = 0, $sumdebit = 0; $i < $count_cur; $i++) {
$sumdebit += $_
if defined($_ = $current->param("debt$i" . "amount"));
}
$sumdebit = h_abbr(fmtntamount $sumdebit);
print << "EOT";
<tr>
<td id="thcdsum" colspan="2">$labelsum</td>
<td class="amount" headers="threcs thcdsum">$sumdebit</td>
</tr>
EOT
# A form to fill in a cash income transaction
} elsif ($self->{"subtype"} eq "income") {
for (my $i = 0, $sumcredit = 0; $i < $count_cur; $i++) {
$sumcredit += $_
if defined($_ = $current->param("crdt$i" . "amount"));
}
$sumcredit = h_abbr(fmtntamount $sumcredit);
print << "EOT";
<tr>
<td id="thccsum" colspan="2">$labelsum</td>
<td class="amount" headers="threcs thccsum">$sumcredit</td>
</tr>
EOT
# A form to fill in a transfer transaction
} elsif ($self->{"subtype"} eq "trans") {
for (my $i = 0, $sumdebit = 0, $sumcredit = 0; $i < $count_cur; $i++) {
$sumdebit += $_
if defined($_ = $current->param("debt$i" . "amount"));
$sumcredit += $_
if defined($_ = $current->param("crdt$i" . "amount"));
}
$sumdebit = h_abbr(fmtntamount $sumdebit);
$sumcredit = h_abbr(fmtntamount $sumcredit);
print << "EOT";
<tr>
<td id="thcdsum" colspan="2">$labelsum</td>
<td class="amount" headers="threcs thcdebit thcdsum">$sumdebit</td>
<td id="thccsum" colspan="2">$labelsum</td>
<td class="amount" headers="threcs thccredit thccsum">$sumcredit</td>
</tr>
EOT
}
}
return;
}
# _html_col_note: The note
sub _html_col_note : method {
$_[0]->_html_coltmpl_textarea("note", h_abbr(C_("Note:")),
h_abbr(C_("Fill in the note here.")), undef, 2);
}
return 1;

498
lib/perl5/Selima/Form/Group.pm Normal file
View File

@@ -0,0 +1,498 @@
# Selima Website Content Management System
# Group.pm: The account group form.
# 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-10-12
package Selima::Form::Group;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::CommText;
use Selima::ChkPriv;
use Selima::ChkFunc;
use Selima::FormFunc;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::UserName;
use Selima::Unicode;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "groups"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this group")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new group.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to update a current group.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a group.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(id dsc subuser subgroup supgroup)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn id dsc subuser subgroup supgroup
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add a New Group");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Update a Current Group");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a Group");
}
}
$self = $class->SUPER::new($status, $args);
if ($$args{"type"} eq "cur" && !is_su && $self->{"sn"} == su_group_sn) {
$self->{"nodelete"} = 1;
push @{$self->{"prefmsg"}}, C_("This is a super-user group. You can only change parts of its infomation.");
}
return $self;
}
# _html_col_id: The group ID.
sub _html_col_id : method {
local ($_, %_);
my $self;
$self = $_[0];
# Read-only for a non-super-user editing a super-user
if ($self->{"type"} eq "cur" && !is_su && $self->{"sn"} == su_group_sn) {
$self->_html_coltmpl_ro("id", h_abbr(C_("Group ID.:")));
} else {
$self->_html_coltmpl_text("id", h_abbr(C_("Group ID.:")));
}
}
# _html_col_dsc: The description
sub _html_col_dsc : method {
$_[0]->_html_coltmpl_text("dsc", h_abbr(C_("Description:")));
}
# _html_col_subuser: Its child users
sub _html_col_subuser : method {
local ($_, %_);
my ($self, $form, $current, $label, $orig, $new, $submit, $mark, $colspan, $title);
#my ($col, $val, $colsn, $valsn, $title);
$self = $_[0];
$form = $self->{"form"};
$current = $self->{"cur"};
$mark = $self->_mark("subuser");
$colspan = $self->_colspan;
$submit = h_abbr(C_("Add a user"));
# A form to create a new item
if ($self->{"type"} eq "new") {
$label = h_abbr(C_("[numerate,_1,User member]:", 0));
print << "EOT";
<tr>
<th class="th" scope="row"><label for="selsubuser">$mark$label</label></th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); defined $form->param("subuser$_" . "sn"); $_++) {
if (defined($title = user_opt_label(scalar $form->param("subuser$_" . "sn"), "subuser$_"))) {
push @_, sprintf(" <li><input type=\"hidden\" name=\"subuser%1\$dsn\"%2\$s />\n"
. " <input id=\"subuser%1\$d\" type=\"checkbox\" name=\"subuser%1\$d\"%3\$s />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("subuser$_" . "sn"),
$self->_val_check("subuser$_"), $title);
} else {
push @_, sprintf(" <li><input type=\"hidden\" name=\"subuser%1\$dsn\"%2\$s />\n"
. " <input type=\"checkbox\"%3\$s disabled=\"disabled\" />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("subuser$_" . "sn"),
$self->_val_check("subuser$_"), h_abbr(t_na));
}
}
push @_, " <li><input id=\"selsubuser\" type=\"submit\" name=\"selsubuser\" value=\"$submit\" /></li>\n";
print "<ul>\n" . join("", @_) . " </ul>\n ";
print << "EOT";
</td>
</tr>
EOT
# A form to edit a current item
} elsif ($self->{"type"} eq "cur") {
# Read-only for a non-super-user editing a super-user group
if (!is_su && $self->{"sn"} == su_group_sn) {
$label = h_abbr(C_("[numerate,_1,User member]:", $_[0]->_delcolcount("subuser")));
print << "EOT";
<tr>
<th colspan="2" scope="row">$mark$label</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("subusercount"); $_++) {
push @_, " <li>" . $self->_cval_text("subuser$_" . "title") . "</li>\n";
}
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
EOT
} else {
$label = h_abbr(C_("[numerate,_1,User member]:", 0));
$orig = h_abbr(C_("Original:"));
$new = h_abbr(C_("New:"));
print << "EOT";
<tr>
<th class="th" rowspan="2" scope="row"><label for="selsubuser">$mark$label</label></th>
<th class="oldnew" scope="row">$orig</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("subusercount"); $_++) {
push @_, " <li>" . $self->_cval_text("subuser$_" . "title") . "</li>\n";
}
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
<tr>
<th class="oldnew" scope="row"><label for="selsubuser">$new</label></th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); defined $form->param("subuser$_" . "sn"); $_++) {
if (defined($title = user_opt_label(scalar $form->param("subuser$_" . "sn"), "subuser$_"))) {
push @_, sprintf(" <li><input type=\"hidden\" name=\"subuser%1\$dsn\"%2\$s />\n"
. " <input id=\"subuser%1\$d\" type=\"checkbox\" name=\"subuser%1\$d\"%3\$s />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("subuser$_" . "sn"),
$self->_val_check("subuser$_"), $title);
} else {
push @_, sprintf(" <li><input type=\"hidden\" name=\"subuser%1\$dsn\"%2\$s />\n"
. " <input type=\"checkbox\"%3\$s disabled=\"disabled\" />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("subuser$_" . "sn"),
$self->_val_check("subuser$_"), h_abbr(t_na));
}
}
push @_, " <li><input id=\"selsubuser\" type=\"submit\" name=\"selsubuser\" value=\"$submit\" /></li>\n";
print "<ul>\n" . join("", @_) . " </ul>\n ";
print << "EOT";
</td>
</tr>
EOT
}
# A form to delete a current item
} else {
$label = h_abbr(C_("[numerate,_1,User member]:", $_[0]->_delcolcount("subuser")));
print << "EOT";
<tr>
<th class="th" scope="row">$mark$label</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("subusercount"); $_++) {
push @_, " <li>" . $self->_cval_text("subuser$_" . "title") . "</li>\n";
}
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
EOT
}
return;
}
# _html_col_subgroup: Its child groups
sub _html_col_subgroup : method {
local ($_, %_);
my ($self, $form, $current, $label, $orig, $new, $submit, $mark, $colspan, $title);
#my ($col, $val, $colsn, $valsn, $title);
$self = $_[0];
$form = $self->{"form"};
$current = $self->{"cur"};
$mark = $self->_mark("subgroup");
$colspan = $self->_colspan;
$submit = h_abbr(C_("Add a group"));
# A form to create a new item
if ($self->{"type"} eq "new") {
$label = h_abbr(C_("[numerate,_1,Group member]:", 0));
print << "EOT";
<tr>
<th class="th" scope="row"><label for="selsubgroup">$mark$label</label></th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); defined $form->param("subgroup$_" . "sn"); $_++) {
if (defined($title = group_opt_label(scalar $form->param("subgroup$_" . "sn"), "subgroup$_"))) {
push @_, sprintf(" <li><input type=\"hidden\" name=\"subgroup%1\$dsn\"%2\$s />\n"
. " <input id=\"subgroup%1\$d\" type=\"checkbox\" name=\"subgroup%1\$d\"%3\$s />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("subgroup$_" . "sn"),
$self->_val_check("subgroup$_"), $title);
} else {
push @_, sprintf(" <li><input type=\"hidden\" name=\"subgroup%1\$dsn\"%2\$s />\n"
. " <input type=\"checkbox\"%3\$s disabled=\"disabled\" />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("subgroup$_" . "sn"),
$self->_val_check("subgroup$_"), h_abbr(t_na));
}
}
push @_, " <li><input id=\"selsubgroup\" type=\"submit\" name=\"selsubgroup\" value=\"$submit\" /></li>\n";
print "<ul>\n" . join("", @_) . " </ul>\n ";
print << "EOT";
</td>
</tr>
EOT
# A form to edit a current item
} elsif ($self->{"type"} eq "cur") {
# Read-only for a non-super-user editing a super-user group
if (!is_su && $self->{"sn"} == su_group_sn) {
$label = h_abbr(C_("[numerate,_1,Group member]:", $_[0]->_delcolcount("subgroup")));
print << "EOT";
<tr>
<th colspan="2" scope="row">$mark$label</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("subgroupcount"); $_++) {
push @_, " <li>" . $self->_cval_text("subgroup$_" . "title") . "</li>\n";
}
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
EOT
} else {
$label = h_abbr(C_("[numerate,_1,Group member]:", 0));
$orig = h_abbr(C_("Original:"));
$new = h_abbr(C_("New:"));
print << "EOT";
<tr>
<th class="th" rowspan="2" scope="row"><label for="selsubgroup">$mark$label</label></th>
<th class="oldnew" scope="row">$orig</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("subgroupcount"); $_++) {
push @_, " <li>" . $self->_cval_text("subgroup$_" . "title") . "</li>\n";
}
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
<tr>
<th class="oldnew" scope="row"><label for="selsubgroup">$new</label></th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); defined $form->param("subgroup$_" . "sn"); $_++) {
if (defined($title = group_opt_label(scalar $form->param("subgroup$_" . "sn"), "subgroup$_"))) {
push @_, sprintf(" <li><input type=\"hidden\" name=\"subgroup%1\$dsn\"%2\$s />\n"
. " <input id=\"subgroup%1\$d\" type=\"checkbox\" name=\"subgroup%1\$d\"%3\$s />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("subgroup$_" . "sn"),
$self->_val_check("subgroup$_"), $title);
} else {
push @_, sprintf(" <li><input type=\"hidden\" name=\"subgroup%1\$dsn\"%2\$s />\n"
. " <input type=\"checkbox\"%3\$s disabled=\"disabled\" />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("subgroup$_" . "sn"),
$self->_val_check("subgroup$_"), h_abbr(t_na));
}
}
push @_, " <li><input id=\"selsubgroup\" type=\"submit\" name=\"selsubgroup\" value=\"$submit\" /></li>\n";
print "<ul>\n" . join("", @_) . " </ul>\n ";
print << "EOT";
</td>
</tr>
EOT
}
# A form to delete a current item
} else {
$label = h_abbr(C_("[numerate,_1,Group member]:", $_[0]->_delcolcount("subgroup")));
print << "EOT";
<tr>
<th class="th" scope="row">$mark$label</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("subgroupcount"); $_++) {
push @_, " <li>" . $self->_cval_text("subgroup$_" . "title") . "</li>\n";
}
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
EOT
}
return;
}
# _html_col_supgroup: Its belonging groups
sub _html_col_supgroup : method {
local ($_, %_);
my ($self, $form, $current, $label, $orig, $new, $submit, $mark, $colspan, $title);
#my ($col, $val, $colsn, $valsn, $title);
$self = $_[0];
$form = $self->{"form"};
$current = $self->{"cur"};
$mark = $self->_mark("supgroup");
$colspan = $self->_colspan;
$label = h_abbr(C_("Belonging to:"));
$submit = h_abbr(C_("Add a group"));
# A form to create a new item
if ($self->{"type"} eq "new") {
print << "EOT";
<tr>
<th class="th" scope="row"><label for="selsupgroup">$mark$label</label></th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); defined $form->param("supgroup$_" . "sn"); $_++) {
if (defined($title = group_opt_label(scalar $form->param("supgroup$_" . "sn"), "supgroup$_"))) {
push @_, sprintf(" <li><input type=\"hidden\" name=\"supgroup%1\$dsn\"%2\$s />\n"
. " <input id=\"supgroup%1\$d\" type=\"checkbox\" name=\"supgroup%1\$d\"%3\$s />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("supgroup$_" . "sn"),
$self->_val_check("supgroup$_"), $title);
} else {
push @_, sprintf(" <li><input type=\"hidden\" name=\"supgroup%1\$dsn\"%2\$s />\n"
. " <input type=\"checkbox\"%3\$s disabled=\"disabled\" />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("supgroup$_" . "sn"),
$self->_val_check("supgroup$_"), h_abbr(t_na));
}
}
push @_, " <li><input id=\"selsupgroup\" type=\"submit\" name=\"selsupgroup\" value=\"$submit\" /></li>\n";
print "<ul>\n" . join("", @_) . " </ul>\n ";
print << "EOT";
</td>
</tr>
EOT
# A form to edit a current item
} elsif ($self->{"type"} eq "cur") {
# Read-only for a non-super-user editing a super-user group
if (!is_su && $self->{"sn"} == su_group_sn) {
print << "EOT";
<tr>
<th colspan="2" scope="row">$mark$label</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("supgroupcount"); $_++) {
push @_, " <li>" . $self->_cval_text("supgroup$_" . "title") . "</li>\n";
}
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
EOT
} else {
$orig = h_abbr(C_("Original:"));
$new = h_abbr(C_("New:"));
print << "EOT";
<tr>
<th class="th" rowspan="2" scope="row"><label for="selsupgroup">$mark$label</label></th>
<th class="oldnew" scope="row">$orig</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("supgroupcount"); $_++) {
push @_, " <li>" . $self->_cval_text("supgroup$_" . "title") . "</li>\n";
}
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
<tr>
<th class="oldnew" scope="row"><label for="selsupgroup">$new</label></th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); defined $form->param("supgroup$_" . "sn"); $_++) {
if (defined($title = group_opt_label(scalar $form->param("supgroup$_" . "sn"), "supgroup$_"))) {
push @_, sprintf(" <li><input type=\"hidden\" name=\"supgroup%1\$dsn\"%2\$s />\n"
. " <input id=\"supgroup%1\$d\" type=\"checkbox\" name=\"supgroup%1\$d\"%3\$s />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("supgroup$_" . "sn"),
$self->_val_check("supgroup$_"), $title);
} else {
push @_, sprintf(" <li><input type=\"hidden\" name=\"supgroup%1\$dsn\"%2\$s />\n"
. " <input type=\"checkbox\"%3\$s disabled=\"disabled\" />\n"
. " %4\$s\n"
. " </li>\n",
h($_), $self->_val_text("supgroup$_" . "sn"),
$self->_val_check("supgroup$_"), h_abbr(t_na));
}
}
push @_, " <li><input id=\"selsupgroup\" type=\"submit\" name=\"selsupgroup\" value=\"$submit\" /></li>\n";
print "<ul>\n" . join("", @_) . " </ul>\n ";
print << "EOT";
</td>
</tr>
EOT
}
# A form to delete a current item
} else {
print << "EOT";
<tr>
<th class="th" scope="row">$mark$label</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("supgroupcount"); $_++) {
push @_, " <li>" . $self->_cval_text("supgroup$_" . "title") . "</li>\n";
}
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
EOT
}
return;
}
return 1;

93
lib/perl5/Selima/Form/GroupMem.pm Normal file
View File

@@ -0,0 +1,93 @@
# Selima Website Content Management System
# GroupMem.pm: The group-to-group membership form.
# 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-10-14
package Selima::Form::GroupMem;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::FormFunc;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::UserName;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "groupmem"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this membership record")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new membership record.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to change a current membership record.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a membership record.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(grp member)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn grp member
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add A New Group Membership Record");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Change a Current Group Membership Record");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a Group Membership Record");
}
}
$self = $class->SUPER::new($status, $args);
return $self;
}
# _html_col_member: The member
sub _html_col_member : method {
$_[0]->_html_coltmpl_call("member", h_abbr(C_("Member:")), \&groupdsc);
}
return 1;

116
lib/perl5/Selima/Form/Guestbook.pm Normal file
View File

@@ -0,0 +1,116 @@
# Selima Website Content Management System
# Guestbook.pm: The base administrative guestbook form.
# 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-10-16
package Selima::Form::Guestbook;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::FormFunc;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "guestbook"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this message")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new message.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to edit a current message.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a message.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(name identity location email url message hid)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn name identity location email url message hid
ip host ct pageno oldpageno
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Write a New Message");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Edit a Current Message");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a Message");
}
}
$self = $class->SUPER::new($status, $args);
${$self->{"maxlens"}}{"message"} = 10240;
return $self;
}
# _html_col_ct: The country
sub _html_col_ct : method {
$_[0]->_html_coltmpl_ro_ct("ct", h_abbr(C_("Country:")));
}
# _html_col_hid: Hide?
sub _html_col_hid : method {
$_[0]->_html_coltmpl_bool("hid", h_abbr(C_("Hide?")),
h_abbr(C_("Hide this message")), h_abbr(C_("Show this message")),
h_abbr(C_("Hide this message currently.")));
}
# _html_col_name: The name
sub _html_col_name : method {
$_[0]->_html_coltmpl_text("name", h_abbr(C_("Signature:")));
}
# _html_col_oldpageno: The old page number
sub _html_col_oldpageno : method {
$_[0]->_html_coltmpl_ro("oldpageno", h_abbr(C_("Old page no.:")));
}
# _html_col_pageno: The page number
sub _html_col_pageno : method {
$_[0]->_html_coltmpl_ro("pageno", h_abbr(C_("Page no.:")));
}
return 1;

86
lib/perl5/Selima/Form/Guestbook/Public.pm Normal file
View File

@@ -0,0 +1,86 @@
# Selima Website Content Management System
# Public.pm: The base guestbook form.
# 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-10-16
package Selima::Form::Guestbook::Public;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form::Guestbook);
use Selima::DataVars qw(:lninfo);
use Selima::GetLang;
use Selima::HTTP;
use Selima::ShortCut;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
# This should always be always a new form
$$args{"type"} = "new"
if !exists $$args{"type"};
$$args{"type_to_pass"} = undef
if !exists $$args{"type_to_pass"};
$$args{"valid_types"} = [qw(new)]
if !exists $$args{"valid_types"};
$$args{"table"} = "guestbook"
if !exists $$args{"table"};
$$args{"header_buttons"} = []
if !exists $$args{"header_buttons"};
$$args{"footer_buttons"} = [
{ "name" => "submit", "value" => h(C_("Leave a messsage")) } ]
if !exists $$args{"footer_buttons"};
$$args{"summary"} = C_("This table provides you a form to leave a message.")
if !exists $$args{"summary"};
$$args{"onsubmit"} = "return isGuestbookOK(this);"
if !exists $$args{"onsubmit"};
$$args{"cols"} = [qw(message name identity location email captcha url)]
if !exists $$args{"cols"};
$$args{"auto_referer2"} = 0
if !exists $$args{"auto_referer2"};
$self = $class->SUPER::new($status, $args);
return $self;
}
# _html_col_message: The message
sub _html_col_message : method {
local ($_, %_);
my ($self, $val, $label, $default, $colspan, $hdef);
$self = $_[0];
$colspan = $self->_colspan_full;
$default = C_("Fill in your message here.");
$val = $self->_val_textarea("message", $default);
$hdef = h($default);
print << "EOT";
<tr>
<td class="gbmessage"$colspan><textarea id="message" name="message" cols="50" rows="10"
onfocus="if (this.value == &quot;$hdef&quot;) this.value = &quot;&quot;;">$val</textarea></td>
</tr>
EOT
return;
}
return 1;

190
lib/perl5/Selima/Form/Link.pm Normal file
View File

@@ -0,0 +1,190 @@
# Selima Website Content Management System
# Link.pm: The related-link form.
# 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-10-24
package Selima::Form::Link;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::ChkFunc;
use Selima::CommText;
use Selima::FormFunc;
use Selima::HTTP;
use Selima::Links;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "links"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this related link")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new related link.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to edit a current related link.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a related link.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(title title_2ln url icon email
addr tel fax dsc hid cats)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn title title_2ln url icon email
addr tel fax dsc hid cats
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add a New Related Link");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Edit a Current Related Link");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a Related Link");
}
}
$self = $class->SUPER::new($status, $args);
return $self;
}
# _html_col_cats: The categories
sub _html_col_cats : method {
$_[0]->_html_coltmpl_select_multi("cat",
h_abbr(C_("[numerate,_1,Category,Categories]:", $_[0]->_delcolcount("cat"))),
\&linkcat_options);
}
# _html_col_hid: Hide?
sub _html_col_hid : method {
$_[0]->_html_coltmpl_bool("hid", h_abbr(C_("Hide?")),
h_abbr(C_("Hide this related link")), h_abbr(C_("Show this related link")),
h_abbr(C_("Hide this related link currently.")));
}
# _html_col_icon: The link icon
sub _html_col_icon : method {
local ($_, %_);
my ($self, $label, $alt, $size, $mark, $colspan);
my ($cur, $preview, $val, $orig, $new);
$self = $_[0];
$mark = $self->_mark("icon");
$colspan = $self->_colspan;
$label = h_abbr(C_("Link icon:"));
$alt = h(C_("Link icon unavailable"));
$size = h($self->{"defsize"});
$self->{"form"}->param("icon", "http://")
if $self->{"is_first_form"} && !defined $self->{"form"}->param("icon");
# A form to create a new item
if ($self->{"type"} eq "new") {
$val = $self->_val_text("icon", "icon");
if (is_url_wellformed $self->{"form"}->param("icon")) {
$preview = "<img src=\"" . h($self->{"form"}->param("icon"))
. "\" alt=\"$alt\" /><br />\n";
} else {
$preview = "";
}
print << "EOT";
<tr>
<th class="th" scope="row"><label for="icon">$mark$label</label></th>
<td$colspan>$preview<input id="icon" class="text" type="text" name="icon" size="$size"$val /></td>
</tr>
EOT
# A form to edit a current item
} elsif ($self->{"type"} eq "cur") {
$cur = $self->{"cur"}->param("icon");
if (defined $cur) {
$cur = "<img src=\"" . h($cur) . "\" alt=\"$alt\" /><br />\n"
. " " . h($cur);
} else {
$cur = h_abbr(t_none);
}
$val = $self->_val_text("icon", "icon");
if (is_url_wellformed $self->{"form"}->param("icon")) {
$preview = "<img src=\"" . h($self->{"form"}->param("icon"))
. "\" alt=\"$alt\" /><br />\n";
} else {
$preview = "";
}
$orig = h_abbr(C_("Original:"));
$new = h_abbr(C_("New:"));
print << "EOT";
<tr>
<th class="th" rowspan="2" scope="row"><label for="icon">$mark$label</label></th>
<th class="oldnew" scope="row">$orig</th>
<td$colspan>$cur</td>
</tr>
<tr>
<th class="oldnew" scope="row"><label for="icon">$new</label></th>
<td$colspan>$preview<input id="icon" class="text" type="text" name="icon" size="$size"$val /></td>
</tr>
EOT
# A form to delete a current item
} elsif ($self->{"type"} eq "del") {
$cur = $self->{"cur"}->param("icon");
if (defined $cur) {
$cur = "<img src=\"" . h($cur) . "\" alt=\"$alt\" /><br />\n"
. " " . h($cur);
} else {
$cur = h_abbr(t_none);
}
print << "EOT";
<tr>
<th class="th" scope="row">$mark$label</th>
<td$colspan>$cur</td>
</tr>
EOT
}
return;
}
# _html_col_title_2ln: Title in the second language
sub _html_col_title_2ln : method {
$_[0]->_html_coltmpl_text("title_2ln", h_abbr(C_("2nd language title:")));
}
return 1;

145
lib/perl5/Selima/Form/LinkCat.pm Normal file
View File

@@ -0,0 +1,145 @@
# Selima Website Content Management System
# LinkCat.pm: The related-link category form.
# 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-10-24
package Selima::Form::LinkCat;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::CommText;
use Selima::FormFunc;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "linkcat"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this category")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new category.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to edit a current category.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a category.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(parent id ord title kw hid)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn parent id ord title kw hid
scats links
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add a New Link Category");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Edit a Current Link Category");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a Link Category");
}
}
$self = $class->SUPER::new($status, $args);
${$self->{"maxlens"}}{"ord"} = 2;
if ($self->{"type"} eq "cur") {
if (defined $self->{"cur"}->param("scatcount") && $self->{"cur"}->param("scatcount") > 0) {
$self->{"nodelete"} = 1;
push @{$self->{"prefmsg"}}, C_("This category has [numerate,_1,a subcategory,subcategories]. It cannot be deleted. To delete the category, [numerate,_1,its subcategory,all of its subcategories] must first be deleted.", $self->{"cur"}->param("scatcount"));
}
if (defined $self->{"cur"}->param("linkcount") && $self->{"cur"}->param("linkcount") > 0) {
$self->{"nodelete"} = 1;
push @{$self->{"prefmsg"}}, C_("This category has [numerate,_1,a link,links]. It cannot be deleted. To delete the category, [numerate,_1,its link,all of its links] must first be deleted.", $self->{"cur"}->param("linkcount"));
}
}
return $self;
}
# _html_col_hid: Hide?
sub _html_col_hid : method {
$_[0]->_html_coltmpl_bool("hid", h_abbr(C_("Hide?")),
h_abbr(C_("Hide this category")), h_abbr(C_("Show this category")),
h_abbr(C_("Hide this category currently.")));
}
# _html_col_id: The ID.
sub _html_col_id : method {
$_[0]->_html_coltmpl_text("id", h_abbr(C_("ID.:")), undef, 8);
}
# _html_col_links: The links
sub _html_col_links : method {
my ($self, $form, $current, $label, $mark, $colspan, $thclass, $thcolspan);
$self = $_[0];
$form = $self->{"form"};
$current = $self->{"cur"};
$mark = $self->_mark("links");
$colspan = $self->_colspan;
$label = h_abbr(C_("[numerate,_1,Link,Links]:", $current->param("linkcount")));
# A current form span for 2 columns
$thclass = $self->{"type"} ne "cur"? " class=\"th\"": "";
$thcolspan = $self->{"type"} eq "cur"? " colspan=\"2\"": "";
print << "EOT";
<tr>
<th$thclass$thcolspan scope="row">$mark$label</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("linkcount"); $_++) {
push @_, sprintf(" <li><a href=\"%1\$s\">%2\$s</a>\n"
. " (<a href=\"%3\$s\"><samp>%3\$s</samp></a>)\n"
. " </li>\n",
h("links.cgi?form=cur&sn=" . $current->param("link$_" . "sn")),
h_abbr($current->param("link$_" . "title")),
h($current->param("link$_" . "url")));
}
print @_ > 0? "<ul>\n" . join("", @_) ." </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
EOT
}
return 1;

98
lib/perl5/Selima/Form/LinkCatz.pm Normal file
View File

@@ -0,0 +1,98 @@
# Selima Website Content Management System
# LinkCatz.pm: The related-link category membership form.
# 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-10-25
package Selima::Form::LinkCatz;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::FormFunc;
use Selima::HTTP;
use Selima::Links;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "linkcatz"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this categorization record")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new categorization record.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to change a current categorization record.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a categorization record.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(cat link)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn cat link
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add A New Link Categorization Record");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Change a Current Link Categorization Record");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a Link Categorization Record");
}
}
$self = $class->SUPER::new($status, $args);
return $self;
}
# _html_col_cat: The category
sub _html_col_cat : method {
$_[0]->_html_coltmpl_call("cat", h_abbr(C_("Category:")), \&linkcat_title);
}
# _html_col_link: The link
sub _html_col_link : method {
$_[0]->_html_coltmpl_call("link", h_abbr(C_("Link:")), \&link_title);
}
return 1;

100
lib/perl5/Selima/Form/Page.pm Normal file
View File

@@ -0,0 +1,100 @@
# Selima Website Content Management System
# Page.pm: The base web page form.
# Copyright (c) 2005-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: 2005-02-28
package Selima::Form::Page;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::FormFunc;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "pages"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this page")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to write a new page.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to edit a current page.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a page.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(path ord title body kw html hid)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn path ord title body kw html hid
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Write a New Page");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Edit a Current Page");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a Page");
}
}
if (!exists $$args{"preview"}) {
$$args{"preview"} = 1;
}
if ($$args{"preview"} && !exists $$args{"prevmsg"}) {
$$args{"prevmsg"} = C_("Preview this page.");
}
$self = $class->SUPER::new($status, $args);
return $self;
}
# _html_col_hid: Hide?
sub _html_col_hid : method {
$_[0]->_html_coltmpl_bool("hid", h_abbr(C_("Hide?")),
h_abbr(C_("Hide this page")), h_abbr(C_("Show this page")),
h_abbr(C_("Hide this page currently.")));
}
return 1;

70
lib/perl5/Selima/Form/Rebuild.pm Normal file
View File

@@ -0,0 +1,70 @@
# Selima Website Content Management System
# Rebuild.pm: The web page rebuild form.
# Copyright (c) 2006-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: 2006-04-04
package Selima::Form::Rebuild;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::PageFunc;
use Selima::ShortCut;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = "new"
if !exists $$args{"type"};
$$args{"type_to_pass"} = undef
if !exists $$args{"type_to_pass"};
$$args{"valid_types"} = [qw(new)]
if !exists $$args{"valid_types"};
$$args{"cols"} = [qw(type)]
if !exists $$args{"cols"};
$$args{"title"} = C_("Rebuild the Pages")
if !exists $$args{"title"};
$$args{"header_buttons"} = []
if !exists $$args{"header_buttons"};
$$args{"footer_buttons"} = [
{ "name" => "confirm", "value" => h(C_("Confirm")) },
{ "name" => "cancel", "value" => h(C_("Cancel")) } ]
if !exists $$args{"footer_buttons"};
$$args{"auto_referer2"} = 0
if !exists $$args{"auto_referer2"};
$self = $class->SUPER::new($status, $args);
return $self;
}
# _html_col_type: The page type
sub _html_col_type : method {
$_[0]->_html_coltmpl_select("type", h_abbr(C_("Type:")),
\&rebuildtype_options, undef);
}
return 1;

93
lib/perl5/Selima/Form/ScptPriv.pm Normal file
View File

@@ -0,0 +1,93 @@
# Selima Website Content Management System
# ScptPriv.pm: The script privilege form.
# 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-10-14
package Selima::Form::ScptPriv;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::FormFunc;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::UserName;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "scptpriv"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this script privilege record")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new script privilege record.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to change a current script privilege record.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a script privilege record.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(script grp)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn script grp
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add A New Script Privilege Record");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Change a Current Script Privilege Record");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a Script Privilege Record");
}
}
$self = $class->SUPER::new($status, $args);
return $self;
}
# _html_col_grp: The privileged group
sub _html_col_grp : method {
$_[0]->_html_coltmpl_call("grp", h_abbr(C_("Privilege:")), \&groupdsc);
}
return 1;

389
lib/perl5/Selima/Form/User.pm Normal file
View File

@@ -0,0 +1,389 @@
# Selima Website Content Management System
# User.pm: The user account form.
# 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-09-30
package Selima::Form::User;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::ChkPriv;
use Selima::CommText;
use Selima::DataVars qw($DBH :groups :l10n :lninfo);
use Selima::FormFunc;
use Selima::GetLang;
use Selima::HTTP;
use Selima::LnInfo;
use Selima::LogIn;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::UserName;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "users"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this user account")
if !exists $$args{"deltext"};
$$args{"https"} = ($$args{"type"} ne "del")
if !exists $$args{"https"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new user account.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to update a current user account.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a user account.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(id passwd name disabled supgroup)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn id passwd name disabled supgroup
admin lang visits visited ip host ct
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add a New User Account");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Update a Current User Account");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a User Account");
}
}
$self = $class->SUPER::new($status, $args);
${$self->{"maxlens"}}{"passwd"} = 16;
if ( $$args{"type"} eq "cur" && !is_su
&& ($self->{"cur"}->param("su") || $self->{"sn"} == get_login_sn)) {
$self->{"nodelete"} = 1;
push @{$self->{"prefmsg"}}, C_("This is a super-user. You can only change parts of her/his infomation.")
if $self->{"cur"}->param("su");
}
# Set all the available belonging groups list
$self->_set_supgroup_list();
return $self;
}
# _set_supgroup_list: Set all the available belonging groups list
sub _set_supgroup_list : method {
local ($_, %_);
my ($self, $form, %checked, $sth, $sql, $count);
my ($lndb, $lndbdef, $title);
$self = $_[0];
$form = $self->{"form"};
# Get the list of checked groups
%checked = qw();
for ($_ = 0; defined $form->param("supgroup$_" . "sn"); $_++) {
$checked{$form->param("supgroup$_" . "sn")} = 1
if defined $form->param("supgroup$_");
}
# Remove the old groups list
foreach ($form->param) {
$form->delete($_) if /^supgroup/;
}
# Get the list of all groups
if (@ALL_LINGUAS > 1) {
$lndb = getlang LN_DATABASE;
if (getlang eq $DEFAULT_LANG) {
$title = $DBH->strcat("id", "' ('", "dsc_$lndb", "')'");
} else {
$lndbdef = ln $DEFAULT_LANG, LN_DATABASE;
$title = $DBH->strcat("id", "' ('",
"COALESCE(dsc_$lndb, dsc_$lndbdef)", "')'");
}
} else {
$title = $DBH->strcat("id", "' ('", "dsc", "')'");
}
$sql = "SELECT sn AS sn, $title AS title FROM groups"
. " WHERE id!=" . $DBH->quote(SU_GROUP)
. " AND id!=" . $DBH->quote(ADMIN_GROUP)
. " AND id!=" . $DBH->quote(ALLUSERS_GROUP)
. " ORDER BY id;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for ($_ = 0; $_ < $count; $_++) {
%_ = %{$sth->fetchrow_hashref};
$form->param("supgroup$_" . "sn", $_{"sn"});
$form->param("supgroup$_" . "title", $_{"title"});
$form->param("supgroup$_", 1) if exists $checked{$_{"sn"}};
}
return;
}
# _html_col_admin: Is this user an administrator?
sub _html_col_admin : method {
$_[0]->_html_coltmpl_ro_bool("admin", h_abbr(C_("Administrator?")),
h_abbr(C_("Administrator")), h_abbr(C_("Non-administrator")));
}
# _html_col_ct: The country
sub _html_col_ct : method {
$_[0]->_html_coltmpl_ro_ct("ct", h_abbr(C_("Country:")));
}
# _html_col_disabled: Disabled?
sub _html_col_disabled : method {
local ($_, %_);
my $self;
$self = $_[0];
# Read-only for a non-super-user editing herself or a super-user
if ( $self->{"type"} eq "cur" && !is_su
&& ($self->{"cur"}->param("su") || $self->{"sn"} == get_login_sn)) {
$self->_html_coltmpl_ro_bool("disabled", h_abbr(C_("Disabled?")),
h_abbr(C_("Disabled")), h_abbr(C_("Enabled")));
} else {
$self->_html_coltmpl_bool("disabled", h_abbr(C_("Disabled?")),
h_abbr(C_("Disabled")), h_abbr(C_("Enabled")),
h_abbr(C_("Disable this user account.")));
}
}
# _html_col_id: The user ID.
sub _html_col_id : method {
local ($_, %_);
my $self;
$self = $_[0];
# Read-only for a non-super-user editing a super-user
if ($self->{"type"} eq "cur" && !is_su && $self->{"cur"}->param("su")) {
$self->_html_coltmpl_ro("id", h_abbr(C_("User ID.:")));
} else {
$self->_html_coltmpl_text("id", h_abbr(C_("User ID.:")));
}
}
# _html_col_lang: The preferred language
sub _html_col_lang : method {
$_[0]->_html_coltmpl_ro_lang("lang", h_abbr(C_("Pref. language:")));
}
# _html_col_name: The name
sub _html_col_name : method {
$_[0]->_html_coltmpl_text("name", h_abbr(C_("Full name:")));
}
# _html_col_passwd: The password
sub _html_col_passwd : method {
local ($_, %_);
my ($self, $label, $dummy, $mark, $colspan);
$self = $_[0];
# Read-only for a non-super-user editing a super-user
if ($self->{"type"} eq "cur" && !is_su && $self->{"cur"}->param("su")) {
$mark = $self->_mark("passwd");
$colspan = $self->_colspan;
$label = h_abbr(C_("Password:"));
$dummy = h("*" x ${$self->{"maxlens"}}{"passwd"});
print << "EOT";
<tr>
<th colspan="2" scope="row">$mark$label</th>
<td$colspan>$dummy</td>
</tr>
EOT
} else {
$self->SUPER::_html_col_passwd();
}
}
# _html_col_supgroup: Its belonging groups
sub _html_col_supgroup : method {
local ($_, %_);
my ($self, $form, $current, $label, $orig, $new, $mark, $colspan);
$self = $_[0];
$form = $self->{"form"};
$current = $self->{"cur"};
$mark = $self->_mark("supgroup");
$colspan = $self->_colspan;
$label = h_abbr(C_("Belonging to:"));
# A form to create a new item
if ($self->{"type"} eq "new") {
print << "EOT";
<tr>
<th class="th" scope="row"><label for="supgroup0">$mark$label</label></th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); defined $form->param("supgroup$_" . "sn"); $_++) {
push @_, sprintf(" <li><input type=\"hidden\" name=\"supgroup%1\$dsn\"%2\$s />\n"
. " <input id=\"supgroup%1\$d\" type=\"checkbox\" name=\"supgroup%1\$d\"%3\$s />\n"
. " <label for=\"supgroup%1\$d\">%4\$s</label>\n"
. " </li>\n",
h($_), $self->_val_text("supgroup$_" . "sn"),
$self->_val_check("supgroup$_"),
h_abbr($form->param("supgroup$_" . "title")));
}
# Only super users can set the super-user group
if (su_group_sn != 0) {
if (is_su) {
push @_, sprintf(" <li><input id=\"su\" type=\"checkbox\" name=\"su\"%s />\n"
. " %s\n"
. " </li>\n",
$self->_val_check("su"),
group_opt_label(su_group_sn, "su"));
} else {
push @_, sprintf(" <li><input id=\"su\" type=\"checkbox\" disabled=\"disabled\" />\n"
. " %s\n"
. " </li>\n",
group_opt_label(su_group_sn));
}
}
# Attach the all-users group in any case
push @_, sprintf(" <li><input id=\"su\" type=\"checkbox\" checked=\"checked\" disabled=\"disabled\" />\n"
. " %s\n"
. " </li>\n",
group_opt_label(groupsn(ALLUSERS_GROUP)))
if defined groupsn(ALLUSERS_GROUP);
print "<ul>\n" . join("", @_) . " </ul>\n ";
print << "EOT";
</td>
</tr>
EOT
# A form to edit a current item
} elsif ($self->{"type"} eq "cur") {
# Read-only for a non-super-user editing herself or a super-user
if (!is_su && $self->{"sn"} == get_login_sn) {
print << "EOT";
<tr>
<th colspan="2" scope="row">$mark$label</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("supgroupcount"); $_++) {
push @_, " <li>" . h_abbr($current->param("supgroup$_" . "title")) . "</li>\n";
}
push @_, " <li>" . group_opt_label(su_group_sn) . "</li>\n"
if $current->param("su");
push @_, " <li>" . group_opt_label(groupsn(ALLUSERS_GROUP)) . "</li>\n"
if defined groupsn(ALLUSERS_GROUP);
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
EOT
} else {
$orig = h_abbr(C_("Original:"));
$new = h_abbr(C_("New:"));
print << "EOT";
<tr>
<th class="th" rowspan="2" scope="row"><label for="supgroup0">$mark$label</label></th>
<th class="oldnew" scope="row">$orig</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("supgroupcount"); $_++) {
push @_, " <li>" . h_abbr($current->param("supgroup$_" . "title")) . "</li>\n";
}
push @_, " <li>" . group_opt_label(su_group_sn) . "</li>\n"
if $current->param("su");
push @_, " <li>" . group_opt_label(groupsn(ALLUSERS_GROUP)) . "</li>\n"
if defined groupsn(ALLUSERS_GROUP);
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
<tr>
<th class="oldnew" scope="row"><label for="supgroup0">$new</label></th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); defined $form->param("supgroup$_" . "sn"); $_++) {
push @_, sprintf(" <li><input type=\"hidden\" name=\"supgroup%1\$dsn\"%2\$s />\n"
. " <input id=\"supgroup%1\$d\" type=\"checkbox\" name=\"supgroup%1\$d\"%3\$s />\n"
. " <label for=\"supgroup%1\$d\">%4\$s</label>\n"
. " </li>\n",
h($_), $self->_val_text("supgroup$_" . "sn"),
$self->_val_check("supgroup$_"),
h_abbr($form->param("supgroup$_" . "title")));
}
# Only super users can set the super-user group
if (su_group_sn != 0) {
if (is_su) {
push @_, sprintf(" <li><input id=\"su\" type=\"checkbox\" name=\"su\"%s />\n"
. " %s\n"
. " </li>\n",
$self->_val_check("su"),
group_opt_label(su_group_sn, "su"));
} else {
push @_, sprintf(" <li><input id=\"su\" type=\"checkbox\"%s disabled=\"disabled\" />\n"
. " %s\n"
. " </li>\n",
$current->param("su")? " checked=\"checked\"": "",
group_opt_label(su_group_sn));
}
}
# Attach the all-users group in any case
push @_, sprintf(" <li><input id=\"su\" type=\"checkbox\" checked=\"checked\" disabled=\"disabled\" />\n"
. " %s\n"
. " </li>\n",
group_opt_label(groupsn(ALLUSERS_GROUP)))
if defined groupsn(ALLUSERS_GROUP);
print "<ul>\n" . join("", @_) . " </ul>\n ";
print << "EOT";
</td>
</tr>
EOT
}
# A form to delete a current item
} else {
print << "EOT";
<tr>
<th class="th" scope="row">$mark$label</th>
EOT
print " <td$colspan>";
for ($_ = 0, @_ = qw(); $_ < $current->param("supgroupcount"); $_++) {
push @_, " <li>" . h_abbr($current->param("supgroup$_" . "title")) . "</li>\n";
}
push @_, " <li>" . group_opt_label(su_group_sn) . "</li>\n"
if $current->param("su");
push @_, " <li>" . group_opt_label(groupsn(ALLUSERS_GROUP)) . "</li>\n"
if defined groupsn(ALLUSERS_GROUP);
print @_ > 0? "<ul>\n" . join("", @_) . " </ul>\n ": h_abbr(t_none);
print << "EOT";
</td>
</tr>
EOT
}
return;
}
return 1;

93
lib/perl5/Selima/Form/UserMem.pm Normal file
View File

@@ -0,0 +1,93 @@
# Selima Website Content Management System
# UserMem.pm: The user-to-group membership form.
# 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-10-14
package Selima::Form::UserMem;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::FormFunc;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::UserName;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "usermem"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this membership record")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new membership record.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to change a current membership record.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a membership record.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(grp member)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn grp member
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add A New User Membership Record");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Change a Current User Membership Record");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a User Membership Record");
}
}
$self = $class->SUPER::new($status, $args);
return $self;
}
# _html_col_member: The member
sub _html_col_member : method {
$_[0]->_html_coltmpl_call("member", h_abbr(C_("Member:")), \&username);
}
return 1;

111
lib/perl5/Selima/Form/UserPref.pm Normal file
View File

@@ -0,0 +1,111 @@
# Selima Website Content Management System
# UserPref.pm: The user preference form.
# 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-10-14
package Selima::Form::UserPref;
use 5.008;
use strict;
use warnings;
use base qw(Selima::Form);
use Selima::DataVars qw(:scptconf);
use Selima::FormFunc;
use Selima::HTTP;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::Unicode;
use Selima::UserName;
# new: Initialize the HTML form table displayer
sub new : method {
local ($_, %_);
my ($class, $status, $args, $self);
($class, $status, $args) = @_;
$args = {} if !defined $args;
# $args must be a hash reference
http_500 "type of argument 2 must be a hash reference"
if ref($args) ne "HASH";
$$args{"type"} = form_type
if !exists $$args{"type"};
$$args{"table"} = "usermem"
if !exists $$args{"table"};
$$args{"deltext"} = C_("Delete this user preference")
if !exists $$args{"deltext"};
if (!exists $$args{"summary"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"summary"} = C_("This table provides you a form to add a new user preference.");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"summary"} = C_("This table provides you a form to modify a current user preference.");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"summary"} = C_("This table provides you a form to delete a user preference.");
}
}
if (!exists $$args{"cols"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"cols"} = [qw(usr domain name value)];
# A form to edit a current item
# A form to delete a current item
} elsif ($$args{"type"} eq "cur" || $$args{"type"} eq "del") {
$$args{"cols"} = [qw(sn usr domain name value
created createdby updated updatedby)];
}
}
if (!exists $$args{"title"}) {
# A form to create a new item
if ($$args{"type"} eq "new") {
$$args{"title"} = C_("Add A New User Preference");
# A form to edit a current item
} elsif ($$args{"type"} eq "cur") {
$$args{"title"} = C_("Modify a Current User Preference");
# A form to delete a current item
} elsif ($$args{"type"} eq "del") {
$$args{"title"} = C_("Delete a User Preference");
}
}
$self = $class->SUPER::new($status, $args);
$self->{"form"}->delete("usr")
if defined $self->{"form"}->param("usr")
&& (!defined $self->{"form"}->param("usr")
|| $self->{"form"}->param("usr") eq "");
return $self;
}
# _html_col_domain: The preference domain
sub _html_col_domain : method {
$_[0]->_html_coltmpl_text_null("domain", h_abbr(C_("Domain:")),
"everywhere", h_abbr(C_("Everywhere")));
}
# _html_col_usr: The user
sub _html_col_usr : method {
$_[0]->_html_coltmpl_call_null("usr", h_abbr(C_("User:")),
"everyone", h_abbr(C_("Everyone")), \&username);
}
# _html_col_value: The preference value
sub _html_col_value : method {
$_[0]->_html_coltmpl_text("value", h_abbr(C_("Value:")));
}
return 1;

115
lib/perl5/Selima/FormFunc.pm Normal file
View File

@@ -0,0 +1,115 @@
# Selima Website Content Management System
# FormFunc.pm: The form-related functions.
# 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::FormFunc;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(get_or_post curform is_form form_type);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub get_or_post();
sub curform();
sub is_form(;$);
sub form_type();
}
use Selima::Cache qw(:formfunc);
use Selima::CallForm;
use Selima::DataVars qw(:env :input);
# get_or_post: whether we should look for form data from $GET or $POST
sub get_or_post() {
local ($_, %_);
return $FormFunc_get_or_post if defined $FormFunc_get_or_post;
$_ = $IS_MODPERL? ($IS_MP2?
Apache2::RequestUtil->request->method: Apache->request->method):
$ENV{"REQUEST_METHOD"};
return ($FormFunc_get_or_post = $_ eq "POST"? $POST: $GET);
}
# curform: Obtain the current form, either from the sent form or
# from the suspended form
sub curform() {
local ($_, %_);
return $FormFunc_curform if defined $FormFunc_curform;
$FormFunc_curform = get_or_post;
$FormFunc_curform = retrieve_form
if defined $FormFunc_curform->param("formid");
return $FormFunc_curform;
}
# is_form: whether this is a form
sub is_form(;$) {
local ($_, %_);
my ($isform, $FORM);
$isform = $_[0];
# Use "isform" to alter the cache
if (defined $isform) {
# A status is provided
if (ref $isform eq "HASH") {
$FormFunc_isform = $$isform{"isform"}? 1: 0
if exists $$isform{"isform"};
# A scalar value
} else {
$FormFunc_isform = $isform? 1: 0;
}
}
# Return the cache
return $FormFunc_isform if defined $FormFunc_isform;
# Obtain the current form
$FORM = curform;
# No valid form infomation
return ($FormFunc_isform = 0) if !defined $FORM->param("form");
# "isform" was specified
if ( defined $FORM->param("status")
&& exists ${$FORM->param("status")}{"isform"}) {
return ($FormFunc_isform = ${$FORM->param("status")}{"isform"}? 1: 0);
}
return ($FormFunc_isform = 1);
}
# form_type: Return the form name (new, cur, del, listpref... etc)
sub form_type() {
local ($_, %_);
# Return the cache
return $FormFunc_formtype if defined $FormFunc_formtype;
# Obtain the current form
$_ = curform;
# Form type specified in arguments
return ($FormFunc_formtype = $_->param("form"))
if defined $_->param("form");
# No form source is found
return ($FormFunc_formtype = -1);
}
return 1;

197
lib/perl5/Selima/Format.pm Normal file
View File

@@ -0,0 +1,197 @@
# Selima Website Content Management System
# Format.pm: The data formatters.
# 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::Format;
use 5.008;
use utf8;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw();
push @EXPORT, qw(fmtno fmtsize fmtdate fmttime rdtime);
push @EXPORT, qw(myfmtdate myfmttime fmtntamount);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub fmtno($);
sub fmtsize($);
sub fmtdate(;$);
sub fmttime(;$);
sub rdtime($);
sub myfmtdate(;$);
sub myfmttime(;$);
sub fmtntamount($);
}
use Time::Local qw(timelocal);
use Selima::ShortCut;
# fmtno: Format the number
sub fmtno($) {
local ($_, %_);
$_ = $_[0];
1 while s/^(\d+)(\d{3})/$1,$2/;
return $_;
}
# fmtsize: Format the size
sub fmtsize($) {
local ($_, %_);
my ($report, $size, $kb, $mb, $gb, $tb, $digits, $rounded);
$size = $_[0];
# Get the size
$report = C_("[#,_1] bytes", $size);
# Try to use KB as the unit
$kb = $size / 1024;
# Bounce if there are fewer than 3 digits in the rounded result
return $report if sprintf("%0.0f", $kb * 100) < 100;
# Check the rounded result for each digit
for ($_ = 2; $_ >= 0; $_--) {
$digits = 10 ** $_;
$rounded = sprintf "%0.0f", $kb * $digits;
# There are 3 significient digits in the rounded result
return sprintf "%s (%." . $_ . "f KB)", $report, $rounded / $digits
if $rounded < 1000;
}
# Try to use MB as the unit
$mb = $kb / 1024;
# Check each digit
for ($_ = 2; $_ >= 0; $_--) {
$digits = 10 ** $_;
$rounded = sprintf "%0.0f", $mb * $digits;
# There are 3 significient digits in the rounded result
return sprintf "%s (%." . $_ . "f MB)", $report, $rounded / $digits
if $rounded < 1000;
}
# Try to use GB as the unit
$gb = $mb / 1024;
# Check each digit
for ($_ = 2; $_ >= 0; $_--) {
$digits = 10 ** $_;
$rounded = sprintf "%0.0f", $gb * $digits;
# There are 3 significient digits in the rounded result
return sprintf "%s (%." . $_ . "f GB)", $report, $rounded / $digits
if $rounded < 1000;
}
# Try to use TB as the unit
$tb = $gb / 1024;
# Check each digit
for ($_ = 2; $_ >= 0; $_--) {
$digits = 10 ** $_;
$rounded = sprintf "%0.0f", $tb * $digits;
# There are 3 significient digits in the rounded result
return sprintf "%s (%." . $_ . "f TB)", $report, $rounded / $digits
if $rounded < 1000;
}
# More than TB
return sprintf "%s (%0.0f TB)", $report, fmtno $tb;
}
# fmtdate: Format the date with the standard ISO format YYYY-MM-DD
sub fmtdate(;$) {
@_ = defined $_[0]? localtime $_[0]: localtime;
return sprintf "%04d-%02d-%02d",
$_[5]+1900, $_[4]+1, $_[3];
}
# fmttime: Format the time with the standard ISO format YYYY-MM-DD HH:MM:SS
sub fmttime(;$) {
local ($_, %_);
if (defined $_[0]) {
$_ = $_[0];
@_ = localtime $_;
$_ = $_ - int $_;
} else {
@_ = localtime;
$_ = 0;
}
$_[5] += 1900;
$_[4]++;
return sprintf "%04d-%02d-%02d %02d:%02d:%02d", @_[5,4,3,2,1,0]
if $_ == 0;
return sprintf "%04d-%02d-%02d %02d:%02d:%02d.%06d",
@_[5,4,3,2,1,0], $_ * 1000000;
}
# rdtime: Read the time with the standard ISO format YYYY-MM-DD HH:MM:SS
sub rdtime($) {
# Not in a correct format
return 0 if $_[0] !~ /^(\d{4})-(\d{2})-(\d{2}) (\d{2}):(\d{2}):(\d{2})$/;
return timelocal($6, $5, $4, $3, $2-1, $1-1900);
}
# myfmtdate: Format the date with my personal format
sub myfmtdate(;$) {
local ($_, %_);
if (defined $_[0]) {
# TODO:
# Actually the timestamp column should be changed to
# timestamp with time zone. But that requires a lot of
# changes, and I have no time for that now.
# imacat <imacat@mail.imacat.idv.tw> 2013-06-27
#@_ = localtime $_[0];
@_ = gmtime $_[0];
} else {
@_ = localtime;
}
$_[5] = ($_[5]+1900) % 100;
$_[4]++;
return sprintf "%d.%d.’%02d.", $_[4], $_[3], $_[5];
}
# myfmttime: Format the time with my personal format
sub myfmttime(;$) {
local ($_, %_);
if (defined $_[0]) {
# TODO:
# Actually the timestamp column should be changed to
# timestamp with time zone. But that requires a lot of
# changes, and I have no time for that now.
# imacat <imacat@mail.imacat.idv.tw> 2013-06-27
#@_ = localtime $_[0];
@_ = gmtime $_[0];
} else {
@_ = localtime;
}
$_[5] = ($_[5]+1900) % 100;
$_[4]++;
$_[0] = ($_[2] < 12)? "am": "pm";
$_[2] = ($_[2] > 12)? $_[2]-12: $_[2];
return sprintf "%d.%d.’%02d. %d:%02d%s.",
$_[4], $_[3], $_[5], $_[2], $_[1], $_[0];
}
# fmtntamount: Format an amount of money in NTD format
sub fmtntamount($) {
local ($_, %_);
$_ = $_[0];
1 while s/^(\d+)(\d{3})/$1,$2/;
return "NT\$ $_.00";
}
no utf8;
return 1;

73
lib/perl5/Selima/GeoIP.pm Normal file
View File

@@ -0,0 +1,73 @@
# Selima Website Content Management System
# GeoIP.pm: The GeoIP-related subroutines.
# 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-10-16
package Selima::GeoIP;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(country_lookup);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub country_lookup(;$);
}
use Geo::IP qw(GEOIP_MEMORY_CACHE);
use Net::CIDR::Lite qw();
BEGIN {
if (exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2) {
require Apache2::Connection;
}
}
use Selima::DataVars qw(:env);
use vars qw($PRIVATE_NETWORKS);
$PRIVATE_NETWORKS = Net::CIDR::Lite->new(
qw(10.0.0.0/8 172.16.0.0/12 192.168.0.0/16));
use constant CT_PRIVATE => "AA";
use constant CT_UNKNOWN => "ZZ";
# country_lookup: Look-up country from IP
sub country_lookup(;$) {
local ($_, %_);
my ($GI, $ip, $ct);
$ip = $_[0];
# Default to look up the client
$ip = $IS_MODPERL? ($IS_MP2?
Apache2::RequestUtil->request->connection->remote_ip:
Apache->request->connection->remote_ip):
$ENV{"REMOTE_ADDR"}
if !defined $ip;
# Start a new GeoIP handler. It rarely needs to be cached
$GI = Geo::IP->new(GEOIP_MEMORY_CACHE);
# Look up in the GeoIP database
return uc $_ if defined($_ = $GI->country_code_by_addr($ip));
# Look up private IP
return CT_PRIVATE if $PRIVATE_NETWORKS->find($ip);
# Not known
return CT_UNKNOWN;
}
return 1;

303
lib/perl5/Selima/GetLang.pm Normal file
View File

@@ -0,0 +1,303 @@
# Selima Website Content Management System
# GetLang.pm: The subroutine to match the user preferred languages with our available languages.
# 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::GetLang;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(getlang getcharset);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub getlang(;$);
sub getcharset();
sub getlang_real();
sub getlang_filename();
sub getlang_env();
sub getlang_accept();
sub getlang_setenv($);
sub getcharset_accept();
sub all_charsets();
}
use CGI::Cookie qw();
use Selima::Cache qw(:getlang);
use Selima::DataVars qw(:input :l10n :lninfo :output :requri);
use Selima::LnInfo;
# getlang: Get the appropriate language from the user-agent
sub getlang(;$) {
local ($_, %_);
$_ = $_[0];
# Return the proper data type
return defined $_? ln(getlang_real, $_): getlang_real;
}
# getcharset: Get the appropriate character set from the user-agent.
sub getcharset() {
local ($_, %_);
my $default;
# Obtained before
return $GetLang_charset if defined $GetLang_charset;
$default = getlang(LN_CHARSET);
# We have no choice
return ($GetLang_charset = $default) if all_charsets < 2;
# Parse the character set by the Accept-Charset header
return $GetLang_charset if defined($GetLang_charset = getcharset_accept);
# Cannot parse -- return the default
return ($GetLang_charset = $default);
}
# getlang_real: The real subroutine
sub getlang_real() {
local ($_, %_);
# Obtained before
return $GetLang_lang if defined $GetLang_lang;
# Uni-lingual
return ($GetLang_lang = $DEFAULT_LANG) if @ALL_LINGUAS == 1;
# Check the file name for specified language
# No setting environment in this case
return $GetLang_lang if defined($GetLang_lang = getlang_filename);
# Methods below should set the language in the environment
# Check the environment for specified language
if (defined($GetLang_lang = getlang_env)) {
getlang_setenv $GetLang_lang;
return $GetLang_lang;
}
# Parse the language by the Accept-Language header
if (defined($GetLang_lang = getlang_accept)) {
getlang_setenv $GetLang_lang;
return $GetLang_lang;
}
# Cannot parse -- return the default
$GetLang_lang = $DEFAULT_LANG;
getlang_setenv $GetLang_lang;
return $GetLang_lang;
}
# getlang_filename: Check the file name for specified language
sub getlang_filename() {
local ($_, %_);
my $langfile;
# Check the file name format
return undef unless defined $REQUEST_PATH && $REQUEST_PATH =~ /\.([^\.\/]+)\.[^\.\/]+$/;
$langfile = $1;
# Check each language for its file name format
@_ = grep $langfile = $_, map ln($_, LN_FILENAME), @ALL_LINGUAS;
return $_[0] if @_ > 0;
# Not found
return undef;
}
# getlang_env: Check the environment for specified language
sub getlang_env() {
local ($_, %_);
%_ = map { $_ => 1 } @ALL_LINGUAS;
# Check the query string
return $_ if defined $GET
&& defined($_ = $GET->param("lang")) && exists $_{$_};
# Check the POSTed form
return $_ if defined $POST
&& defined($_ = $POST->param("lang")) && exists $_{$_};
# Check the cookies
return $_ if exists $COOKIES{"lang"}
&& exists $_{$_ = $COOKIES{"lang"}->value};
# Not set
return undef;
}
# getlang_accept: Parse the language by the Accept-Language header
# Refer to HTTP/1.1 section 14.4 for this algorism
sub getlang_accept() {
local ($_, %_);
my (@rngs, %rngqf, $defqf, $ln, @attrs, %tagqf, $tag, $match);
# Accept-Language not set
return undef if !exists $ENV{"HTTP_ACCEPT_LANGUAGE"};
# Split into language ranges
$_ = $ENV{"HTTP_ACCEPT_LANGUAGE"};
s/^\s*(.*?)\s*$/$1/;
@rngs = split /\s*,\s*/, $_;
%rngqf = qw();
foreach my $range (@rngs) {
# Split into attributes
$range =~ s/^\s*(.*?)\s*$/$1/;
@attrs = split /\s*;\s*/, $range;
# First piece is the language range
$ln = shift @attrs;
# Lower-case it
$ln = lc $ln;
# Find the quality factor
foreach my $attr (@attrs) {
# A numeric quality factor found
$rngqf{$ln} = $1+0 if $attr =~ /^q=([01](?:\.\d{1,3})?)$/;
}
# Default quality factor to 1
$rngqf{$ln} = 1 if !exists $rngqf{$ln};
}
# The default quality factor
if (exists $rngqf{"*"}) {
$defqf = $rngqf{"*"};
delete $rngqf{"*"};
} else {
$defqf = 0;
}
# Language tags (what we have)
%tagqf = qw(); # Calculated quality factor
foreach my $ln (@ALL_LINGUAS) {
# Language tag, as specified in ISO
$tag = ln $ln, LN_NAME;
# Matched range of the quality factor
undef $match if defined $match;
# Language ranges (what the user sent to match us)
foreach my $range (keys %rngqf) {
# Exactly match or match a prefix
if ($tag eq $range || $tag =~ /^\Q$range\E-/) {
# Not matched yet
if (!defined $match) {
$tagqf{$ln} = $rngqf{$range}; # Quality Factor
$match = $range; # Record the matched range
# A longer match range
} elsif (length $range > length $match) {
$tagqf{$ln} = $rngqf{$range}; # Quality Factor
$match = $range; # Record the matched range
}
}
}
# Not matched -- apply a default quality factor
$tagqf{$ln} = $defqf if !exists $tagqf{$ln};
}
# Drop unacceptable languages
foreach my $ln (keys %tagqf) {
delete $tagqf{$ln} unless $tagqf{$ln} > 0;
}
# Nothing acceptable
return undef if scalar(keys %tagqf) == 0;
# Sort by the quality factor
@_ = sort { $tagqf{$b} <=> $tagqf{$a}
|| ($a eq $DEFAULT_LANG? -1: 0)
|| ($b eq $DEFAULT_LANG? 1: 0) } keys %tagqf;
# A preferred match
return $_[0];
}
# getlang_setenv: Check the environment for specified language
sub getlang_setenv($) {
local ($_, %_);
$_ = $_[0];
# Set the cookie to keep the result
$NEWCOOKIES{"lang"} = new CGI::Cookie(-name=>"lang", -value=>$_)
if !exists $COOKIES{"lang"} || $COOKIES{"lang"}->value ne $_;
return;
}
# getcharset_accept: Parse the character set by the Accept-Charset header
# Refer to HTTP/1.1 section 14.2 for this algorism
sub getcharset_accept() {
local ($_, %_);
my (@rngs, %rngqf, $defqf, $cs, @attrs, %tagqf, $tag, $default);
# Accept-Charset not set
return undef if !exists $ENV{"HTTP_ACCEPT_CHARSET"};
$default = getlang(LN_CHARSET);
# Split into character set ranges
$_ = $ENV{"HTTP_ACCEPT_CHARSET"};
s/^\s*(.*?)\s*$/$1/;
@rngs = split /\s*,\s*/, $_;
%rngqf = qw();
foreach my $range (@rngs) {
# Split into attributes
$range =~ s/^\s*(.*?)\s*$/$1/;
@attrs = split /\s*;\s*/, $range;
# First piece is the character set range
$cs = shift @attrs;
# Lower-case it
$cs = lc $cs;
# Find the quality factor
foreach my $attr (@attrs) {
# A numeric quality factor found
$rngqf{$cs} = $1+0 if $attr =~ /^q=([01](?:\.\d{1,3})?)$/;
}
# Default quality factor to 1
$rngqf{$cs} = 1 if !exists $rngqf{$cs};
}
# The default quality factor
if (exists $rngqf{"*"}) {
$defqf = $rngqf{"*"};
delete $rngqf{"*"};
} else {
# Default ISO-8859-1 to 1
$rngqf{"iso-8859-1"} = 1 if !exists $rngqf{"iso-8859-1"};
$defqf = 0;
}
# Character set tags (what we have)
%tagqf = qw(); # Calculated quality factor
foreach my $cs (all_charsets) {
# Character set tag, as specified in ISO
$tag = lc $cs;
# Character set ranges (what the user sent to match us)
foreach my $range (keys %rngqf) {
# Matched
$tagqf{$cs} = $rngqf{$range} # Quality Factor
if $tag eq $range;
}
# Not matched -- apply a default quality factor
$tagqf{$cs} = $defqf if !exists $tagqf{$cs};
}
# Drop unacceptable character sets
foreach my $cs (keys %tagqf) {
delete $tagqf{$cs} unless $tagqf{$cs} > 0;
}
# Nothing acceptable
return undef if scalar(keys %tagqf) == 0;
# Sort by the quality factor
@_ = sort { $tagqf{$b} <=> $tagqf{$a}
|| ($a eq $default? -1: 0)
|| ($b eq $default? 1: 0) } keys %tagqf;
# A preferred match
return $_[0];
}
# all_charsets: Obtain all the available character sets
# Available character sets are the default character set of this
# language, and UTF-8
sub all_charsets() {
local ($_, %_);
return @GetLang_all_charsets if @GetLang_all_charsets > 0;
%_ = qw();
$_ = getlang(LN_CHARSET);
$_{$_} = 1;
$_{"UTF-8"} = 1;
@GetLang_all_charsets = keys %_;
return @GetLang_all_charsets;
}
return 1;

83
lib/perl5/Selima/Guest.pm Normal file
View File

@@ -0,0 +1,83 @@
# Selima Website Content Management System
# Guest.pm: The subroutines for anonymouse/guest operations.
# 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-09-26
package Selima::Guest;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(is_guest gactlog goutpage grmoldpage grmoldfile);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub is_guest(;$);
sub gactlog($;$);
sub goutpage($$;$);
sub grmoldpage($;$);
sub grmoldfile($;$);
}
use Selima::Array;
use Selima::Cache qw(:guest);
use Selima::ChkPriv;
use Selima::DataVars qw(:input :groups);
use Selima::Logging;
use Selima::LogIn;
use Selima::MkAllDir;
use Selima::PageFunc;
use Selima::UserName;
use Selima::XFileIO;
# is_guest: If the user is a guest (by the user id)
sub is_guest(;$) {
local ($_, %_);
$_ = $_[0];
# Default to the current logged-in user
return !is_su && in_array(GUEST_GROUP, get_login_groups)
if !defined $_ || (defined get_login_sn && $_ == get_login_sn);
# Super user is never a guest
return ($Guest_is_guest{$_} = 0) if is_su($_);
# Obtain the groups
return ($Guest_is_guest{$_} = in_array(GUEST_GROUP,
user_parent_groups($_)));
}
# gactlog: Add an activity log record if the user is not a guest
sub gactlog($;$) {
actlog $_[0], $_[1] unless is_guest;
}
# goutpage: outpage() if the user is not a guest
sub goutpage($$;$) {
outpage $_[0], $_[1], $_[2] unless is_guest;
}
# grmoldpage: rmoldpage() if the user is not a guest
sub grmoldpage($;$) {
rmoldpage $_[0], $_[1] unless is_guest;
}
# grmoldfile: rmoldfile() if the user is not a guest
sub grmoldfile($;$) {
rmoldfile $_[0], $_[1] unless is_guest;
}
return 1;

206
lib/perl5/Selima/Guestbook.pm Normal file
View File

@@ -0,0 +1,206 @@
# Selima Website Content Management System
# Guestbook.pm: The guestbook-related subroutines.
# 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-10-23
package Selima::Guestbook;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(update_pageno);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub update_pageno($$$;$);
sub split_page(\@\%$;$);
sub update_old_gbpageno($$;$);
}
use Selima::DataVars qw($DBH);
use Selima::Format;
# update_pageno: Update the guestbook page number
sub update_pageno($$$;$) {
local ($_, %_);
my ($table, $page_size, $cols, $from, $sql, $sth, $count, $row, $len, $where);
my (@ents, %sizes, %orig, %pagenos, $startno, $startat, $commit);
($table, $page_size, $cols, $from) = @_;
# If we should begin and commit here
$commit = $DBH->{"AutoCommit"};
$DBH->begin_work if $commit;
# Update the current page number
# Check the page to start from
undef $startno;
undef $startat;
$from = fmttime $from if defined $from;
if (defined $from) {
$sql = "SELECT pageno FROM $table WHERE NOT hid AND created<'$from'"
. " ORDER BY created DESC LIMIT 1;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
undef $from if $sth->rows != 1;
}
if (defined $from) {
$startno = ${$sth->fetch}[0];
undef $sth;
$sql = "SELECT created FROM $table WHERE NOT hid AND pageno=$startno"
. " ORDER BY created LIMIT 1;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$startat = ${$sth->fetch}[0];
}
@_ = qw();
push @_, "created>='" . fmttime($startat) . "'" if defined $startat;
$where = (@_ > 0)? " WHERE " . join(" AND ", @_): "";
# Ge the size of everyhing
$len = join " + ", map "CASE WHEN $_ IS NULL THEN 0 ELSE char_length($_) END", @$cols;
$len = "CASE WHEN hid THEN 0 ELSE $len END AS len";
$sql = "SELECT sn, $len, pageno FROM $table $where ORDER BY created;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for ($_ = 0, @ents = qw(), %sizes = qw(), %orig = qw(); $_ < $count; $_++) {
$row = $sth->fetchrow_hashref;
push @ents, $$row{"sn"};
$sizes{$$row{"sn"}} = $$row{"len"};
$orig{$$row{"sn"}} = $$row{"pageno"};
}
# Split page
%pagenos = split_page @ents, %sizes, $page_size, $startno;
# Update it
foreach (@ents) {
next if $orig{$_} == $pagenos{$_};
$sql = "UPDATE $table SET pageno=$pagenos{$_} WHERE sn=$_;\n";
$DBH->gdo($sql);
}
# Update the old page number
# No need to update it anymore. Let it go.
$DBH->commit if $commit;
return;
}
# split_page: Split page according to the entry sizes
sub split_page(\@\%$;$) {
local ($_, %_);
my ($ents, $sizes, $page_size, $startno, $cursize, %pagenos);
($ents, $sizes, $page_size, $startno) = @_;
$startno = 1 if !defined $startno;
# Bounce for nothing
return if scalar @$ents == 0;
# Split pages
%pagenos = qw();
$pagenos{$$ents[0]} = $startno;
$cursize = $$sizes{$$ents[0]};
for ($_ = 1; $_ < scalar(@$ents); $_++) {
my ($hi_gap, $lo_gap);
# We need at least one record
if ($cursize == 0) {
$pagenos{$$ents[$_]} = $pagenos{$$ents[$_-1]};
$cursize += $$sizes{$$ents[$_]};
next;
# Not oversized yet
} elsif ($cursize + $$sizes{$$ents[$_]} < $page_size) {
$pagenos{$$ents[$_]} = $pagenos{$$ents[$_-1]};
$cursize += $$sizes{$$ents[$_]};
next;
}
$hi_gap = $cursize + $$sizes{$$ents[$_]} - $page_size;
$lo_gap = $page_size - $cursize;
# The upper boundary is closer, and the page is not too oversized
if ($hi_gap < $lo_gap && $hi_gap <= $page_size / 4) {
$pagenos{$$ents[$_]} = $pagenos{$$ents[$_-1]};
$cursize += $$sizes{$$ents[$_]};
# Or, we prefer the lower, since the page is not oversized
} else {
$pagenos{$$ents[$_]} = $pagenos{$$ents[$_-1]} + 1;
$cursize = $$sizes{$$ents[$_]};
}
}
return %pagenos;
}
# update_old_gbpageno: Update the old guestbook page number
sub update_old_gbpageno($$;$) {
local ($_, %_);
my ($table, $page_size, $from, $sql, $sth, $count, $row, $len, $cond);
my (@ents, %sizes, %orig, %pagenos, $startno, $startat, $commit);
($table, $page_size, $from) = @_;
# If we should begin and commit here
$commit = $DBH->{"AutoCommit"};
$DBH->begin_work if $commit;
# Update the old page number
undef $startno;
undef $startat;
if (defined $from) {
$sql = "SELECT oldpageno FROM $table WHERE NOT hid AND created<'$from'"
. " ORDER BY created DESC LIMIT 1;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$startno = ${$sth->fetch}[0];
undef $sth;
$sql = "SELECT created FROM $table WHERE NOT hid AND oldpageno=$startno"
. " ORDER BY created LIMIT 1;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$startat = ${$sth->fetch}[0];
}
@_ = qw();
push @_, "NOT hid";
push @_, "created>='$startat'" if defined $startat;
$cond = join " AND ", @_;
# Ge the size of everyhing
$len = "${table}_oldlen(created, ip, host, name, identity, location, email, url, message, updated, updatedby) AS len";
# Tavern Backalley has a special table structure
$len = "garbage_oldlen(created, ip, host, message, updated, updatedby) AS len"
if $table eq "garbage";
$sql = "SELECT sn, $len, oldpageno FROM $table WHERE $cond ORDER BY created;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for ($_ = 0, @ents = qw(), %sizes = qw(), %orig = qw(); $_ < $count; $_++) {
$row = $sth->fetchrow_hashref;
push @ents, $$row{"sn"};
$sizes{$$row{"sn"}} = $$row{"len"};
$orig{$$row{"sn"}} = $$row{"oldpageno"};
}
# Split page
# Old page size is always 10240
%pagenos = split_page @ents, %sizes, 10240, $startno;
# Update it
foreach (@ents) {
next if $orig{$_} == $pagenos{$_};
$sql = "UPDATE $table SET oldpageno=$pagenos{$_} WHERE sn=$_;\n";
$DBH->gdo($sql);
}
$DBH->commit if $commit;
return;
}
return 1;

1627
lib/perl5/Selima/HTTP.pm Normal file
View File

File diff suppressed because it is too large Load Diff

94
lib/perl5/Selima/HTTPS.pm Normal file
View File

@@ -0,0 +1,94 @@
# Selima Website Content Management System
# HTTPS.pm: The HTTPS SSL subroutines.
# 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-09-12
package Selima::HTTPS;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(https_process https_host fqdn is_https);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub https_process(;$);
sub https_host();
sub fqdn();
sub is_https();
}
use Socket qw(inet_aton inet_ntoa AF_INET);
use Selima::Cache qw(:https);
use Selima::DataVars qw(:hostconf);
use Selima::Server;
# https_process: Use HTTPs to process the request
sub https_process(;$) {
local ($_, %_);
my $https;
$https = $_[0];
# Set the answer
$HTTPS_https_process = 1 if defined $https;
# Return the answer
return $HTTPS_https_process;
}
# https_host: The default HTTPs host name
sub https_host() {
local ($_, %_);
# Respect the pre-defined setting
return $HTTPS_HOST if defined $HTTPS_HOST;
# Use the fully-qualified domain name (FQDN)
return ($HTTPS_HOST = fqdn);
}
# fqdn: The fully qualified domain name
sub fqdn() {
local ($_, %_);
# Return the cache
return $HTTPS_fqdn if defined $HTTPS_fqdn;
# Use DNS look-up for the current host name
# Apache implementation
$_ = is_apache? $ENV{"SERVER_ADDR"}:
# Microsoft IIS implementation
is_iis? $ENV{"LOCAL_ADDR"}:
# Else, do DNS query
inet_ntoa(scalar gethostbyname $ENV{"SERVER_NAME"});
# Reverse-DNS query for a fully-qualified domain name (FQDN)
$HTTPS_fqdn = gethostbyaddr inet_aton($_), AF_INET;
return $HTTPS_fqdn;
}
# is_https: Check if current scheme is HTTPS
sub is_https() {
local ($_, %_);
# Apache implementation
return exists $ENV{"HTTPS"} if is_apache;
# Microsoft IIS implementation
return exists $ENV{"SERVER_PORT_SECURE"} if is_iis;
# Well, set port 443 to https and others to http.
# This is a bad approach. Avoid it whenever possible.
return ($ENV{"SERVER_PORT"} == 443);
}
return 1;

351
lib/perl5/Selima/Init.pm Normal file
View 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 =~ /&amp;/;
# 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;

106
lib/perl5/Selima/L10N.pm Normal file
View File

@@ -0,0 +1,106 @@
# Selima Website Content Management System
# L10N.pm: The core localization class.
# 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-04-21
package Selima::L10N;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
return 1;
# The core Chinese (Taiwan) localized messages.
package Selima::L10N::zh_tw;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
sub numerate : method { $_[2] }
return 1;
# The core Chinese (China) localized messages.
package Selima::L10N::zh_cn;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
sub numerate : method { $_[2] }
return 1;
# The core Chinese localized messages.
package Selima::L10N::zh;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
sub numerate : method { $_[2] }
return 1;
# The core English localized messages.
package Selima::L10N::en;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
return 1;
# The core English (United States) localized messages.
package Selima::L10N::en_us;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
return 1;
# The core default-language localized messages.
package Selima::L10N::i_default;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
return 1;
# The core automatic localized messages.
package Selima::_AUTO::L10N;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
return 1;
# The core automatic default-language localized messages.
package Selima::_AUTO::L10N::i_default;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
return 1;

173
lib/perl5/Selima/LastModf.pm Normal file
View File

@@ -0,0 +1,173 @@
# Selima Website Content Management System
# LastModf.pm: The web site last-modified time calculator.
# 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::LastModf;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw(not_modified);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub not_modified(\@\@);
sub find_last_modified(\@\@);
sub check_inc();
sub updmtime_tables(\@);
sub updmtime_file($);
}
use File::Spec::Functions qw(catfile);
use HTTP::Date qw(str2time);
use Selima::CallForm;
use Selima::DataVars qw($DBH :input :l10n :lninfo :lastmod :libdir :requri :siteconf);
use Selima::GetLang;
use Selima::HTTP;
use Selima::Session;
# not_modified: Check if we should send "HTTP/1.1 304 Not Modified"
sub not_modified(\@\@) {
local ($_, %_);
my ($tables, $files);
($tables, $files) = @_;
# HTTP/1.1 304 only works for GET or HEAD
return 0 unless $ENV{"REQUEST_METHOD"} eq "GET"
|| $ENV{"REQUEST_METHOD"} eq "HEAD";
# Find the last-modified time
find_last_modified @$tables, @$files;
# If-Modified-Since not supplied. The client had not cached yet.
return 0 if !exists $ENV{"HTTP_IF_MODIFIED_SINCE"};
# Malformed If-Modified-Since value
return 0 if !defined($_ = str2time($ENV{"HTTP_IF_MODIFIED_SINCE"}));
# We are newer than the cache
return 0 if $LAST_MODIFIED > $_;
# Yes, use the cache
return 1;
}
# find_last_modified: Find the last-modified time
sub find_last_modified(\@\@) {
local ($_, %_);
my ($tables, $files);
($tables, $files) = @_;
# Checked before
return if defined $LAST_MODIFIED;
# Remove duplicates
%_ = map { $_ => 1 } @$tables;
@$tables = keys %_;
%_ = map { $_ => 1 } @$files;
@$files = keys %_;
# Start with EPOCH 1970-01-01 00:00:00
$LAST_MODIFIED = 0;
# Check myself
updmtime_file $0;
# Check mtime from the included modules and gettext MO files
check_inc;
# Check the supplied data files
updmtime_file $_ foreach grep -f $_, @$files;
# Check the supplied data tables
updmtime_tables @$tables;
# Check the saved form and status
if (defined $GET->param("formid")) {
$_ = catfile($Selima::Session::DIR, "saveform_" . $GET->param("formid"));
updmtime_file $_ if -f $_;
}
if (defined $GET->param("statid")) {
$_ = catfile($Selima::Session::DIR, "savestat_" . $GET->param("statid"));
updmtime_file $_ if -f $_;
}
return;
}
# check_inc: Check mtime from the included modules and gettext MO files
sub check_inc() {
local ($_, %_);
my ($t, $DH);
# Check the included modules
updmtime_file $_ foreach grep /^\Q$SITE_LIBDIR\E\b/, values %INC;
$t = COMMON_LIBDIR;
updmtime_file $_ foreach grep /^$t\b/, values %INC;
# Check the header and footer
$_ = $DOC_ROOT . "/magicat/include";
@_ = qw();
if (@ALL_LINGUAS > 1) {
push @_, $_ . "/header." . getlang(LN_FILENAME) . ".html";
push @_, $_ . "/footer." . getlang(LN_FILENAME) . ".html";
} else {
push @_, $_ . "/header.html";
push @_, $_ . "/footer.html";
}
foreach (@_) {
updmtime_file $_ if -e $_;
}
# Check the gettext mo files
if (-d $LOCALEDIR) {
opendir $DH, $LOCALEDIR or http_500 "$LOCALEDIR: $!";
@_ = readdir $DH or http_500 "$LOCALEDIR: $!";
closedir $DH or http_500 "$LOCALEDIR: $!";
foreach (@_) {
$_ = "$LOCALEDIR/$_/LC_MESSAGES/$PACKAGE.mo";
updmtime_file $_ if -f $_;
}
}
opendir $DH, COMMON_LOCALEDIR or http_500 COMMON_LOCALEDIR . ": $!";
@_ = readdir $DH or http_500 COMMON_LOCALEDIR . ": $!";
closedir $DH or http_500 COMMON_LOCALEDIR . ": $!";
foreach (@_) {
$_ = COMMON_LOCALEDIR . "/$_/LC_MESSAGES/" . COMMON_DOMAIN . ".mo";
updmtime_file $_ if -f $_;
}
return;
}
# updmtime_tables: Update the $LAST_MODIFIED with the mtime of tables
sub updmtime_tables(\@) {
local ($_, %_);
my ($tables, $sql, $sth);
$tables = $_[0];
# Only work when using database
return if !defined $DBH;
return unless defined($_ = $DBH->lastupd(@$tables));
$_ = int $_;
$LAST_MODIFIED = $_ if defined $_ && $LAST_MODIFIED < $_;
return;
}
# updmtime_file: Update the $LAST_MODIFIED with the mtime of a file
sub updmtime_file($) {
local ($_, %_);
$_ = (stat $_[0])[9];
$LAST_MODIFIED = $_ if $LAST_MODIFIED < $_;
return;
}
return 1;

364
lib/perl5/Selima/Links.pm Normal file
View File

@@ -0,0 +1,364 @@
# Selima Website Content Management System
# Links.pm: The related-link related subroutines.
# 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-10-24
package Selima::Links;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw();
push @EXPORT, qw(linkcat_title linkcat_options link_title);
push @EXPORT, qw(links_shown_parts link_tree link_tree_full);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub linkcat_title($);
sub linkcat_options($);
sub link_title($);
sub links_shown_parts();
sub link_tree($$;$);
sub link_tree_full($;$);
sub link_subtree($$$;$);
}
use Encode qw(decode);
use Selima::Cache qw(:links);
use Selima::ChkFunc;
use Selima::CommText;
use Selima::DataVars qw($DBH :l10n :lninfo);
use Selima::EchoForm;
use Selima::GetLang;
use Selima::LnInfo;
use Selima::PageFunc;
use Selima::ShortCut;
# linkcat_title: Obtain a link category title
sub linkcat_title($) {
local ($_, %_);
my ($sn, $sql, $sth, $col, $thiscol, $lang, $defcol);
$sn = $_[0];
# Bounce if there is any problem with $sn
return t_notset if !defined $sn;
# Return the cache
return $Links_linkcat_title{$sn} if exists $Links_linkcat_title{$sn};
# Check the serial number first
return ($Links_linkcat_title{$sn} = t_na)
if !check_sn $sn;
# Query
# Unilingual
if (@ALL_LINGUAS == 1) {
$col = "linkcat_fulltitle(parent, title) AS title";
# Multilingual
} else {
$thiscol = "title_" . getlang LN_DATABASE;
$lang = getlang;
# Default language
if ($lang eq $DEFAULT_LANG) {
$col = "linkcat_fulltitle('$lang', parent, $thiscol) AS title";
# Fall back to the default language
} else {
$defcol = "title_" . ln($DEFAULT_LANG, LN_DATABASE);
$col = "linkcat_fulltitle('$lang', parent, COALESCE($thiscol, $defcol)) AS title";
}
}
$sql = "SELECT $col FROM linkcat WHERE sn=$sn;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
# Not found
return ($Links_linkcat_title{$sn} = t_na)
unless $sth->rows == 1;
# Found
return ($Links_linkcat_title{$sn} = ${$sth->fetch}[0]);
}
# linkcat_options: Obtain a link category options list
sub linkcat_options($) {
local ($_, %_);
my ($value, $sql, $thiscol, $defcol, $lang, $content);
$value = $_[0];
# Unilingual
if (@ALL_LINGUAS == 1) {
$content = "linkcat_fulltitle(parent, title) AS content";
# Multilingual
} else {
$thiscol = "title_" . getlang(LN_DATABASE);
$lang = getlang;
# Default language
if ($lang eq $DEFAULT_LANG) {
$content = "linkcat_fulltitle('$lang', parent, $thiscol) AS content";
# Fall back to the default language
} else {
$defcol = "title_" . ln($DEFAULT_LANG, LN_DATABASE);
$content = "linkcat_fulltitle('$lang', parent, COALESCE($thiscol, $defcol)) AS content";
}
}
$sql = "SELECT sn AS value, $content FROM linkcat"
. " ORDER BY linkcat_fullord(parent, ord);\n";
return opt_list $sql, $value;
}
# link_title: Obtain a link title
sub link_title($) {
local ($_, %_);
my ($sn, $sql, $sth, $thiscol, $defcol);
$sn = $_[0];
# Bounce if there is any problem with $sn
return t_notset if !defined $sn;
# Return the cache
return $Links_link_title{$sn} if exists $Links_link_title{$sn};
# Check the serial number first
return ($Links_link_title{$sn} = t_na)
if !check_sn $sn;
# Query
$sql = "SELECT title FROM links WHERE sn=$sn;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
# Not found
return ($Links_link_title{$sn} = t_na)
unless $sth->rows == 1;
# Found
return ($Links_link_title{$sn} = ${$sth->fetch}[0]);
}
# link_url: Obtain a link URL
sub link_url($) {
local ($_, %_);
my ($sn, $sql, $sth, $thiscol, $defcol);
$sn = $_[0];
# Bounce if there is any problem with $sn
return t_notset if !defined $sn;
# Return the cache
return $Links_link_title{$sn} if exists $Links_link_title{$sn};
# Check the serial number first
return ($Links_link_title{$sn} = t_na)
if !check_sn $sn;
# Query
$sql = "SELECT url FROM links WHERE sn=$sn;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
# Not found
return ($Links_link_title{$sn} = t_na)
unless $sth->rows == 1;
# Found
return ($Links_link_title{$sn} = ${$sth->fetch}[0]);
}
# links_shown_parts: Obtain the shown links parts
sub links_shown_parts() {
local ($_, %_);
my ($sql, $sth, $count, $row, $path);
%_ = (
"cats" => [],
"catspath" => [],
);
# Obtain the shown categories
$path = $DBH->strcat("'/links'", "linkcat_path(sn, id, parent)")
. " AS path";
$sql = "SELECT sn, $path FROM linkcat"
. " WHERE linkcat_isshown(sn, hid, parent)"
. " ORDER BY linkcat_fullord(parent, ord);\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for ($_ = 0; $_ < $count; $_++) {
$row = $sth->fetchrow_hashref;
push @{$_{"cats"}}, $$row{"sn"};
push @{$_{"catspath"}}, $$row{"path"};
}
@{$_{"cats"}} = sort @{$_{"cats"}};
@{$_{"catspath"}} = sort @{$_{"catspath"}};
return \%_;
}
####################
# Subroutines about link categories
####################
# link_tree: Get the page tree of the links
sub link_tree($$;$) {
local ($_, %_);
my ($path, $lang, $preview, $dir, $tree);
($path, $lang, $preview) = @_;
# Obtain the directory
$dir = $path;
$dir =~ s/[^\/]+\/?$//;
# Initialize the directory array
$Links_link_tree{$lang} = {}
if !exists $Links_link_tree{$lang};
# Return the cache
return ${$Links_link_tree{$lang}}{$dir}
if exists ${$Links_link_tree{$lang}}{$dir};
# Get the full page tree of the links
$tree = link_tree_full $lang, $preview;
# Make a hash of the page tree
$Links_link_tree{$lang} = {hash_tree $tree};
# Not found
return undef if !exists ${$Links_link_tree{$lang}}{$dir};
return ${$Links_link_tree{$lang}}{$dir};
}
# link_tree_full: Get the page tree of the links
sub link_tree_full($;$) {
local ($_, %_);
my ($lang, $preview, $charset, $tree, $pages);
($lang, $preview) = @_;
# Return the cache
return $Links_link_tree_full{$lang}
if exists $Links_link_tree_full{$lang};
# Set the language
$charset = ln($lang, LN_CHARSET);
# Initialize the result
$tree = qw();
# Set the index page
$$tree{"index"} = {
"path" => "/links/",
"title" => C_("Related Links"),
};
# Get the link categories
$pages = link_subtree "/links", undef, $lang, $preview;
$$tree{"pages"} = $pages if defined $pages;
return $tree;
}
# link_subtree: Get the page subtree of the links
sub link_subtree($$$;$) {
local ($_, %_);
my ($path, $parent, $lang, $preview);
my ($lndb, $lndbdef, $has_links, $pages);
my ($sql, $sth, $count, @cols, @conds);
($path, $parent, $lang, $preview) = @_;
# Check if there is any link below this category
$has_links = 0;
if (defined $parent) {
$sql = "SELECT links.sn FROM links"
. " INNER JOIN linkcatz ON linkcatz.link=links.sn"
. " WHERE linkcatz.cat=" . $parent
. " AND NOT links.hid;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$has_links = ($sth->rows > 0);
# Check the preview
$has_links = in_array($parent, @{$$preview{"cats"}})
if !$has_links && defined $preview;
}
# Obtain the subcategories
@cols = qw();
push @cols, "sn AS sn";
push @cols, "id AS id";
# Unilingual
if (@ALL_LINGUAS == 1) {
push @cols, "title AS title";
# Multilingual
} else {
# Set the language
$lndb = ln $lang, LN_DATABASE;
if ($lang eq $DEFAULT_LANG) {
push @cols, "title_$lndb AS title";
} else {
$lndbdef = ln $DEFAULT_LANG, LN_DATABASE;
push @cols, "COALESCE(title_$lndb, title_$lndbdef)"
. " AS title";
}
}
push @cols, "ord AS ord";
@conds = qw();
if (!defined $parent) {
push @conds, "parent IS NULL";
} else {
push @conds, "parent=$parent";
}
push @conds, "NOT hid";
push @conds, "sn!=" . $$preview{"sn"}
if defined $preview && exists $$preview{"sn"};
$sql = "SELECT " . join(", ", @cols) . " FROM linkcat"
. " WHERE " . join(" AND ", @conds)
. " ORDER BY ord;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for ($_ = 0, $pages = []; $_ < $count; $_++) {
my ($row, $subpages, $subpath);
$row = $sth->fetchrow_hashref;
$subpages = link_subtree($path . "/" . $$row{"id"},
$$row{"sn"}, $lang, $preview);
# Only create subtree that has some content
if (defined $subpages) {
# No subcategories -- create it as a ".html" page
if (@$subpages == 0) {
$subpath = $path . "/" . $$row{"id"} . ".html";
push @$pages, {
"path" => $subpath,
"title" => $$row{"title"},
"ord" => $$row{"ord"},
};
# There are subcatgories -- create it as a directory
} else {
$subpath = $path . "/" . $$row{"id"} . "/";
push @$pages, {
"path" => $subpath,
"title" => $$row{"title"},
"ord" => $$row{"ord"},
"sub" => {
"index" => {
"path" => $subpath,
"title" => $$row{"title"},
},
"pages" => $subpages,
},
};
}
}
}
# No content below
return undef if !$has_links && @$pages == 0;
return $pages;
}
return 1;

1619
lib/perl5/Selima/List.pm Normal file
View File

File diff suppressed because it is too large Load Diff

121
lib/perl5/Selima/List/Accounting/Records.pm Normal file
View File

@@ -0,0 +1,121 @@
# Selima Website Content Management System
# Records.pm: The accounting record list.
# Copyright (c) 2007-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: 2007-09-23
package Selima::List::Accounting::Records;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use Selima::CommText;
use Selima::Format;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$_[1] = "acctrecs" if !defined $_[1];
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = $self->{"is_called_form"}?
C_("Select an Accounting Record"):
C_("Manage Accounting Records");
# The default sort order
$self->{"DEFAULT_SORTBY"} = "trx";
# Column labels
$self->col_labels(
"trx" => C_("Accounting transaction"),
"credit" => C_("Debit/credit"),
"subj" => C_("Accounting subject"),
"summary" => C_("Summary"),
"amount" => C_("Amount"),
);
return $self;
}
# html_newlink: Display a link to add a new item
sub html_newlink : method {
local ($_, %_);
# Run the parent method
return $_[0]->SUPER::html_newlink(C_("Add a new accounting record."));
}
# html_search: Display the search box
sub html_search : method {
# Run the parent method
return $_[0]->SUPER::html_search(C_("Search for an accounting record:"));
}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my $self;
$self = $_[0];
# No record to list
if ($self->{"total"} == 0) {
# Inherit the empty list statistics message
return $self->SUPER::liststat_message;
# Fit in one page
} elsif ($self->{"total"} <= $self->{"pagesize"}) {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,accounting record].", $self->{"total"});
# List result
} else {
return C_("[*,_1,accounting record].", $self->{"total"});
}
# More than one page
} else {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,accounting record], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
# List result
} else {
return C_("[*,_1,accounting record], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
}
}
}
# colval: Output a list column value
sub colval : method {
local ($_, %_);
my ($self, $col, %row);
($self, $col, %row) = @_;
# Null/no value
return h(t_notset()) if !defined $row{$col};
# The balance
if ($col eq "amount") {
return "<div class=\"amount\">"
. h_abbr(fmtntamount $row{$col}) . "</div>";
}
# Run the parent method
return $self->SUPER::colval($col, %row);
}
return 1;

667
lib/perl5/Selima/List/Accounting/Reports.pm Normal file
View File

@@ -0,0 +1,667 @@
# Selima Website Content Management System
# Reports.pm: The base accounting report.
# Copyright (c) 2007-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: 2007-09-24
package Selima::List::Accounting::Reports;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use Time::Local qw(timelocal);
use Selima::AddGet;
use Selima::CommText;
use Selima::ChkFunc;
use Selima::DataVars qw($DBH :input :requri);
use Selima::Format;
use Selima::LogIn;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class, $sql, $sth);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = C_("View the Accounting Reports");
# Known columns that should not be displayed (has a special purpose)
push @{$self->{"COLS_NO_DISPLAY"}}, qw(_subj _date _trx);
# Known columns that should not be sorted with
# List sorting is disabled here at all
push @{$self->{"COLS_NO_SORT_BY"}}, qw(date month trxno subj summary
income expense debit credit balance note);
# The list type
$self->{"type"} = $self->{"FORM"}->param("list");
# The date range
$self->{"range"} = $self->{"FORM"}->param("r");
# The onload event handler
$self->{"onload"} = "acctRepQueryDisableNoUseRanges();";
# Should we return the data as CSV
$self->{"iscsv"} = 0;
$self->{"iscsv"} = 1
if defined($_ = $self->{"FORM"}->param("format")) && $_ eq "csv";
# If the database is empty
$sql = "SELECT sn FROM accttrx LIMIT 1;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$self->{"nodata"} = ($sth->rows == 0);
# The full period - used in all reports
if (!$self->{"nodata"}) {
# The earliest start date
$sql = "SELECT date FROM accttrx ORDER BY date LIMIT 1;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
@_ = localtime ${$sth->fetchrow_hashref}{"date"};
$self->{"startdate"} = sprintf "%04d-%02d-%02d",
$_[5] + 1900, $_[4] + 1, $_[3];
# The latest end date
$sql = "SELECT date FROM accttrx ORDER BY date DESC LIMIT 1;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
@_ = localtime ${$sth->fetchrow_hashref}{"date"};
$self->{"enddate"} = sprintf "%04d-%02d-%02d",
$_[5] + 1900, $_[4] + 1, $_[3];
}
# Column labels
$self->col_labels(
"month" => C_("Month"),
"subj" => C_("Accounting subject"),
"summary" => C_("Summary"),
"debit" => C_("Debit"),
"credit" => C_("Credit"),
"income" => C_("Income"),
"expense" => C_("Expense"),
"balance" => C_("Balance"),
);
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
return if !defined $_[0]->{"type"};
# Run the parent method
return $_[0]->SUPER::fetch;
}
# colval: Output a list column value
sub colval : method {
local ($_, %_);
my ($self, $col, %row);
($self, $col, %row) = @_;
# Null/no value
return h(t_notset()) if !defined $row{$col};
# The debit and the credit
if ( $col eq "debit" || $col eq "credit"
|| $col eq "income" || $col eq "expense") {
return "" if $row{$col} == 0;
return "<div class=\"amount\">"
. h_abbr(fmtntamount $row{$col}) . "</div>";
}
# Run the parent method
return $self->SUPER::colval($col, %row);
}
# pre_filter: Set the pre-defined filter
sub pre_filter : method {
local ($_, %_);
my ($self, $form, @conds, $year, $month, $day, $from, $to);
my ($sql, $sth, $startdate);
$self = $_[0];
$form = $self->{"FORM"};
# No need to run if there is no data at all
return undef if $self->{"nodata"};
@conds = qw();
# The active range that is affecting this list
$self->{"actrange"} = undef;
# Range specified
if (defined $self->{"range"}) {
# By month
if ($self->{"range"} eq "m") {
# Trim the value
if (defined($_ = $form->param("m"))) {
s/^\s+//;
s/\s+$//;
$form->param("m", $_);
}
if (!defined $form->param("m") || $form->param("m") eq "") {
$self->{"error"} = {"msg"=>N_("Please specify a month.")}
if !defined $self->{"error"};
} elsif ( $form->param("m") !~ /^(\d{4})-(\d{2})$/
|| !check_date($year = $1, $month = $2, 1)) {
$self->{"error"} = {"msg"=>N_("Please specify a valid month in YYYY-MM format.")}
if !defined $self->{"error"};
} else {
$from = sprintf "%04d-%02d-%02d", $year, $month, 1;
$self->{"startdate"} = $from
if ($self->{"startdate"} cmp $from) < 0;
# The next month
$month++;
if ($month > 12) {
$year++;
$month = 1;
}
# The previous day before the first day of next month
# - The last day of this month
$_ = timelocal(0, 0, 0, 1, $month - 1, $year - 1900);
$_ -= 86400;
@_ = localtime $_;
$to = sprintf "%04d-%02d-%02d",
$_[5] + 1900, $_[4] + 1, $_[3];
$self->{"enddate"} = $to
if ($self->{"enddate"} cmp $to) > 0;
push @conds, "date>=" . $DBH->quote($self->{"startdate"});
push @conds, "date<=" . $DBH->quote($self->{"enddate"});
$self->{"actrange"} = "r=m&m=" . $form->param("m");
}
# By year
} elsif ($self->{"range"} eq "y") {
# Trim the value
if (defined($_ = $form->param("y"))) {
s/^\s+//;
s/\s+$//;
$form->param("y", $_);
}
if (!defined $form->param("y") || $form->param("y") eq "") {
$self->{"error"} = {"msg"=>N_("Please specify a year.")}
if !defined $self->{"error"};
} elsif ( ($_ = $form->param("y")) !~ /^\d{4}$/
|| !check_date($_, 1, 1)) {
$self->{"error"} = {"msg"=>N_("Please specify a valid year in YYYY format.")}
if !defined $self->{"error"};
} else {
$from = sprintf "%04d-%02d-%02d", $_, 1, 1;
$self->{"startdate"} = $from
if ($self->{"startdate"} cmp $from) < 0;
$to = sprintf "%04d-%02d-%02d", $_, 12, 31;
$self->{"enddate"} = $to
if ($self->{"enddate"} cmp $to) > 0;
push @conds, "date>=" . $DBH->quote($self->{"startdate"});
push @conds, "date<=" . $DBH->quote($self->{"enddate"});
$self->{"actrange"} = "r=y&y=" . $form->param("y");
}
# Specified reange
} elsif ($self->{"range"} eq "s") {
my @actrange;
@actrange = qw();
# Trim the value
if (defined($_ = $form->param("f"))) {
s/^\s+//;
s/\s+$//;
$form->param("f", $_);
}
if (defined($_ = $form->param("t"))) {
s/^\s+//;
s/\s+$//;
$form->param("t", $_);
}
# The start day
if (!defined $form->param("f") || $form->param("f") eq "") {
$self->{"error"} = {"msg"=>N_("Please specify the start date.")}
if !defined $self->{"error"};
} elsif ( $form->param("f") !~ /^(\d{4})-(\d{2})-(\d{2})$/
|| !check_date($year = $1, $month = $2, $day =$3)) {
$self->{"error"} = {"msg"=>N_("Please specify a valid start date in YYYY-MM-DD format.")}
if !defined $self->{"error"};
} else {
$from = sprintf "%04d-%02d-%02d", $year, $month, $day;
$self->{"startdate"} = $from
if ($self->{"startdate"} cmp $from) < 0;
push @conds, "date>=" . $DBH->quote($self->{"startdate"});
push @actrange, "f=" . $form->param("f");
}
# The end day
if (!defined $form->param("t") || $form->param("t") eq "") {
$self->{"error"} = {"msg"=>N_("Please specify the end date.")};
} elsif ( $form->param("t") !~ /^(\d{4})-(\d{2})-(\d{2})$/
|| !check_date($year = $1, $month = $2, $day =$3)) {
$self->{"error"} = {"msg"=>N_("Please specify a valid end date in YYYY-MM-DD format.")}
if !defined $self->{"error"};
} else {
$to = sprintf "%04d-%02d-%02d", $year, $month, $day;
$self->{"enddate"} = $to
if ($self->{"enddate"} cmp $to) > 0;
push @conds, "date<=" . $DBH->quote($self->{"enddate"});
push @actrange, "t=" . $form->param("t");
}
if (@actrange > 0) {
unshift @actrange, "r=s";
$self->{"actrange"} = join "&", @actrange;
}
# All
} elsif ($self->{"range"} eq "a") {
# No condition is applied here
$self->{"actrange"} = "r=a";
# Else
} else {
$self->{"error"} = {"msg"=>N_("This option is invalid. Please select a proper date range.")}
if !defined $self->{"error"};
}
}
# Range not set - default to the current month
if (!defined $self->{"actrange"}) {
($year, $month) = (localtime)[5,4];
$year += 1900;
$month++;
$from = sprintf "%04d-%02d-%02d", $year, $month, 1;
$self->{"startdate"} = $from
if ($self->{"startdate"} cmp $from) < 0;
$self->{"actrange"} = "r=m&m=" . sprintf("%04d-%02d", $year, $month);
$month++;
if ($month > 12) {
$year++;
$month = 1;
}
# The previous day before the first day of next month
# - The last day of this month
$_ = timelocal(0, 0, 0, 1, $month - 1, $year - 1900);
$_ -= 86400;
@_ = localtime $_;
$to = sprintf "%04d-%02d-%02d",
$_[5] + 1900, $_[4] + 1, $_[3];
$self->{"enddate"} = $to
if ($self->{"enddate"} cmp $to) > 0;
push @conds, "date>=" . $DBH->quote($self->{"startdate"});
push @conds, "date<=" . $DBH->quote($self->{"enddate"});
}
# Th end date should not be before the first date
$self->{"enddate"} = $self->{"startdate"}
if exists $self->{"startdate"} && exists $self->{"enddate"}
&& ($self->{"startdate"} cmp $self->{"enddate"}) > 0;
return undef if @conds == 0;
return join " AND ", @conds;
}
# html: Output the list
sub html : method {
local ($_, %_);
my $self;
$self = $_[0];
# Fetch the current list if not fetched yet
$self->fetch if !$self->{"fetched"};
# Download the CSV
return $self->html_csv if $self->{"iscsv"} && $self->can("html_csv");
# Run the parent method
return $self->SUPER::html;
}
# set_listpref: Set the list preference
sub set_listpref : method {
local ($_, %_);
my $self;
$self = $_[0];
$_ = new Selima::ListPref::AcctReps($self->{"FORM"});
$_->main;
}
# html_newlink: Display a link to add a new item
sub html_newlink : method {
local ($_, %_);
my ($self, $urle, $urli, $urlt, $prompt);
$self = $_[0];
$urle = "accttrx.cgi?form=new&formsub=expense";
$urli = "accttrx.cgi?form=new&formsub=income";
$urlt = "accttrx.cgi?form=new&formsub=trans";
$prompt = C_("<a href=\"[_1]\">Add a new cash expense transaction</a>, <a href=\"[_2]\">add a new cash income transaction</a> or <a href=\"[_3]\">add a new transfer transaction</a>.",
h($urle), h($urli), h($urlt));
print << "EOT";
<p>$prompt</p>
EOT
return;
}
# html_lists_switch: Display the switch for different lists
sub html_lists_switch : method {
local ($_, %_);
my ($self, $labellist, @lists);
$self = $_[0];
# No need to run if there is no data at all
return if $self->{"nodata"};
# Switch for different lists
$labellist = h_abbr(C_("Report type:"));
@lists = qw();
push @lists, {
"type" => "cash",
"title" => C_("Cash book"),
};
push @lists, {
"type" => "cashsum",
"title" => C_("Cash book summary"),
};
push @lists, {
"type" => "ldgr",
"title" => C_("Ledger"),
};
push @lists, {
"type" => "ldgrsum",
"title" => C_("Ledger summary"),
};
push @lists, {
"type" => "journal",
"title" => C_("Journal"),
};
push @lists, {
"type" => "tb",
"title" => C_("Trial balance"),
};
push @lists, {
"type" => "incmstat",
"title" => C_("Income statement"),
};
push @lists, {
"type" => "blncshet",
"title" => C_("Balance sheet"),
};
# Display the form
print << "EOT";
<p>$labellist
EOT
@_ = qw();
foreach (@lists) {
if (defined $self->{"type"} && $self->{"type"} eq $$_{"type"}) {
push @_, h($$_{"title"});
} else {
push @_, sprintf("<a href=\"%s\">%s</a>",
h($REQUEST_FILE . "?list=" . $$_{"type"}),
h($$_{"title"}));
}
}
print join(" |\n", @_) . "\n";
print << "EOT";
</p>
EOT
return;
}
# html_search: Display the search box
sub html_search : method {
local ($_, %_);
my ($self, $prompt, $label, $query, $request_file);
($self, $prompt) = @_;
# No need to run if there is no data at all
return if $self->{"nodata"};
# Display the report query box
$self->html_report_query;
$prompt = C_("Search the accounting records:") if !defined $prompt;
$prompt = h($prompt);
$request_file = h($REQUEST_FILE);
$query = defined $self->{"query"}? h($self->{"query"}): "";
$label = h(C_("Search"));
print << "EOT";
<form action="$request_file" method="get" accept-charset="<!--selima:charset-->">
<div class="searchbox">
<input type="hidden" name="list" value="search" />
<label for="query">$prompt</label>
<input id="query" type="text" name="query" value="$query" /><input
type="hidden" name="charset" value="<!--selima:charset-->" /><input
type="submit" value="$label" />
</div>
</form>
EOT
return;
}
# html_report_query: Display the report query box
sub html_report_query : method {
local ($_, %_);
my ($self, $form, $request_file, $label, $curlist);
my ($labelmonth, $labelyear, $labelspecified, $labelall);
my ($labelfrom, $labelto, $labelrange);
my ($valrm, $valry, $valrs, $valra);
my ($valm, $valy, $valf, $valt);
my ($sql, $sth, $count, $row);
$self = $_[0];
$form = $self->{"FORM"};
$request_file = h($REQUEST_FILE);
$label = h_abbr(C_("Query"));
$labelrange = h_abbr(C_("Date range:"));
$labelmonth = h_abbr(C_("By month:"));
$labelyear = h_abbr(C_("By year:"));
$labelspecified = h_abbr(C_("Specified date range:"));
$labelall = h_abbr(C_("All"));
$labelfrom = h_abbr(C_("From"));
$labelto = h_abbr(C_("to"));
# Whether each radio button is checked
($valrm, $valry, $valrs, $valra) = ("", "", "", "");
if (defined $self->{"range"}) {
$valrm = " checked=\"checked\""
if $self->{"range"} eq "m";
$valry = " checked=\"checked\""
if $self->{"range"} eq "y";
$valrs = " checked=\"checked\""
if $self->{"range"} eq "s";
$valra = " checked=\"checked\""
if $self->{"range"} eq "a";
# Default to this month
} else {
$valrm = " checked=\"checked\"";
}
# The value of each range
@_ = localtime;
$_[5] += 1900;
$_[4]++;
$valm = defined $form->param("m")? h($form->param("m")):
sprintf("%04d-%02d", @_[5,4]);
$valy = defined $form->param("y")? h($form->param("y")): $_[5];
$valf = defined $form->param("f")? h($form->param("f")):
sprintf("%04d-%02d-%02d", @_[5,4,3]);
$valt = defined $form->param("t")? h($form->param("t")):
sprintf("%04d-%02d-%02d", @_[5,4,3]);
$curlist = h($self->{"type"});
print << "EOT";
<form id="acctrepquery" action="$request_file" method="get" accept-charset="<!--selima:charset-->">
<div class="acctrepquery">
<div><input type="hidden" name="list" value="$curlist" /></div>
EOT
# Display the subject selection if available
$self->html_select_subject if $self->can("html_select_subject");
print << "EOT";
<p>$labelrange
<input id="rangemonth" type="radio" name="r" value="m"$valrm onchange="acctRepQueryDisableNoUseRanges();" /><label
for="rangemonth">$labelmonth</label><select
name="m">
EOT
$sql = "SELECT extract(year FROM date) AS year, extract(month FROM date) AS month FROM accttrx"
. " GROUP BY extract(year FROM date), extract(month FROM date)"
. " ORDER BY extract(year FROM date) DESC, extract(month FROM date) DESC;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @_ = qw(); $i < $count; $i++) {
my ($val, $selected);
$row = $sth->fetchrow_hashref;
$_ = sprintf "%04d-%02d", $$row{"year"}, $$row{"month"};
$val = h($_);
$selected = $valm eq $_? " selected=\"selected\"": "";
print << "EOT";
<option value="$val"$selected>$_</option>
EOT
}
print << "EOT";
</select>
<input id="rangeyear" type="radio" name="r" value="y"$valry onchange="acctRepQueryDisableNoUseRanges();" /><label
for="rangeyear">$labelyear</label><select
name="y">
EOT
$sql = "SELECT extract(year FROM date) AS year FROM accttrx"
. " GROUP BY extract(year FROM date)"
. " ORDER BY extract(year FROM date) DESC;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @_ = qw(); $i < $count; $i++) {
my ($val, $selected);
$row = $sth->fetchrow_hashref;
$_ = $$row{"year"};
$val = h($_);
$selected = $valy eq $_? " selected=\"selected\"": "";
print << "EOT";
<option value="$val"$selected>$_</option>
EOT
}
print << "EOT";
</select>
<input id="rangespecified" type="radio" name="r" value="s"$valrs onchange="acctRepQueryDisableNoUseRanges();" /><label
for="rangespecified">$labelspecified</label><label
for="rangestart">$labelfrom</label><input
id="rangestart" type="text" name="f" value="$valf" size="10" /><label
for="rangeend">$labelto</label><input
id="rangeend" type="text" name="t" value="$valt" size="10" />
<input id="rangeall" type="radio" name="r" value="a"$valra onchange="acctRepQueryDisableNoUseRanges();" /><label
for="rangeall">$labelall</label>
</p>
<p><input type="hidden" name="charset" value="<!--selima:charset-->" /><input
type="submit" value="$label" />
</p>
</div>
</form>
EOT
return;
}
# html_liststat: Display the list statistics
sub html_liststat : method {
local ($_, %_);
my $self;
$self = $_[0];
# Print the current time period
if (!$self->{"nodata"}) {
my ($message, $from, $to);
($from, $to) = ($self->{"startdate"}, $self->{"enddate"});
$message = h(C_("From [_1] to [_2].", $from, $to));
print << "EOT";
<p>$message</p>
EOT
}
# Run the parent method
return $self->SUPER::html_liststat;
}
# html_listprefform: Display a form to change the list preference
sub html_listprefform : method {
local ($_, %_);
my ($self, $submit, $referer, $request_file_h, $domain);
my ($label, $pagesize);
$self = $_[0];
# Do not show the list
return if !defined $self->{"total"};
# No record to be listed
return if $self->{"total"} == 0;
# Return if users preferences are not available
return if !use_users || !defined $SESSION;
$submit = C_("Set");
# The referer
$referer = h(rem_get_arg $REQUEST_FULLURI, "statid");
$request_file_h = h($REQUEST_FILE);
# The domain -- my class name
$domain = h(ref($self));
print << "EOT";
<form action="$request_file_h" method="post" accept-charset="<!--selima:charset-->">
<div><input type="hidden" name="charset" value="<!--selima:charset-->" /><input
type="hidden" name="form" value="listpref" /><input
type="hidden" name="referer" value="$referer" /><input
type="hidden" name="domain" value="$domain" />
EOT
# The number of rows per page
$label = h_abbr(C_("Rows per page:"));
$pagesize = h($self->{"pagesize"});
print << "EOT";
<label for="listsize">$label</label><input
id="listsize" type="text" name="listsize" size="5" maxlength="5" value="$pagesize" />
EOT
print << "EOT";
<input type="submit" name="confirm" value="$submit" /></div>
</form>
EOT
return;
}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my $self;
$self = $_[0];
# No record to list
if ($self->{"total"} == 0) {
# Inherit the empty list statistics message
return $self->SUPER::liststat_message;
# Fit in one page
} elsif ($self->{"total"} <= $self->{"pagesize"}) {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,accounting record].", $self->{"total"});
# List result
} else {
return C_("[*,_1,accounting record].", $self->{"total"});
}
# More than one page
} else {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,accounting record], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
# List result
} else {
return C_("[*,_1,accounting record], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
}
}
}
return 1;

372
lib/perl5/Selima/List/Accounting/Reports/BlncShet.pm Normal file
View File

@@ -0,0 +1,372 @@
# Selima Website Content Management System
# BlncShet.pm: The balance sheet accounting report.
# Copyright (c) 2007-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: 2007-10-03
package Selima::List::Accounting::Reports::BlncShet;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Accounting::Reports);
use Selima::Accounting;
use Selima::CommText;
use Selima::DataVars qw($DBH :l10n :lninfo :output :requri);
use Selima::Format;
use Selima::GetLang;
use Selima::LnInfo;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = C_("Balance Sheet");
# The list type
$self->{"type"} = "blncshet";
# The default number of rows per page
$self->{"DEFAULT_LIST_SIZE"} = undef;
# Known columns that should not be sorted with
# List sorting is disabled here at all
push @{$self->{"COLS_NO_SORT_BY"}}, qw(subjd amountd subjc amountc);
$self->{"noselect"} = 1;
# Column labels
$self->col_labels(
"subjd" => C_("Assets accounting subject"),
"amountd" => C_("Assets amount"),
"subjc" => C_("Liabilities accounting subject"),
"amountc" => C_("Liabilities amount"),
);
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my ($self, @cols, $title, $sth, $sql, $error);
my (@subjs, %recs, @debits, @credits, $sumdebit, $sumcredit);
$self = $_[0];
# Fetched before
return $self->{"error"} if $self->{"fetched"};
$self->{"fetched"} = 1;
# Initialize the error status
$self->{"error"} = undef;
$self->{"total"} = undef;
# No need to run if there is no data at all
if (exists $self->{"nodata"} && $self->{"nodata"}) {
$self->{"total"} = 0;
return;
}
# Construct the SQL query statement
# Obtain the period once
$self->sql_filter;
@cols = qw();
if (@ALL_LINGUAS == 1) {
$title = "acctsubj.title";
} else {
my ($lndb, $lndbdef);
$lndb = getlang LN_DATABASE;
if (getlang eq $DEFAULT_LANG) {
$title = "acctsubj.title_$lndb";
} else {
$lndbdef = ln $DEFAULT_LANG, LN_DATABASE;
$title = "COALESCE(acctsubj.title_$lndb, acctsubj.title_$lndbdef)";
}
}
push @cols, $DBH->strcat("acctsubj.code", "' '", $title) . " AS subj";
push @cols, "sum(CASE WHEN acctrecs.credit THEN acctrecs.amount ELSE -acctrecs.amount END)"
. " AS balance";
$sql = "SELECT " . join(", ", @cols)
. " FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE date<=" . $DBH->quote($self->{"enddate"})
. " AND (acctsubj.code LIKE '1%'"
. " OR acctsubj.code LIKE '2%'"
. " OR acctsubj.code LIKE '3%')"
. " GROUP BY acctsubj.code, $title"
. " ORDER BY acctsubj.code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
@subjs = qw();
push @subjs, $_
while defined($_ = $sth->fetchrow_hashref);
undef $sth;
@subjs = grep $$_{"balance"} != 0, @subjs;
# Obtain the carry-over record of assets/liabilities
$_ = "sum(CASE WHEN acctrecs.credit THEN -acctrecs.amount ELSE acctrecs.amount END)"
. " AS balance";
$sql = "SELECT $_ FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE (acctsubj.code LIKE '1%'"
. " OR acctsubj.code LIKE '2%'"
. " OR acctsubj.code LIKE '3%')"
. " AND accttrx.date<" . $DBH->quote($self->{"startdate"}) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$_ = $sth->fetchrow_hashref;
undef $sth;
push @subjs, {
"subj" => acctsubj_title(acctsubj_sn(ACCTSUBJ_INCOME_ACUM)),
"balance" => $$_{"balance"},
} if defined $$_{"balance"};
# Obtain the net income or loss for current period
$self->sql_filter;
$_ = "sum(CASE WHEN acctrecs.credit THEN acctrecs.amount ELSE -acctrecs.amount END)"
. " AS balance";
$sql = "SELECT $_ FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE date>=" . $DBH->quote($self->{"startdate"})
. " AND date<=" . $DBH->quote($self->{"enddate"})
. " AND NOT (acctsubj.code LIKE '1%'"
. " OR acctsubj.code LIKE '2%'"
. " OR acctsubj.code LIKE '3%');\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$_ = $sth->fetchrow_hashref;
undef $sth;
push @subjs, {
"subj" => acctsubj_title(acctsubj_sn(ACCTSUBJ_INCOME_CUR)),
"balance" => $$_{"balance"},
} if defined $$_{"balance"};
# Add each major category
%recs = qw();
($sumdebit, $sumcredit) = (0, 0);
foreach my $majsubj ((1, 2, 3)) {
my $sum;
$recs{$majsubj} = [];
push @{$recs{$majsubj}}, {
"subj" => acctsubj_title(acctsubj_sn($majsubj)),
"amount" => "",
};
$sum = 0;
%_ = map { substr($$_{"subj"}, 0, 2) => 1 }
grep $$_{"subj"} =~ /^$majsubj/, @subjs;
foreach my $minsubj (sort keys %_) {
push @{$recs{$majsubj}}, {
"subj" => acctsubj_title(acctsubj_sn($minsubj)),
"amount" => "",
} if $minsubj !~ /^(?:12|15|22)$/;
foreach (sort { $$a{"subj"} cmp $$b{"subj"} } grep $$_{"subj"} =~ /^$minsubj/, @subjs) {
push @{$recs{$majsubj}}, {
"subj" => $$_{"subj"},
"amount" => $$_{"balance"},
};
$sum += $$_{"balance"};
}
}
push @{$recs{$majsubj}}, {
"subj" => C_("Total"),
"amount" => $sum,
};
if ($majsubj == 1) {
$sumdebit += $sum;
} else {
$sumcredit += $sum;
}
}
@debits = @{$recs{1}};
@credits = (@{$recs{2}}, { "subj" => "", "amount" => "" }, @{$recs{3}});
# Supply blank records
while (@debits != @credits) {
if (@debits < @credits) {
push @debits, { "subj" => "", "amount" => "" };
} else {
push @credits, { "subj" => "", "amount" => "" };
}
}
# Supply the total record
push @debits, {
"subj" => C_("Total"),
"amount" => $sumdebit,
};
push @credits, {
"subj" => C_("Total"),
"amount" => $sumcredit,
};
# Invert the amount of the debit records
foreach (@debits) {
$$_{"amount"} *= -1 if $$_{"amount"} ne "";
}
# Join the debit and credit records into the balance sheet
$self->{"current"} = [];
for ($_ = 0; $_ < @debits; $_++) {
push @{$self->{"current"}}, {
"subjd" => ${$debits[$_]}{"subj"},
"amountd" => ${$debits[$_]}{"amount"},
"subjc" => ${$credits[$_]}{"subj"},
"amountc" => ${$credits[$_]}{"amount"},
};
}
# The number of rows per page
$self->{"pagesize"} = $self->{"DEFAULT_LIST_SIZE"};
# Paging not in use
$self->{"total"} = scalar(@{$self->{"current"}});
$self->{"lastpage"} = 1;
$self->{"startno"} = 0;
$self->{"endno"} = $self->{"total"} - 1;
# If endno is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Set the columns to be displayed
$self->{"cols"} = [qw(subjd amountd subjc amountc)];
$self->{"listcols"} = [qw(subjd amountd subjc amountc)];
# Done
return $self->{"error"};
}
# colval: Output a list column value
sub colval : method {
local ($_, %_);
my ($self, $col, %row);
($self, $col, %row) = @_;
# Null/no value
return h(t_notset()) if !defined $row{$col};
# The debit and the credit
if ($col eq "subjd" || $col eq "subjc") {
if ($row{$col} =~ /^\d\d /) {
return "<div class=\"subjlv2\">"
. h_abbr($row{$col}) . "</div>";
} elsif ($row{$col} =~ /^\d\d\d/) {
return "<div class=\"subjlastlv\">"
. h_abbr($row{$col}) . "</div>";
} else {
return h_abbr($row{$col});
}
}
# The amount
if ($col eq "amountd" || $col eq "amountc") {
return "" if $row{$col} eq "";
if ($row{$col} < 0) {
return "<div class=\"amount\"><span class=\"neg\">("
. h_abbr(fmtntamount -$row{$col}) . ")</span></div>";
} else {
return "<div class=\"amount\">"
. h_abbr(fmtntamount $row{$col}) . "</div>";
}
}
# Run the parent method
return $self->SUPER::colval($col, %row);
}
# html_data_download: Display the data download link
sub html_data_download : method {
local ($_, %_);
my ($self, $url, $title);
$self = $_[0];
# No data
return if $self->{"total"} == 0;
# Construct the URL
@_ = qw();
push @_, "list=blncshet";
push @_, $self->{"actrange"};
push @_, "format=csv";
$url = $REQUEST_FILE . "?" . join "&", @_;
$title = h_abbr(C_("Download the data as a CSV file."));
print << "EOT";
<p><a href="$url">$title</a></p>
EOT
return;
}
# html_csv: Return the data as CSV
sub html_csv : method {
local ($_, %_);
my $self;
$self = $_[0];
# Output a header to suggest for download instead of display
$HTTP_HEADERS{"Content-Disposition"} =
"attachment; filename=balance_sheet.csv";
$CONTENT_TYPE = "text/csv; charset=" . getlang LN_CHARSET;
# The header column
@_ = map((exists ${$self->{"col_labels"}}{$_}? ${$self->{"col_labels"}}{$_}: $_),
@{$self->{"listcols"}});
s/"/""/g foreach @_; # "
print join(",", map "\"$_\"", @_) . "\n";
# The data
foreach my $current (@{$self->{"current"}}) {
@_ = map $$current{$_}, @{$self->{"listcols"}};
foreach (@_) {
$_ = "" if !defined $_;
s/"/""/g; # "
}
print join(",", map "\"$_\"", @_) . "\n";
}
return;
}
# html_liststat: Display the list statistics
sub html_liststat : method {
local ($_, %_);
my $self;
$self = $_[0];
# Print the current time period
if (!$self->{"nodata"}) {
my ($message, $from, $to);
($from, $to) = ($self->{"startdate"}, $self->{"enddate"});
$message = h(C_("From [_1] to [_2].", $from, $to));
print << "EOT";
<p>$message</p>
EOT
}
return;
}
# html_listprefform: Display a form to change the list preference
# Make it a null function
sub html_listprefform : method {}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my ($self, $total);
$self = $_[0];
$total = $self->{"total"};
# Inherit the empty list statistics message
return $self->SUPER::liststat_message if $self->{"total"} == 0;
return C_("[*,_1,accounting subject].", $self->{"total"} - 1);
}
return 1;

440
lib/perl5/Selima/List/Accounting/Reports/Cash.pm Normal file
View File

@@ -0,0 +1,440 @@
# Selima Website Content Management System
# Cash.pm: The cash accounting report.
# Copyright (c) 2007-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: 2007-09-24
package Selima::List::Accounting::Reports::Cash;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Accounting::Reports);
use POSIX qw(floor);
use Text::Capitalize qw(capitalize_title);
use URI::Escape qw(uri_escape);
use Selima::Accounting;
use Selima::CommText;
use Selima::DataVars qw($DBH :l10n :lninfo :output :requri);
use Selima::Format;
use Selima::GetLang;
use Selima::LnInfo;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::UserPref;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The list type
$self->{"type"} = "cash";
if (@ALL_LINGUAS == 1) {
$self->{"view"} = "acctrep_cash_list";
} else {
$self->{"view"} = "acctrep_cash_list_" . getlang(LN_DATABASE);
}
# The subject
$self->{"subj"} = $self->{"FORM"}->param("subj");
$self->{"subj"} = "" if !defined $self->{"subj"};
# The page title
$_ = $self->{"subj"} eq ""?
C_("current assets and liabilities"):
acctsubj_title(acctsubj_sn($self->{"subj"}));
s/^\d+ //;
$self->{"title"} = capitalize_title(C_("Cash book - [_1]", $_));
$self->{"title"} =~ s/ - /\x{2014}/;
# Column labels
$self->col_labels(
);
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my ($self, $cols, $table, $where, $orderby, $limit, $sth, $sql, $error);
my ($balance, $brought, $sumincome, $sumexpense);
$self = $_[0];
# Fetched before
return $self->{"error"} if $self->{"fetched"};
$self->{"fetched"} = 1;
# Initialize the error status
$self->{"error"} = undef;
$self->{"total"} = undef;
# No need to run if there is no data at all
if ($self->{"nodata"}) {
$self->{"total"} = 0;
return $self->{"error"};
}
# See if we need to use views or not.
# Views make things much faster and easier, but some DBMS has no views.
# *MySQL has no views*
if ($self->{"useview"}) {
($cols, $table, $where, $orderby, $limit) = $self->select_with_view;
} else {
($cols, $table, $where, $orderby, $limit) = $self->select_without_view;
}
# Find the balance before our date range
$_ = "sum(CASE WHEN acctrecs.credit THEN -amount ELSE amount END) AS sum";
if ($self->{"subj"} eq "") {
$sql = "SELECT $_ FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE (acctsubj.code LIKE '11%'"
. " OR acctsubj.code LIKE '12%'"
. " OR acctsubj.code LIKE '21%'"
. " OR acctsubj.code LIKE '22%')"
. " AND accttrx.date<" . $DBH->quote($self->{"startdate"}) . ";\n";
} else {
$sql = "SELECT $_ FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE acctsubj.code LIKE '" . $self->{"subj"} . "%'"
. " AND accttrx.date<" . $DBH->quote($self->{"startdate"}) . ";\n";
}
$sth = $DBH->prepare($sql);
$sth->execute;
$balance = ${$sth->fetch}[0];
# Fetch everything
$self->{"select"} = sprintf "SELECT %s FROM %s%s%s%s;\n",
$cols, $table, $where, $orderby, $limit;
$sql = $self->{"select"};
$sth = $DBH->prepare($sql);
$sth->execute;
$self->{"current"} = [];
push @{$self->{"current"}}, $_
while defined($_ = $sth->fetchrow_hashref);
undef $sth;
# Brought-forward record
undef $brought;
$brought = {
"_sel" => 0,
"_selurl" => undef,
"date" => $self->{"startdate"},
"subj" => acctsubj_title(acctsubj_sn(ACCTSUBJ_INCOME_ACUM)),
"summary" => undef,
"income" => $balance > 0? $balance: 0,
"expense" => $balance < 0? -$balance: 0,
"balance" => $balance,
} if defined $balance;
# Do calculation on each record
$balance = 0 if !defined $balance;
($sumincome, $sumexpense) = (0, 0);
for (my $i = 0; $i < @{$self->{"current"}}; $i++) {
$_ = ${$self->{"current"}}[$i];
$balance = $balance + $$_{"income"} - $$_{"expense"};
$sumincome += $$_{"income"};
$sumexpense += $$_{"expense"};
$$_{"balance"} = $balance;
}
# Prepend the brought-forward record
unshift @{$self->{"current"}}, $brought if defined $brought;
# Append the total record
push @{$self->{"current"}}, {
"_sel" => 0,
"_selurl" => undef,
"date" => $self->{"enddate"},
"subj" => $self->{"subj"} eq ""?
C_("current assets and liabilities"):
acctsubj_title(acctsubj_sn($self->{"subj"})),
"summary" => C_("Total"),
"income" => $sumincome,
"expense" => $sumexpense,
"balance" => $balance,
};
# The number of rows per page
$_ = userpref("listsize", ref $self);
$self->{"pagesize"} = defined $_? $_: $self->{"DEFAULT_LIST_SIZE"};
# Paging not in use
if (!defined $self->{"pagesize"}) {
$self->{"total"} = scalar(@{$self->{"current"}});
$self->{"lastpage"} = 1;
$self->{"startno"} = 0;
$self->{"endno"} = $self->{"total"} - 1;
# If endno is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Done
return $self->{"error"};
}
# Obtain the total number
$self->{"total"} = scalar @{$self->{"current"}};
$self->{"lastpage"} = floor(($self->{"total"} - 1) / $self->{"pagesize"}) + 1;
# If last page is 0 (when total is 0), set to page 1
$self->{"lastpage"} = 1 if $self->{"lastpage"} < 1;
# Check the page number
# Show the last page by default, but not reverse the number colume
$_ = $self->{"reverse"};
$self->{"reverse"} = 1;
$error = $self->check_pageno;
$self->{"reverse"} = $_;
$self->{"error"} = $error if defined $error && !defined $self->{"error"};
# Calculate the start and end record number
$self->{"startno"} = ($self->{"pageno"} - 1) * $self->{"pagesize"};
$self->{"endno"} = $self->{"pageno"} * $self->{"pagesize"} - 1;
# If there is not enough remaining records, set to the last one
$self->{"endno"} = $self->{"total"} - 1
if $self->{"endno"} > $self->{"total"} - 1;
# If the last record is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Obtain everything in this page
$self->{"current"} = [ @{$self->{"current"}}[$self->{"startno"}...$self->{"endno"}] ]
if !$self->{"iscsv"};
# Set the columns to be displayed
$self->{"listcols"} = [qw(date subj summary income expense balance)];
# Done
return $self->{"error"};
}
# page_param: Obtain page parameters
sub page_param : method {
local ($_, %_);
my ($self, $rev, $r);
$self = $_[0];
$rev = $self->{"reverse"};
$self->{"reverse"} = 1;
# Run the parent method
$r = $self->SUPER::page_param;
$self->{"reverse"} = $rev;
return $r;
}
# colval: Output a list column value
sub colval : method {
local ($_, %_);
my ($self, $col, %row);
($self, $col, %row) = @_;
# Display nothing instead of "not set" for empty summaries
return "" if $col =~ /^(?:date|summary)$/ && !defined $row{$col};
# Null/no value
return h(t_notset()) if !defined $row{$col};
# The balance
if ($col eq "balance") {
return "" if $row{$col} eq "";
if ($row{$col} > 0) {
return "<div class=\"amount\">"
. h_abbr(fmtntamount $row{$col}) . "</div>";
} elsif ($row{$col} < 0) {
return "<div class=\"amount\"><span class=\"neg\">-"
. h_abbr(fmtntamount -$row{$col}) . "</span></div>";
} else {
return "<div class=\"amount\">-</div>";
}
}
# Run the parent method
return $self->SUPER::colval($col, %row);
}
# pre_filter: Set the pre-defined filter
sub pre_filter : method {
local ($_, %_);
my ($self, @conds);
$self = $_[0];
@conds = qw();
if ($self->{"subj"} eq "") {
push @conds, "_subj NOT LIKE '11%'";
push @conds, "_subj NOT LIKE '12%'";
push @conds, "_subj NOT LIKE '21%'";
push @conds, "_subj NOT LIKE '22%'";
@_ = qw();
push @_, "accttrx_has_subj(_trx, '11')";
push @_, "accttrx_has_subj(_trx, '12')";
push @_, "accttrx_has_subj(_trx, '21')";
push @_, "accttrx_has_subj(_trx, '22')";
push @conds, "(" . join(" OR ", @_) . ")";
} else {
push @conds, "_subj NOT LIKE '" . $self->{"subj"} . "%'";
push @conds, "accttrx_has_subj(_trx, '" . $self->{"subj"} . "')";
}
push @conds, $_ if defined($_ = $self->SUPER::pre_filter);
return undef if @conds == 0;
return join " AND ", @conds;
}
# html_select_subject: Display the subject search box
sub html_select_subject : method {
local ($_, %_);
my ($self, $label, @subjs);
my ($sql, $sth, $count, $row, $thiscol, $defcol);
$self = $_[0];
# The subject
$label = h_abbr(C_("Accounting subject:"));
# Obtain all the cash subjects
$sql = "SELECT acctsubj.code FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " WHERE acctsubj.code LIKE '11%'"
. " OR acctsubj.code LIKE '12%'"
. " OR acctsubj.code LIKE '21%'"
. " OR acctsubj.code LIKE '22%'"
. " GROUP BY acctsubj.code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @_ = qw(); $i < $count; $i++) {
$row = $sth->fetchrow_hashref;
push @_, $$row{"code"};
}
undef $sth;
%_ = map { $_ => 1 } @_;
# Add all of their parents
foreach (keys %_) {
$_{$_} = 1 while s/.$//;
}
delete $_{""};
delete $_{"1"};
delete $_{"11"};
delete $_{"12"};
delete $_{"2"};
delete $_{"21"};
delete $_{"22"};
@_ = qw();
push @_, "code AS value";
if (@ALL_LINGUAS == 1) {
push @_, $DBH->strcat("code", "' '", "title")
. " AS content";
} else {
$thiscol = "title_" . getlang LN_DATABASE;
if (getlang eq $DEFAULT_LANG) {
push @_, $DBH->strcat("code", "' '", $thiscol)
. " AS content";
} else {
$defcol = "title_" . ln($DEFAULT_LANG, LN_DATABASE);
push @_, $DBH->strcat("code", "' '", "COALESCE($thiscol, $defcol)")
. " AS content";
}
}
$sql = "SELECT " . join(", ", @_) . " FROM acctsubj"
. " WHERE " . join(" OR ", map "code=" . $DBH->quote($_), sort keys %_)
. " ORDER BY code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @subjs = qw(); $i < $count; $i++) {
push @subjs, {%{$sth->fetchrow_hashref}};
}
undef $sth;
unshift @subjs, { "value" => "", "content" => C_("current assets and liabilities"), };
# Display the form
print << "EOT";
<p>$label
<select name="subj">
EOT
foreach (@subjs) {
my ($val, $content, $selected);
$val = h($$_{"value"});
$content = h($$_{"content"});
$selected = defined $self->{"subj"} && $self->{"subj"} eq $$_{"value"}?
" selected=\"selected\"": "";
print << "EOT";
<option value="$val"$selected>$content</option>
EOT
}
print << "EOT";
</select>
</p>
EOT
return;
}
# html_data_download: Display the data download link
sub html_data_download : method {
local ($_, %_);
my ($self, $form, $url, $title);
$self = $_[0];
$form = $self->{"FORM"};
# No data
return if $self->{"total"} == 0;
# Construct the URL
@_ = qw();
push @_, "list=cash";
push @_, "subj=" . uri_escape($self->{"subj"});
push @_, $self->{"actrange"};
push @_, "format=csv";
$url = $REQUEST_FILE . "?" . join "&", @_;
$title = h_abbr(C_("Download the data as a CSV file."));
print << "EOT";
<p><a href="$url">$title</a></p>
EOT
return;
}
# html_csv: Return the data as CSV
sub html_csv : method {
local ($_, %_);
my $self;
$self = $_[0];
# Output a header to suggest for download instead of display
$HTTP_HEADERS{"Content-Disposition"} =
"attachment; filename=cash_details.csv";
$CONTENT_TYPE = "text/csv; charset=" . getlang LN_CHARSET;
# The header column
@_ = map((exists ${$self->{"col_labels"}}{$_}? ${$self->{"col_labels"}}{$_}: $_),
@{$self->{"listcols"}});
s/"/""/g foreach @_; # "
print join(",", map "\"$_\"", @_) . "\n";
# The data
foreach my $current (@{$self->{"current"}}) {
@_ = map $$current{$_}, @{$self->{"listcols"}};
foreach (@_) {
$_ = "" if !defined $_;
s/"/""/g; # "
}
print join(",", map "\"$_\"", @_) . "\n";
}
return;
}
# html_pagebar: Display a page navigation bar
sub html_pagebar : method {
local ($_, %_);
my ($self, $rev, $r);
$self = $_[0];
$rev = $self->{"reverse"};
$self->{"reverse"} = 1;
# Run the parent method
$r = $self->SUPER::html_pagebar;
$self->{"reverse"} = $rev;
return $r;
}
return 1;

477
lib/perl5/Selima/List/Accounting/Reports/Cash/Summary.pm Normal file
View File

@@ -0,0 +1,477 @@
# Selima Website Content Management System
# Summary.pm: The cash summary accounting report.
# Copyright (c) 2007-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: 2007-09-27
package Selima::List::Accounting::Reports::Cash::Summary;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Accounting::Reports);
use POSIX qw(floor);
use Text::Capitalize qw(capitalize_title);
use URI::Escape qw(uri_escape);
use Selima::Accounting;
use Selima::CommText;
use Selima::DataVars qw($DBH :env :l10n :lninfo :output :requri);
use Selima::Format;
use Selima::GetLang;
use Selima::LnInfo;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::UserPref;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class, @cols, $sql);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The list type
$self->{"type"} = "cashsum";
# The subject
$self->{"subj"} = $self->{"FORM"}->param("subj");
$self->{"subj"} = "" if !defined $self->{"subj"};
# The page title
$_ = $self->{"subj"} eq ""?
C_("current assets and liabilities"):
acctsubj_title(acctsubj_sn($self->{"subj"}));
s/^\d+ //;
$self->{"title"} = capitalize_title(C_("Cash Book Summary - [_1]", $_));
$self->{"title"} =~ s/ - /\x{2014}/;
# Construct the view
$self->{"view"} = "acctrep_cash_summary_list";
$self->{"noselect"} = 1;
@_ = qw();
push @_, "list=cash";
push @_, "subj=" . uri_escape($self->{"subj"});
push @_, "r=m";
push @_, "m=";
$_ = $REQUEST_FILE . "?" . join "&", @_;
if ($self->{"subj"} eq "") {
@cols = qw();
push @cols, $DBH->strcat($DBH->quote($_),
"lpad(cast(extract(year FROM date) AS text), 4, '0')",
"'-'", "lpad(cast(extract(month FROM date) AS text), 2, '0')") . " AS _viewurl";
push @cols, $DBH->strcat("lpad(cast(extract(year FROM date) AS text), 4, '0')",
"'-'", "lpad(cast(extract(month FROM date) AS text), 2, '0')") . " AS month";
@_ = qw();
push @_, "acctsum_debit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '11')";
push @_, "acctsum_debit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '12')";
push @_, "acctsum_debit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '21')";
push @_, "acctsum_debit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '22')";
push @cols, join(" + ", @_) . " AS income";
@_ = qw();
push @_, "acctsum_credit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '11')";
push @_, "acctsum_credit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '12')";
push @_, "acctsum_credit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '21')";
push @_, "acctsum_credit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '22')";
push @cols, join(" + ", @_) . " AS expense";
@_ = qw();
push @_, "acctsum_balance(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '11')";
push @_, "acctsum_balance(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '12')";
push @_, "acctsum_balance(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '21')";
push @_, "acctsum_balance(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), '22')";
push @cols, join(" + ", @_) . " AS balance";
$sql = "CREATE TEMPORARY VIEW " . $self->{"view"} . " AS"
. " SELECT " . join(", ", @cols)
. " FROM accttrx"
. " GROUP BY extract(year FROM date), extract(month FROM date)"
. " ORDER BY extract(year FROM date), extract(month FROM date);\n";
} else {
@cols = qw();
push @cols, $DBH->strcat($DBH->quote($_),
"lpad(cast(extract(year FROM date) AS text), 4, '0')",
"'-'", "lpad(extract(cast(month FROM date) AS text), 2, '0')") . " AS _viewurl";
push @cols, $DBH->strcat("lpad(cast(extract(year FROM date) AS text), 4, '0')",
"'-'", "lpad(cast(extract(month FROM date) AS text), 2, '0')") . " AS month";
push @cols, "acctsum_debit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), "
. " " . $DBH->quote($self->{"subj"}) . ") AS income";
push @cols, "acctsum_credit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer),"
. " " . $DBH->quote($self->{"subj"}) . ") AS expense";
push @cols, "acctsum_balance(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), "
. " " . $DBH->quote($self->{"subj"}) . ") AS balance";
$sql = "CREATE TEMPORARY VIEW " . $self->{"view"} . " AS"
. " SELECT " . join(", ", @cols)
. " FROM accttrx"
. " GROUP BY extract(year FROM date), extract(month FROM date)"
. " ORDER BY extract(year FROM date), extract(month FROM date);\n";
}
$DBH->do($sql);
# Column labels
$self->col_labels(
);
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my ($self, $cols, $table, $where, $orderby, $limit, $sth, $sql, $error);
my ($sumincome, $sumexpense);
$self = $_[0];
# Fetched before
return $self->{"error"} if $self->{"fetched"};
$self->{"fetched"} = 1;
# Initialize the error status
$self->{"error"} = undef;
$self->{"total"} = undef;
# No need to run if there is no data at all
if (exists $self->{"nodata"} && $self->{"nodata"}) {
$self->{"total"} = 0;
return;
}
# See if we need to use views or not.
# Views make things much faster and easier, but some DBMS has no views.
# *MySQL has no views*
if ($self->{"useview"}) {
($cols, $table, $where, $orderby, $limit) = $self->select_with_view;
} else {
($cols, $table, $where, $orderby, $limit) = $self->select_without_view;
}
# Fetch everything
$self->{"select"} = sprintf "SELECT %s FROM %s%s%s%s;\n",
$cols, $table, $where, $orderby, $limit;
$sql = $self->{"select"};
$sth = $DBH->prepare($sql);
$sth->execute;
$self->{"current"} = [];
push @{$self->{"current"}}, $_
while defined($_ = $sth->fetchrow_hashref);
undef $sth;
# Do calculation on each record
($sumincome, $sumexpense) = (0, 0);
foreach (@{$self->{"current"}}) {
$sumincome += $$_{"income"};
$sumexpense += $$_{"expense"};
}
# Remove the starting and ending empty records
@_ = @{$self->{"current"}};
shift @_ while @_ > 0 && ${$_[0]}{"income"} == 0 && ${$_[0]}{"expense"} == 0;
pop @_ while @_ > 0 && ${$_[$#_]}{"income"} == 0 && ${$_[$#_]}{"expense"} == 0;
$self->{"current"} = [@_];
# Append the total record
if (@{$self->{"current"}} > 0) {
@_ = qw();
push @_, "list=cash";
push @_, "subj=" . uri_escape($self->{"subj"});
push @_, "r=a";
push @{$self->{"current"}}, {
"_viewurl" => $REQUEST_FILE . "?" . join("&", @_),
"month" => C_("Total"),
"income" => $sumincome,
"expense" => $sumexpense,
"balance" => ${(reverse @{$self->{"current"}})[0]}{"balance"},
};
}
# The number of rows per page
$_ = userpref("listsize", ref $self);
$self->{"pagesize"} = defined $_? $_: $self->{"DEFAULT_LIST_SIZE"};
# Paging not in use
if (!defined $self->{"pagesize"}) {
$self->{"total"} = scalar(@{$self->{"current"}});
$self->{"lastpage"} = 1;
$self->{"startno"} = 0;
$self->{"endno"} = $self->{"total"} - 1;
# If endno is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Done
return $self->{"error"};
}
# Obtain the total number
$self->{"total"} = scalar @{$self->{"current"}};
$self->{"lastpage"} = floor(($self->{"total"} - 1) / $self->{"pagesize"}) + 1;
# If last page is 0 (when total is 0), set to page 1
$self->{"lastpage"} = 1 if $self->{"lastpage"} < 1;
# Check the page number
# Show the last page by default, but not reverse the number colume
$_ = $self->{"reverse"};
$self->{"reverse"} = 1;
$error = $self->check_pageno;
$self->{"reverse"} = $_;
$self->{"error"} = $error if defined $error && !defined $self->{"error"};
# Calculate the start and end record number
$self->{"startno"} = ($self->{"pageno"} - 1) * $self->{"pagesize"};
$self->{"endno"} = $self->{"pageno"} * $self->{"pagesize"} - 1;
# If there is not enough remaining records, set to the last one
$self->{"endno"} = $self->{"total"} - 1
if $self->{"endno"} > $self->{"total"} - 1;
# If the last record is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Obtain everything in this page
$self->{"current"} = [ @{$self->{"current"}}[$self->{"startno"}...$self->{"endno"}] ]
if !$self->{"iscsv"};
# Set the columns to be displayed
$self->{"cols"} = [qw(_viewurl month income expense balance)];
$self->{"listcols"} = [qw(month income expense balance)];
# Done
return $self->{"error"};
}
# page_param: Obtain page parameters
sub page_param : method {
local ($_, %_);
my ($self, $rev, $r);
$self = $_[0];
$rev = $self->{"reverse"};
$self->{"reverse"} = 1;
# Run the parent method
$r = $self->SUPER::page_param;
$self->{"reverse"} = $rev;
return $r;
}
# colval: Output a list column value
sub colval : method {
local ($_, %_);
my ($self, $col, %row);
($self, $col, %row) = @_;
# Null/no value
return h(t_notset()) if !defined $row{$col};
# The balance
if ($col eq "balance") {
if ($row{$col} > 0) {
return "<div class=\"amount\">"
. h_abbr(fmtntamount $row{$col}) . "</div>";
} elsif ($row{$col} < 0) {
return "<div class=\"amount\"><span class=\"neg\">-"
. h_abbr(fmtntamount -$row{$col}) . "</span></div>";
} else {
return "<div class=\"amount\">-</div>";
}
}
# Run the parent method
return $self->SUPER::colval($col, %row);
}
# pre_filter: Set the pre-defined filter
# Make it a null function
sub pre_filter : method { }
# html_report_query: Display the report query box
sub html_report_query : method {
local ($_, %_);
my ($self, $form, $request_file, $label, $curlist);
$self = $_[0];
$form = $self->{"FORM"};
$request_file = h($REQUEST_FILE);
$label = h_abbr(C_("Query"));
$curlist = h($self->{"type"});
print << "EOT";
<form action="$request_file" method="get" accept-charset="<!--selima:charset-->">
<div class="acctrepquery">
<div><input type="hidden" name="list" value="$curlist" /></div>
EOT
# Display the subject selection if available
$self->html_select_subject if $self->can("html_select_subject");
print << "EOT";
<p><input type="hidden" name="charset" value="<!--selima:charset-->" /><input
type="submit" value="$label" />
</p>
</div>
</form>
EOT
return;
}
# html_select_subject: Display the subject search box
sub html_select_subject : method {
local ($_, %_);
my ($self, $label, @subjs);
my ($sql, $sth, $count, $row, $thiscol, $defcol);
$self = $_[0];
# The subject
$label = h_abbr(C_("Accounting subject:"));
# Obtain all the cash subjects
$sql = "SELECT acctsubj.code FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " WHERE acctsubj.code LIKE '11%'"
. " OR acctsubj.code LIKE '12%'"
. " OR acctsubj.code LIKE '21%'"
. " OR acctsubj.code LIKE '22%'"
. " GROUP BY acctsubj.code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @_ = qw(); $i < $count; $i++) {
$row = $sth->fetchrow_hashref;
push @_, $$row{"code"};
}
undef $sth;
%_ = map { $_ => 1 } @_;
# Add all of their parents
foreach (keys %_) {
$_{$_} = 1 while s/.$//;
}
delete $_{""};
delete $_{"1"};
delete $_{"11"};
delete $_{"12"};
delete $_{"2"};
delete $_{"21"};
delete $_{"22"};
@_ = qw();
push @_, "code AS value";
if (@ALL_LINGUAS == 1) {
push @_, $DBH->strcat("code", "' '", "title")
. " AS content";
} else {
$thiscol = "title_" . getlang LN_DATABASE;
if (getlang eq $DEFAULT_LANG) {
push @_, $DBH->strcat("code", "' '", $thiscol)
. " AS content";
} else {
$defcol = "title_" . ln($DEFAULT_LANG, LN_DATABASE);
push @_, $DBH->strcat("code", "' '", "COALESCE($thiscol, $defcol)")
. " AS content";
}
}
$sql = "SELECT " . join(", ", @_) . " FROM acctsubj"
. " WHERE " . join(" OR ", map "code=" . $DBH->quote($_), sort keys %_)
. " ORDER BY code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @subjs = qw(); $i < $count; $i++) {
push @subjs, {%{$sth->fetchrow_hashref}};
}
undef $sth;
unshift @subjs, { "value" => "", "content" => C_("current assets and liabilities"), };
# Display the form
print << "EOT";
<p>$label
<select name="subj">
EOT
foreach (@subjs) {
my ($val, $content, $selected);
$val = h($$_{"value"});
$content = h($$_{"content"});
$selected = defined $self->{"subj"} && $self->{"subj"} eq $$_{"value"}?
" selected=\"selected\"": "";
print << "EOT";
<option value="$val"$selected>$content</option>
EOT
}
print << "EOT";
</select>
</p>
EOT
return;
}
# html_data_download: Display the data download link
sub html_data_download : method {
local ($_, %_);
my ($self, $url, $title);
$self = $_[0];
# No data
return if $self->{"total"} == 0;
# Construct the URL
@_ = qw();
push @_, "list=cashsum";
push @_, "subj=" . uri_escape($self->{"subj"});
push @_, "format=csv";
$url = $REQUEST_FILE . "?" . join "&", @_;
$title = h_abbr(C_("Download the data as a CSV file."));
print << "EOT";
<p><a href="$url">$title</a></p>
EOT
return;
}
# html_csv: Return the data as CSV
sub html_csv : method {
local ($_, %_);
my $self;
$self = $_[0];
# Output a header to suggest for download instead of display
$HTTP_HEADERS{"Content-Disposition"} =
"attachment; filename=cash_summary.csv";
$CONTENT_TYPE = "text/csv; charset=" . getlang LN_CHARSET;
# The header column
@_ = map((exists ${$self->{"col_labels"}}{$_}? ${$self->{"col_labels"}}{$_}: $_),
@{$self->{"listcols"}});
s/"/""/g foreach @_; # "
print join(",", map "\"$_\"", @_) . "\n";
# The data
foreach my $current (@{$self->{"current"}}) {
print join(",", map $$current{$_}, @{$self->{"listcols"}}) . "\n";
}
return;
}
# html_pagebar: Display a page navigation bar
sub html_pagebar : method {
local ($_, %_);
my ($self, $rev, $r);
$self = $_[0];
$rev = $self->{"reverse"};
$self->{"reverse"} = 1;
# Run the parent method
$r = $self->SUPER::html_pagebar;
$self->{"reverse"} = $rev;
return $r;
}
return 1;

366
lib/perl5/Selima/List/Accounting/Reports/IncmStat.pm Normal file
View File

@@ -0,0 +1,366 @@
# Selima Website Content Management System
# IncmStat.pm: The income statement accounting report.
# Copyright (c) 2007-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: 2007-10-03
package Selima::List::Accounting::Reports::IncmStat;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Accounting::Reports);
use Selima::Accounting;
use Selima::CommText;
use Selima::DataVars qw($DBH :l10n :lninfo :output :requri);
use Selima::Format;
use Selima::GetLang;
use Selima::LnInfo;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = C_("Income Statement");
# The list type
$self->{"type"} = "incmstat";
# The default number of rows per page
$self->{"DEFAULT_LIST_SIZE"} = undef;
# Known columns that should not be sorted with
# List sorting is disabled here at all
push @{$self->{"COLS_NO_SORT_BY"}}, qw(amount1 amount2);
$self->{"noselect"} = 1;
# Column labels
$self->col_labels(
"amount1" => C_("Amount"),
"amount2" => C_("Amount"),
);
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my ($self, @cols, $title, $sth, $sql, $error);
my (@subjs, $sum, $balance);
$self = $_[0];
# Fetched before
return $self->{"error"} if $self->{"fetched"};
$self->{"fetched"} = 1;
# Initialize the error status
$self->{"error"} = undef;
$self->{"total"} = undef;
# No need to run if there is no data at all
if (exists $self->{"nodata"} && $self->{"nodata"}) {
$self->{"total"} = 0;
return;
}
# Construct the SQL query statement
# Obtain the period once
$self->sql_filter;
@cols = qw();
if (@ALL_LINGUAS == 1) {
$title = "acctsubj.title";
} else {
my ($lndb, $lndbdef);
$lndb = getlang LN_DATABASE;
if (getlang eq $DEFAULT_LANG) {
$title = "acctsubj.title_$lndb";
} else {
$lndbdef = ln $DEFAULT_LANG, LN_DATABASE;
$title = "COALESCE(acctsubj.title_$lndb, acctsubj.title_$lndbdef)";
}
}
push @cols, $DBH->strcat("acctsubj.code", "' '", $title) . " AS subj";
push @cols, "sum(CASE WHEN acctrecs.credit THEN acctrecs.amount ELSE -acctrecs.amount END)"
. " AS balance";
$sql = "SELECT " . join(", ", @cols)
. " FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE date>=" . $DBH->quote($self->{"startdate"})
. " AND date<=" . $DBH->quote($self->{"enddate"})
. " AND NOT (acctsubj.code LIKE '1%'"
. " OR acctsubj.code LIKE '2%'"
. " OR acctsubj.code LIKE '3%')"
. " GROUP BY acctsubj.code, $title"
. " ORDER BY acctsubj.code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
@subjs = qw();
push @subjs, $_
while defined($_ = $sth->fetchrow_hashref);
undef $sth;
$self->{"current"} = [];
$balance = 0;
foreach my $majsubj ((4, 5, 6, 7, 8, 9)) {
push @{$self->{"current"}}, {
"subj" => acctsubj_title(acctsubj_sn($majsubj)),
"amount1" => "",
"amount2" => "",
};
# non-operating revenue and expenses, other income (expense)
if ($majsubj == 7) {
# non-operating revenue
$sum = 0;
push @{$self->{"current"}}, {
"subj" => acctsubj_title(acctsubj_sn(71)),
"amount1" => "",
"amount2" => "",
};
foreach (grep $$_{"subj"} =~ /^7[1234]/, @subjs) {
push @{$self->{"current"}}, {
"subj" => $$_{"subj"},
"amount1" => $$_{"balance"},
"amount2" => "",
};
$sum += $$_{"balance"};
}
push @{$self->{"current"}}, {
"subj" => C_("Total"),
"amount1" => "",
"amount2" => $sum,
};
$balance += $sum;
# non-operating expenses
$sum = 0;
push @{$self->{"current"}}, {
"subj" => acctsubj_title(acctsubj_sn(75)),
"amount1" => "",
"amount2" => "",
};
foreach (grep $$_{"subj"} =~ /^7[5678]/, @subjs) {
push @{$self->{"current"}}, {
"subj" => $$_{"subj"},
"amount1" => $$_{"balance"},
"amount2" => "",
};
$sum += $$_{"balance"};
}
push @{$self->{"current"}}, {
"subj" => C_("Total"),
"amount1" => "",
"amount2" => $sum,
};
$balance += $sum;
# Other categories
} else {
$sum = 0;
%_ = map { substr($$_{"subj"}, 0, 2) => 1 }
grep $$_{"subj"} =~ /^$majsubj/, @subjs;
foreach my $minsubj (sort keys %_) {
push @{$self->{"current"}}, {
"subj" => acctsubj_title(acctsubj_sn($minsubj)),
"amount1" => "",
"amount2" => "",
};
foreach (grep $$_{"subj"} =~ /^$minsubj/, @subjs) {
push @{$self->{"current"}}, {
"subj" => $$_{"subj"},
"amount1" => $$_{"balance"},
"amount2" => "",
};
$sum += $$_{"balance"};
}
}
push @{$self->{"current"}}, {
"subj" => C_("Total"),
"amount1" => "",
"amount2" => $sum,
};
$balance += $sum;
}
# 4 operating revenue
# No balance after operating revenue
if ($majsubj != 4) {
# 5 operating costs
$_ = C_("Gross income") if $majsubj == 5;
# 6 operating expenses
$_ = C_("Operating income") if $majsubj == 6;
# 7 non-operating revenue and expenses, other income (expense)
$_ = C_("Before tax income") if $majsubj == 7;
# 8 income tax expense (or benefit)
$_ = C_("After tax income") if $majsubj == 8;
# 9 nonrecurring gain or loss
$_ = acctsubj_title(acctsubj_sn(ACCTSUBJ_INCOME_CUR))
if $majsubj == 9;
push @{$self->{"current"}}, {
"subj" => $_,
"amount1" => "",
"amount2" => $balance,
};
}
# Put a blank separator record
if ($majsubj != 9) {
push @{$self->{"current"}}, {
"subj" => "",
"amount1" => "",
"amount2" => "",
};
}
}
# The number of rows per page
$self->{"pagesize"} = $self->{"DEFAULT_LIST_SIZE"};
# Paging not in use
$self->{"total"} = scalar(@{$self->{"current"}});
$self->{"lastpage"} = 1;
$self->{"startno"} = 0;
$self->{"endno"} = $self->{"total"} - 1;
# If endno is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Set the columns to be displayed
$self->{"cols"} = [qw(subj amount1 amount2)];
$self->{"listcols"} = [qw(subj amount1 amount2)];
# Done
return $self->{"error"};
}
# colval: Output a list column value
sub colval : method {
local ($_, %_);
my ($self, $col, %row);
($self, $col, %row) = @_;
# Null/no value
return h(t_notset()) if !defined $row{$col};
# The debit and the credit
if ($col eq "subj") {
if ($row{$col} =~ /^\d\d /) {
return "<div class=\"subjlv2\">"
. h_abbr($row{$col}) . "</div>";
} elsif ( $row{$col} =~ /^\d\d\d/
&& substr($row{$col}, 0, 4) ne ACCTSUBJ_INCOME_CUR) {
return "<div class=\"subjlastlv\">"
. h_abbr($row{$col}) . "</div>";
} else {
return h_abbr($row{$col});
}
}
# The amount
if ($col eq "amount1" || $col eq "amount2") {
return "" if $row{$col} eq "";
if ($row{$col} < 0) {
return "<div class=\"amount\"><span class=\"neg\">("
. h_abbr(fmtntamount -$row{$col}) . ")</span></div>";
} else {
return "<div class=\"amount\">"
. h_abbr(fmtntamount $row{$col}) . "</div>";
}
}
# Run the parent method
return $self->SUPER::colval($col, %row);
}
# html_data_download: Display the data download link
sub html_data_download : method {
local ($_, %_);
my ($self, $url, $title);
$self = $_[0];
# No data
return if $self->{"total"} == 0;
# Construct the URL
@_ = qw();
push @_, "list=incmstat";
push @_, $self->{"actrange"};
push @_, "format=csv";
$url = $REQUEST_FILE . "?" . join "&", @_;
$title = h_abbr(C_("Download the data as a CSV file."));
print << "EOT";
<p><a href="$url">$title</a></p>
EOT
return;
}
# html_csv: Return the data as CSV
sub html_csv : method {
local ($_, %_);
my $self;
$self = $_[0];
# Output a header to suggest for download instead of display
$HTTP_HEADERS{"Content-Disposition"} =
"attachment; filename=income_statement.csv";
$CONTENT_TYPE = "text/csv; charset=" . getlang LN_CHARSET;
# The header column
@_ = map((exists ${$self->{"col_labels"}}{$_}? ${$self->{"col_labels"}}{$_}: $_),
@{$self->{"listcols"}});
s/"/""/g foreach @_; # "
print join(",", map "\"$_\"", @_) . "\n";
# The data
foreach my $current (@{$self->{"current"}}) {
@_ = map $$current{$_}, @{$self->{"listcols"}};
foreach (@_) {
$_ = "" if !defined $_;
s/"/""/g; # "
}
print join(",", map "\"$_\"", @_) . "\n";
}
return;
}
# html_liststat: Display the list statistics
sub html_liststat : method {
local ($_, %_);
my $self;
$self = $_[0];
# Print the current time period
if (!$self->{"nodata"}) {
my ($message, $from, $to);
($from, $to) = ($self->{"startdate"}, $self->{"enddate"});
$message = h(C_("From [_1] to [_2].", $from, $to));
print << "EOT";
<p>$message</p>
EOT
}
return;
}
# html_listprefform: Display a form to change the list preference
# Make it a null function
sub html_listprefform : method {}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my ($self, $total);
$self = $_[0];
$total = $self->{"total"};
# Inherit the empty list statistics message
return $self->SUPER::liststat_message if $self->{"total"} == 0;
return C_("[*,_1,accounting subject].", $self->{"total"} - 1);
}
return 1;

322
lib/perl5/Selima/List/Accounting/Reports/Journal.pm Normal file
View File

@@ -0,0 +1,322 @@
# Selima Website Content Management System
# Journal.pm: The journal accounting report.
# Copyright (c) 2007-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: 2007-09-29
package Selima::List::Accounting::Reports::Journal;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Accounting::Reports);
use POSIX qw(floor);
use URI::Escape qw(uri_escape);
use Selima::Accounting;
use Selima::CommText;
use Selima::DataVars qw($DBH :l10n :lninfo :output :requri);
use Selima::GetLang;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::UserPref;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = C_("Journal");
# The list type
$self->{"type"} = "journal";
if (@ALL_LINGUAS == 1) {
$self->{"view"} = "acctrep_search_list";
} else {
$self->{"view"} = "acctrep_search_list_" . getlang(LN_DATABASE);
}
# Columns should be displayed in a reversed order
$self->{"reverse"} = 1;
# Column labels
$self->col_labels(
"trxno" => C_("Transaction Number"),
"note" => C_("Note"),
);
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my ($self, $cols, $table, $where, $orderby, $limit, $sth, $sql, $error);
my (@debits, @credits);
$self = $_[0];
# Fetched before
return $self->{"error"} if $self->{"fetched"};
$self->{"fetched"} = 1;
# Initialize the error status
$self->{"error"} = undef;
$self->{"total"} = undef;
# No need to run if there is no data at all
if (exists $self->{"nodata"} && $self->{"nodata"}) {
$self->{"total"} = 0;
return;
}
# See if we need to use views or not.
# Views make things much faster and easier, but some DBMS has no views.
# *MySQL has no views*
if ($self->{"useview"}) {
($cols, $table, $where, $orderby, $limit) = $self->select_with_view;
} else {
($cols, $table, $where, $orderby, $limit) = $self->select_without_view;
}
# Fetch everything
$self->{"select"} = sprintf "SELECT %s FROM %s%s%s%s;\n",
$cols, $table, $where, $orderby, $limit;
$sql = $self->{"select"};
$sth = $DBH->prepare($sql);
$sth->execute;
$self->{"current"} = [];
push @{$self->{"current"}}, $_
while defined($_ = $sth->fetchrow_hashref);
undef $sth;
# Set the selection column
unshift @{$self->{"cols"}}, "_sel";
$$_{"_sel"} = 1 foreach @{$self->{"current"}};
# Find the carry-over balance
@_ = qw();
push @_, "acctsubj.code AS code";
push @_, "sum(CASE WHEN acctrecs.credit THEN -amount ELSE amount END) AS sum";
$sql = "SELECT " . join(", ", @_) . " FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE (acctsubj.code LIKE '1%'"
. " OR acctsubj.code LIKE '2%'"
. " OR acctsubj.code LIKE '3%')"
. " AND acctsubj.code != " . $DBH->quote(ACCTSUBJ_INCOME_ACUM)
. " AND accttrx.date<" . $DBH->quote($self->{"startdate"})
. " GROUP BY acctsubj.code"
. " ORDER BY acctsubj.code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
for ($_ = 0, @_ = qw(); $_ < $sth->rows; $_++) {
push @_, {%{$sth->fetchrow_hashref}};
}
undef $sth;
# Create the carry-over transaction
@debits = qw();
@credits = qw();
foreach (@_) {
# Positive balance - from carry-over to account
if ($$_{"sum"} > 0) {
push @debits, {
"_sel" => 0,
"_selurl" => undef,
"date" => $self->{"startdate"},
"trxno" => "",
"subj" => acctsubj_title(acctsubj_sn($$_{"code"})),
"summary" => "",
"debit" => $$_{"sum"},
"credit" => 0,
"note" => C_("Brought forward"),
};
push @credits, {
"_sel" => 0,
"_selurl" => undef,
"date" => $self->{"startdate"},
"trxno" => "",
"subj" => acctsubj_title(acctsubj_sn(ACCTSUBJ_INCOME_ACUM)),
"summary" => acctsubj_title(acctsubj_sn($$_{"code"})),
"debit" => 0,
"credit" => $$_{"sum"},
"note" => C_("Brought forward"),
};
# Negative balance - from account to carry-over
} elsif ($$_{"sum"} < 0) {
push @debits, {
"_sel" => 0,
"_selurl" => undef,
"date" => $self->{"startdate"},
"trxno" => "",
"subj" => acctsubj_title(acctsubj_sn(ACCTSUBJ_INCOME_ACUM)),
"summary" => acctsubj_title(acctsubj_sn($$_{"code"})),
"debit" => -$$_{"sum"},
"credit" => 0,
"note" => C_("Brought forward"),
};
push @credits, {
"_sel" => 0,
"_selurl" => undef,
"date" => $self->{"startdate"},
"trxno" => "",
"subj" => acctsubj_title(acctsubj_sn($$_{"code"})),
"summary" => "",
"debit" => 0,
"credit" => -$$_{"sum"},
"note" => C_("Brought forward"),
};
}
# Skip subjects with zero balances
}
$self->{"current"} = [@debits, @credits, @{$self->{"current"}}];
# The number of rows per page
$_ = userpref("listsize", ref $self);
$self->{"pagesize"} = defined $_? $_: $self->{"DEFAULT_LIST_SIZE"};
# Paging not in use
if (!defined $self->{"pagesize"}) {
$self->{"total"} = scalar(@{$self->{"current"}});
$self->{"lastpage"} = 1;
$self->{"startno"} = 0;
$self->{"endno"} = $self->{"total"} - 1;
# If endno is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Done
return $self->{"error"};
}
# Obtain the total number
$self->{"total"} = scalar @{$self->{"current"}};
$self->{"lastpage"} = floor(($self->{"total"} - 1) / $self->{"pagesize"}) + 1;
# If last page is 0 (when total is 0), set to page 1
$self->{"lastpage"} = 1 if $self->{"lastpage"} < 1;
# Check the page number
# Show the last page by default, but not reverse the number colume
$_ = $self->{"reverse"};
$self->{"reverse"} = 1;
$error = $self->check_pageno;
$self->{"reverse"} = $_;
$self->{"error"} = $error if defined $error && !defined $self->{"error"};
# Calculate the start and end record number
$self->{"startno"} = ($self->{"pageno"} - 1) * $self->{"pagesize"};
$self->{"endno"} = $self->{"pageno"} * $self->{"pagesize"} - 1;
# If there is not enough remaining records, set to the last one
$self->{"endno"} = $self->{"total"} - 1
if $self->{"endno"} > $self->{"total"} - 1;
# If the last record is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Obtain everything in this page
$self->{"current"} = [ @{$self->{"current"}}[$self->{"startno"}...$self->{"endno"}] ]
if !$self->{"iscsv"};
# Set the columns to be displayed
$self->{"listcols"} = [qw(date trxno subj summary debit credit note)];
# Done
return $self->{"error"};
}
# colval: Output a list column value
sub colval : method {
local ($_, %_);
my ($self, $col, %row);
($self, $col, %row) = @_;
# The subject
if ($col eq "subj") {
if ($row{"credit"} > 0) {
return "<div class=\"crdtsubj\">"
. h_abbr($row{$col}) . "</div>";
} else {
return h_abbr($row{$col});
}
}
# The summary
if ($col eq "summary") {
return "" if !defined $row{$col};
return h_abbr($row{$col});
}
# Null/no value
return h(t_notset()) if !defined $row{$col};
# Run the parent method
return $self->SUPER::colval($col, %row);
}
# html_data_download: Display the data download link
sub html_data_download : method {
local ($_, %_);
my ($self, $url, $title);
$self = $_[0];
# No data
return if $self->{"total"} == 0;
# Construct the URL
@_ = qw();
push @_, "list=journal";
push @_, $self->{"actrange"};
push @_, "format=csv";
$url = $REQUEST_FILE . "?" . join "&", @_;
$title = h_abbr(C_("Download the data as a CSV file."));
print << "EOT";
<p><a href="$url">$title</a></p>
EOT
return;
}
# html_csv: Return the data as CSV
sub html_csv : method {
local ($_, %_);
my $self;
$self = $_[0];
# Output a header to suggest for download instead of display
$HTTP_HEADERS{"Content-Disposition"} =
"attachment; filename=journal.csv";
$CONTENT_TYPE = "text/csv; charset=" . getlang LN_CHARSET;
# The header column
@_ = map((exists ${$self->{"col_labels"}}{$_}? ${$self->{"col_labels"}}{$_}: $_),
@{$self->{"listcols"}});
s/"/""/g foreach @_; # "
print join(",", map "\"$_\"", @_) . "\n";
# The data
foreach my $current (@{$self->{"current"}}) {
@_ = map $$current{$_}, @{$self->{"listcols"}};
foreach (@_) {
$_ = "" if !defined $_;
s/"/""/g; # "
}
print join(",", map "\"$_\"", @_) . "\n";
}
return;
}
# html_list: List the items
sub html_list : method {
local ($_, %_);
my $self;
$self = $_[0];
$self->{"reverse"} = 0;
# Run the parent method
$self->SUPER::html_list;
$self->{"reverse"} = 1;
return;
}
return 1;

412
lib/perl5/Selima/List/Accounting/Reports/Ledger.pm Normal file
View File

@@ -0,0 +1,412 @@
# Selima Website Content Management System
# Ledger.pm: The ledger accounting report.
# Copyright (c) 2007-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: 2007-09-24
package Selima::List::Accounting::Reports::Ledger;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Accounting::Reports);
use POSIX qw(floor);
use Text::Capitalize qw(capitalize_title);
use URI::Escape qw(uri_escape);
use Selima::Accounting;
use Selima::CommText;
use Selima::DataVars qw($DBH :l10n :lninfo :output :requri);
use Selima::Format;
use Selima::GetLang;
use Selima::LnInfo;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::UserPref;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The list type
$self->{"type"} = "ldgr";
if (@ALL_LINGUAS == 1) {
$self->{"view"} = "acctrep_ledger_list";
} else {
$self->{"view"} = "acctrep_ledger_list_" . getlang(LN_DATABASE);
}
# The subject
$self->{"subj"} = $self->{"FORM"}->param("subj");
$self->{"subj"} = ACCTSUBJ_CASH if !defined $self->{"subj"};
# The page title
$_ = acctsubj_title(acctsubj_sn($self->{"subj"}));
s/^\d+ //;
$self->{"title"} = capitalize_title(C_("Ledger - [_1]", $_));
$self->{"title"} =~ s/ - /\x{2014}/;
# Column labels
$self->col_labels(
);
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my ($self, $cols, $table, $where, $orderby, $limit, $sth, $sql, $error);
my ($balance, @carryover);
$self = $_[0];
# Fetched before
return $self->{"error"} if $self->{"fetched"};
$self->{"fetched"} = 1;
# Initialize the error status
$self->{"error"} = undef;
$self->{"total"} = undef;
# No need to run if there is no data at all
if (exists $self->{"nodata"} && $self->{"nodata"}) {
$self->{"total"} = 0;
return;
}
# See if we need to use views or not.
# Views make things much faster and easier, but some DBMS has no views.
# *MySQL has no views*
if ($self->{"useview"}) {
($cols, $table, $where, $orderby, $limit) = $self->select_with_view;
} else {
($cols, $table, $where, $orderby, $limit) = $self->select_without_view;
}
# Fetch everything
$self->{"select"} = sprintf "SELECT %s FROM %s%s%s%s;\n",
$cols, $table, $where, $orderby, $limit;
$sql = $self->{"select"};
$sth = $DBH->prepare($sql);
$sth->execute;
$self->{"current"} = [];
push @{$self->{"current"}}, $_
while defined($_ = $sth->fetchrow_hashref);
undef $sth;
# Find the carry-over records
if ($self->{"subj"} =~ /^[123]/) {
@_ = qw();
push @_, "acctsubj.code AS code";
push @_, "sum(CASE WHEN acctrecs.credit THEN -amount ELSE amount END) AS sum";
$sql = "SELECT " . join(", ", @_) . " FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE acctsubj.code LIKE " . $DBH->strcat($DBH->quote($self->{"subj"}), "'%'")
. " AND accttrx.date<" . $DBH->quote($self->{"startdate"})
. " GROUP BY acctsubj.code"
. " ORDER BY acctsubj.code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
for ($_ = 0, @_ = qw(); $_ < $sth->rows; $_++) {
push @_, {%{$sth->fetchrow_hashref}};
}
undef $sth;
# Create the carry over transaction
@carryover = qw();
foreach (@_) {
# Positive balance - from carry-over to account
if ($$_{"sum"} > 0) {
push @carryover, {
"_sel" => 0,
"_selurl" => undef,
"_subj" => $self->{"subj"},
"_date" => $self->{"startdate"},
"date" => $self->{"startdate"},
"subj" => acctsubj_title(acctsubj_sn($$_{"code"})),
"summary" => C_("Brought forward"),
"debit" => $$_{"sum"},
"credit" => 0,
"balance" => 0,
};
# Negative balance - from account to carry-over
} elsif ($$_{"sum"} < 0) {
push @carryover, {
"_sel" => 0,
"_selurl" => undef,
"_subj" => $self->{"subj"},
"_date" => $self->{"startdate"},
"date" => $self->{"startdate"},
"subj" => acctsubj_title(acctsubj_sn($$_{"code"})),
"summary" => C_("Brought forward"),
"debit" => 0,
"credit" => -$$_{"sum"},
"balance" => 0,
};
}
# Skip subjects with zero balances
}
$self->{"current"} = [@carryover, @{$self->{"current"}}];
}
# Calculate the balance
$balance = 0;
foreach (@{$self->{"current"}}) {
$balance = $balance + $$_{"debit"} - $$_{"credit"};
$$_{"balance"} = $balance;
}
# The number of rows per page
$_ = userpref("listsize", ref $self);
$self->{"pagesize"} = defined $_? $_: $self->{"DEFAULT_LIST_SIZE"};
# Paging not in use
if (!defined $self->{"pagesize"}) {
$self->{"total"} = scalar(@{$self->{"current"}});
$self->{"lastpage"} = 1;
$self->{"startno"} = 0;
$self->{"endno"} = $self->{"total"} - 1;
# If endno is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Done
return $self->{"error"};
}
# Obtain the total number
$self->{"total"} = scalar @{$self->{"current"}};
$self->{"lastpage"} = floor(($self->{"total"} - 1) / $self->{"pagesize"}) + 1;
# If last page is 0 (when total is 0), set to page 1
$self->{"lastpage"} = 1 if $self->{"lastpage"} < 1;
# Check the page number
# Show the last page by default, but not reverse the number colume
$_ = $self->{"reverse"};
$self->{"reverse"} = 1;
$error = $self->check_pageno;
$self->{"reverse"} = $_;
$self->{"error"} = $error if defined $error && !defined $self->{"error"};
# Calculate the start and end record number
$self->{"startno"} = ($self->{"pageno"} - 1) * $self->{"pagesize"};
$self->{"endno"} = $self->{"pageno"} * $self->{"pagesize"} - 1;
# If there is not enough remaining records, set to the last one
$self->{"endno"} = $self->{"total"} - 1
if $self->{"endno"} > $self->{"total"} - 1;
# If the last record is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Obtain everything in this page
$self->{"current"} = [ @{$self->{"current"}}[$self->{"startno"}...$self->{"endno"}] ]
if !$self->{"iscsv"};
# Set the columns to be displayed
$self->{"listcols"} = [qw(date subj summary debit credit balance)];
# Done
return $self->{"error"};
}
# page_param: Obtain page parameters
sub page_param : method {
local ($_, %_);
my ($self, $rev, $r);
$self = $_[0];
$rev = $self->{"reverse"};
$self->{"reverse"} = 1;
# Run the parent method
$r = $self->SUPER::page_param;
$self->{"reverse"} = $rev;
return $r;
}
# colval: Output a list column value
sub colval : method {
local ($_, %_);
my ($self, $col, %row);
($self, $col, %row) = @_;
# Null/no value
return h(t_notset()) if !defined $row{$col};
# The balance
if ($col eq "balance") {
return "" if $row{$col} eq "";
if ($row{$col} > 0) {
return "<div class=\"amount\">" . h_abbr(C_("Debit")) . " "
. h_abbr(fmtntamount $row{$col}) . "</div>";
} elsif ($row{$col} < 0) {
return "<div class=\"amount\"><span class=\"neg\">"
. h_abbr(C_("Credit")) . " "
. h_abbr(fmtntamount -$row{$col}) . "</span></div>";
} else {
return "<div class=\"amount\">-</div>";
}
}
# Run the parent method
return $self->SUPER::colval($col, %row);
}
# pre_filter: Set the pre-defined filter
sub pre_filter : method {
local ($_, %_);
my $self;
$self = $_[0];
@_ = qw();
push @_, "_subj LIKE '" . $self->{"subj"} . "%'";
push @_, $_ if defined($_ = $self->SUPER::pre_filter);
return undef if @_ == 0;
return join " AND ", @_;
}
# html_select_subject: Display the subject search box
sub html_select_subject : method {
local ($_, %_);
my ($self, $label, @subjs);
my ($sql, $sth, $count, $row, $thiscol, $defcol);
$self = $_[0];
# The subject
$label = h_abbr(C_("Accounting subject:"));
# Obtain all the using subjects
$sql = "SELECT acctsubj.code FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " GROUP BY acctsubj.code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @_ = qw(); $i < $count; $i++) {
$row = $sth->fetchrow_hashref;
push @_, $$row{"code"};
}
undef $sth;
%_ = map { $_ => 1 } @_;
# Add all of their parents
foreach (keys %_) {
$_{$_} = 1 while s/.$//;
}
delete $_{""};
@_ = qw();
push @_, "code AS value";
if (@ALL_LINGUAS == 1) {
push @_, $DBH->strcat("code", "' '", "title")
. " AS content";
} else {
$thiscol = "title_" . getlang LN_DATABASE;
if (getlang eq $DEFAULT_LANG) {
push @_, $DBH->strcat("code", "' '", $thiscol)
. " AS content";
} else {
$defcol = "title_" . ln($DEFAULT_LANG, LN_DATABASE);
push @_, $DBH->strcat("code", "' '", "COALESCE($thiscol, $defcol)")
. " AS content";
}
}
$sql = "SELECT " . join(", ", @_) . " FROM acctsubj"
. " WHERE " . join(" OR ", map "code=" . $DBH->quote($_), sort keys %_)
. " ORDER BY code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @subjs = qw(); $i < $count; $i++) {
push @subjs, {%{$sth->fetchrow_hashref}};
}
undef $sth;
# Display the form
print << "EOT";
<p>$label
<select name="subj">
EOT
foreach (@subjs) {
my ($val, $content, $selected);
$val = h($$_{"value"});
$content = h($$_{"content"});
$selected = defined $self->{"subj"} && $self->{"subj"} eq $$_{"value"}?
" selected=\"selected\"": "";
print << "EOT";
<option value="$val"$selected>$content</option>
EOT
}
print << "EOT";
</select>
</p>
EOT
return;
}
# html_data_download: Display the data download link
sub html_data_download : method {
local ($_, %_);
my ($self, $url, $title);
$self = $_[0];
# No data
return if $self->{"total"} == 0;
# Construct the URL
@_ = qw();
push @_, "list=ldgr";
push @_, "subj=" . uri_escape($self->{"subj"});
push @_, $self->{"actrange"};
push @_, "format=csv";
$url = $REQUEST_FILE . "?" . join "&", @_;
$title = h_abbr(C_("Download the data as a CSV file."));
print << "EOT";
<p><a href="$url">$title</a></p>
EOT
return;
}
# html_csv: Return the data as CSV
sub html_csv : method {
local ($_, %_);
my $self;
$self = $_[0];
# Output a header to suggest for download instead of display
$HTTP_HEADERS{"Content-Disposition"} =
"attachment; filename=ledger.csv";
$CONTENT_TYPE = "text/csv; charset=" . getlang LN_CHARSET;
# The header column
@_ = map((exists ${$self->{"col_labels"}}{$_}? ${$self->{"col_labels"}}{$_}: $_),
@{$self->{"listcols"}});
s/"/""/g foreach @_; # "
print join(",", map "\"$_\"", @_) . "\n";
# The data
foreach my $current (@{$self->{"current"}}) {
@_ = map $$current{$_}, @{$self->{"listcols"}};
foreach (@_) {
$_ = "" if !defined $_;
s/"/""/g; # "
}
print join(",", map "\"$_\"", @_) . "\n";
}
return;
}
# html_pagebar: Display a page navigation bar
sub html_pagebar : method {
local ($_, %_);
my ($self, $rev, $r);
$self = $_[0];
$rev = $self->{"reverse"};
$self->{"reverse"} = 1;
# Run the parent method
$r = $self->SUPER::html_pagebar;
$self->{"reverse"} = $rev;
return $r;
}
return 1;

422
lib/perl5/Selima/List/Accounting/Reports/Ledger/Summary.pm Normal file
View File

@@ -0,0 +1,422 @@
# Selima Website Content Management System
# Summary.pm: The summary ledger accounting report.
# Copyright (c) 2007-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: 2007-09-30
package Selima::List::Accounting::Reports::Ledger::Summary;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Accounting::Reports);
use POSIX qw(floor);
use Text::Capitalize qw(capitalize_title);
use URI::Escape qw(uri_escape);
use Selima::Accounting;
use Selima::CommText;
use Selima::DataVars qw($DBH :env :l10n :lninfo :output :requri);
use Selima::Format;
use Selima::GetLang;
use Selima::LnInfo;
use Selima::MarkAbbr;
use Selima::ShortCut;
use Selima::UserPref;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class, @cols, $sql);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The list type
$self->{"type"} = "ldgrsum";
# The subject
$self->{"subj"} = $self->{"FORM"}->param("subj");
$self->{"subj"} = ACCTSUBJ_CASH if !defined $self->{"subj"};
# The page title
$_ = acctsubj_title(acctsubj_sn($self->{"subj"}));
s/^\d+ //;
$self->{"title"} = capitalize_title(C_("Ledger Summary - [_1]", $_));
$self->{"title"} =~ s/ - /\x{2014}/;
# Construct the view
$self->{"view"} = "acctrep_ledger_summary_list";
$self->{"noselect"} = 1;
@_ = qw();
push @_, "list=ldgr";
push @_, "subj=" . uri_escape($self->{"subj"});
push @_, "r=m";
push @_, "m=";
$_ = $REQUEST_FILE . "?" . join "&", @_;
@cols = qw();
push @cols, $DBH->strcat($DBH->quote($_),
"lpad(cast(extract(year FROM date) AS text), 4, '0')",
"'-'", "lpad(cast(extract(month FROM date) AS text), 2, '0')") . " AS _viewurl";
push @cols, $DBH->strcat("lpad(cast(extract(year FROM date) AS text), 4, '0')",
"'-'", "lpad(cast(extract(month FROM date) AS text), 2, '0')") . " AS month";
push @cols, "acctsum_debit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer),"
. " " . $DBH->quote($self->{"subj"}) . ") AS debit";
push @cols, "acctsum_credit(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), "
. " " . $DBH->quote($self->{"subj"}) . ") AS credit";
push @cols, "acctsum_balance(cast(extract(year FROM date) AS integer),"
. " cast(extract(month FROM date) AS integer), "
. " " . $DBH->quote($self->{"subj"}) . ") AS balance";
$sql = "CREATE TEMPORARY VIEW " . $self->{"view"} . " AS"
. " SELECT " . join(", ", @cols)
. " FROM accttrx"
. " GROUP BY extract(year FROM date), extract(month FROM date)"
. " ORDER BY extract(year FROM date), extract(month FROM date);\n";
$DBH->do($sql);
# Column labels
$self->col_labels(
);
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my ($self, $cols, $table, $where, $orderby, $limit, $sth, $sql, $error);
my ($sumdebit, $sumcredit);
$self = $_[0];
# Fetched before
return $self->{"error"} if $self->{"fetched"};
$self->{"fetched"} = 1;
# Initialize the error status
$self->{"error"} = undef;
$self->{"total"} = undef;
# No need to run if there is no data at all
if (exists $self->{"nodata"} && $self->{"nodata"}) {
$self->{"total"} = 0;
return;
}
# See if we need to use views or not.
# Views make things much faster and easier, but some DBMS has no views.
# *MySQL has no views*
if ($self->{"useview"}) {
($cols, $table, $where, $orderby, $limit) = $self->select_with_view;
} else {
($cols, $table, $where, $orderby, $limit) = $self->select_without_view;
}
# Fetch everything
$self->{"select"} = sprintf "SELECT %s FROM %s%s%s%s;\n",
$cols, $table, $where, $orderby, $limit;
$sql = $self->{"select"};
$sth = $DBH->prepare($sql);
$sth->execute;
$self->{"current"} = [];
push @{$self->{"current"}}, $_
while defined($_ = $sth->fetchrow_hashref);
undef $sth;
# Do calculation on each record
($sumdebit, $sumcredit) = (0, 0);
foreach (@{$self->{"current"}}) {
$$_{"balance"} = 0 if !defined $$_{"balance"};
$sumdebit += $$_{"debit"};
$sumcredit += $$_{"credit"};
}
# Remove the starting and ending empty records
@_ = @{$self->{"current"}};
shift @_ while @_ > 0 && ${$_[0]}{"credit"} == 0 && ${$_[0]}{"debit"} == 0;
pop @_ while @_ > 0 && ${$_[$#_]}{"credit"} == 0 && ${$_[$#_]}{"debit"} == 0;
$self->{"current"} = [@_];
# Append the total record
if (@{$self->{"current"}} > 0) {
@_ = qw();
push @_, "list=ldgr";
push @_, "subj=" . uri_escape($self->{"subj"});
push @_, "r=a";
push @{$self->{"current"}}, {
"_viewurl" => $REQUEST_FILE . "?" . join("&", @_),
"month" => C_("Total"),
"debit" => $sumdebit,
"credit" => $sumcredit,
"balance" => ${(reverse @{$self->{"current"}})[0]}{"balance"},
};
}
# The number of rows per page
$_ = userpref("listsize", ref $self);
$self->{"pagesize"} = defined $_? $_: $self->{"DEFAULT_LIST_SIZE"};
# Paging not in use
if (!defined $self->{"pagesize"}) {
$self->{"total"} = scalar(@{$self->{"current"}});
$self->{"lastpage"} = 1;
$self->{"startno"} = 0;
$self->{"endno"} = $self->{"total"} - 1;
# If endno is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Done
return $self->{"error"};
}
# Obtain the total number
$self->{"total"} = scalar @{$self->{"current"}};
$self->{"lastpage"} = floor(($self->{"total"} - 1) / $self->{"pagesize"}) + 1;
# If last page is 0 (when total is 0), set to page 1
$self->{"lastpage"} = 1 if $self->{"lastpage"} < 1;
# Check the page number
# Show the last page by default, but not reverse the number colume
$_ = $self->{"reverse"};
$self->{"reverse"} = 1;
$error = $self->check_pageno;
$self->{"reverse"} = $_;
$self->{"error"} = $error if defined $error && !defined $self->{"error"};
# Calculate the start and end record number
$self->{"startno"} = ($self->{"pageno"} - 1) * $self->{"pagesize"};
$self->{"endno"} = $self->{"pageno"} * $self->{"pagesize"} - 1;
# If there is not enough remaining records, set to the last one
$self->{"endno"} = $self->{"total"} - 1
if $self->{"endno"} > $self->{"total"} - 1;
# If the last record is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Obtain everything in this page
$self->{"current"} = [ @{$self->{"current"}}[$self->{"startno"}...$self->{"endno"}] ]
if !$self->{"iscsv"};
# Set the columns to be displayed
$self->{"cols"} = [qw(_viewurl month debit credit balance)];
$self->{"listcols"} = [qw(month debit credit balance)];
# Done
return $self->{"error"};
}
# page_param: Obtain page parameters
sub page_param : method {
local ($_, %_);
my ($self, $rev, $r);
$self = $_[0];
$rev = $self->{"reverse"};
$self->{"reverse"} = 1;
# Run the parent method
$r = $self->SUPER::page_param;
$self->{"reverse"} = $rev;
return $r;
}
# colval: Output a list column value
sub colval : method {
local ($_, %_);
my ($self, $col, %row);
($self, $col, %row) = @_;
# Null/no value
return h(t_notset()) if !defined $row{$col};
# The balance
if ($col eq "balance") {
if ($row{$col} > 0) {
return "<div class=\"amount\">" . h_abbr(C_("Debit")) . " "
. h_abbr(fmtntamount $row{$col}) . "</div>";
} elsif ($row{$col} < 0) {
return "<div class=\"amount\"><span class=\"neg\">"
. h_abbr(C_("Credit")) . " "
. h_abbr(fmtntamount -$row{$col}) . "</span></div>";
} else {
return "<div class=\"amount\">-</div>";
}
}
# Run the parent method
return $self->SUPER::colval($col, %row);
}
# pre_filter: Set the pre-defined filter
# Make it a null function
sub pre_filter : method { }
# html_report_query: Display the report query box
sub html_report_query : method {
local ($_, %_);
my ($self, $form, $request_file, $label, $curlist);
$self = $_[0];
$form = $self->{"FORM"};
$request_file = h($REQUEST_FILE);
$label = h_abbr(C_("Query"));
$curlist = h($self->{"type"});
print << "EOT";
<form action="$request_file" method="get" accept-charset="<!--selima:charset-->">
<div class="acctrepquery">
<div><input type="hidden" name="list" value="$curlist" /></div>
EOT
# Display the subject selection if available
$self->html_select_subject if $self->can("html_select_subject");
print << "EOT";
<p><input type="hidden" name="charset" value="<!--selima:charset-->" /><input
type="submit" value="$label" />
</p>
</div>
</form>
EOT
return;
}
# html_select_subject: Display the subject search box
sub html_select_subject : method {
local ($_, %_);
my ($self, $label, @subjs);
my ($sql, $sth, $count, $row, $thiscol, $defcol);
$self = $_[0];
# The subject
$label = h_abbr(C_("Accounting subject:"));
# Obtain all the using subjects
$sql = "SELECT acctsubj.code FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " GROUP BY acctsubj.code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @_ = qw(); $i < $count; $i++) {
$row = $sth->fetchrow_hashref;
push @_, $$row{"code"};
}
undef $sth;
%_ = map { $_ => 1 } @_;
# Add all of their parents
foreach (keys %_) {
$_{$_} = 1 while s/.$//;
}
delete $_{""};
@_ = qw();
push @_, "code AS value";
if (@ALL_LINGUAS == 1) {
push @_, $DBH->strcat("code", "' '", "title")
. " AS content";
} else {
$thiscol = "title_" . getlang LN_DATABASE;
if (getlang eq $DEFAULT_LANG) {
push @_, $DBH->strcat("code", "' '", $thiscol)
. " AS content";
} else {
$defcol = "title_" . ln($DEFAULT_LANG, LN_DATABASE);
push @_, $DBH->strcat("code", "' '", "COALESCE($thiscol, $defcol)")
. " AS content";
}
}
$sql = "SELECT " . join(", ", @_) . " FROM acctsubj"
. " WHERE " . join(" OR ", map "code=" . $DBH->quote($_), sort keys %_)
. " ORDER BY code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$count = $sth->rows;
for (my $i = 0, @subjs = qw(); $i < $count; $i++) {
push @subjs, {%{$sth->fetchrow_hashref}};
}
undef $sth;
# Display the form
print << "EOT";
<p>$label
<select name="subj">
EOT
foreach (@subjs) {
my ($val, $content, $selected);
$val = h($$_{"value"});
$content = h($$_{"content"});
$selected = defined $self->{"subj"} && $self->{"subj"} eq $$_{"value"}?
" selected=\"selected\"": "";
print << "EOT";
<option value="$val"$selected>$content</option>
EOT
}
print << "EOT";
</select>
</p>
EOT
return;
}
# html_data_download: Display the data download link
sub html_data_download : method {
local ($_, %_);
my ($self, $url, $title);
$self = $_[0];
# No data
return if $self->{"total"} == 0;
# Construct the URL
@_ = qw();
push @_, "list=ldgrsum";
push @_, "subj=" . uri_escape($self->{"subj"});
push @_, "format=csv";
$url = $REQUEST_FILE . "?" . join "&", @_;
$title = h_abbr(C_("Download the data as a CSV file."));
print << "EOT";
<p><a href="$url">$title</a></p>
EOT
return;
}
# html_csv: Return the data as CSV
sub html_csv : method {
local ($_, %_);
my $self;
$self = $_[0];
# Output a header to suggest for download instead of display
$HTTP_HEADERS{"Content-Disposition"} =
"attachment; filename=ledger_summary.csv";
$CONTENT_TYPE = "text/csv; charset=" . getlang LN_CHARSET;
# The header column
@_ = map((exists ${$self->{"col_labels"}}{$_}? ${$self->{"col_labels"}}{$_}: $_),
@{$self->{"listcols"}});
s/"/""/g foreach @_; # "
print join(",", map "\"$_\"", @_) . "\n";
# The data
foreach my $current (@{$self->{"current"}}) {
print join(",", map $$current{$_}, @{$self->{"listcols"}}) . "\n";
}
return;
}
# html_pagebar: Display a page navigation bar
sub html_pagebar : method {
local ($_, %_);
my ($self, $rev, $r);
$self = $_[0];
$rev = $self->{"reverse"};
$self->{"reverse"} = 1;
# Run the parent method
$r = $self->SUPER::html_pagebar;
$self->{"reverse"} = $rev;
return $r;
}
return 1;

120
lib/perl5/Selima/List/Accounting/Reports/Search.pm Normal file
View File

@@ -0,0 +1,120 @@
# Selima Website Content Management System
# Search.pm: The accounting data search result list.
# Copyright (c) 2007-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: 2007-09-29
package Selima::List::Accounting::Reports::Search;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Accounting::Reports);
use Selima::DataVars qw(:l10n :lninfo);
use Selima::GetLang;
use Selima::Logging;
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The page title
if (!defined $self->{"query"}) {
$self->{"title"} = C_("Search the Accounting Records");
} else {
$self->{"title"} = C_("Search Result");
}
if (@ALL_LINGUAS == 1) {
$self->{"view"} = "acctrep_search_list";
} else {
$self->{"view"} = "acctrep_search_list_" . getlang(LN_DATABASE);
}
# Column labels
$self->col_labels(
"trxno" => C_("Transaction Number"),
"note" => C_("Note"),
);
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my $self;
$self = $_[0];
# No search specified
if (!defined $self->{"query"}) {
$self->{"total"} = undef;
return $self->{"error"};
}
# Check the query phrase
# Regularize it
$self->{"query"} =~ s/^\s*(.*?)\s*$/$1/;
# Check if it is filled
if ($self->{"query"} eq"") {
$self->{"total"} = undef;
$self->{"error"} = {"msg"=>N_("Please fill in your query.")};
return $self->{"error"};
}
# Run the parent method
$self->SUPER::fetch;
# Set the columns to be displayed
$self->{"listcols"} = [qw(date trxno subj summary debit credit note)];
# Done
return $self->{"error"};
}
# check_pageno: Check the page number
# Default to the last page
sub check_pageno : method {
local ($_, %_);
my ($self, $rev);
$self = $_[0];
$rev = $self->{"reverse"};
$self->{"reverse"} = 1;
# Run the parent method
$self->SUPER::check_pageno;
$self->{"reverse"} = $rev;
return;
}
# pre_filter: Set the pre-defined filter
# Make it a null function
sub pre_filter : method { }
# html_report_query: Display the report query box
# Make it a null function
sub html_report_query : method { }
# html_pagebar: Display a page navigation bar
# The first page needs a page number, because default to the last page
sub html_pagebar : method {
local ($_, %_);
my ($self, $rev, $r);
$self = $_[0];
$rev = $self->{"reverse"};
$self->{"reverse"} = 1;
# Run the parent method
$r = $self->SUPER::html_pagebar;
$self->{"reverse"} = $rev;
return $r;
}
return 1;

268
lib/perl5/Selima/List/Accounting/Reports/TriBlnc.pm Normal file
View File

@@ -0,0 +1,268 @@
# Selima Website Content Management System
# TriBlnc.pm: The trial balance accounting report.
# Copyright (c) 2007-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: 2007-09-29
package Selima::List::Accounting::Reports::TriBlnc;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Accounting::Reports);
use Selima::Accounting;
use Selima::CommText;
use Selima::DataVars qw($DBH :l10n :lninfo :output :requri);
use Selima::GetLang;
use Selima::LnInfo;
use Selima::MarkAbbr;
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = C_("Trial Balance");
# The list type
$self->{"type"} = "tb";
# The default number of rows per page
$self->{"DEFAULT_LIST_SIZE"} = undef;
$self->{"noselect"} = 1;
# Column labels
$self->col_labels(
);
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my ($self, @cols, $title, $sth, $sql, $error);
$self = $_[0];
# Fetched before
return $self->{"error"} if $self->{"fetched"};
$self->{"fetched"} = 1;
# Initialize the error status
$self->{"error"} = undef;
$self->{"total"} = undef;
# Construct the SQL query statement
# Obtain the period once
$self->sql_filter;
@cols = qw();
if (@ALL_LINGUAS == 1) {
$title = "acctsubj.title";
} else {
my ($lndb, $lndbdef);
$lndb = getlang LN_DATABASE;
if (getlang eq $DEFAULT_LANG) {
$title = "acctsubj.title_$lndb";
} else {
$lndbdef = ln $DEFAULT_LANG, LN_DATABASE;
$title = "COALESCE(acctsubj.title_$lndb, acctsubj.title_$lndbdef)";
}
}
push @cols, "acctsubj.code AS code";
push @cols, $DBH->strcat("acctsubj.code", "' '", $title) . " AS subj";
push @cols, "sum(CASE WHEN acctrecs.credit THEN -acctrecs.amount ELSE acctrecs.amount END)"
. " AS balance";
$self->{"current"} = [];
# The real accounts
$sql = "SELECT " . join(", ", @cols)
. " FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE date<=" . $DBH->quote($self->{"enddate"})
. " AND (acctsubj.code LIKE '1%'"
. " OR acctsubj.code LIKE '2%'"
. " OR acctsubj.code LIKE '3%')"
. " GROUP BY acctsubj.code, $title"
. " ORDER BY acctsubj.code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
push @{$self->{"current"}}, $_
while defined($_ = $sth->fetchrow_hashref);
undef $sth;
# The nominal accounts
$sql = "SELECT " . join(", ", @cols)
. " FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE date>=" . $DBH->quote($self->{"startdate"})
. " AND date<=" . $DBH->quote($self->{"enddate"})
. " AND NOT (acctsubj.code LIKE '1%'"
. " OR acctsubj.code LIKE '2%'"
. " OR acctsubj.code LIKE '3%')"
. " GROUP BY acctsubj.code, $title"
. " ORDER BY acctsubj.code;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
push @{$self->{"current"}}, $_
while defined($_ = $sth->fetchrow_hashref);
undef $sth;
# Obtain the carry-over record of assets/liabilities
$_ = "sum(CASE WHEN acctrecs.credit THEN -acctrecs.amount ELSE acctrecs.amount END)"
. " AS balance";
$sql = "SELECT $_ FROM acctrecs"
. " LEFT JOIN acctsubj ON acctrecs.subj=acctsubj.sn"
. " LEFT JOIN accttrx ON acctrecs.trx=accttrx.sn"
. " WHERE (acctsubj.code LIKE '1%'"
. " OR acctsubj.code LIKE '2%'"
. " OR acctsubj.code LIKE '3%')"
. " AND accttrx.date<" . $DBH->quote($self->{"startdate"}) . ";\n";
$sth = $DBH->prepare($sql);
$sth->execute;
$_ = $sth->fetchrow_hashref;
undef $sth;
if (defined $$_{"balance"}) {
push @{$self->{"current"}}, {
"subj" => acctsubj_title(acctsubj_sn(ACCTSUBJ_INCOME_ACUM)),
"balance" => -$$_{"balance"},
};
}
# Sort by the subject
$self->{"current"} = [ sort { $$a{"subj"} cmp $$b{"subj"} } @{$self->{"current"}} ];
# Set the debit and credit amount
if (@{$self->{"current"}} > 0) {
my ($sumdebit, $sumcredit, $viewurl);
($sumdebit, $sumcredit) = (0, 0);
@_ = qw();
push @_, "list=ldgr";
push @_, "subj=%s";
push @_, $self->{"actrange"};
$viewurl = $REQUEST_FILE . "?" . join "&", @_;
foreach (@{$self->{"current"}}) {
$$_{"_viewurl"} = sprintf $viewurl, $$_{"code"};
delete $$_{"code"};
if ($$_{"balance"} > 0) {
$$_{"debit"} = $$_{"balance"};
$$_{"credit"} = 0;
$sumdebit += $$_{"debit"};
} elsif ($$_{"balance"} < 0) {
$$_{"debit"} = 0;
$$_{"credit"} = -$$_{"balance"};
$sumcredit += $$_{"credit"};
} else {
$$_{"debit"} = 0;
$$_{"credit"} = 0;
}
delete $_{"balance"};
}
# Append the total record
if (@{$self->{"current"}} > 0) {
push @{$self->{"current"}}, {
"_viewurl" => undef,
"subj" => C_("Total"),
"debit" => $sumdebit,
"credit" => $sumcredit,
};
}
}
# The number of rows per page
$self->{"pagesize"} = $self->{"DEFAULT_LIST_SIZE"};
# Paging not in use
$self->{"total"} = scalar(@{$self->{"current"}});
$self->{"lastpage"} = 1;
$self->{"startno"} = 0;
$self->{"endno"} = $self->{"total"} - 1;
# If endno is -1 (when total is 0), set to 0
$self->{"endno"} = 0 if $self->{"endno"} < 0;
# Set the columns to be displayed
$self->{"cols"} = [qw(_viewurl subj debit credit)];
$self->{"listcols"} = [qw(subj debit credit)];
# Done
return $self->{"error"};
}
# html_data_download: Display the data download link
sub html_data_download : method {
local ($_, %_);
my ($self, $url, $title);
$self = $_[0];
# No data
return if $self->{"total"} == 0;
# Construct the URL
@_ = qw();
push @_, "list=tb";
push @_, $self->{"actrange"};
push @_, "format=csv";
$url = $REQUEST_FILE . "?" . join "&", @_;
$title = h_abbr(C_("Download the data as a CSV file."));
print << "EOT";
<p><a href="$url">$title</a></p>
EOT
return;
}
# html_csv: Return the data as CSV
sub html_csv : method {
local ($_, %_);
my $self;
$self = $_[0];
# Output a header to suggest for download instead of display
$HTTP_HEADERS{"Content-Disposition"} =
"attachment; filename=trial_balance.csv";
$CONTENT_TYPE = "text/csv; charset=" . getlang LN_CHARSET;
# The header column
@_ = map((exists ${$self->{"col_labels"}}{$_}? ${$self->{"col_labels"}}{$_}: $_),
@{$self->{"listcols"}});
s/"/""/g foreach @_; # "
print join(",", map "\"$_\"", @_) . "\n";
# The data
foreach my $current (@{$self->{"current"}}) {
@_ = map $$current{$_}, @{$self->{"listcols"}};
foreach (@_) {
$_ = "" if !defined $_;
s/"/""/g; # "
}
print join(",", map "\"$_\"", @_) . "\n";
}
return;
}
# html_listprefform: Display a form to change the list preference
# Make it a null function
sub html_listprefform : method {}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my ($self, $total);
$self = $_[0];
$total = $self->{"total"};
# Inherit the empty list statistics message
return $self->SUPER::liststat_message if $self->{"total"} == 0;
return C_("[*,_1,accounting subject].", $self->{"total"} - 1);
}
return 1;

95
lib/perl5/Selima/List/Accounting/Subjects.pm Normal file
View File

@@ -0,0 +1,95 @@
# Selima Website Content Management System
# Subjects.pm: The accounting subject list.
# Copyright (c) 2007-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: 2007-08-23
package Selima::List::Accounting::Subjects;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$_[1] = "acctsubj" if !defined $_[1];
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = $self->{"is_called_form"}?
C_("Select an Accounting Subject"):
C_("Manage Accounting Subjects");
# The default sort order
$self->{"DEFAULT_SORTBY"} = "code";
# Column labels
$self->col_labels(
"parent" => C_("Parent subject"),
"code" => C_("Code"),
);
return $self;
}
# html_newlink: Display a link to add a new item
sub html_newlink : method {
# Run the parent method
return $_[0]->SUPER::html_newlink(C_("Add a new accounting subject."));
}
# html_search: Display the search box
sub html_search : method {
# Run the parent method
return $_[0]->SUPER::html_search(C_("Search for an accounting subject:"));
}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my $self;
$self = $_[0];
# No record to list
if ($self->{"total"} == 0) {
# Inherit the empty list statistics message
return $self->SUPER::liststat_message;
# Fit in one page
} elsif ($self->{"total"} <= $self->{"pagesize"}) {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,accounting subject].", $self->{"total"});
# List result
} else {
return C_("[*,_1,accounting subject].", $self->{"total"});
}
# More than one page
} else {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,accounting subject], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
# List result
} else {
return C_("[*,_1,accounting subject], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
}
}
}
return 1;

45
lib/perl5/Selima/List/Accounting/Subjects/LastLv.pm Normal file
View File

@@ -0,0 +1,45 @@
# Selima Website Content Management System
# LastLv.pm: The last-level accounting subject list.
# Copyright (c) 2007-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: 2007-09-22
package Selima::List::Accounting::Subjects::LastLv;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Accounting::Subjects);
use Selima::DataVars qw(:l10n :lninfo);
use Selima::GetLang;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$_[1] = "acctsubj" if !defined $_[1];
$self = $class->SUPER::new(@_);
if (@ALL_LINGUAS == 1) {
$self->{"view"} = "acctsubj_lastlv_list";
} else {
$self->{"view"} = "acctsubj_lastlv_list_" . getlang LN_DATABASE;
}
return $self;
}
return 1;

116
lib/perl5/Selima/List/Accounting/Transacts.pm Normal file
View File

@@ -0,0 +1,116 @@
# Selima Website Content Management System
# Transacts.pm: The accounting transaction list.
# Copyright (c) 2007-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: 2007-08-23
package Selima::List::Accounting::Transacts;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use Selima::AddGet;
use Selima::DataVars qw(:requri);
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$_[1] = "accttrx" if !defined $_[1];
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = $self->{"is_called_form"}?
C_("Select an Accounting Transaction"):
C_("Manage Accounting Transactions");
# The default sort order
$self->{"DEFAULT_SORTBY"} = "-date,-ord";
# Column labels
$self->col_labels(
"num" => C_("Number"),
"note" => C_("Note"),
);
return $self;
}
# html_newlink: Display a link to add a new item
sub html_newlink : method {
local ($_, %_);
my ($self, $urle, $urli, $urlt, $prompt);
$self = $_[0];
# No new item creation if it is a called form
return if $self->{"is_called_form"};
$_ = $REQUEST_FILEQS;
# Remove list parameters
$_ = rem_get_arg $_, "query", "sortby", "pageno", "form", "formcat", "formid", "statid";
$_ = add_get_arg $_, "form", "new", DUP_OK;
$urle = add_get_arg $_, "formsub", "expense", DUP_OK;
$urli = add_get_arg $_, "formsub", "income", DUP_OK;
$urlt = add_get_arg $_, "formsub", "trans", DUP_OK;
$prompt = C_("<a href=\"[_1]\">Add a new cash expense transaction</a>, <a href=\"[_2]\">add a new cash income transaction</a> or <a href=\"[_3]\">add a new transfer transaction</a>.",
h($urle), h($urli), h($urlt));
print << "EOT";
<p>$prompt</p>
EOT
return;
}
# html_search: Display the search box
sub html_search : method {
# Run the parent method
return $_[0]->SUPER::html_search(C_("Search for an accounting transaction:"));
}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my $self;
$self = $_[0];
# No record to list
if ($self->{"total"} == 0) {
# Inherit the empty list statistics message
return $self->SUPER::liststat_message;
# Fit in one page
} elsif ($self->{"total"} <= $self->{"pagesize"}) {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,accounting transaction].", $self->{"total"});
# List result
} else {
return C_("[*,_1,accounting transaction].", $self->{"total"});
}
# More than one page
} else {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,accounting transaction], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
# List result
} else {
return C_("[*,_1,accounting transaction], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
}
}
}
return 1;

256
lib/perl5/Selima/List/ActLog.pm Normal file
View File

@@ -0,0 +1,256 @@
# Selima Website Content Management System
# ActLog.pm: The activity log record list.
# Copyright (c) 2005-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: 2005-05-10
package Selima::List::ActLog;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use Encode qw(decode);
use Fcntl qw(:flock);
use Selima::A2HTML;
use Selima::DataVars qw(:lninfo :requri);
use Selima::GetLang;
use Selima::Logging;
use Selima::HTTP;
use Selima::Query;
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = C_("Browse the Activity Log");
$self->{"rows"} = defined $self->{"FORM"}->param("rows")?
$self->{"FORM"}->param("rows"): undef;
$self->{"rdgt"} = 4;
$self->{"reverse"} = 1;
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my ($self, $error, $FH);
$self = $_[0];
# Fetched before
return $self->{"error"} if $self->{"fetched"};
$self->{"fetched"} = 1;
# Initialize the error status
$self->{"error"} = undef;
$self->{"total"} = undef;
# Check the query phrases
$self->check_query;
# Check the number of rows to display
$error = $self->check_pagesize;
if (defined $error) {
$self->{"error"} = $error if !defined $self->{"error"};
$self->{"pagesize"} = $self->{"DEFAULT_LIST_SIZE"};
} elsif (!defined $self->{"rows"}) {
$self->{"pagesize"} = $self->{"DEFAULT_LIST_SIZE"};
} else {
$self->{"pagesize"} = $self->{"rows"};
}
check_actlog_file;
open $FH, $ACTLOG or http_500 "$ACTLOG: $!";
flock $FH, LOCK_SH or http_500 "$ACTLOG: $!";
# Obtain all the log entries
if (@{$self->{"query_phrases"}} == 0) {
$self->{"current"} = [map decode("UTF-8", $_), <$FH>];
# Obtain all the matched log entries
} else {
$self->{"current"} = [];
while (defined($_ = <$FH>)) {
my $matched;
$_ = decode("UTF-8", $_);
$matched = 1;
foreach my $phrase (@{$self->{"query_phrases"}}) {
next if /\Q$phrase\E/i;
$matched = 0;
last;
}
push @{$self->{"current"}}, $_ if $matched;
}
}
flock $FH, LOCK_UN or http_500 "$ACTLOG: $!";
close $FH or http_500 "$ACTLOG: $!";
$self->{"total"} = scalar @{$self->{"current"}};
$self->{"endno"} = $self->{"total"} - 1;
$self->{"startno"} = 1;
if ($self->{"total"} > $self->{"pagesize"}) {
$self->{"startno"} = $self->{"endno"} - $self->{"pagesize"} + 1;
$self->{"current"} = [@{$self->{"current"}}[$self->{"startno"}...$self->{"endno"}]];
}
$self->{"current"} = [reverse @{$self->{"current"}}];
# Done
return $self->{"error"};
}
# check_query: Check the query phrases
sub check_query : method {
local ($_, %_);
my $self;
$self = $_[0];
# No query, return
return if !defined $self->{"query"};
# Regularize it
$self->{"query"} =~ s/^\s*(.*?)\s*$/$1/;
# Check if it is filled
return if $self->{"query"} eq "";
$self->{"query_phrases"} = [parse_query $self->{"query"}];
return;
}
# check_pagesize: Check the number of rows to display
sub check_pagesize : method {
local ($_, %_);
my ($self, $error, $errmsg);
$self = $_[0];
# No rows, return
return if !defined $self->{"rows"};
# Regularize it
$self->{"rows"} =~ s/^\s*(.*?)\s*$/$1/;
# Check if it is filled
return {"msg"=>N_("Please fill in the number of rows to display.")}
if $self->{"rows"} eq "";
# If there is any non-digit character
return {"msg"=>N_("Please fill in a positive integer number of rows to display.")}
unless $self->{"rows"} =~ /^[1-9][0-9]*$/;
# Set to an integer
$self->{"rows"} += 0;
# Check the length
return {"msg"=>N_("This number of rows to display is too long. (Max. length [#,_1])"),
"margs"=>[$self->{"rdgt"}]}
if length $self->{"rows"} > $self->{"rdgt"};
# OK
return;
}
# html_newlink: Display a link to add a new item
# Make it a null function
sub html_newlink : method {}
# html_search: Display the search box
sub html_search : method {
local ($_, %_);
my ($self, $prompt, $label, $query, $request_file);
my ($prompt2, $rows, $size);
($self, $prompt) = @_;
$prompt = C_("Search for log entries:") if !defined $prompt;
$prompt = h($prompt);
$request_file = h($REQUEST_FILE);
$query = defined $self->{"query"}? h($self->{"query"}): "";
$label = h(C_("Display"));
$prompt2 = h(C_("Display rows:"));
$rows = defined $self->{"rows"}? h($self->{"rows"}):
h($self->{"DEFAULT_LIST_SIZE"});
$size = h($self->{"rdgt"});
print << "EOT";
<form action="$request_file" method="get" accept-charset="<!--selima:charset-->">
<div class="searchbox">
<label for="query">$prompt</label><input
id="query" type="text" name="query" value="$query" />
<label for="rows">$prompt2</label><input
id="rows" type="text" name="rows" size="$size" maxlength="$size" value="$rows" />
<input type="hidden" name="charset" value="<!--selima:charset-->" />
<input type="submit" value="$label" />
</div>
</form>
EOT
return;
}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my $self;
$self = $_[0];
# No record to list
if ($self->{"total"} == 0) {
# Inherit the empty list statistics message
return $self->SUPER::liststat_message;
# Fit in one page
} elsif ($self->{"total"} <= $self->{"pagesize"}) {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,log entry,log entries].", $self->{"total"});
# List result
} else {
return C_("[*,_1,log entry,log entries].", $self->{"total"});
}
# More than one page
} else {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,log entry,log entries], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
# List result
} else {
return C_("[*,_1,log entry,log entries], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
}
}
}
# html_pagebar: Display a page navigation bar
# Make it a null function
sub html_pagebar : method {}
# html_list: List the items
sub html_list : method {
local ($_, %_);
my $self;
$self = $_[0];
# Do not show the list
return if !defined $self->{"total"};
# No record to be listed
return if $self->{"total"} == 0;
$_ = a2html(join "", @{$self->{"current"}});
s/([\x00-\x08\x0B\x0C\x0E-\x1F])/sprintf("\\x%02x", ord($1));/ge;
print << "EOT";
<div>
$_
</div>
EOT
return;
}
return 1;

74
lib/perl5/Selima/List/Category.pm Normal file
View File

@@ -0,0 +1,74 @@
# Selima Website Content Management System
# Category.pm: The base category list.
# Copyright (c) 2006-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: 2006-03-21
package Selima::List::Category;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use Selima::ShortCut;
# html_newlink: Display a link to add a new item
sub html_newlink : method {
# Run the parent method
return $_[0]->SUPER::html_newlink(C_("Add a new category."));
}
# html_search: Display the search box
sub html_search : method {
# Run the parent method
return $_[0]->SUPER::html_search(C_("Search for a category:"));
}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my $self;
$self = $_[0];
# No record to list
if ($self->{"total"} == 0) {
# Inherit the empty list statistics message
return $self->SUPER::liststat_message;
# Fit in one page
} elsif ($self->{"total"} <= $self->{"pagesize"}) {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,category,categories].", $self->{"total"});
# List result
} else {
return C_("[*,_1,category,categories].", $self->{"total"});
}
# More than one page
} else {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,category,categories], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
# List result
} else {
return C_("[*,_1,category,categories], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
}
}
}
return 1;

74
lib/perl5/Selima/List/Categorz.pm Normal file
View File

@@ -0,0 +1,74 @@
# Selima Website Content Management System
# Categorz.pm: The base category membership list.
# Copyright (c) 2006-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: 2006-03-21
package Selima::List::Categorz;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use Selima::ShortCut;
# html_newlink: Display a link to add a new item
sub html_newlink : method {
# Run the parent method
return $_[0]->SUPER::html_newlink(C_("Add a new categorization record."));
}
# html_search: Display the search box
sub html_search : method {
# Run the parent method
return $_[0]->SUPER::html_search(C_("Search for a categorization record:"));
}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my $self;
$self = $_[0];
# No record to list
if ($self->{"total"} == 0) {
# Inherit the empty list statistics message
return $self->SUPER::liststat_message;
# Fit in one page
} elsif ($self->{"total"} <= $self->{"pagesize"}) {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,categorization record].", $self->{"total"});
# List result
} else {
return C_("[*,_1,categorization record].", $self->{"total"});
}
# More than one page
} else {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,categorization record], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
# List result
} else {
return C_("[*,_1,categorization record], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
}
}
}
return 1;

95
lib/perl5/Selima/List/GroupMem.pm Normal file
View File

@@ -0,0 +1,95 @@
# Selima Website Content Management System
# GroupMem.pm: The group-to-group membership list.
# 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-10-14
package Selima::List::GroupMem;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$_[1] = "groupmem" if !defined $_[1];
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = $self->{"is_called_form"}?
C_("Select a Group Membership Record"):
C_("Manage Group Membership");
# The default sort order
$self->{"DEFAULT_SORTBY"} = "grp,member";
# Column labels
$self->col_labels(
"grp" => C_("Group"),
"member" => C_("Member"),
);
return $self;
}
# html_newlink: Display a link to add a new item
sub html_newlink : method {
# Run the parent method
return $_[0]->SUPER::html_newlink(C_("Add a new membership record."));
}
# html_search: Display the search box
sub html_search : method {
# Run the parent method
return $_[0]->SUPER::html_search(C_("Search for a membership record:"));
}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my $self;
$self = $_[0];
# No record to list
if ($self->{"total"} == 0) {
# Inherit the empty list statistics message
return $self->SUPER::liststat_message;
# Fit in one page
} elsif ($self->{"total"} <= $self->{"pagesize"}) {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,membership record].", $self->{"total"});
# List result
} else {
return C_("[*,_1,membership record].", $self->{"total"});
}
# More than one page
} else {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,membership record], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
# List result
} else {
return C_("[*,_1,membership record], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
}
}
}
return 1;

94
lib/perl5/Selima/List/Groups.pm Normal file
View File

@@ -0,0 +1,94 @@
# Selima Website Content Management System
# Groups.pm: The account group list.
# 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-10-12
package Selima::List::Groups;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$_[1] = "groups" if !defined $_[1];
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = $self->{"is_called_form"}? C_("Select a Group"):
C_("Manage Groups");
# The default sort order
$self->{"DEFAULT_SORTBY"} = "id";
# Column labels
$self->col_labels(
"id" => C_("Group ID."),
"dsc" => C_("Description"),
);
return $self;
}
# html_newlink: Display a link to add a new item
sub html_newlink : method {
# Run the parent method
return $_[0]->SUPER::html_newlink(C_("Add a new group."));
}
# html_search: Display the search box
sub html_search : method {
# Run the parent method
return $_[0]->SUPER::html_search(C_("Search for a group:"));
}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my $self;
$self = $_[0];
# No record to list
if ($self->{"total"} == 0) {
# Inherit the empty list statistics message
return $self->SUPER::liststat_message;
# Fit in one page
} elsif ($self->{"total"} <= $self->{"pagesize"}) {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,group].", $self->{"total"});
# List result
} else {
return C_("[*,_1,group].", $self->{"total"});
}
# More than one page
} else {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,group], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
# List result
} else {
return C_("[*,_1,group], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
}
}
}
return 1;

110
lib/perl5/Selima/List/Guestbook.pm Normal file
View File

@@ -0,0 +1,110 @@
# Selima Website Content Management System
# Guestbook.pm: The base administrative guestbook message list.
# 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-10-16
package Selima::List::Guestbook;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use Selima::AddGet;
use Selima::DataVars qw(:requri);
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$_[1] = "guestbook" if !defined $_[1];
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = $self->{"is_called_form"}?
C_("Select a Message"):
C_("Manage Guestbook");
# The default sort order
$self->{"DEFAULT_SORTBY"} = "created";
# Columns that should display its brief instead
push @{$self->{"COLS_BRIEF"}}, qw(message);
# Columns should be displayed in a reversed order
$self->{"reverse"} = 1;
# The list brief size
$self->{"DEFAULT_BRIEF_LEN"} = 20;
# Column labels
$self->col_labels(
"name" => C_("Signature"),
"identity" => C_("Identity"),
"location" => C_("Location"),
"message" => C_("Message"),
"ip" => C_("IP"),
"host" => C_("Host"),
"ct" => C_("Country"),
"pageno" => C_("Page No."),
"oldpageno" => C_("Old page No."),
);
return $self;
}
# html_newlink: Display a link to add a new item
sub html_newlink : method {
# Run the parent method
return $_[0]->SUPER::html_newlink(C_("Write a new message."));
}
# html_search: Display the search box
sub html_search : method {
# Run the parent method
return $_[0]->SUPER::html_search(C_("Search for a message:"));
}
# liststat_message: Return the current list statistics message
sub liststat_message : method {
local ($_, %_);
my $self;
$self = $_[0];
# No record to list
if ($self->{"total"} == 0) {
# Inherit the empty list statistics message
return $self->SUPER::liststat_message;
# Fit in one page
} elsif ($self->{"total"} <= $self->{"pagesize"}) {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,message].", $self->{"total"});
# List result
} else {
return C_("[*,_1,message].", $self->{"total"});
}
# More than one page
} else {
# Result comes from a query
if (defined $self->{"query"}) {
return C_("Your query found [*,_1,message], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
# List result
} else {
return C_("[*,_1,message], listing [#,_2] to [#,_3].",
$self->{"total"}, $self->{"startno"}+1, $self->{"endno"}+1);
}
}
}
return 1;

226
lib/perl5/Selima/List/Guestbook/Public.pm Normal file
View File

@@ -0,0 +1,226 @@
# Selima Website Content Management System
# Public.pm: The base guestbook message list.
# 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-10-23
package Selima::List::Guestbook::Public;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List);
use IO::NestedCapture qw(CAPTURE_STDOUT);
use Selima::A2HTML;
use Selima::DataVars qw($DBH :requri);
use Selima::Format;
use Selima::GetLang;
use Selima::MungAddr;
use Selima::ShortCut;
use Selima::Unicode;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$_[1] = "guestbook" if !defined $_[1];
$self = $class->SUPER::new(@_);
$self->{"view"} = "guestbook_public";
# Entries should be displayed in a reversed order
$self->{"reverse"} = 1;
# Magical Traditional/Simplified Chinese conversion
$self->{"magic_zhconv"} = 0;
return $self;
}
# fetch: Fetch the current list
sub fetch : method {
local ($_, %_);
my ($self, $table, $sth, $sql, $error);
$self = $_[0];
# Fetched before
return $self->{"error"} if $self->{"fetched"};
$self->{"fetched"} = 1;
# Initialize the error status
$self->{"error"} = undef;
# The view name
$table = $DBH->quote_identifier($self->{"view"});
# Find the last page number
$sql = "SELECT pageno FROM $table ORDER BY pageno DESC LIMIT 1;\n";
$sth = $DBH->prepare($sql);
$sth->execute;
# No records yet
if ($sth->rows != 1) {
$self->{"lastpage"} = 1;
} else {
$self->{"lastpage"} = ${$sth->fetch}[0];
}
# Check the page number
$error = $self->check_pageno;
$self->{"error"} = $error if defined $error && !defined $self->{"error"};
# Obtain the total number
$self->{"select_total"} = sprintf "SELECT count(*) FROM $table;\n";
$sql = $self->{"select_total"};
$sth = $DBH->prepare($sql);
$sth->execute;
$self->{"total"} = ($sth->fetchrow_array)[0];
# Obtain everything in this page
$self->{"current"} = [];
# Always reverse
$self->{"select"} = "SELECT * FROM $table"
. " WHERE pageno=" . $self->{"pageno"} . ";\n";
$sql = $self->{"select"};
$sth = $DBH->prepare($sql);
$sth->execute;
push @{$self->{"current"}}, $_
while defined($_ = $sth->fetchrow_hashref);
undef $sth;
# Done
return $self->{"error"};
}
# page_param: Obtain page parameters
sub page_param : method {
local ($_, %_);
my ($self, $args);
$self = $_[0];
# Run the parent method
$args = $self->SUPER::page_param;
# Add the page bar to the page parameters
if (defined $args && $self->{"lastpage"} > 1) {
my $FD;
# Obtain the page bar
IO::NestedCapture->start(CAPTURE_STDOUT);
binmode IO::NestedCapture->instance->{"STDOUT_current"}[-1], ":utf8";
$self->html_pagebar;
IO::NestedCapture->stop(CAPTURE_STDOUT);
$FD = IO::NestedCapture->get_last_out;
$$args{"header_html_nav"} = join "", <$FD>;
$$args{"header_html_nav"} =~ s/\s+$//;
$$args{"footer_html_nav"} = $$args{"header_html_nav"};
}
return $args;
}
# html: Output the list
sub html : method {
local ($_, %_);
my $self;
$self = $_[0];
# Fetch the current list if not fetched yet
$self->fetch if !$self->{"fetched"};
# Display the error message
$self->html_errmsg;
# List the items
$self->html_list;
return;
}
# html_list: List the items
sub html_list : method {
local ($_, %_);
my ($self, @htmls, $emailalt);
$self = $_[0];
# No record to be listed
return if $self->{"total"} == 0;
$emailalt = h(C_("E-mail"));
foreach my $current (@{$self->{"current"}}) {
my $h;
# Magical Traditional/Simplified Chinese conversion
if ($self->{"magic_zhconv"}) {
$_ = getlang;
if ( $_ eq "zh-tw" &&
!(defined $$current{"lang"}
&& $$current{"lang"} eq "zh-tw")) {
foreach my $col (qw(name identity location email url message)) {
$$current{$col} = all_to_trad($$current{$col})
if defined $$current{$col};
}
} elsif ( $_ eq "zh-cn" &&
!(defined $$current{"lang"}
&& $$current{"lang"} eq "zh-cn")) {
foreach my $col (qw(name identity location email url message)) {
$$current{$col} = all_to_simp($$current{$col})
if defined $$current{$col};
}
}
}
$h = "";
$h .= "<div id=\"msg" . h($$current{"sn"}) . "\" class=\"entry\">\n";
$h .= "<div>\n" . a2html($$current{"message"}) . "\n</div>\n\n";
# <form ...>...</form> cannot live inside of <address>...</address>
$h .= "<form action=\"/cgi-bin/mailto.cgi\" method=\"post\">\n"
if defined $$current{"email"} && $$current{"email"} =~ /\@/;
$h .= "<address>\n";
$h .= "<cite>" . h($$current{"name"}) . "</cite><br />\n"
if defined $$current{"name"};
if (getlang eq "en") {
$h .= myfmttime($$current{"date"}) . "<br />\n";
} else {
$h .= "<span xml:lang=\"en\">" . myfmttime($$current{"date"}) . "</span><br />\n";
}
$h .= h($$current{"identity"}) . "<br />\n"
if defined $$current{"identity"};
$h .= h($$current{"location"}) . "<br />\n"
if defined $$current{"location"};
if (defined $$current{"email"}) {
if ($$current{"email"} =~ /\@/) {
$h .= "<samp>" . mung_email_span(h($$current{"email"})) . "</samp>"
. "<input\n type=\"hidden\" name=\"email\" value=\""
. h(mung_address_at($$current{"email"})) . "\" />"
. "<input\n type=\"image\" src=\"/images/email\" alt=\"$emailalt\" /><br />\n";
} else {
$h .= "<samp>" . mung_email_span(h($$current{"email"})) . "</samp><br />\n";
}
}
if (defined $$current{"url"}) {
if ($$current{"url"} =~ /^(?:http|https|ftp|gopher|telnet):\/\//) {
$h .= "<samp><a href=\"" . h($$current{"url"}) . "\">"
. h($$current{"url"}) . "</a></samp><br />\n";
} else {
$h .= h($$current{"url"}) . "<br />\n";
}
}
$h .= C_("~[<a href=\"[_1]\">Edit</a>~]",
h("/magicat/cgi-bin/guestbook.cgi?form=cur&sn=" . $$current{"sn"})) . "\n"
if $ENV{"REMOTE_ADDR"} =~ /^10\./;
$h .= "</address>\n";
$h .= "</form>\n" if defined $$current{"email"} && $$current{"email"} =~ /\@/;
$h .= "</div>\n\n";
push @htmls, $h;
}
$_ = h(C_("The message entry seperator"));
print "<hr />\n\n<div class=\"entries\">\n\n"
. join("<hr title=\"$_\" />\n\n", @htmls) . "</div>\n\n";
return;
}
return 1;

48
lib/perl5/Selima/List/LinkCat.pm Normal file
View File

@@ -0,0 +1,48 @@
# Selima Website Content Management System
# LinkCat.pm: The related-link category list.
# 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-10-24
package Selima::List::LinkCat;
use 5.008;
use strict;
use warnings;
use base qw(Selima::List::Category);
use Selima::ShortCut;
# new: Initialize the handler
sub new : method {
local ($_, %_);
my ($self, $class);
($class, @_) = @_;
$_[1] = "linkcat" if !defined $_[1];
$self = $class->SUPER::new(@_);
# The page title
$self->{"title"} = $self->{"is_called_form"}?
C_("Select a Link Category"):
C_("Manage Link Categories");
# The default sort order
$self->{"DEFAULT_SORTBY"} = "ord,id";
# Column labels
$self->col_labels(
);
return $self;
}
return 1;

Some files were not shown because too many files have changed in this diff Show More