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