295 lines
8.5 KiB
Perl
295 lines
8.5 KiB
Perl
# 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;
|