Initial commit.
This commit is contained in:
294
lib/perl5/Selima/Accounting.pm
Normal file
294
lib/perl5/Selima/Accounting.pm
Normal 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;
|
||||
Reference in New Issue
Block a user