Initial commit
This commit is contained in:
commit
f4bfb0e367
71 changed files with 10399 additions and 0 deletions
357
Dam/Application.pm
Normal file
357
Dam/Application.pm
Normal file
|
|
@ -0,0 +1,357 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Application
|
||||
|
||||
=head1 DECRIPTION
|
||||
|
||||
Initialization of the default global variables and definition of the entry point
|
||||
for the predefined and customized run modes created using the Dam framework.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Application;
|
||||
|
||||
use base 'CGI::Application';
|
||||
|
||||
use CGI qw(-utf8);
|
||||
use Authen::Simple::ActiveDirectory;
|
||||
use Crypt::Tea_JS;
|
||||
use String::Random qw(random_string);
|
||||
use Date::Calc qw(Today_and_Now);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::Debug;
|
||||
use Dam::Database;
|
||||
use Dam::DamLogic qw(
|
||||
is_report is_download Show__error_403 Show__about Show
|
||||
Session__new Session__flush Session__close
|
||||
User__is_logged_in User__access
|
||||
cgiapp_param cgiapp_cookie cgiapp_header_add cgiapp_header_props
|
||||
_t package_config tmpl_core
|
||||
);
|
||||
use Dam::Var;
|
||||
|
||||
my %CURRENT_PACKAGE = ();
|
||||
|
||||
|
||||
|
||||
sub pre__session_user_params {
|
||||
my ($CGIAPP, $uid) = @_;
|
||||
return ();
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub pre__load_stylesheets {
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub pre__load_javascripts {
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub setup {
|
||||
my $CGIAPP = shift;
|
||||
|
||||
RESERVED(CGIAPP => $CGIAPP);
|
||||
|
||||
# Connect to database:
|
||||
RESERVED(DBH => database_connect(
|
||||
DB_DSN => CONFIG('DB_DSN'),
|
||||
DB_USER => CONFIG('DB_USER'),
|
||||
DB_PASSWORD => CONFIG('DB_PASSWORD')
|
||||
));
|
||||
|
||||
my @run_modes = (
|
||||
'APP_login',
|
||||
'APP_confirm',
|
||||
'RUN_home',
|
||||
'RUN_report',
|
||||
'RUN_error403',
|
||||
'RUN_close'
|
||||
);
|
||||
|
||||
if (User__is_logged_in()) {
|
||||
my %ROUTES = %{CONFIG('REF_ROUTES')};
|
||||
my @user_access = User__access();
|
||||
foreach my $menu (sort keys(%ROUTES)) {
|
||||
__setup_run_modes(\@run_modes, \%{$ROUTES{$menu}{OPTIONS}}, \@user_access);
|
||||
}
|
||||
}
|
||||
$CGIAPP->run_modes(\@run_modes);
|
||||
$CGIAPP->start_mode('RUN_home');
|
||||
|
||||
# The template directory is initialized:
|
||||
$CGIAPP->tmpl_path(CONFIG('DIR_TEMPLATES'));
|
||||
|
||||
# Enable file uploads:
|
||||
$CGIAPP::DISABLE_UPLOADS = 0;
|
||||
$CGIAPP::POST_SIZE = CONFIG('UPLOAD_MAX_FILESIZE');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub teardown {
|
||||
# Discconnect from database:
|
||||
database_disconnect();
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub cgiapp_prerun {
|
||||
my ($CGIAPP, $run_mode) = @_;
|
||||
|
||||
my $binmode = 1;
|
||||
cgiapp_header_props(
|
||||
-charset => 'UTF-8'
|
||||
);
|
||||
if (!is_eq(substr($run_mode, 0, 4), 'APP_')) {
|
||||
if (User__is_logged_in()) {
|
||||
if (!is_eq(substr($run_mode, 0, 4), 'RUN_')) {
|
||||
# 1. Get the user access permissions:
|
||||
my @user_access = User__access();
|
||||
|
||||
# 2. Debugging mode is disabled if user is not a developer:
|
||||
CONFIG('DEBUG_MODE' => 0) if !in_array(0, \@user_access);
|
||||
|
||||
# 3. Load report:
|
||||
info($run_mode);
|
||||
my %ROUTES = %{CONFIG('REF_ROUTES')};
|
||||
foreach my $menu (sort (%ROUTES)) {
|
||||
%CURRENT_PACKAGE = __search_run_mode($run_mode, \%{$ROUTES{$menu}{OPTIONS}});
|
||||
if (%CURRENT_PACKAGE) {
|
||||
$CURRENT_PACKAGE{ID} = $ROUTES{$menu}{ID};
|
||||
RESERVED('REF_CURRENT_PACKAGE' => \%CURRENT_PACKAGE);
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
# 4. Check if user has access permission to the current report:
|
||||
if (!defined($CURRENT_PACKAGE{ACCESS}) || match_arrays(\@user_access, $CURRENT_PACKAGE{ACCESS})) {
|
||||
# 5. Check if it's a download:
|
||||
if (is_download()) {
|
||||
my ($download_mode, $filename_extension) = split(',', cgiapp_param('dm'));
|
||||
my $package = $run_mode;
|
||||
my @packages = split('::', $run_mode);
|
||||
if (scalar(@packages) > 1) {
|
||||
$package = pop(@packages);
|
||||
$package = pop(@packages) if is_eq($package, $CURRENT_PACKAGE{RUN});
|
||||
}
|
||||
my $filename = strval($package, '_', $download_mode, '-', sprintf("%04d%02d%02d_%02d%02d%02d", Today_and_Now()), '.', $filename_extension);
|
||||
cgiapp_header_props(
|
||||
-type => 'application/x-download',
|
||||
-Content_Disposition => strval('attachment; filename="', $filename, '"')
|
||||
);
|
||||
$binmode = 0;
|
||||
}
|
||||
elsif (!is_report()) {
|
||||
$CGIAPP->prerun_mode('RUN_report');
|
||||
}
|
||||
}
|
||||
else {
|
||||
$CGIAPP->prerun_mode('RUN_error403');
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$CGIAPP->prerun_mode('APP_login');
|
||||
}
|
||||
}
|
||||
binmode STDOUT, ":utf8" if $binmode;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub cgiapp_postrun {
|
||||
DROP_TEMP_TABLES(); # Drop temporal database tables
|
||||
Session__flush(); # Synchronize the session with the database
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub APP_login {
|
||||
return __login();
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub APP_confirm {
|
||||
my $user = lc cgiapp_param('user');
|
||||
my $pass = decrypt(cgiapp_param('pass'), cgiapp_param('key'));
|
||||
|
||||
# Check if the user exists (according to input parameters):
|
||||
my $user_db = QUERY(SELECT(
|
||||
FIELDS => 'user_uid, user_password, user_firstname, user_name, user_access, user_active',
|
||||
FROM => 'users',
|
||||
WHERE => COMPARE_STR('BINARY user_login', '=', $user)
|
||||
));
|
||||
|
||||
# User not registered. Request the login again:
|
||||
return __login($user, 1) if $user_db->rows == 0;
|
||||
|
||||
my @user_data = $user_db->fetchrow_array();
|
||||
|
||||
# Non-active user. Show warning message:
|
||||
return __login($user, 2, _t('User not active!'), _t('Consult with your systems manager to activate your user')) if $user_data[5] eq 0;
|
||||
|
||||
# Check if user is in the Active Directory:
|
||||
my $ad = Authen::Simple::ActiveDirectory->new(host => CONFIG('LDAP_DOMAIN'), principal => CONFIG('LDAP_DOMAIN'), timeout => 20);
|
||||
if (!$ad->authenticate($user, $pass)) {
|
||||
# Unidentified user. Or is it a local user:
|
||||
my $passcrypt = __crypt_password($pass);
|
||||
# Unidentified user. Request the login again:
|
||||
return __login($user, 3) if !defined($user_data[1]) || $user_data[1] ne $passcrypt;
|
||||
}
|
||||
|
||||
# Validated user. Login with user settings:
|
||||
Session__new($user_data[0], $user_data[2], $user_data[3], $user_data[4], RESERVED('CGIAPP')->pre__session_user_params($user_data[0]));
|
||||
|
||||
# Show home page:
|
||||
return RUN_home();
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub RUN_home {
|
||||
return Show__about();
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub RUN_report {
|
||||
return Show();
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub RUN_error403 {
|
||||
return Show__error_403();
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub RUN_close {
|
||||
Session__close(); # Delete the user session
|
||||
return __login(); # Return to the login form
|
||||
}
|
||||
|
||||
|
||||
# PRIVATE FUNCTIONS:
|
||||
|
||||
|
||||
sub __setup_run_modes {
|
||||
my ($run_modes_ref, $options_ref, $user_access_ref) = @_;
|
||||
|
||||
my $superuser = in_array(0, $user_access_ref);
|
||||
foreach my $option (sort keys(%$options_ref)) {
|
||||
next if !is_eq(ref($$options_ref{$option}), 'HASH') && is_eq($$options_ref{$option}, _DIVIDER_);
|
||||
if (defined($$options_ref{$option}{OPTIONS})) {
|
||||
__setup_run_modes($run_modes_ref, \%{$$options_ref{$option}{OPTIONS}}, $user_access_ref);
|
||||
}
|
||||
else {
|
||||
next if is_empty($$options_ref{$option}{PACKAGE}) && is_empty($$options_ref{$option}{RUN});
|
||||
next if defined($$options_ref{$option}{ENABLED}) && $$options_ref{$option}{ENABLED} == 0;
|
||||
next unless $superuser || (defined($$options_ref{$option}{ACCESS}) && match_arrays($user_access_ref, $$options_ref{$option}{ACCESS}));
|
||||
|
||||
my $run_mode = strval_trio($$options_ref{$option}{PACKAGE}, '::', defined($$options_ref{$option}{RUN}) ? $$options_ref{$option}{RUN} : 'Run');
|
||||
fatal('Duplicated "', $run_mode, '" run mode.') if in_array($run_mode, $run_modes_ref);
|
||||
push(@$run_modes_ref, $run_mode);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub __search_run_mode {
|
||||
my ($run_mode, $options_ref) = @_;
|
||||
|
||||
foreach my $option (sort keys(%$options_ref)) {
|
||||
next if !is_eq(ref($$options_ref{$option}), 'HASH') && is_eq($$options_ref{$option}, _DIVIDER_);
|
||||
if (defined($$options_ref{$option}{OPTIONS})) {
|
||||
my %search_option = __search_run_mode($run_mode, \%{$$options_ref{$option}{OPTIONS}});
|
||||
return %search_option if %search_option;
|
||||
}
|
||||
else {
|
||||
next if is_empty($$options_ref{$option}{PACKAGE}) && is_empty($$options_ref{$option}{RUN});
|
||||
next if !is_eq($run_mode, strval_trio($$options_ref{$option}{PACKAGE}, '::', defined($$options_ref{$option}{RUN}) ? $$options_ref{$option}{RUN} : 'Run'));
|
||||
return package_config(\%{$$options_ref{$option}});
|
||||
}
|
||||
}
|
||||
return ();
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub __login {
|
||||
my ($login, $error, $error_title, $error_message) = @_;
|
||||
|
||||
cgiapp_header_add(-cookie => cgiapp_cookie(CGISESSID => ''));
|
||||
|
||||
my $tmpl_login = tmpl_core('Login',
|
||||
APP_NAME => CONFIG('APP_NAME'),
|
||||
KEY => random_string('ssssssssssssssssssssssssssssss'),
|
||||
LOGIN => $login,
|
||||
CRYPT_TEA => tea_in_javascript(),
|
||||
|
||||
T_USERNAME => _t('Username'),
|
||||
T_PASSWORD => _t('Password'),
|
||||
T_LOGIN => _t('Login')
|
||||
);
|
||||
|
||||
if (defined($error)) {
|
||||
$tmpl_login->param(
|
||||
ERROR => $error,
|
||||
ERROR_TITLE => defined($error_title) ? $error_title : _t('Access error!'),
|
||||
ERROR_MESSAGE => defined($error_message) ? $error_message : _t('Verify username and retype password')
|
||||
);
|
||||
}
|
||||
|
||||
return Show(DISPLAY => 'PAGE', TITLE => 'Login', TEMPLATE => $tmpl_login);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub __crypt_password {
|
||||
my $password = shift;
|
||||
return length($password) ? crypt($password, substr(crypt($password, 'CRTSGR'), -2, 2)) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
124
Dam/Components/Actions/Download.pm
Normal file
124
Dam/Components/Actions/Download.pm
Normal file
|
|
@ -0,0 +1,124 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Actions::Download
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $download_mode = Component__Get(ACTION_DOWNLOAD, ['csv']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Action to execute a download.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Download',
|
||||
ID => 'csv' (default),
|
||||
LABEL => 'CSV' (default),
|
||||
TOOLTIP => 'Download the current report in CSV format' (default),
|
||||
ICON => 'download-alt' (default),
|
||||
MODE_EXT => 'CSV' (default),
|
||||
FILE_EXT => 'csv' (default)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
package Dam::Components::Actions::Download;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Action__html Action__js
|
||||
);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'csv';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
LABEL => [ ARG_DEFAULT, 'CSV' ],
|
||||
TOOLTIP => [ ARG_DEFAULT, _t('Download current report in CSV format') ],
|
||||
ICON => [ ARG_DEFAULT, 'download-alt' ],
|
||||
MODE_EXT => [ ARG_DEFAULT, 'CSV' ],
|
||||
FILE_EXT => [ ARG_DEFAULT, 'csv' ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Action__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
return is_report() ? strval('
|
||||
<button type="button" class="btn btn-info input-lg" id="', $$arg_ref{ID}, '" data-toggle="tooltip" title="', $$arg_ref{TOOLTIP}, '"><span class="glyphicon glyphicon-', $$arg_ref{ICON}, '"></span> ', $$arg_ref{LABEL}, '</button>
|
||||
') : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Action__js {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
return is_report() ? strval('
|
||||
$("#', $$arg_ref{ID}, '").click(function(){
|
||||
$("#xt").val(3);
|
||||
$("#dm").val("', $$arg_ref{MODE_EXT}, ',', $$arg_ref{FILE_EXT}, '");
|
||||
$("#submit").click();
|
||||
});
|
||||
') : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my ($download_mode, $filename_extension) = split(',', cgiapp_param('dm'));
|
||||
return is_download() ? $download_mode : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
107
Dam/Components/Actions/Print.pm
Normal file
107
Dam/Components/Actions/Print.pm
Normal file
|
|
@ -0,0 +1,107 @@
|
|||
=head1 NAME
|
||||
|
||||
App::api::actions::Action_Print
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Action to print.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Print',
|
||||
ID => 'print' (default),
|
||||
LABEL => 'Print' (default)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Actions::Print;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Action__html Action__js
|
||||
);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'print';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
LABEL => [ ARG_DEFAULT, _t('Print') ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Action__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
return is_report() ? strval('
|
||||
<button type="button" class="btn btn-success input-lg" id="', $$arg_ref{ID},'"><span class="glyphicon glyphicon-print"></span> ', $$arg_ref{LABEL},'</button>
|
||||
') : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Action__js {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
return is_report() ? strval('
|
||||
$("#', $$arg_ref{ID},'").click(function(){
|
||||
window.print();
|
||||
});
|
||||
') : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
122
Dam/Components/Actions/Run.pm
Normal file
122
Dam/Components/Actions/Run.pm
Normal file
|
|
@ -0,0 +1,122 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Actions::Run
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Action to run a report.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Run',
|
||||
ID => 'submit' (default),
|
||||
LABEL => 'Run' (default)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Actions::Run;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Action__html Action__js
|
||||
);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'submit';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
LABEL => [ ARG_DEFAULT, _t('Run') ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Action__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
return strval('
|
||||
<button type="submit" class="btn btn-primary input-lg" id="', $$arg_ref{ID}, '"><span class="glyphicon glyphicon-repeat"></span> ', $$arg_ref{LABEL},'</button>
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Action__js {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
# Required javascripts:
|
||||
Component__Header(ADD => 'JS', RESOURCE => '/dam/js/spin.min.js', VERSION => '2.3.2' );
|
||||
|
||||
return strval('
|
||||
$(function(){
|
||||
var middle = Math.floor($(window).height() / 2) + "px";
|
||||
var spin = { lines: 10, length: 28, width: 25, radius: 40, scale: 0.5, corners: 1, color: "#000", opacity: 0.3, rotate: 0, direction: 1, speed: 1, trail: 60, fps: 20, zIndex: 2e9, className: "spinner", top: middle, left: "50%", shadow: false, hwaccel: false, position: "absolute" }
|
||||
$("#filter").on("submit", function(e) {
|
||||
if ($("#nv").val() != 1 && $("#filter").valid()) {
|
||||
if ($("#xt").val() == 2) $("#xt").val(1);
|
||||
if ($("#xt").val() == 3) $("#xt").val(2);
|
||||
if ($("#xt").val() < 2) {
|
||||
var spinner = new Spinner(spin).spin(document.getElementById("loading"));
|
||||
$("#loading").show();
|
||||
}
|
||||
}
|
||||
$("#nv").val(0);
|
||||
});
|
||||
});
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
216
Dam/Components/Actions/Sort.pm
Normal file
216
Dam/Components/Actions/Sort.pm
Normal file
|
|
@ -0,0 +1,216 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Actions::Sort
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $orderby = Component__Get(ACTION_SORT);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Action to order a list by columns.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Sort',
|
||||
COLUMNS => { 'col1' => 'Column 1', 'col2' => 'Column 2' } (default),
|
||||
DEFAULT => 'col1' (default valus is undef)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Actions::Sort;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Action__html Action__js
|
||||
);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'sort';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
COLUMNS => [ ARG_DEFAULT, { 'col1' => 'Column 1', 'col2' => 'Column 2' } ],
|
||||
DEFAULT => [ ARG_OPTIONAL ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Action__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my $default = undef;
|
||||
my %list_columns = %{$$arg_ref{COLUMNS}};
|
||||
if (!is_empty($$arg_ref{DEFAULT})) {
|
||||
my @default = split(' ', $$arg_ref{DEFAULT});
|
||||
if (defined($list_columns{$default[0]}) && !defined($default[2])) {
|
||||
my $dir = in_array(uc($default[1]), 'ASC', 'DESC') ? uc($default[1]) : 'ASC';
|
||||
$default = strval($default[0], ' ', $dir);
|
||||
}
|
||||
}
|
||||
|
||||
# Order value:
|
||||
my $orderby_value = cgiapp_param('orderby');
|
||||
$orderby_value = $default if is_empty($orderby_value) && defined($default);
|
||||
|
||||
if (defined($orderby_value)) {
|
||||
my @orderby = split(' ', $orderby_value);
|
||||
if (defined($orderby[0]) && defined($list_columns{$orderby[0]})) {
|
||||
my $orderby = $list_columns{$orderby[0]};
|
||||
if (defined($orderby[1])) {
|
||||
$orderby = strval($orderby, is_eq($orderby[1], 'ASC') ? strval(' (', _t('ascendant'), ')') : is_eq($orderby[1], 'DESC') ? strval(' (', _t('descendent'), ')') : '');
|
||||
}
|
||||
push(@{$info_ref}, { DATA => _t('Order by'), VALUE => $orderby });
|
||||
}
|
||||
else {
|
||||
$orderby_value = '';
|
||||
}
|
||||
}
|
||||
else {
|
||||
$orderby_value = '';
|
||||
}
|
||||
|
||||
return strval('
|
||||
<input type="hidden" name="orderby" id="orderby" value="', $orderby_value, '" />
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Action__js {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my $default = undef;
|
||||
my %list_columns = %{$$arg_ref{COLUMNS}};
|
||||
if (!is_empty($$arg_ref{DEFAULT})) {
|
||||
my @default = split(' ', $$arg_ref{DEFAULT});
|
||||
if (defined($list_columns{$default[0]}) && !defined($default[2])) {
|
||||
my $dir = in_array(uc($default[1]), 'ASC', 'DESC') ? uc($default[1]) : 'ASC';
|
||||
$default = strval($default[0], ' ', $dir);
|
||||
}
|
||||
}
|
||||
|
||||
my $columns_id = '';
|
||||
my $columns_name = '';
|
||||
foreach my $column (keys(%list_columns)) {
|
||||
$columns_id .= strval('#', $column, ',');
|
||||
$columns_name .= strval($list_columns{$column}, ',');
|
||||
}
|
||||
chop($columns_id);
|
||||
chop($columns_name);
|
||||
|
||||
return strval('
|
||||
$(function(){
|
||||
var current_orderby = $("#orderby").val().split(" ");
|
||||
var columns_id = ["', strval_join('","', split(',', $columns_id)), '"];
|
||||
var columns_name = ["', strval_join('","', split(',', $columns_name)), '"];
|
||||
columns_id.forEach(function(value,index,array){
|
||||
var glypho = "sort";
|
||||
if (current_orderby[0] == value.substring(1)) {
|
||||
if (current_orderby[1] == "ASC") {
|
||||
glypho = "triangle-bottom";
|
||||
}
|
||||
else if (current_orderby[1] == "DESC") {
|
||||
glypho = "triangle-top";
|
||||
}
|
||||
}
|
||||
$(value).css("white-space","nowrap");
|
||||
$(value).prepend("<span style=\"font-size: medium; color: #999;\" class=\"minitip glyphicon glyphicon-" + glypho + " hidden-print\" data-toggle=\"tooltip\" title=\"', _t('Sort by'), ' " + columns_name[index] + "\"></span>");
|
||||
$(value).hover(function(){
|
||||
$(this).css("cursor","pointer");
|
||||
});
|
||||
$(value).click(function(){
|
||||
var current_column = $(this).attr("id");
|
||||
if (current_column == current_orderby[0]) {
|
||||
if (current_orderby[1] == "ASC") {
|
||||
current_column += " DESC";
|
||||
}
|
||||
else if (current_orderby[1] != "DESC") {
|
||||
current_column += " ASC";
|
||||
}
|
||||
else {
|
||||
current_column = "', $default, '";
|
||||
}
|
||||
}
|
||||
else {
|
||||
current_column += " ASC";
|
||||
}
|
||||
$("#orderby").val(current_column);
|
||||
$("#submit").click();
|
||||
});
|
||||
});
|
||||
$(".minitip").tooltip();
|
||||
});
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my $orderby_value = cgiapp_param('orderby');
|
||||
return undef if is_empty($orderby_value);
|
||||
return $orderby_value;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Set {
|
||||
my ($self, $value, $id) = @_;
|
||||
|
||||
cgiapp_param('orderby', $value);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
127
Dam/Components/Controls/Check.pm
Normal file
127
Dam/Components/Controls/Check.pm
Normal file
|
|
@ -0,0 +1,127 @@
|
|||
=head1 NAME
|
||||
|
||||
App::api::controls::Control_Check
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $check = Component__Get(CONTROL_CHECK, ['check']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Control para marcar/desmarcar una opción.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Check',
|
||||
ID => 'check' (default),
|
||||
INFO => 1 (show info in header; default) or 0 (don't show),
|
||||
LABEL => 'Check' (default),
|
||||
LABEL_INFO => Same as LABEL (default),
|
||||
DEFAULT => 0 (unchecked; default) or 1 (checked)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Controls::Check;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Control__html Control__js Get
|
||||
);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'check';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
$$arg_ref{LABEL} = 'Check' if is_empty($$arg_ref{LABEL});
|
||||
$$arg_ref{LABEL_INFO} = $$arg_ref{LABEL} if is_empty($$arg_ref{LABEL_INFO});
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
INFO => [ ARG_DEFAULT, 1, 0 ],
|
||||
LABEL => [ ARG_REQUIRED ],
|
||||
LABEL_INFO => [ ARG_REQUIRED ],
|
||||
DEFAULT => [ ARG_DEFAULT, 0, 1 ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my $check_value = !is_report() ? $$arg_ref{DEFAULT} : is_empty(cgiapp_param($$arg_ref{ID})) ? 0 : 1;
|
||||
|
||||
push(@{$info_ref}, { DATA => _t('Option'), VALUE => $$arg_ref{LABEL_INFO} }) if $$arg_ref{INFO} && $check_value;
|
||||
|
||||
return strval('
|
||||
<div class="form-group form-group-', $ID_DEFAULT, ' input-lg">
|
||||
<label for="', $$arg_ref{ID}, '"><input type="checkbox" id="', $$arg_ref{ID}, '" name="', $$arg_ref{ID}, '" value="check"', $check_value ? ' checked ' : ' ', '/> ', $$arg_ref{LABEL}, '</label>
|
||||
</div>
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__js {
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
$id = $ID_DEFAULT if is_empty($id);
|
||||
|
||||
return is_empty(cgiapp_param($id)) ? 0 : 1;
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
158
Dam/Components/Controls/Date.pm
Normal file
158
Dam/Components/Controls/Date.pm
Normal file
|
|
@ -0,0 +1,158 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Controls::Date
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $date = Component__Get(CONTROL_DATE, ['date']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Control para seleccionar una fecha.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Date',
|
||||
ID => 'date' (default),
|
||||
INFO => 1 (show info in header; default) or 0 (don't show),
|
||||
LABEL => 'Date' (default),
|
||||
LABEL_INFO => Same as LABEL (default),
|
||||
REQUIRED => 1 (control required; default) or 0 (not required)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Controls::Date;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Control__html Control__js Get
|
||||
);
|
||||
|
||||
use Date::Calc qw(Today Add_Delta_Days);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'date';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
$$arg_ref{LABEL} = _t('Date') if is_empty($$arg_ref{LABEL});
|
||||
$$arg_ref{LABEL_INFO} = $$arg_ref{LABEL} if is_empty($$arg_ref{LABEL_INFO});
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
INFO => [ ARG_DEFAULT, 1, 0 ],
|
||||
LABEL => [ ARG_REQUIRED ],
|
||||
LABEL_INFO => [ ARG_REQUIRED ],
|
||||
REQUIRED => [ ARG_DEFAULT, 1, 0 ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my $date_value = cgiapp_param($$arg_ref{ID});
|
||||
|
||||
if (!is_report()) {
|
||||
my @previous = Add_Delta_Days(Today(), -1);
|
||||
$date_value = strval(sprintf("%02d", $previous[2]), '/', sprintf("%02d", $previous[1]), '/', $previous[0]);
|
||||
}
|
||||
push(@{$info_ref}, { DATA => $$arg_ref{LABEL_INFO}, VALUE => $date_value }) if $$arg_ref{INFO};
|
||||
|
||||
# Required stylesheets:
|
||||
Component__Header(ADD => 'CSS', RESOURCE => PACK_DATEPICKER);
|
||||
|
||||
return strval('
|
||||
<div class="form-group form-group-', $ID_DEFAULT, '">
|
||||
<label for="', $$arg_ref{ID}, $$arg_ref{REQUIRED} ? '" class="required">' : '">', $$arg_ref{LABEL}, '</label>
|
||||
<input type="text" class="form-control input-lg input-date-date" data-provide="datepicker" id="', $$arg_ref{ID}, '" name="', $$arg_ref{ID}, '" value="', $date_value, '" autocomplete="off" size=4', $$arg_ref{REQUIRED} ? ' required="required"' : '', ' />
|
||||
</div>
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__js {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
# Required javascripts:
|
||||
Component__Header(ADD => 'JS', RESOURCE => PACK_DATEPICKER);
|
||||
|
||||
return strval('
|
||||
$(function(){
|
||||
$("#', $$arg_ref{ID}, '").datepicker({
|
||||
language: "', _t('LANGUAGE_CODE'), '",
|
||||
autoclose: true,
|
||||
todayHighlight: true,
|
||||
disableTouchKeyboard: true,
|
||||
endDate: "0d"
|
||||
});
|
||||
});
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
$id = $ID_DEFAULT if is_empty($id);
|
||||
|
||||
my @date_value = split('/', cgiapp_param($id));
|
||||
my $date_value = "$date_value[2]-$date_value[1]-$date_value[0]";
|
||||
|
||||
return $date_value;
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
221
Dam/Components/Controls/DateRange.pm
Normal file
221
Dam/Components/Controls/DateRange.pm
Normal file
|
|
@ -0,0 +1,221 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Controls::DateRange
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my ($ini, $end) = Component__Get(CONTROL_DATERANGE, ['range']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Control para obtener un rango de fechas.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'DateRange',
|
||||
ID => 'range' (default),
|
||||
INFO => 1 (show info in header; default) or 0 (don't show),
|
||||
LABEL => 'Date range' (default),
|
||||
LABEL_INFO => Same as LABEL (default),
|
||||
REQUIRED => 1 (control required; default) or 0 (not required)
|
||||
MAXDAYS => 1095 (default) or maximum number of days for range
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Controls::DateRange;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Control__html Control__js Get
|
||||
);
|
||||
|
||||
use Date::Calc qw(Today Add_Delta_YM Days_in_Month);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
use Dam::Var;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'range';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
$$arg_ref{LABEL} = _t('Date range') if is_empty($$arg_ref{LABEL});
|
||||
$$arg_ref{LABEL_INFO} = $$arg_ref{LABEL} if is_empty($$arg_ref{LABEL_INFO});
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
INFO => [ ARG_DEFAULT, 1, 0 ],
|
||||
LABEL => [ ARG_REQUIRED ],
|
||||
LABEL_INFO => [ ARG_REQUIRED ],
|
||||
REQUIRED => [ ARG_DEFAULT, 1, 0 ],
|
||||
MAXDAYS => [ ARG_DEFAULT, 1095 ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my $ini_value = cgiapp_param($$arg_ref{ID});
|
||||
my $end_value = cgiapp_param(strval($$arg_ref{ID}, '_end'));
|
||||
|
||||
if (!is_report()) {
|
||||
my @previous = Add_Delta_YM(Today(), 0, -1);
|
||||
$ini_value = strval('01/', sprintf("%02d", $previous[1]), '/', $previous[0]);
|
||||
$end_value = strval(Days_in_Month($previous[0], $previous[1]), '/', sprintf("%02d", $previous[1]), '/', $previous[0]);
|
||||
}
|
||||
my @ini = split(/\//, $ini_value);
|
||||
my @end = split(/\//, $end_value);
|
||||
my $range = strval($ini_value, ' al ', $end_value);
|
||||
if (($ini[0] == 1) && ($ini[2] == $end[2])) {
|
||||
if (($end[0] == Days_in_Month($ini[2],$ini[1])) && ($ini[1] == $end[1])) {
|
||||
$range = strval($range, ' (', uc(_t('MONTHS', $ini[1])), ' ', $ini[2], ')');
|
||||
}
|
||||
elsif (($ini[1] == 1) && ($end[0] == 31) && ($end[1] == 12)) {
|
||||
$range = strval($range, ' (', _t('YEAR'), ' ', $ini[2], ')');
|
||||
}
|
||||
elsif (($ini[1] == 1) && ($end[0] == 30) && ($end[1] == 6)) {
|
||||
$range = strval($range, ' (', _t('FIRST SEMESTER'), ' ', $ini[2], ')');
|
||||
}
|
||||
elsif (($ini[1] == 7) && ($end[0] == 31) && ($end[1] == 12)) {
|
||||
$range = strval($range, ' (', _t('SECOND SEMESTER'), ' ', $ini[2], ')');
|
||||
}
|
||||
elsif (($ini[1] == 1) && ($end[0] == 30) && ($end[1] == 4)) {
|
||||
$range = strval($range, ' (', _t('FIRST QUARTER'), ' ', $ini[2], ')');
|
||||
}
|
||||
elsif (($ini[1] == 5) && ($end[0] == 31) && ($end[1] == 8)) {
|
||||
$range = strval($range, ' (', _t('SECOND QUARTER'), ' ', $ini[2], ')');
|
||||
}
|
||||
elsif (($ini[1] == 9) && ($end[0] == 31) && ($end[1] == 12)) {
|
||||
$range = strval($range, ' (', _t('THIRD QUARTER'), ' ', $ini[2], ')');
|
||||
}
|
||||
elsif (($ini[1] == 1) && ($end[0] == 31) && ($end[1] == 3)) {
|
||||
$range = strval($range, ' (', _t('FIRST TRIMESTER'), ' ', $ini[2], ')');
|
||||
}
|
||||
elsif (($ini[1] == 4) && ($end[0] == 30) && ($end[1] == 6)) {
|
||||
$range = strval($range, ' (', _t('SECOND TRIMESTER'), ' ', $ini[2], ')');
|
||||
}
|
||||
elsif (($ini[1] == 7) && ($end[0] == 30) && ($end[1] == 9)) {
|
||||
$range = strval($range, ' (', _t('THIRD TRIMESTER'), ' ', $ini[2], ')');
|
||||
}
|
||||
elsif (($ini[1] == 10) && ($end[0] == 31) && ($end[1] == 12)) {
|
||||
$range = strval($range, ' (', _t('FOURTH TRIMESTER'), ' ', $ini[2], ')');
|
||||
}
|
||||
}
|
||||
push(@{$info_ref}, { DATA => $$arg_ref{LABEL_INFO}, VALUE => $range }) if $$arg_ref{INFO};
|
||||
|
||||
# Required stylesheets:
|
||||
Component__Header(ADD => 'CSS', RESOURCE => PACK_DATEPICKER);
|
||||
|
||||
return strval('
|
||||
<div class="form-group form-group-', $ID_DEFAULT, '">
|
||||
<label for="', $$arg_ref{ID}, $$arg_ref{REQUIRED} ? '" class="required">' : '">', $$arg_ref{LABEL}, '</label>
|
||||
<div class="input-group input-daterange" data-provide="datepicker">
|
||||
<input type="text" class="form-control input-lg" id="', $$arg_ref{ID}, '" name="', $$arg_ref{ID}, '" value="', $ini_value, '" autocomplete="off" size=10', $$arg_ref{REQUIRED} ? ' required="required"' : '', ' />
|
||||
<span class="input-group-addon">al</span>
|
||||
<input type="text" class="form-control input-lg" id="', $$arg_ref{ID}, '_end" name="', $$arg_ref{ID}, '_end" value="', $end_value, '" autocomplete="off" size=10', $$arg_ref{REQUIRED} ? ' required="required"' : '', ' />
|
||||
</div>
|
||||
</div>
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__js {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
# Required javascripts:
|
||||
Component__Header(ADD => 'JS', RESOURCE => PACK_DATEPICKER);
|
||||
|
||||
return strval('
|
||||
$(function(){
|
||||
$(".input-group.input-daterange").datepicker({
|
||||
language: "', _t('LANGUAGE_CODE'), '",
|
||||
autoclose: true,
|
||||
todayHighlight: true,
|
||||
disableTouchKeyboard: true,
|
||||
// endDate: "0d",
|
||||
startDate: "01/01/1900" // https://github.com/uxsolutions/bootstrap-datepicker/issues/721#issuecomment-86275874 (workaround)
|
||||
});
|
||||
$("#filter").on("submit", function(e) {
|
||||
if ($("#filter").valid()) {
|
||||
var range = ', $$arg_ref{MAXDAYS}, ';
|
||||
if (Math.round(($("#', $$arg_ref{ID}, '_end").datepicker("getDate") - $("#', $$arg_ref{ID}, '").datepicker("getDate")) / (1000 * 60 * 60 * 24)) > range) {
|
||||
$("#nv").val(1);
|
||||
$("#filter-message").text("', _t('Date ranges greater than <--max--> are not allowed.', max => $$arg_ref{MAXDAYS} % 365 ? strval($$arg_ref{MAXDAYS}, ' ', _t('day(s)')) : strval($$arg_ref{MAXDAYS} / 365, ' ', _t('year(s)'))), '");
|
||||
$("#filter-error").modal();
|
||||
e.preventDefault();
|
||||
return false;
|
||||
}
|
||||
}
|
||||
});
|
||||
});
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
$id = $ID_DEFAULT if is_empty($id);
|
||||
|
||||
my @ini_value = split('/', cgiapp_param($id));
|
||||
my $ini_value = "$ini_value[2]-$ini_value[1]-$ini_value[0]";
|
||||
|
||||
my @end_value = split('/', cgiapp_param(strval($id, '_end')));
|
||||
my $end_value = "$end_value[2]-$end_value[1]-$end_value[0]";
|
||||
|
||||
return ($ini_value, $end_value);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
153
Dam/Components/Controls/Input.pm
Normal file
153
Dam/Components/Controls/Input.pm
Normal file
|
|
@ -0,0 +1,153 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Controls::Input
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $input = Component__Get(CONTROL_INPUT, ['input']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Control para introducir un texto.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Input',
|
||||
ID => 'input' (default),
|
||||
INFO => 1 (show info in header; default) or 0 (don't show),
|
||||
LABEL => 'Enter text' (default),
|
||||
LABEL_INFO => 'Input text' (default),
|
||||
REQUIRED => 1 (control required; default) or 0 (not required)
|
||||
ONLY => 'All' (allows any alphanumeric character; default) ó 'Digits'
|
||||
(allow only numbers)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Controls::Input;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Control__html Control__js Get
|
||||
);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'input';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
INFO => [ ARG_DEFAULT, 1, 0 ],
|
||||
LABEL => [ ARG_DEFAULT, _t('Enter text') ],
|
||||
LABEL_INFO => [ ARG_DEFAULT, _t('Input text') ],
|
||||
REQUIRED => [ ARG_DEFAULT, 1, 0 ],
|
||||
ONLY => [ ARG_DEFAULT, 'All', 'Digits' ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my $input_value = cgiapp_param($$arg_ref{ID});
|
||||
|
||||
push(@{$info_ref}, { DATA => $$arg_ref{LABEL_INFO}, VALUE => $input_value }) if !is_empty($input_value);
|
||||
|
||||
return strval('
|
||||
<div class="form-group form-group-', $ID_DEFAULT, '">
|
||||
<label for="', $$arg_ref{ID}, $$arg_ref{REQUIRED} ? '" class="required">' : '">', $$arg_ref{LABEL}, '</label>
|
||||
<div class="form-div form-control-', $ID_DEFAULT, '">
|
||||
<input type="input" class="form-control input-lg" id="', $$arg_ref{ID}, '" name="', $$arg_ref{ID}, '"', !is_empty($input_value) ? strval(' value = "', $input_value, '"') : '', $$arg_ref{REQUIRED} ? ' required="required"' : '', ' />
|
||||
</div>
|
||||
</div>
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__js {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
return is_eq($$arg_ref{ONLY}, 'Digits') ? strval('
|
||||
$(function(){
|
||||
$.fn.inputFilter = function(inputFilter) {
|
||||
return this.on("input keydown keyup mousedown mouseup select contextmenu drop", function() {
|
||||
if (inputFilter(this.value)) {
|
||||
this.oldValue = this.value;
|
||||
this.oldSelectionStart = this.selectionStart;
|
||||
this.oldSelectionEnd = this.selectionEnd;
|
||||
} else if (this.hasOwnProperty("oldValue")) {
|
||||
this.value = this.oldValue;
|
||||
this.setSelectionRange(this.oldSelectionStart, this.oldSelectionEnd);
|
||||
}
|
||||
});
|
||||
};
|
||||
$("#', $$arg_ref{ID}, '").inputFilter(function(value) {
|
||||
return /^\d*$/.test(value);
|
||||
});
|
||||
});
|
||||
') : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
$id = $ID_DEFAULT if is_empty($id);
|
||||
|
||||
return cgiapp_param($id);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
177
Dam/Components/Controls/Month.pm
Normal file
177
Dam/Components/Controls/Month.pm
Normal file
|
|
@ -0,0 +1,177 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Controls::Month
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my ($year, $month) = Component__Get(CONTROL_MONTH, ['month']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Control para seleccionar un mes del año.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Month',
|
||||
ID => 'month' (default),
|
||||
INFO => 1 (show info in header; default) or 0 (don't show),
|
||||
LABEL => 'Month' (default),
|
||||
LABEL_INFO => Same as LABEL (default),
|
||||
REQUIRED => 1 (control required; default) or 0 (not required)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Controls::Month;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Control__html Control__js Get
|
||||
);
|
||||
|
||||
use Date::Calc qw(Today);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
use Dam::Var;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'month';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
$$arg_ref{LABEL} = _t('Month') if is_empty($$arg_ref{LABEL});
|
||||
$$arg_ref{LABEL_INFO} = $$arg_ref{LABEL} if is_empty($$arg_ref{LABEL_INFO});
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
INFO => [ ARG_DEFAULT, 1, 0 ],
|
||||
LABEL => [ ARG_REQUIRED ],
|
||||
LABEL_INFO => [ ARG_REQUIRED ],
|
||||
REQUIRED => [ ARG_DEFAULT, 1, 0 ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my $value = cgiapp_param($$arg_ref{ID});
|
||||
|
||||
my @today = Today();
|
||||
my ($month_name, $month_value, $year_value) = ('', $today[1], $today[0]);
|
||||
|
||||
if (!is_report() || is_empty($value)) {
|
||||
if ($month_value == 1) {
|
||||
$month_value = 12;
|
||||
$year_value--;
|
||||
}
|
||||
else {
|
||||
$month_value--;
|
||||
}
|
||||
$month_name = _t('MONTHS', $month_value);
|
||||
}
|
||||
else {
|
||||
($month_name, $year_value) = split(/ /, $value);
|
||||
$month_value = _t('MONTHS', $month_name);
|
||||
}
|
||||
push(@{$info_ref}, { DATA => $$arg_ref{LABEL_INFO}, VALUE => "$month_name $year_value" }) if $$arg_ref{INFO};
|
||||
|
||||
# Required stylesheets:
|
||||
Component__Header(ADD => 'CSS', RESOURCE => PACK_DATEPICKER);
|
||||
|
||||
return strval('
|
||||
<div class="form-group form-group-', $ID_DEFAULT, '">
|
||||
<label for="', $$arg_ref{ID}, $$arg_ref{REQUIRED} ? '" class="required">' : '">', $$arg_ref{LABEL}, '</label>
|
||||
<input type="text" class="form-control input-lg input-date-month" data-provide="datepicker" id="', $$arg_ref{ID}, '" name="', $$arg_ref{ID}, '" value="', $month_name, ' ', $year_value, '" autocomplete="off" size=4', $$arg_ref{REQUIRED} ? ' required="required"' : '', ' />
|
||||
</div>
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__js {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my @today = Today();
|
||||
|
||||
# Required javascripts:
|
||||
Component__Header(ADD => 'JS', RESOURCE => PACK_DATEPICKER);
|
||||
|
||||
return strval('
|
||||
$(function(){
|
||||
$("#', $$arg_ref{ID}, '").datepicker({
|
||||
language: "', _t('LANGUAGE_CODE'), '",
|
||||
autoclose: true,
|
||||
todayHighlight: true,
|
||||
disableTouchKeyboard: true,
|
||||
minViewMode: "months",
|
||||
format: "MM yyyy",
|
||||
endDate: "', $today[1] - 1, '-', $today[0], '"
|
||||
});
|
||||
});
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
$id = $ID_DEFAULT if is_empty($id);
|
||||
|
||||
my $value = cgiapp_param($id);
|
||||
return (undef, undef) if is_empty($value);
|
||||
my ($month_name, $year_value) = split(/ /, $value);
|
||||
my $month_value = _t('MONTHS', $month_name);
|
||||
return ($year_value, $month_value);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
161
Dam/Components/Controls/MultiCheck.pm
Normal file
161
Dam/Components/Controls/MultiCheck.pm
Normal file
|
|
@ -0,0 +1,161 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Controls::MultiCheck
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my ($check_1, $check_2, ...) = Component__Get(CONTROL_MULTICHECK, ['multicheck']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Control para seleccionar una o más opciones de una lista.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'MultiCheck',
|
||||
ID => 'multicheck' (default),
|
||||
INFO => 1 (show info in header; default) or 0 (don't show),
|
||||
LABEL => 'MultiCheck' (default),
|
||||
LABEL_INFO => Same as LABEL (default),
|
||||
REQUIRED => 1 (control required; default) or 0 (not required)
|
||||
MULTIPLE => 1 (allows to select any number of options; default) or 0 (allows
|
||||
to select only one option),
|
||||
OPTIONS => { 'op1' => 'Option 1', 'op2' => 'Option 2' } (default); you can
|
||||
use { ..., 'opN' => _DIVIDER_, ... } to include separators
|
||||
between the options according to order,
|
||||
DEFAULT => Default option(s), e.g. "'op1'" or "'op1','op3'"
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Controls::MultiCheck;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Control__html Control__js Get
|
||||
);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'multicheck';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
$$arg_ref{LABEL} = 'MultiCheck' if is_empty($$arg_ref{LABEL});
|
||||
$$arg_ref{LABEL_INFO} = $$arg_ref{LABEL} if is_empty($$arg_ref{LABEL_INFO});
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
INFO => [ ARG_DEFAULT, 1, 0 ],
|
||||
LABEL => [ ARG_REQUIRED ],
|
||||
LABEL_INFO => [ ARG_REQUIRED ],
|
||||
REQUIRED => [ ARG_DEFAULT, 1, 0 ],
|
||||
MULTIPLE => [ ARG_DEFAULT, 1, 0 ],
|
||||
OPTIONS => [ ARG_DEFAULT, { 'op1' => strval(_t('Option'), ' 1'), 'op2' => strval(_t('Option'), ' 2') } ],
|
||||
DEFAULT => [ ARG_OPTIONAL ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my $multicheck_value = !is_report() && !is_empty($$arg_ref{DEFAULT}) ? $$arg_ref{DEFAULT} : strval_join(',', cgiapp_param($$arg_ref{ID}));
|
||||
|
||||
my $form_group = 'form-group';
|
||||
|
||||
my $list_opts = '';
|
||||
my $info_opts = '';
|
||||
my $count_opts = 0;
|
||||
for my $key (sort keys(%{$$arg_ref{OPTIONS}})) {
|
||||
if (is_eq(${$$arg_ref{OPTIONS}}{$key}, _DIVIDER_)) {
|
||||
$list_opts .= '<option data-divider="true"></option>';
|
||||
}
|
||||
else {
|
||||
my $checked = defined($multicheck_value) && index($multicheck_value, $key) >= 0;
|
||||
my $selected = $checked ? '" selected="selected">' : '">';
|
||||
$list_opts .= strval('<option value="\'', $key, '\'" title="', ${$$arg_ref{OPTIONS}}{$key}, $selected, ${$$arg_ref{OPTIONS}}{$key}, '</option>');
|
||||
$form_group .= ' form-group-smaller' if $count_opts++ == 14;
|
||||
$info_opts .= ' ' if $checked && !is_empty($info_opts);
|
||||
$info_opts .= strval(${$$arg_ref{OPTIONS}}{$key}, ',') if $checked;
|
||||
}
|
||||
}
|
||||
chop($info_opts) if !is_empty($info_opts);
|
||||
push(@{$info_ref}, { DATA => $$arg_ref{LABEL_INFO}, VALUE => $info_opts }) if $$arg_ref{INFO} && length($info_opts);
|
||||
|
||||
# Required stylesheets:
|
||||
Component__Header(ADD => 'CSS', RESOURCE => PACK_SELECT);
|
||||
|
||||
return strval('
|
||||
<div class="', $form_group, ' form-group-', $ID_DEFAULT, ' form-selectpicker">
|
||||
<label for="', $$arg_ref{ID}, $$arg_ref{REQUIRED} ? '" class="required">' : '">', $$arg_ref{LABEL}, '</label>
|
||||
<select class="form-control input-lg selectpicker" id="', $$arg_ref{ID}, '" name="', $$arg_ref{ID}, '" multiple="multiple"', !$$arg_ref{MULTIPLE} ? ' data-max-options="1"' : '', ' data-selected-text-format="count > 2"', $$arg_ref{REQUIRED} ? ' required="required">' : '>', $list_opts, '</select>
|
||||
</div>
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__js {
|
||||
# Required javascripts:
|
||||
Component__Header(ADD => 'JS', RESOURCE => PACK_SELECT);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
$id = $ID_DEFAULT if is_empty($id);
|
||||
|
||||
return strval_join(',', cgiapp_param($id));
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
138
Dam/Components/Controls/Option.pm
Normal file
138
Dam/Components/Controls/Option.pm
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Controls::Option
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $option = Component__Get(CONTROL_OPTION, ['option']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Control para seleccionar una opción de una lista sencilla.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Option',
|
||||
ID => 'opt' (default),
|
||||
INFO => 1 (show info in header; default) or 0 (don't show),
|
||||
LABEL => 'Options' (default),
|
||||
LABEL_INFO => Same as LABEL (default),
|
||||
REQUIRED => 1 (control required; default) or 0 (not required)
|
||||
OPTIONS => { 'op1' => 'Option 1', 'op2' => 'Option 2' } (default)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Controls::Option;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Control__html Control__js Get
|
||||
);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'option';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
$$arg_ref{LABEL} = _t('Options') if is_empty($$arg_ref{LABEL});
|
||||
$$arg_ref{LABEL_INFO} = $$arg_ref{LABEL} if is_empty($$arg_ref{LABEL_INFO});
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
INFO => [ ARG_DEFAULT, 1, 0 ],
|
||||
LABEL => [ ARG_REQUIRED ],
|
||||
LABEL_INFO => [ ARG_REQUIRED ],
|
||||
REQUIRED => [ ARG_DEFAULT, 1, 0 ],
|
||||
OPTIONS => [ ARG_DEFAULT, { 'op1' => strval(_t('Option'), ' 1'), 'op2' => strval(_t('Option'), ' 2') } ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my $opt_value = cgiapp_param($$arg_ref{ID});
|
||||
|
||||
my $list_opts = $$arg_ref{REQUIRED} ? '' : strval('<option value="" title=""></option>');
|
||||
for my $key (sort keys(%{$$arg_ref{OPTIONS}})) {
|
||||
my $selected = '">';
|
||||
if (is_eq($opt_value, $key)) {
|
||||
$selected = '" selected="selected">';
|
||||
push(@{$info_ref}, { DATA => $$arg_ref{LABEL_INFO}, VALUE => ${$$arg_ref{OPTIONS}}{$key} }) if $$arg_ref{INFO};
|
||||
}
|
||||
$list_opts .= strval('<option value="', $key, '" title="', ${$$arg_ref{OPTIONS}}{$key}, $selected, ${$$arg_ref{OPTIONS}}{$key}, '</option>');
|
||||
}
|
||||
|
||||
return strval('
|
||||
<div class="form-group form-group-', $ID_DEFAULT, '">
|
||||
<label for="', $$arg_ref{ID}, $$arg_ref{REQUIRED} ? '" class="required">' : '">', $$arg_ref{LABEL}, '</label>
|
||||
<select class="form-control input-lg" id="', $$arg_ref{ID}, '" name="', $$arg_ref{ID}, '"', $$arg_ref{REQUIRED} ? ' required="required">' : '>', $list_opts, '</select>
|
||||
</div>
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__js {
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
$id = $ID_DEFAULT if is_empty($id);
|
||||
|
||||
return cgiapp_param($id);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
184
Dam/Components/Controls/Upload.pm
Normal file
184
Dam/Components/Controls/Upload.pm
Normal file
|
|
@ -0,0 +1,184 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Controls::Upload
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my ($filehandle, $filename, $filetype) = Component__Get(CONTROL_UPLOAD, ['upload']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Control para subir un archivo al servidor.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Upload',
|
||||
ID => 'upload' (default),
|
||||
INFO => 1 (show info in header; default) or 0 (don't show),
|
||||
LABEL => 'Upload file' (default),
|
||||
LABEL_INFO => 'File' (default),
|
||||
REQUIRED => 1 (control required; default) or 0 (not required)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Controls::Upload;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Control__html Control__js Get
|
||||
);
|
||||
|
||||
use File::Copy qw(copy);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::Debug;
|
||||
use Dam::DamLogic;
|
||||
use Dam::Var;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'upload';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
INFO => [ ARG_DEFAULT, 1, 0 ],
|
||||
LABEL => [ ARG_DEFAULT, _t('Upload file') ],
|
||||
LABEL_INFO => [ ARG_DEFAULT, _t('File') ],
|
||||
REQUIRED => [ ARG_DEFAULT, 1, 0 ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
# Previous file info:
|
||||
my $filename = cgiapp_param(strval($$arg_ref{ID}, '_name')) || '';
|
||||
my $filesafe = cgiapp_param(strval($$arg_ref{ID}, '_safe')) || '';
|
||||
my $filetype = cgiapp_param(strval($$arg_ref{ID}, '_type')) || '';
|
||||
if (!is_empty($filename)) {
|
||||
report_info(_t('If no other file is selected, then <--file--> previously uploaded will be used.', file => strval('<strong>', $filename, '</strong>')));
|
||||
}
|
||||
|
||||
push(@{$info_ref}, { DATA => $$arg_ref{LABEL_INFO}, VALUE => $filename }) if $$arg_ref{INFO} && !is_empty($filename);
|
||||
|
||||
return strval('
|
||||
<div class="form-group form-group-', $ID_DEFAULT, '">
|
||||
<label for="', $$arg_ref{ID}, $$arg_ref{REQUIRED} ? '" class="required">' : '">', $$arg_ref{LABEL}, '</label>
|
||||
<div class="form-div form-control-', $ID_DEFAULT, '">
|
||||
<input type="file" class="form-control input-lg" id="', $$arg_ref{ID}, '" name="', $$arg_ref{ID}, '"', $$arg_ref{REQUIRED} ? ' required="required"' : '', ' />
|
||||
<input type="hidden" id="', $$arg_ref{ID}, '_name" name="', $$arg_ref{ID}, '_name" value="', $filename, '" />
|
||||
<input type="hidden" id="', $$arg_ref{ID}, '_safe" name="', $$arg_ref{ID}, '_safe" value="', $filesafe, '" />
|
||||
<input type="hidden" id="', $$arg_ref{ID}, '_type" name="', $$arg_ref{ID}, '_type" value="', $filetype, '" />
|
||||
</div>
|
||||
</div>
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__js {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
return strval('
|
||||
$(function(){
|
||||
if ($("#', $$arg_ref{ID}, '_name").val()) {
|
||||
$("#', $$arg_ref{ID}, '").prop("required", false);
|
||||
}
|
||||
});
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
$id = $ID_DEFAULT if is_empty($id);
|
||||
|
||||
# File handler:
|
||||
my $filehandle = cgiapp_upload($id);
|
||||
|
||||
# File name:
|
||||
my $filename = cgiapp_param($id);
|
||||
my $filesafe = $filename;
|
||||
|
||||
# File type:
|
||||
my $filetype = !is_empty($filename) ? cgiapp_uploadInfo($filename)->{'Content-Type'} : undef;
|
||||
|
||||
if ($filehandle) {
|
||||
my $safe_characters = "a-zA-Z0-9_.-";
|
||||
$filesafe =~ tr/ /_/;
|
||||
$filesafe =~ s/[^$safe_characters]//g;
|
||||
if ($filesafe =~ /^([$safe_characters]+)$/) {
|
||||
$filesafe = strval('file-', time(), '_', $1);
|
||||
if (copy($filehandle, strval(CONFIG('DIR_UPLOADS'), '/', $filesafe)) && open($filehandle, '<', strval(CONFIG('DIR_UPLOADS'), '/', $filesafe))) {
|
||||
cgiapp_param(strval($id, '_name'), $filename);
|
||||
cgiapp_param(strval($id, '_safe'), $filesafe);
|
||||
cgiapp_param(strval($id, '_type'), $filetype);
|
||||
return ($filehandle, $filename, $filetype);
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$filename = cgiapp_param(strval($id, '_name'));
|
||||
$filesafe = cgiapp_param(strval($id, '_safe'));
|
||||
$filetype = cgiapp_param(strval($id, '_type'));
|
||||
if (!is_empty($filesafe) && open($filehandle, '<', strval(CONFIG('DIR_UPLOADS'), '/', $filesafe))) {
|
||||
return ($filehandle, $filename, $filetype);
|
||||
}
|
||||
}
|
||||
|
||||
return (undef, undef, undef);
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
160
Dam/Components/Controls/Year.pm
Normal file
160
Dam/Components/Controls/Year.pm
Normal file
|
|
@ -0,0 +1,160 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Controls::Year
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $year = Component__Get(CONTROL_YEAR, ['year']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Control para seleccionar un año.
|
||||
|
||||
=head1 ARGUMENTS
|
||||
|
||||
(
|
||||
TYPE => 'Year',
|
||||
ID => 'year' (default),
|
||||
INFO => 1 (show info in header; default) or 0 (don't show),
|
||||
LABEL => 'Year' (default),
|
||||
LABEL_INFO => Same as LABEL (default),
|
||||
REQUIRED => 1 (control required; default) or 0 (not required)
|
||||
)
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Controls::Year;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Control__html Control__js Get
|
||||
);
|
||||
|
||||
use Date::Calc qw(Today);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::DamLogic;
|
||||
|
||||
|
||||
|
||||
my $ID_DEFAULT = 'year';
|
||||
|
||||
|
||||
|
||||
sub __arguments {
|
||||
my $arg_ref = shift;
|
||||
|
||||
$$arg_ref{LABEL} = _t('Year') if is_empty($$arg_ref{LABEL});
|
||||
$$arg_ref{LABEL_INFO} = $$arg_ref{LABEL} if is_empty($$arg_ref{LABEL_INFO});
|
||||
|
||||
check_arguments($arg_ref,
|
||||
TYPE => [ ARG_REQUIRED ],
|
||||
ID => [ ARG_DEFAULT, $ID_DEFAULT ],
|
||||
INFO => [ ARG_DEFAULT, 1, 0 ],
|
||||
LABEL => [ ARG_REQUIRED ],
|
||||
LABEL_INFO => [ ARG_REQUIRED ],
|
||||
REQUIRED => [ ARG_DEFAULT, 1, 0 ]
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__html {
|
||||
my ($self, $arg_ref, $info_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my $year_value = cgiapp_param($$arg_ref{ID});
|
||||
|
||||
if (!is_report()) {
|
||||
my @today = Today();
|
||||
$year_value = $today[0];
|
||||
}
|
||||
push(@{$info_ref}, { DATA => $$arg_ref{LABEL_INFO}, VALUE => $year_value }) if $$arg_ref{INFO};
|
||||
|
||||
# Required stylesheets:
|
||||
Component__Header(ADD => 'CSS', RESOURCE => PACK_DATEPICKER);
|
||||
|
||||
return strval('
|
||||
<div class="form-group form-group-', $ID_DEFAULT, '">
|
||||
<label for="', $$arg_ref{ID}, $$arg_ref{REQUIRED} ? '" class="required">' : '">', $$arg_ref{LABEL}, '</label>
|
||||
<input type="text" class="form-control input-lg input-date-year" data-provide="datepicker" id="', $$arg_ref{ID}, '" name="', $$arg_ref{ID}, '" value="', $year_value, '" autocomplete="off" size=4', $$arg_ref{REQUIRED} ? ' required="required"' : '', ' />
|
||||
</div>
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Control__js {
|
||||
my ($self, $arg_ref) = @_;
|
||||
|
||||
__arguments($arg_ref);
|
||||
|
||||
my @today = Today();
|
||||
|
||||
# Required javascripts:
|
||||
Component__Header(ADD => 'JS', RESOURCE => PACK_DATEPICKER);
|
||||
|
||||
return strval('
|
||||
$(function(){
|
||||
$("#', $$arg_ref{ID}, '").datepicker({
|
||||
language: "', _t('LANGUAGE_CODE'), '",
|
||||
autoclose: true,
|
||||
todayHighlight: true,
|
||||
disableTouchKeyboard: true,
|
||||
minViewMode: "years",
|
||||
format: "yyyy",
|
||||
endDate: "', $today[0], '"
|
||||
});
|
||||
});
|
||||
');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub Get {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
$id = $ID_DEFAULT if is_empty($id);
|
||||
|
||||
my $value = cgiapp_param($id);
|
||||
return !is_empty($value) ? $value : undef;
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
46
Dam/Components/Templates/About.tmpl.html
Normal file
46
Dam/Components/Templates/About.tmpl.html
Normal file
|
|
@ -0,0 +1,46 @@
|
|||
<div class="jumbotron hemotron">
|
||||
<div style="float: right;"><TMPL_VAR VERSION></div>
|
||||
<h1><TMPL_VAR APP_NAME></h1>
|
||||
<p><TMPL_VAR APP_SLOGAN></p>
|
||||
|
||||
<TMPL_IF GLOBAL_WARNING>
|
||||
<br /><div class="alert alert-warning" role="alert"><TMPL_VAR GLOBAL_WARNING></div>
|
||||
</TMPL_IF>
|
||||
|
||||
<TMPL_IF CHANGELOG_LAST>
|
||||
<br />
|
||||
<div class="panel panel-default">
|
||||
<!-- Nav tabs -->
|
||||
<ul id="changelog" class="nav nav-tabs" role="tablist">
|
||||
<li role="presentation" class="active"><a href="#home" aria-controls="home" role="tab" data-toggle="tab"><TMPL_VAR T_VERSION_NEWS></a></li>
|
||||
<li role="presentation"><a href="#profile" aria-controls="profile" role="tab" data-toggle="tab"><TMPL_VAR T_VERSION_PREV></a></li>
|
||||
</ul>
|
||||
<!-- Tab panes -->
|
||||
<div class="tab-content">
|
||||
<div role="tabpanel" class="tab-pane fade in active" id="home">
|
||||
<div class="panel-body">
|
||||
<ul class="changelog-list"><TMPL_LOOP CHANGELOG_LAST>
|
||||
<TMPL_VAR ITEM></TMPL_LOOP>
|
||||
</ul>
|
||||
</div>
|
||||
</div>
|
||||
<TMPL_IF CHANGELOG_PREV>
|
||||
<div role="tabpanel" class="tab-pane fade" id="profile">
|
||||
<div class="panel-body">
|
||||
<ul class="changelog-list"><TMPL_LOOP CHANGELOG_PREV>
|
||||
<TMPL_VAR ITEM></TMPL_LOOP>
|
||||
</ul>
|
||||
</div>
|
||||
</div>
|
||||
</TMPL_IF>
|
||||
</div>
|
||||
<script type="text/javascript">
|
||||
$('#changelog a').click(function (e) {
|
||||
e.preventDefault();
|
||||
$(this).tab('show');
|
||||
});
|
||||
</script>
|
||||
</div>
|
||||
</TMPL_IF>
|
||||
|
||||
</div>
|
||||
14
Dam/Components/Templates/Debug.tmpl.html
Normal file
14
Dam/Components/Templates/Debug.tmpl.html
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
<TMPL_IF DEBUG>
|
||||
<div class="panel panel-default hidden-print">
|
||||
<div class="panel-heading">
|
||||
<h4 class="panel-title">
|
||||
<strong><span class="glyphicon glyphicon-wrench"></span> <a data-toggle="collapse" data-target="#debug-info" onClick="return false;" style="cursor: pointer;">DEBUG</a></strong>
|
||||
</h4>
|
||||
</div>
|
||||
<div id="debug-info" class="panel-collapse collapse">
|
||||
<div class="panel-body">
|
||||
<TMPL_VAR DEBUG>
|
||||
</div>
|
||||
</div>
|
||||
</div>
|
||||
</TMPL_IF>
|
||||
5
Dam/Components/Templates/Error403.tmpl.html
Normal file
5
Dam/Components/Templates/Error403.tmpl.html
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
<div class="jumbotron hemotron">
|
||||
<h1><TMPL_VAR APP_NAME></h1>
|
||||
<h2><span class="glyphicon glyphicon-eye-close"></span> <TMPL_VAR T_ATTENTION> <TMPL_VAR T_UNAUTHORIZED_ACCESS> </h2>
|
||||
<p><TMPL_VAR T_REPORT_WITHOUT_ACCESS> <TMPL_VAR T_CONTACT_ADMINISTRATOR></p>
|
||||
</div>
|
||||
5
Dam/Components/Templates/Error500.tmpl.html
Normal file
5
Dam/Components/Templates/Error500.tmpl.html
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
<div class="jumbotron hemotron">
|
||||
<h1><TMPL_VAR APP_NAME></h1>
|
||||
<h2><span class="glyphicon glyphicon-eye-close"></span> <TMPL_VAR T_ATTENTION> <TMPL_VAR T_UNEXPECTED_ERROR></h2>
|
||||
<p><TMPL_VAR T_ERROR_DURING_EXECUTION> <TMPL_VAR T_CONTACT_ADMINISTRATOR></p>
|
||||
</div>
|
||||
72
Dam/Components/Templates/Filter.tmpl.html
Normal file
72
Dam/Components/Templates/Filter.tmpl.html
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
<input type="hidden" name="xt" id="xt" value="<TMPL_VAR FIRSTTIME>" />
|
||||
<input type="hidden" name="rm" id="rm" value="<TMPL_VAR RUN_MODE>" />
|
||||
<input type="hidden" name="dm" id="dm" value="" />
|
||||
<input type="hidden" name="nv" id="nv" value="" />
|
||||
|
||||
<div class="panel panel-info panel-filter hidden-print">
|
||||
<div class="panel-heading"><TMPL_VAR FILTER_TITLE></div>
|
||||
<div class="panel-body">
|
||||
|
||||
<div class="modal fade" tabindex="-1" id="filter-error">
|
||||
<div class="modal-dialog"><div class="modal-content"><div class="modal-body">
|
||||
<button type="button" class="close" data-dismiss="modal"><span>×</span></button>
|
||||
<h3><strong><TMPL_VAR T_WATCH_OUT></strong></h3><h4 id="filter-message"></h4>
|
||||
<p class="text-right"><button type="button" class="btn btn-default" data-dismiss="modal"><TMPL_VAR T_CLOSE></button></p>
|
||||
</div></div></div>
|
||||
</div>
|
||||
|
||||
<TMPL_IF DESCRIPTION><p class="description"><TMPL_VAR DESCRIPTION></p></TMPL_IF>
|
||||
|
||||
<TMPL_LOOP FILTER_CONTROLS><TMPL_VAR CONTROL></TMPL_LOOP>
|
||||
|
||||
<div class="form-group filter-buttons"><TMPL_LOOP FILTER_ACTIONS><TMPL_VAR ACTION></TMPL_LOOP>
|
||||
</div>
|
||||
|
||||
<TMPL_IF REPORT_ERROR>
|
||||
<div class="alert alert-danger hidden-print" role="alert"><TMPL_VAR REPORT_ERROR></div>
|
||||
</TMPL_IF>
|
||||
<TMPL_IF REPORT_WARNING>
|
||||
<div class="alert alert-warning hidden-print" role="alert"><TMPL_VAR REPORT_WARNING></div>
|
||||
</TMPL_IF>
|
||||
<TMPL_IF REPORT_INFO>
|
||||
<div class="alert alert-info hidden-print" role="alert"><TMPL_VAR REPORT_INFO></div>
|
||||
</TMPL_IF>
|
||||
|
||||
</div>
|
||||
</div>
|
||||
|
||||
<script type="text/javascript">
|
||||
$(function(){
|
||||
$("#filter").validate();
|
||||
});
|
||||
<TMPL_LOOP FILTER_JS><TMPL_VAR JAVASCRIPT></TMPL_LOOP>
|
||||
</script>
|
||||
|
||||
|
||||
<div class="panel panel-default panel-informa visible-print-block">
|
||||
<div class="panel-heading"><TMPL_VAR APP_NAME></div>
|
||||
<table class="table table-bordered table-condensed">
|
||||
<tbody>
|
||||
<tr>
|
||||
<td style="width: 20%;"> <TMPL_VAR T_REPORT>: </td>
|
||||
<td> <TMPL_VAR REPORT> </td>
|
||||
</tr><TMPL_IF DESCRIPTION><tr>
|
||||
<td> <TMPL_VAR T_DESCRIPTION>: </td>
|
||||
<td> <TMPL_VAR DESCRIPTION> </td>
|
||||
</tr></TMPL_IF><tr>
|
||||
<td> <TMPL_VAR T_EDITION_DATE>: </td>
|
||||
<td> <TMPL_VAR TODAY> </td>
|
||||
</tr><tr>
|
||||
<td> <TMPL_VAR T_REQUESTED_BY>: </td>
|
||||
<td> <TMPL_VAR USER> </td>
|
||||
|
||||
<TMPL_LOOP FILTER_OPTIONS>
|
||||
</tr><tr>
|
||||
<td> <TMPL_VAR DATA>: </td>
|
||||
<td> <TMPL_VAR VALUE> </td>
|
||||
</TMPL_LOOP>
|
||||
|
||||
</tr>
|
||||
</tbody>
|
||||
</table>
|
||||
</div>
|
||||
39
Dam/Components/Templates/Footer.tmpl.html
Normal file
39
Dam/Components/Templates/Footer.tmpl.html
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
<TMPL_IF DEBUG_MODE>
|
||||
<div class="container hidden-print">
|
||||
<div class="alert alert-info" role="alert" style="text-align: center;">
|
||||
<strong><TMPL_VAR T_ATTENTION> <TMPL_VAR T_WARNING_MODE></strong>
|
||||
</div>
|
||||
</div>
|
||||
</TMPL_IF>
|
||||
|
||||
<a href="#" class="scrollup">Arriba</a>
|
||||
|
||||
<footer>
|
||||
<div class="container">
|
||||
<p class="copyright"> <TMPL_VAR FOOTER_COPYRIGHT> </p>
|
||||
<p class="today"> <TMPL_VAR TODAY> </p>
|
||||
</div>
|
||||
</footer>
|
||||
|
||||
<TMPL_IF CHECK_BROWSER>
|
||||
<div id="outdated">
|
||||
<h6><TMPL_VAR T_OLD_BROWSER></h6>
|
||||
<p><TMPL_VAR T_UPDATE_BROWSER> <a id="btnUpdateBrowser" href="http://outdatedbrowser.com/es"><TMPL_VAR T_UPDATE_NOW></a>.</p>
|
||||
<p class="last"><a href="#" id="btnCloseUpdateBrowser" title="<TMPL_VAR T_CLOSE>">×</a></p>
|
||||
</div>
|
||||
|
||||
<script type="text/javascript">
|
||||
<!--
|
||||
outdatedBrowser({
|
||||
bgColor: '#f25648',
|
||||
color: '#ffffff',
|
||||
lowerThan: 'boxShadow',
|
||||
languagePath: ''
|
||||
});
|
||||
// -->
|
||||
</script>
|
||||
</TMPL_IF>
|
||||
|
||||
</body>
|
||||
|
||||
</html>
|
||||
34
Dam/Components/Templates/Header.tmpl.html
Normal file
34
Dam/Components/Templates/Header.tmpl.html
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
<!DOCTYPE html>
|
||||
<html lang="<TMPL_VAR LANGUAGE_CODE>" dir="ltr">
|
||||
|
||||
<head>
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
|
||||
<link rel="shortcut icon" href="<TMPL_VAR ROOT_WWW>/favicon.ico" type="image/x-icon" />
|
||||
<title><TMPL_VAR TITLE></title>
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1, maximum-scale=1" />
|
||||
<meta http-equiv="X-UA-Compatible" content="IE=edge" />
|
||||
<TMPL_LOOP STYLESHEETS>
|
||||
<link rel="stylesheet" href="<TMPL_VAR ROOT_WWW><TMPL_VAR RESOURCE><TMPL_IF VERSION>?v=<TMPL_VAR VERSION></TMPL_IF>" type="text/css" /><TMPL_IF DEBUG_MODE> <!-- Priority <TMPL_VAR PRIORITY> --></TMPL_IF></TMPL_LOOP>
|
||||
<TMPL_LOOP JAVASCRIPTS>
|
||||
<script src="<TMPL_VAR ROOT_WWW><TMPL_VAR RESOURCE><TMPL_IF VERSION>?v=<TMPL_VAR VERSION></TMPL_IF>"<TMPL_IF CHARSET> charset="<TMPL_VAR CHARSET>"</TMPL_IF>></script><TMPL_IF DEBUG_MODE> <!-- Priority <TMPL_VAR PRIORITY> --></TMPL_IF></TMPL_LOOP>
|
||||
<TMPL_IF CHECK_BROWSER>
|
||||
<link rel="stylesheet" href="<TMPL_VAR ROOT_WWW>/dam/css/outdatedbrowser.min.css?v=1.1.5" type="text/css" />
|
||||
<script src="<TMPL_VAR ROOT_WWW>/dam/js/outdatedbrowser.min.js?v=1.1.5"></script>
|
||||
</TMPL_IF>
|
||||
|
||||
<!--[if lt IE 9]>
|
||||
<link rel="stylesheet" media="all" href="<TMPL_VAR ROOT_WWW>/dam/css/ie8.css" type="text/css" />
|
||||
<script src="<TMPL_VAR ROOT_WWW>/dam/js/respond.min.js"></script>
|
||||
<script src="<TMPL_VAR ROOT_WWW>/dam/js/html5shiv.min.js"></script>
|
||||
<![endif]-->
|
||||
</head>
|
||||
|
||||
<body<TMPL_IF BODY_CLASSES> class="<TMPL_VAR BODY_CLASSES>"</TMPL_IF>>
|
||||
|
||||
<div id="loading"></div>
|
||||
|
||||
<TMPL_IF GLOBAL_ERROR>
|
||||
<div class="container fatal-error">
|
||||
<div class="alert alert-danger" role="alert"><TMPL_VAR GLOBAL_ERROR></div>
|
||||
</div>
|
||||
</TMPL_IF>
|
||||
26
Dam/Components/Templates/Login.tmpl.html
Normal file
26
Dam/Components/Templates/Login.tmpl.html
Normal file
|
|
@ -0,0 +1,26 @@
|
|||
<h1 class="login-heading"><TMPL_VAR APP_NAME></h1>
|
||||
|
||||
<form name="login" method="post" class="form-login" onsubmit="
|
||||
document.login.pass.value=encrypt(document.login.hide.value,document.login.key.value);
|
||||
document.login.hide.value=document.login.pass.value.substr(0,document.login.hide.value.length);
|
||||
">
|
||||
|
||||
<input type="hidden" name="rm" value="APP_confirm" />
|
||||
<input type="hidden" name="key" value="<TMPL_VAR KEY>" />
|
||||
<input type="hidden" name="pass" value="" />
|
||||
|
||||
<label for="user" class="sr-only"> <TMPL_VAR T_USERNAME> </label>
|
||||
<input type="text" class="form-control" name="user" placeholder="<TMPL_VAR T_USERNAME>" maxlength="20" value="<TMPL_VAR LOGIN>" required autofocus />
|
||||
<label for="pass" class="sr-only"> <TMPL_VAR T_PASSWORD> </label>
|
||||
<input type="password" class="form-control" name="hide" placeholder="<TMPL_VAR T_PASSWORD>" maxlength="20" required />
|
||||
<button type="submit" class="btn btn-lg btn-primary btn-block"> <TMPL_VAR T_LOGIN> </button>
|
||||
|
||||
<TMPL_IF ERROR>
|
||||
<br /><br /><div class="alert alert-danger" role="alert">
|
||||
<h4> <TMPL_VAR ERROR_TITLE> </h4>
|
||||
<p> <TMPL_VAR ERROR_MESSAGE> (Error <TMPL_VAR ERROR>). </p>
|
||||
</div>
|
||||
</TMPL_IF>
|
||||
</form>
|
||||
|
||||
<TMPL_VAR CRYPT_TEA>
|
||||
23
Dam/Components/Templates/Menu.tmpl.html
Normal file
23
Dam/Components/Templates/Menu.tmpl.html
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
<TMPL_IF ROUTES>
|
||||
<form id="naviga" method="post"><input type="hidden" name="rm" />
|
||||
<nav class="navbar navbar-default navbar-inverse navbar-fixed-top">
|
||||
<div class="container">
|
||||
|
||||
<div class="navbar-header">
|
||||
|
||||
<button type="button" class="navbar-toggle collapsed" data-toggle="collapse" data-target=".navbar-collapse">
|
||||
<span class="sr-only"><TMPL_VAR T_NAVIGATION></span>
|
||||
<span class="icon-bar"></span>
|
||||
<span class="icon-bar"></span>
|
||||
<span class="icon-bar"></span>
|
||||
</button>
|
||||
|
||||
<a href="#" class="navbar-brand option" id="RUN_home" title="<TMPL_VAR APP_NAME>"><TMPL_VAR APP_MNEMO></a>
|
||||
</div>
|
||||
|
||||
<TMPL_VAR ROUTES>
|
||||
|
||||
</div>
|
||||
</nav>
|
||||
</form>
|
||||
</TMPL_IF>
|
||||
152
Dam/Components/Translations/ES_es.pm
Normal file
152
Dam/Components/Translations/ES_es.pm
Normal file
|
|
@ -0,0 +1,152 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Components::Translations::ES_es
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Traducciones a español.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Components::Translations::ES_es;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
Get
|
||||
);
|
||||
|
||||
my %T = (
|
||||
LANGUAGE_CODE => 'es',
|
||||
MONTHS => [ 'Enero', 'Febrero', 'Marzo', 'Abril', 'Mayo', 'Junio', 'Julio', 'Agosto', 'Septiembre', 'Octubre', 'Noviembre', 'Diciembre' ],
|
||||
|
||||
'Username' => 'Nombre de usuario',
|
||||
'Password' => 'Contraseña',
|
||||
'Login' => 'Entrar',
|
||||
'User not active!' => '¡Usuario no activo!',
|
||||
'Consult with your systems manager to activate your user' => 'Consulte con el responsable de sistemas para activar su usuario',
|
||||
'Access error!' => '¡Error de acceso!',
|
||||
'Verify username and retype password' => 'Verifique el nombre de usuario y vuelva a teclear la contraseña',
|
||||
'Close' => 'Cerrar',
|
||||
'Close session' => 'Cerrar sesión',
|
||||
'Navigation' => 'Navegación',
|
||||
'alpha' => 'alfa',
|
||||
'beta' => 'beta',
|
||||
|
||||
'Original access' => 'Acceso original',
|
||||
'Assigned access' => 'Acceso asignado',
|
||||
|
||||
'ERROR!' => '¡ERROR!',
|
||||
'ERRORS!' => '¡ERRORES!',
|
||||
'WARNING!' => '¡ADVERTENCIA!',
|
||||
'WARNINGS!' => '¡ADVERTENCIAS!',
|
||||
'ATTENTION!' => '¡ATENCIÓN!',
|
||||
'Unauthorized Access' => 'Acceso No Autorizado',
|
||||
'You are trying to run a report without sufficient access privileges.' => 'Está intentando ejecutar un informe sin suficientes privilegios de acceso.',
|
||||
'Unexpected Error' => 'Error Inesperado',
|
||||
'An unexpected error occurred during execution.' => 'Se ha producido un error inesperado durante la ejecución.',
|
||||
'Please contact the administrator to resolve it.' => 'Por favor, contacte con el administrador para resolverlo.',
|
||||
|
||||
'Report' => 'Informe',
|
||||
'Description' => 'Descripción',
|
||||
'Edition date' => 'Fecha de edición',
|
||||
'Requested by' => 'Solicitado por',
|
||||
'Reports in <--alpha--> status are under development and may show errors or not give the expected results.' => 'Los informes en estado <--alpha--> están en desarrollo y pueden mostrar errores o no dar los resultados esperados.',
|
||||
'Reports in <--beta--> status are in validation process.' => 'Los informes en estado <--beta--> están en proceso de validación.',
|
||||
|
||||
'WATCH OUT!' => '¡CUIDADO!',
|
||||
'NO DATA!' => '¡SIN DATOS!',
|
||||
'There is no data to apply the selection form filter.' => 'No hay registros que cumplan los criterios del filtro de selección.',
|
||||
'Check the filter conditions.' => 'Compruebe las condiciones del filtro.',
|
||||
|
||||
'Filter fields marked with <--required--> are required.' => 'Los campos del filtro marcados con <--required--> son obligatorios.',
|
||||
|
||||
'This browser is out of date' => 'Este navegador es antiguo',
|
||||
'You must update to use <--app--> correctly.' => 'Hay que actualizar para usar <--app--> correctamente.',
|
||||
'Update my browser now' => 'Actualizar mi navegador ahora',
|
||||
|
||||
'You are running <--app--> in <--mode-->.' => 'Está ejecutando <--app--> en <--mode-->.',
|
||||
'develop mode' => 'modo de desarrollo',
|
||||
'testing mode' => 'modo de pruebas',
|
||||
|
||||
'About <--app-->' => 'Sobre <--app-->',
|
||||
'What\'s new' => 'Novedades',
|
||||
'Previous version' => 'Versión anterior',
|
||||
|
||||
# ACTIONS:
|
||||
|
||||
'Run' => 'Calcular',
|
||||
'Print' => 'Imprimir',
|
||||
'Download current report in CSV format' => 'Descarga el informe actual en formato CSV',
|
||||
'Order by' => 'Ordenado por',
|
||||
'Sort by' => 'Ordenar por',
|
||||
'ascendant' => 'ascendente',
|
||||
'descendent' => 'descendente',
|
||||
|
||||
# CONTROLS:
|
||||
|
||||
'Date' => 'Fecha',
|
||||
'Date range' => 'Período',
|
||||
'Month' => 'Mes',
|
||||
'Year' => 'Año',
|
||||
'YEAR' => 'AÑO',
|
||||
'FIRST SEMESTER' => 'PRIMER SEMESTRE',
|
||||
'SECOND SEMESTER' => 'SEGUNDO SEMESTRE',
|
||||
'FIRST QUARTER' => 'PRIMER CUATRIMESTRE',
|
||||
'SECOND QUARTER' => 'SEGUNDO CUATRIMESTRE',
|
||||
'THIRD QUARTER' => 'TERCER CUATRIMESTRE',
|
||||
'FIRST TRIMESTER' => 'PRIMER TRIMESTRE',
|
||||
'SECOND TRIMESTER' => 'SEGUNDO TRIMESTRE',
|
||||
'THIRD TRIMESTER' => 'TERCER TRIMESTRE',
|
||||
'FOURTH TRIMESTER' => 'CUARTO TRIMESTRE',
|
||||
'Date ranges greater than <--max--> are not allowed.' => 'No se admiten rangos de fechas superiores a <--max-->.',
|
||||
'day(s)' => 'día(s)',
|
||||
'year(s)' => 'año(s)',
|
||||
'Option' => 'Opción',
|
||||
'Options' => 'Opciones',
|
||||
'Enter text' => 'Introducir texto',
|
||||
'Input text' => 'Texto de entrada',
|
||||
'Upload file' => 'Subir archivo',
|
||||
'File' => 'Archivo',
|
||||
'If no other file is selected, then <--file--> previously uploaded will be used.' => 'Si no se selecciona otro archivo, entonces se usará el mismo <--file--> subido anteriormente.'
|
||||
);
|
||||
sub Get { return \%T; }
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
1107
Dam/DamLogic.pm
Normal file
1107
Dam/DamLogic.pm
Normal file
File diff suppressed because it is too large
Load diff
652
Dam/Database.pm
Normal file
652
Dam/Database.pm
Normal file
|
|
@ -0,0 +1,652 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Database
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
API for database access.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Database;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
UNKNOWN_COLUMN DUPLICATE_ENTRY SQL_SYNTAX_ERROR
|
||||
|
||||
database_connect database_disconnect database_last_err database_last_errstr
|
||||
CREATE_TEMP_TABLE DROP_TEMP_TABLE DROP_TEMP_TABLES
|
||||
QUERY UPDATE INSERT_INTO DELETE_FROM
|
||||
SELECT COUNT SUM AVG UNION
|
||||
FIELDS FROM JOINS WHERE GROUP_BY HAVING ORDER_BY LIMIT
|
||||
CLOSED AND OR NOT
|
||||
COMPARE COMPARE_STR COMPARE_DATE COMPARE_FIELDS
|
||||
BETWEEN BETWEEN_STR BETWEEN_DATES
|
||||
EXISTS IN_FIELD
|
||||
);
|
||||
|
||||
use DBI;
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::Debug;
|
||||
|
||||
|
||||
|
||||
use constant {
|
||||
UNKNOWN_COLUMN => 1054,
|
||||
DUPLICATE_ENTRY => 1062,
|
||||
SQL_SYNTAX_ERROR => 1064
|
||||
};
|
||||
|
||||
my $DBH = undef; # Database handle
|
||||
my @TEMP_TABLES = (); # Temporal tables created during execution
|
||||
|
||||
|
||||
|
||||
=head2 database_connect()
|
||||
|
||||
Open connection to the database.
|
||||
|
||||
=cut
|
||||
|
||||
sub database_connect {
|
||||
my %arg = @_;
|
||||
check_arguments(\%arg,
|
||||
DB_DSN => [ ARG_REQUIRED ],
|
||||
DB_USER => [ ARG_REQUIRED ],
|
||||
DB_PASSWORD => [ ARG_REQUIRED ]
|
||||
);
|
||||
|
||||
$DBH = DBI->connect($arg{DB_DSN}, $arg{DB_USER}, $arg{DB_PASSWORD}) if !is_eq($arg{DB_DSN}, 'DBI:mysql:database=dbname;host=hostname');
|
||||
return $DBH;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 database_disconnect()
|
||||
|
||||
Close the connection to the database.
|
||||
|
||||
=cut
|
||||
|
||||
sub database_disconnect {
|
||||
$DBH->disconnect() if defined($DBH);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 database_last_err()
|
||||
|
||||
Returns the exit code of the last database access statement executed.
|
||||
|
||||
=cut
|
||||
|
||||
sub database_last_err {
|
||||
return defined($DBH->err) ? $DBH->err : 0;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 database_last_errstr()
|
||||
|
||||
Returns the output text message of the last database access statement executed.
|
||||
|
||||
=cut
|
||||
|
||||
sub database_last_errstr {
|
||||
return defined($DBH->errstr) ? $DBH->errstr : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 CREATE_TEMP_TABLE($table, %SOURCE)
|
||||
|
||||
Create a temporary table in the database.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$table> (required): Name of the new data table.
|
||||
- B<%SOURCE> (required): Its structure. Can be:
|
||||
- C<DEF> => a definition of the fields in the new table;
|
||||
- C<LIKE> => the name of an existing table to copy its structure; or
|
||||
- C<AS> => a SELECT statement from which to get fields and data.
|
||||
|
||||
=cut
|
||||
|
||||
sub CREATE_TEMP_TABLE {
|
||||
my ($table, %SOURCE) = @_;
|
||||
|
||||
my $query = strval('
|
||||
CREATE TEMPORARY TABLE ', $table,
|
||||
!is_empty($SOURCE{DEF}) ? strval(' ( ', strval_join(', ', array($SOURCE{DEF})), ' )') : '',
|
||||
!is_empty($SOURCE{LIKE}) ? strval(' LIKE ', $SOURCE{LIKE}) : '',
|
||||
!is_empty($SOURCE{AS}) ? strval(' AS ( ', $SOURCE{AS}, ' )') : ''
|
||||
);
|
||||
$DBH->do($query);
|
||||
debug_info('CREATE TABLE', '<samp style="color: #888;">', $query, '</samp>');
|
||||
if ($DBH->err) {
|
||||
debug_error($DBH->errstr);
|
||||
}
|
||||
else {
|
||||
push(@TEMP_TABLES, $table);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 DROP_TEMP_TABLE($table)
|
||||
|
||||
Drop a temporary table from the database.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$table> (required): Table name.
|
||||
|
||||
=cut
|
||||
|
||||
sub DROP_TEMP_TABLE {
|
||||
my $table = shift;
|
||||
|
||||
my $query = strval('
|
||||
DROP TEMPORARY TABLE ', $table
|
||||
);
|
||||
$DBH->do($query);
|
||||
debug_info('DROP TABLE', '<samp style="color: #888;">', $query, '</samp>');
|
||||
if ($DBH->err) {
|
||||
debug_error($DBH->errstr);
|
||||
}
|
||||
else {
|
||||
my $index = index_in_array($table, \@TEMP_TABLES);
|
||||
splice(@TEMP_TABLES, $index, 1) if $index != -1;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 DROP_TEMP_TABLES()
|
||||
|
||||
Delete the temporary tables created up to the moment of execution.
|
||||
|
||||
=cut
|
||||
|
||||
sub DROP_TEMP_TABLES {
|
||||
while (@TEMP_TABLES) {
|
||||
my $query = strval('
|
||||
DROP TEMPORARY TABLE ', pop(@TEMP_TABLES)
|
||||
);
|
||||
$DBH->do($query);
|
||||
debug_info('DROP TABLE', '<samp style="color: #888;">', $query, '</samp>');
|
||||
debug_error($DBH->errstr) if $DBH->err;
|
||||
}
|
||||
@TEMP_TABLES = ();
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 QUERY($query)
|
||||
|
||||
Execute a query on the database.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$query> (required): SELECT statement to execute.
|
||||
|
||||
=cut
|
||||
|
||||
sub QUERY {
|
||||
my $query = shift;
|
||||
|
||||
my $execute = $DBH->prepare($query);
|
||||
$execute->execute();
|
||||
my $rows = $execute->rows != -1 ? strval(' => <kbd>', $execute->rows, '</kbd> ', $execute->rows == 1 ? 'fila seleccionada.' : 'filas seleccionadas.') : '';
|
||||
debug_info('QUERY', '<samp style="color: #888;">', $query, '</samp>', $rows);
|
||||
debug_error($execute->errstr) if $execute->err;
|
||||
return $execute;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 UPDATE($table, %SET)
|
||||
|
||||
Run an update on the database.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$table> (required): Data table to be updated.
|
||||
- B<%SET>: Fields to update.
|
||||
|
||||
=cut
|
||||
|
||||
sub UPDATE {
|
||||
my ($table, %SET) = @_;
|
||||
|
||||
my $query = strval('
|
||||
UPDATE ', $table,
|
||||
!is_empty($SET{SET}) ? strval(' SET ', strval_join(', ', array($SET{SET}))) : '',
|
||||
WHERE(array($SET{WHERE}))
|
||||
);
|
||||
$DBH->do($query);
|
||||
debug_info('UPDATE', '<samp style="color: #888;">', $query, '</samp>');
|
||||
debug_error($DBH->errstr) if $DBH->err;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 INSERT_INTO($table, %INTO)
|
||||
|
||||
Insert data into a table in the database and return the number of rows inserted
|
||||
or -1 if any error occurred.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$table> (required): Table in which the data will be inserted.
|
||||
- B<%INTO>: Selection of data to insert.
|
||||
|
||||
=cut
|
||||
|
||||
sub INSERT_INTO {
|
||||
my ($table, %INTO) = @_;
|
||||
|
||||
my $query = strval('
|
||||
INSERT INTO ', $table,
|
||||
!is_empty($INTO{FIELDS}) ? strval(' ( ', strval_join(', ', array($INTO{FIELDS})), ' )') : '',
|
||||
!is_empty($INTO{VALUES}) ? strval(' VALUES ( ', strval_join(', ', array($INTO{VALUES})), ' )') : '',
|
||||
is_eq(ref($INTO{SELECT}), 'HASH') ? SELECT(%{$INTO{SELECT}}) : strval(' ', $INTO{SELECT})
|
||||
);
|
||||
my $rows = $DBH->do($query);
|
||||
$rows = -1 if $DBH->err;
|
||||
$rows = 0 if is_eq($rows, '0E0');
|
||||
my $inserted_rows = $rows != -1 ? strval(' => <kbd>', $rows, '</kbd> ', $rows == 1 ? 'fila insertada.' : 'filas insertadas.') : '';
|
||||
debug_info('INSERT INTO', '<samp style="color: #888;">', $query, '</samp>', $inserted_rows);
|
||||
debug_error($DBH->errstr) if $DBH->err;
|
||||
return $rows;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 DELETE_FROM($table, %WHERE)
|
||||
|
||||
Delete a set of records from the database.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$table> (required): Table from which records will be deleted.
|
||||
- B<%WHERE>: Conditions to delete.
|
||||
|
||||
=cut
|
||||
|
||||
sub DELETE_FROM {
|
||||
my ($table, %WHERE) = @_;
|
||||
|
||||
my $query = strval('
|
||||
DELETE FROM ', $table,
|
||||
WHERE(array($WHERE{WHERE}))
|
||||
);
|
||||
$DBH->do($query);
|
||||
debug_info('DELETE FROM', '<samp style="color: #888;">', $query, '</samp>');
|
||||
debug_error($DBH->errstr) if $DBH->err;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 SELECT(%SELECT)
|
||||
|
||||
Construct a valid SELECT statement with the input arguments.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<%SELECT>: SELECT statement elements.
|
||||
|
||||
=cut
|
||||
|
||||
sub SELECT {
|
||||
my %SELECT = @_;
|
||||
|
||||
return strval('
|
||||
SELECT ',
|
||||
FIELDS(array($SELECT{FIELDS})),
|
||||
FROM(array($SELECT{FROM})),
|
||||
JOINS(array($SELECT{JOINS})),
|
||||
WHERE(array($SELECT{WHERE})),
|
||||
GROUP_BY(array($SELECT{GROUP_BY})),
|
||||
HAVING($SELECT{HAVING}),
|
||||
ORDER_BY(array($SELECT{ORDER_BY})),
|
||||
LIMIT($SELECT{LIMIT})
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 COUNT(%SELECT)
|
||||
|
||||
Constructs and executes a valid SELECT COUNT(C<$SELECT{FIELDS}>) statement with
|
||||
the input arguments and returns the number of records that apply.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<%SELECT>: SELECT statement elements.
|
||||
|
||||
=cut
|
||||
|
||||
sub COUNT {
|
||||
my %SELECT = @_;
|
||||
|
||||
$SELECT{FIELDS} = strval('COUNT(', is_empty($SELECT{FIELDS}) ? '*' : $SELECT{FIELDS}, ')');
|
||||
|
||||
my $query = SELECT(%SELECT);
|
||||
|
||||
my $execute = $DBH->prepare($query);
|
||||
$execute->execute();
|
||||
my $count = numval(($execute->fetchrow_array())[0]);
|
||||
debug_info('COUNT', '<samp style="color: #888;">', $query, '</samp> => Cuenta <kbd>', $count, '</kbd>');
|
||||
debug_error($execute->errstr) if $execute->err;
|
||||
return $count;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 SUM(%SELECT)
|
||||
|
||||
Constructs and executes a valid SELECT SUM(C<$SELECT{FIELDS}>) statement with
|
||||
the input arguments and returns the requested sum.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<%SELECT>: SELECT statement elements.
|
||||
|
||||
=cut
|
||||
|
||||
sub SUM {
|
||||
my %SELECT = @_;
|
||||
|
||||
$SELECT{FIELDS} = !is_empty($SELECT{FIELDS}) ? strval('SUM(', $SELECT{FIELDS}, ')') : '';
|
||||
|
||||
my $query = SELECT(%SELECT);
|
||||
|
||||
my $execute = $DBH->prepare($query);
|
||||
$execute->execute();
|
||||
my $sum = numval(($execute->fetchrow_array())[0]);
|
||||
debug_info('SUM', '<samp style="color: #888;">', $query, '</samp> => Suma <kbd>', $sum, '</kbd>');
|
||||
debug_error($execute->errstr) if $execute->err;
|
||||
return $sum;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 AVG(%SELECT)
|
||||
|
||||
Constructs and executes a valid SELECT AVG(C<$SELECT{FIELDS}>) statement with
|
||||
the input arguments and returns the requested average.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<%SELECT>: SELECT statement elements.
|
||||
|
||||
=cut
|
||||
|
||||
sub AVG {
|
||||
my %SELECT = @_;
|
||||
|
||||
$SELECT{FIELDS} = !is_empty($SELECT{FIELDS}) ? strval('AVG(', $SELECT{FIELDS}, ')') : '';
|
||||
|
||||
my $query = SELECT(%SELECT);
|
||||
|
||||
my $execute = $DBH->prepare($query);
|
||||
$execute->execute();
|
||||
my $avg = numval(($execute->fetchrow_array())[0]);
|
||||
debug_info('AVG', '<samp style="color: #888;">', $query, '</samp> => Media <kbd>', $avg, '</kbd>');
|
||||
debug_error($execute->errstr) if $execute->err;
|
||||
return $avg;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 UNION(@SELECTS)
|
||||
|
||||
Concatenates a list of SELECT statements into a valid UNION sentence.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@SELECTS>: SELECT statement list.
|
||||
|
||||
=cut
|
||||
|
||||
sub UNION {
|
||||
return trim(strval_join(' UNION ', @_));
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub FIELDS {
|
||||
my $fields = trim(strval_join(', ', @_));
|
||||
return !is_empty($fields) ? strval(' ', $fields) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub FROM {
|
||||
my $from = trim(strval_join(', ', @_));
|
||||
return !is_empty($from) ? strval(' FROM ', $from) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub JOINS {
|
||||
my $joins = trim(strval_join(' ', @_));
|
||||
return !is_empty($joins) ? strval(' ', $joins) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub WHERE {
|
||||
my $where = trim(AND(@_));
|
||||
return !is_empty($where) ? strval(' WHERE ', $where) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub GROUP_BY {
|
||||
my $group_by = trim(strval_join(', ', @_));
|
||||
return !is_empty($group_by) ? strval(' GROUP BY ', $group_by) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub HAVING {
|
||||
my $having = trim(shift);
|
||||
return !is_empty($having) ? strval(' HAVING ', $having) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub ORDER_BY {
|
||||
my $order_by = trim(strval_join(', ', @_));
|
||||
return !is_empty($order_by) ? strval(' ORDER BY ', $order_by) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub LIMIT {
|
||||
my $limit = trim(shift);
|
||||
return !is_empty($limit) ? strval(' LIMIT ', $limit) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub CLOSED {
|
||||
my $sentence = trim(shift);
|
||||
return !is_empty($sentence) ? strval(' ( ', $sentence, ' )') : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub AND {
|
||||
my $conditions = trim(strval_join(' AND ', @_));
|
||||
return !is_empty($conditions) ? strval(' ', $conditions) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub OR {
|
||||
my $conditions = trim(strval_join(' OR ', @_));
|
||||
return !is_empty($conditions) ? strval(' ', $conditions) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub NOT {
|
||||
my $sentence = trim(shift);
|
||||
return !is_empty($sentence) ? strval(' NOT ', $sentence) : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub COMPARE {
|
||||
my ($field, $op, $value) = @_;
|
||||
|
||||
$field = trim($field);
|
||||
$op = trim(one_space(uc($op)));
|
||||
return '' if is_empty($field) || is_empty($op);
|
||||
$value = trim($value);
|
||||
if (is_empty($value)) {
|
||||
return is_eq($op, 'IS NULL') || is_eq($op, 'IS NOT NULL') ? strval(' ', $field, ' ', $op) : '';
|
||||
}
|
||||
return strval(' ', $field, ' IS NULL') if is_eq($op, '=') && is_eq(uc($value), 'NULL');
|
||||
return strval(' ', $field, ' IS NOT NULL') if is_eq($op, '!=') && is_eq(uc($value), 'NULL');
|
||||
return strval(' ', $field, ' ', $op, ' ', $value);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub COMPARE_STR {
|
||||
my ($field, $op, $string) = @_;
|
||||
|
||||
$field = trim($field);
|
||||
$op = trim(one_space(uc($op)));
|
||||
return '' if is_empty($field) || is_empty($op);
|
||||
if (is_empty(trim($string))) {
|
||||
return is_eq($op, 'IS NULL') || is_eq($op, 'IS NOT NULL') ? strval(' ', $field, ' ', $op) : '';
|
||||
}
|
||||
return strval(' ', $field, ' IS NULL') if is_eq($op, '=') && is_eq(uc($string), 'NULL');
|
||||
return strval(' ', $field, ' IS NOT NULL') if is_eq($op, '!=') && is_eq(uc($string), 'NULL');
|
||||
return strval(' ', $field, ' ', $op, " '", $string, "'");
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub COMPARE_DATE {
|
||||
return COMPARE_STR(@_);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub COMPARE_FIELDS {
|
||||
return COMPARE(@_);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub BETWEEN {
|
||||
my ($field, $ini, $end) = @_;
|
||||
|
||||
my $c1 = COMPARE($field, '>=', $ini);
|
||||
my $c2 = COMPARE($field, '<=', $end);
|
||||
return is_empty($c1) || is_empty($c2) ? strval($c1, $c2) : strval(' (', $c1, ' AND', $c2, ' )');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub BETWEEN_STR {
|
||||
my ($field, $ini, $end) = @_;
|
||||
|
||||
my $c1 = COMPARE_STR($field, '>=', $ini);
|
||||
my $c2 = COMPARE_STR($field, '<=', $end);
|
||||
return is_empty($c1) || is_empty($c2) ? strval($c1, $c2) : strval(' (', $c1, ' AND', $c2, ' )');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub BETWEEN_DATES {
|
||||
return BETWEEN_STR(@_);
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub EXISTS {
|
||||
my $sentence = shift;
|
||||
return !is_empty($sentence) ? strval(' EXISTS ( ', $sentence, ' )') : '';
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub IN_FIELD {
|
||||
my ($field, $values) = @_;
|
||||
|
||||
$field = trim($field);
|
||||
$values = trim($values);
|
||||
|
||||
return '' if is_empty($field) || is_empty($values);
|
||||
|
||||
my $isnot = is_eq(substr($values, 0, 1), '!');
|
||||
$values = substr($values, 1) if $isnot;
|
||||
|
||||
my @values = split(m/('[^']+'|"[^"]+"|[^,]+)(?:\s*,\s*)?/, $values);
|
||||
|
||||
my $isnull = '';
|
||||
my @nulls = ("'NULL'", '"NULL"', 'NULL');
|
||||
my @infield = ();
|
||||
foreach my $value (@values) {
|
||||
if (!is_empty($value)) {
|
||||
if (in_array($value, \@nulls)) {
|
||||
$isnull = $isnot ? "$field IS NOT NULL" : "$field IS NULL";
|
||||
}
|
||||
else {
|
||||
push(@infield, $value);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $isnull if scalar(@infield) == 0;
|
||||
my $infield = strval($field, $isnot ? ' NOT IN ( ' : ' IN ( ', strval_join(', ', @infield), ' )');
|
||||
return is_empty($isnull) ? $infield : strval("( $infield ", $isnot ? 'AND' : 'OR', " $isnull )");
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
189
Dam/Debug.pm
Normal file
189
Dam/Debug.pm
Normal file
|
|
@ -0,0 +1,189 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Debug
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
API for handling error, warning, information and debug messages.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Debug;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
report_error report_warning report_info
|
||||
debug_error debug_info debug
|
||||
);
|
||||
|
||||
use Date::Calc qw(Now);
|
||||
|
||||
use Dam::Util;
|
||||
use Dam::Var;
|
||||
|
||||
|
||||
|
||||
=head2 report_error(@message)
|
||||
|
||||
Push an error message to display in report execution.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@message> (must): Error message formed by one or more strings.
|
||||
|
||||
=cut
|
||||
|
||||
sub report_error {
|
||||
my $error = strval(@_);
|
||||
my $REPORT_ERROR = RESERVED('REF_REPORT_ERROR');
|
||||
push(@$REPORT_ERROR, $error) if !is_empty($error);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 report_warning(@message)
|
||||
|
||||
Push a warning message to display in report execution.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@message> (must): Warning message formed by one or more strings.
|
||||
|
||||
=cut
|
||||
|
||||
sub report_warning {
|
||||
my $warning = strval(@_);
|
||||
my $REPORT_WARNING = RESERVED('REF_REPORT_WARNING');
|
||||
push(@$REPORT_WARNING, $warning) if !is_empty($warning);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 report_info(@message)
|
||||
|
||||
Push an information message to display in report execution.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@message> (must): Information message formed by one or more strings.
|
||||
|
||||
=cut
|
||||
|
||||
sub report_info {
|
||||
my $info = strval(@_);
|
||||
my $REPORT_INFO = RESERVED('REF_REPORT_INFO');
|
||||
push(@$REPORT_INFO, $info) if !is_empty($info);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 debug_error(@message)
|
||||
|
||||
Prepares a message with current time to display (according to
|
||||
B<CONFIG('DEBUG_MODE')>) with all code debug messages sorted at the beginning of
|
||||
the current report.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@message>: Error message formed by one or more strings.
|
||||
|
||||
=cut
|
||||
|
||||
sub debug_error {
|
||||
my $DEBUG_INFO = RESERVED('REF_DEBUG_INFO');
|
||||
push(@$DEBUG_INFO, strval('[', sprintf("%02d:%02d:%02d", Now()), '] <strong style="color: red;">ERROR!</strong> <samp style="color: navy;">', @_, '</samp>')) if CONFIG('DEBUG_MODE');
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 debug_info($title, @message)
|
||||
|
||||
Prepare a message with current time, a short title and data of the function and
|
||||
the call files, to show (according to B<CONFIG('DEBUG_MODE')>) with all code
|
||||
debugging messages sorted at the beginning of the current report.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$title> (must): Short title to show.
|
||||
- B<@message>: Message formed by one or more strings.
|
||||
|
||||
=cut
|
||||
|
||||
sub debug_info {
|
||||
my ($title, @message) = @_;
|
||||
|
||||
if (CONFIG('DEBUG_MODE')) {
|
||||
my ($p0, $filename0, $line0) = caller(1);
|
||||
$filename0 = substr($filename0, 3);
|
||||
my ($p1, $filename1, $line1, $subroutine1) = caller(2);
|
||||
$filename1 = substr($filename1, 3);
|
||||
my $DEBUG_INFO = RESERVED('REF_DEBUG_INFO');
|
||||
push(@$DEBUG_INFO, strval(
|
||||
'[', sprintf("%02d:%02d:%02d", Now()), '] <strong>', $title, '</strong>: ',
|
||||
'<code>', $filename0, '</code> línea ', $line0, ' (<code>', substr($subroutine1, 9), '</code>)',
|
||||
index($filename1, 'CGI/Application.pm') == -1 ? strval(', desde <code>', $filename1, '</code> línea ', $line1) : '',
|
||||
'.<br />', @message
|
||||
));
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 debug($title, @message)
|
||||
|
||||
Prepare a message with current time and a short title to display (according to
|
||||
B<CONFIG('DEBUG_MODE')>) with all code debugging messages sorted at the
|
||||
beginning of the current report.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$title> (must): Short title to show.
|
||||
- B<@message>: Message formed by one or more strings.
|
||||
|
||||
=cut
|
||||
|
||||
sub debug {
|
||||
my ($title, @message) = @_;
|
||||
my $DEBUG_INFO = RESERVED('REF_DEBUG_INFO');
|
||||
push(@$DEBUG_INFO, strval('[', sprintf("%02d:%02d:%02d", Now()), '] <strong>', $title, '</strong>: ', @message)) if CONFIG('DEBUG_MODE');
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
21
Dam/LICENSE
Normal file
21
Dam/LICENSE
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
728
Dam/Util.pm
Normal file
728
Dam/Util.pm
Normal file
|
|
@ -0,0 +1,728 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Util
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Global functions for applications created using the Dam framework.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Util;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
TRUE FALSE
|
||||
ARG_OPTIONAL ARG_REQUIRED ARG_DEFAULT
|
||||
_DIVIDER_
|
||||
|
||||
is_true is_empty is_eq is_num
|
||||
numval pctval sumval
|
||||
strval strval_trio strval_join trim
|
||||
one_space escape_quotes
|
||||
array in_array index_in_array occurrences_in_array match_arrays array_uniq
|
||||
fatal warning info
|
||||
check_arguments
|
||||
format_num format_pct format_date_dmy get_today_ymd
|
||||
csv_header csv_line
|
||||
);
|
||||
|
||||
use Date::Calc qw(Today);
|
||||
use Scalar::Util qw(looks_like_number);
|
||||
|
||||
|
||||
|
||||
use constant {
|
||||
TRUE => 1,
|
||||
FALSE => 0,
|
||||
|
||||
ARG_OPTIONAL => 0,
|
||||
ARG_REQUIRED => 1,
|
||||
ARG_DEFAULT => 2,
|
||||
|
||||
_DIVIDER_ => '_DIVIDER_'
|
||||
};
|
||||
|
||||
|
||||
|
||||
=head2 is_true($var)
|
||||
|
||||
Returns C<TRUE> if C<$var> is not C<undef> and has a value other than C<0>, or
|
||||
C<'0'> or the empty string C<''>. Or C<FALSE> otherwise.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$var> (must): Variable to check.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_true {
|
||||
my $var = shift;
|
||||
return defined($var) && $var ne '' && $var ne '0' ? TRUE : FALSE;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 is_empty($var)
|
||||
|
||||
Returns C<TRUE> if C<$var> is C<undef> or the empty string C<''>. Or C<FALSE>
|
||||
otherwise.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$var> (must): Variable to check.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_empty {
|
||||
my $var = shift;
|
||||
return !defined($var) || $var eq '' ? TRUE : FALSE;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 is_eq($var, $str)
|
||||
|
||||
Returns C<TRUE> if C<$var> is not C<undef>, C<$str> is not C<undef> and they are
|
||||
equals. Or C<FALSE> otherwise.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$var> (must): Variable to check.
|
||||
- B<$str> (must): Value to compare.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_eq {
|
||||
my ($var, $str) = @_;
|
||||
return defined($var) && defined($str) && $var eq $str ? TRUE : FALSE;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 is_num($num)
|
||||
|
||||
Returns C<TRUE> if C<$num> is a number, or C<FALSE> otherwise.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$num> (must): Number to check.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_num {
|
||||
return looks_like_number(shift) ? TRUE : FALSE;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 numval($num)
|
||||
|
||||
Returns C<$num> when C<is_num($num)>. Returns C<0> when C<is_empty($num)>. And
|
||||
C<undef> otherwise.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$num> (must): Number to check.
|
||||
|
||||
=cut
|
||||
|
||||
sub numval {
|
||||
my $num = shift;
|
||||
|
||||
return $num if is_num($num);
|
||||
return 0 if is_empty($num);
|
||||
warning('Invalid number');
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 pctval($numerator, $denominator, $decimals, $byzero)
|
||||
|
||||
Returns (C<$numerator> * 100) / C<$denominator> if C<is_num($numerator)>,
|
||||
C<is_num($denominator)> and C<$denominator> is not C<0>. Otherwise it will
|
||||
return C<undef>.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$numerator> (must): The numerator of the percentage to calculate.
|
||||
- B<$denominator> (must): The denominator of the percentage to calculate.
|
||||
- B<$decimals> (optional): Maximum number of decimal places for the result.
|
||||
- B<$byzero> (optional): If C<is_true($byzero)> it will send a warning message
|
||||
when C<$denominator> is zero.
|
||||
|
||||
=cut
|
||||
|
||||
sub pctval {
|
||||
my ($numerator, $denominator, $decimals, $byzero) = @_;
|
||||
|
||||
$numerator = 0 if is_empty($numerator);
|
||||
if (is_num($numerator) && is_num($denominator)) {
|
||||
warning('Invalid number of decimals') if !is_empty($decimals) && (!is_num($decimals) || $decimals < 0 || !($decimals - int($decimals)));
|
||||
if ($denominator != 0) {
|
||||
my $pctval = $numerator * 100 / $denominator;
|
||||
return is_empty($decimals) ? $pctval : sprintf("%.${decimals}f", $pctval);
|
||||
}
|
||||
warning('Division by zero') if is_true($byzero);
|
||||
return undef;
|
||||
}
|
||||
warning('Invalid numerator') if !is_num($numerator);
|
||||
warning('Invalid denominator') if !is_num($denominator);
|
||||
return undef;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 sumval(@items)
|
||||
|
||||
Sum all the items in C<@items> considering each one as C<numval($item)>.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@items> (must): List of items to add.
|
||||
|
||||
=cut
|
||||
|
||||
sub sumval {
|
||||
my $sum = 0;
|
||||
foreach my $item (@_) {
|
||||
$sum += numval($item);
|
||||
}
|
||||
return $sum;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 strval(@str)
|
||||
|
||||
Returns the concatenation of all strings in C<@str>, considering C<undef> as the
|
||||
empty string C<''>.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@str> (must): Array of strings to concatenate.
|
||||
|
||||
=cut
|
||||
|
||||
sub strval {
|
||||
my $strval = '';
|
||||
foreach my $str (@_) {
|
||||
$strval .= defined($str) ? $str : '';
|
||||
}
|
||||
return $strval;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 strval_trio($str1, $separator, $str2)
|
||||
|
||||
Returns the concatenation of the strings C<$str1>, C<$separator> and C<$str2> if
|
||||
not C<is_empty($str1)> and not C<is_empty($str2)>. Otherwise it returns the
|
||||
string C<$str1> or C<$str2> that is not empty, or the empty string C<''> if
|
||||
both are.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$str1> (optional): First string.
|
||||
- B<$separator> (must): Separation string.
|
||||
- B<$str2> (optional): Second string.
|
||||
|
||||
=cut
|
||||
|
||||
sub strval_trio {
|
||||
my ($str1, $separator, $str2) = @_;
|
||||
|
||||
return strval($str1, $separator, $str2) if !is_empty($str1) && !is_empty($str2);
|
||||
return strval($str1) if is_empty($str2);
|
||||
return strval($str2);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 strval_join($separator, @str)
|
||||
|
||||
Returns the concatenation of the (not empty) strings of C<@str> or the
|
||||
referenced array of strings instead, using the string C<$separator> as the
|
||||
separation between each one.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$separator> (must): Separation string.
|
||||
- B<@str> (must): Strings or reference to the array of strings to concatenate.
|
||||
|
||||
=cut
|
||||
|
||||
sub strval_join {
|
||||
my ($separator, @str) = @_;
|
||||
|
||||
return '' if !@str;
|
||||
@str = @{$str[0]} if scalar(@str) == 1 && ref($str[0]) eq 'ARRAY';
|
||||
$separator = '' if is_empty($separator);
|
||||
return join($separator, grep { !is_empty($_) } @str);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 trim($str)
|
||||
|
||||
Returns a string whose leading and trailing spaces have been removed from
|
||||
C<$str>. Or the empty string C<''> if C<is_empty($str)>.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$str> (must): String to process.
|
||||
|
||||
=cut
|
||||
|
||||
sub trim {
|
||||
my $str = shift;
|
||||
|
||||
return '' if is_empty($str);
|
||||
$str =~ s/^\s+|\s+$//g;
|
||||
return $str;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 one_space($str)
|
||||
|
||||
Returns a string that converts the sequences of two or more consecutive spaces
|
||||
of C<$str> into a single space. Or the empty string C<''> if
|
||||
C<is_empty($str)>.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$str> (must): String to process.
|
||||
|
||||
=cut
|
||||
|
||||
sub one_space {
|
||||
my $str = shift;
|
||||
|
||||
return '' if is_empty($str);
|
||||
$str =~ s/\s+/ /g;
|
||||
return $str;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 escape_quotes($str)
|
||||
|
||||
Returns the same string C<$str> by putting an escape character in front of each
|
||||
escape character, single quote or double quote. Or the empty string C<''> if
|
||||
C<is_empty($str)>.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$str> (must): String to process.
|
||||
|
||||
=cut
|
||||
|
||||
sub escape_quotes {
|
||||
my $str = shift;
|
||||
|
||||
return '' if is_empty($str);
|
||||
$str =~ s/('|"|\\)/\\$1/g;
|
||||
return $str;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 array($var)
|
||||
|
||||
If C<$var> is a reference to an array then it returns the array. If it is a
|
||||
variable then it returns an array with that element. It returns an empty array
|
||||
otherwise.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$var> (must): Variable (or reference to the array) to check.
|
||||
|
||||
=cut
|
||||
|
||||
sub array {
|
||||
my $var = shift;
|
||||
|
||||
return () if !defined($var);
|
||||
return ref($var) eq 'ARRAY' ? @{$var} : ( $var );
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 in_array($element, @array)
|
||||
|
||||
Returns C<TRUE> if C<$element> is in array C<@array> or in the referenced array
|
||||
instead. Or C<FALSE> otherwise.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$element> (must): Element to search.
|
||||
- B<@array> (must): Array (or reference to the array) in which the element is
|
||||
searched.
|
||||
|
||||
=cut
|
||||
|
||||
sub in_array {
|
||||
my ($element, @array) = @_;
|
||||
|
||||
return FALSE if !defined($element) || !@array;
|
||||
@array = @{$array[0]} if scalar(@array) == 1 && ref($array[0]) eq 'ARRAY';
|
||||
|
||||
my %hash_array = map { $_ => 1 } @array;
|
||||
return defined($hash_array{$element}) ? TRUE : FALSE;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 index_in_array($element, @array)
|
||||
|
||||
Returns the position where C<$element> is in array C<@array> or in the array
|
||||
referenced instead, with C<0> being the first position in the array. Or it
|
||||
returns C<-1> if there are no arguments or the element is not found.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$element> (must): Element to search.
|
||||
- B<@array> (must): Array (or reference to the array) in which the element is
|
||||
searched.
|
||||
|
||||
=cut
|
||||
|
||||
sub index_in_array {
|
||||
my ($element, @array) = @_;
|
||||
|
||||
return -1 if !defined($element) || !@array;
|
||||
@array = @{$array[0]} if scalar(@array) == 1 && ref($array[0]) eq 'ARRAY';
|
||||
|
||||
my $index = 0;
|
||||
foreach my $current (@array) {
|
||||
return $index if $current eq $element;
|
||||
$index++;
|
||||
}
|
||||
return -1;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 occurrences_in_array($element, @array)
|
||||
|
||||
Returns the number of occurrences of C<$element> in array C<@array> or in the
|
||||
referenced array instead. Or it returns C<-1> if there are no arguments.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$element> (must): Element to search.
|
||||
- B<@array> (must): Array (or reference to the array) in which the element is
|
||||
searched.
|
||||
|
||||
=cut
|
||||
|
||||
sub occurrences_in_array {
|
||||
my ($element, @array) = @_;
|
||||
|
||||
return -1 if !defined($element) || !@array;
|
||||
@array = @{$array[0]} if scalar(@array) == 1 && ref($array[0]) eq 'ARRAY';
|
||||
|
||||
return grep { $_ eq $element } @array;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 match_arrays($array_ref1, $array_ref2)
|
||||
|
||||
Returns C<TRUE> if arrays C<@$array_ref1> and C<@$array_ref2> have one or more
|
||||
equal elements. Or C<FALSE> otherwise.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<$array_ref1> (required): Reference to the first array.
|
||||
- B<$array_ref2> (required): Reference to the second array.
|
||||
|
||||
=cut
|
||||
|
||||
sub match_arrays {
|
||||
my ($array_ref1, $array_ref2) = @_;
|
||||
|
||||
foreach my $match (@{$array_ref1}) {
|
||||
return TRUE if in_array($match, $array_ref2);
|
||||
}
|
||||
return FALSE;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 array_uniq(@array)
|
||||
|
||||
Returns a new array without duplicate elements of array C<@array>.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@array> (required): Array to process.
|
||||
|
||||
=cut
|
||||
|
||||
sub array_uniq {
|
||||
my %seen;
|
||||
grep !is_empty($_) && !$seen{$_}++, @_;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 fatal(@message)
|
||||
|
||||
Sends error message C<strval(@message)> to STDERR and abort program execution.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@message> (optional): Error message consisting of one or more strings.
|
||||
|
||||
=cut
|
||||
|
||||
sub fatal {
|
||||
my $message = strval(@_);
|
||||
|
||||
$message .= '. ' if !is_empty($message);
|
||||
$message .= 'Fatal error';
|
||||
|
||||
my @call1 = caller(2);
|
||||
my @call2 = caller(1);
|
||||
|
||||
die strval($message, ' at ', $call1[1], ' line ', $call1[2], '. See ', $call1[3], ' at ', $call2[1], ' line ', $call2[2], '. Info');
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 warning(@message)
|
||||
|
||||
Sends error message C<strval(@message)> to STDERR but does not abort program
|
||||
execution.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@message> (optional): Warning message consisting of one or more strings.
|
||||
|
||||
=cut
|
||||
|
||||
sub warning {
|
||||
my $message = strval(@_);
|
||||
|
||||
$message .= '. ' if !is_empty($message);
|
||||
$message .= 'Warning';
|
||||
|
||||
my @call1 = caller(2);
|
||||
my @call2 = caller(1);
|
||||
|
||||
print STDERR strval($message, ' at ', $call1[1], ' line ', $call1[2], '. See ', $call1[3], ' at ', $call2[1], ' line ', $call2[2], "\n");
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 info(@message)
|
||||
|
||||
Sends information message C<strval(@message)> to STDERR.
|
||||
|
||||
=head3 Arguments:
|
||||
|
||||
- B<@message> (optional): Information message consisting of one or more
|
||||
strings.
|
||||
|
||||
=cut
|
||||
|
||||
sub info {
|
||||
print STDERR strval(@_, "\n");
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub check_arguments {
|
||||
my ($arg_ref, %ARGUMENTS) = @_;
|
||||
|
||||
my @valid_args = keys(%ARGUMENTS);
|
||||
|
||||
foreach my $arg (keys(%$arg_ref)) {
|
||||
fatal('Invalid "', $arg, '" argument') if !in_array($arg, \@valid_args);
|
||||
}
|
||||
|
||||
foreach my $arg (@valid_args) {
|
||||
my @values = array($ARGUMENTS{$arg});
|
||||
if (@values) {
|
||||
my $required = shift(@values);
|
||||
my $ref_value_0 = ref($values[0]);
|
||||
if ($required == ARG_DEFAULT) {
|
||||
if (is_empty($$arg_ref{$arg}) && @values) {
|
||||
if (is_empty($ref_value_0)) {
|
||||
$$arg_ref{$arg} = $values[0];
|
||||
}
|
||||
elsif (is_eq($ref_value_0, 'ARRAY')) {
|
||||
$$arg_ref{$arg} = (@{$values[0]});
|
||||
}
|
||||
elsif (is_eq($ref_value_0, 'HASH')) {
|
||||
$$arg_ref{$arg} = {%{$values[0]}};
|
||||
}
|
||||
else {
|
||||
$$arg_ref{$arg} = ${$values[0]};
|
||||
}
|
||||
}
|
||||
fatal('Default value for "', $arg, '" is required') if !defined($$arg_ref{$arg});
|
||||
push(@values, $$arg_ref{$arg}) if !in_array($$arg_ref{$arg}, \@values);
|
||||
}
|
||||
elsif ($required == ARG_REQUIRED) {
|
||||
fatal('Value for "', $arg, '" is required') if !defined($$arg_ref{$arg});
|
||||
}
|
||||
elsif ($required != ARG_OPTIONAL) {
|
||||
fatal('Type of argument not recognized');
|
||||
}
|
||||
fatal('Invalid "', $arg, '" value "', $$arg_ref{$arg}, '"') if @values && !is_empty($$arg_ref{$arg}) && !in_array($$arg_ref{$arg}, \@values);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub format_num {
|
||||
my ($number, %arg) = @_;
|
||||
check_arguments(\%arg,
|
||||
FORMAT => [ ARG_OPTIONAL ],
|
||||
ZERO => [ ARG_DEFAULT, FALSE, TRUE ],
|
||||
DECIMALS => [ ARG_DEFAULT, 0 ],
|
||||
DEC_POINT => [ ARG_DEFAULT, ',' ],
|
||||
THOUSANDS_SEP => [ ARG_DEFAULT, '.', 'none' ]
|
||||
);
|
||||
|
||||
$number = trim($number);
|
||||
return '' if is_empty($number);
|
||||
return $number if in_array($number, '∞', '~');
|
||||
return '' if !is_num($number);
|
||||
$number = numval($number);
|
||||
|
||||
return '' if $number == 0 && !is_true($arg{ZERO});
|
||||
|
||||
return sprintf($arg{FORMAT}, $number) if !is_empty($arg{FORMAT});
|
||||
|
||||
$number = sprintf("%.$arg{DECIMALS}f", $number);
|
||||
eval "\$number =~ tr/./$arg{DEC_POINT}/";
|
||||
eval "\$number =~ s/(\\d)(?=(\\d{3})+(\\D|\$))/\$1\$arg{THOUSANDS_SEP}/g" if !is_eq($arg{THOUSANDS_SEP}, 'none');
|
||||
return $number;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub format_pct {
|
||||
my ($number, %arg) = @_;
|
||||
check_arguments(\%arg,
|
||||
ZERO => [ ARG_DEFAULT, FALSE, TRUE ],
|
||||
DECIMALS => [ ARG_DEFAULT, 2 ]
|
||||
);
|
||||
|
||||
$number = format_num($number, %arg);
|
||||
return is_empty($number) ? '' : strval($number, '%');
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub format_date_dmy {
|
||||
my $date = shift;
|
||||
|
||||
return '' if is_empty($date);
|
||||
|
||||
my @date = split('-', $date);
|
||||
return '' if is_empty($date[2]) || is_empty($date[1]) || is_empty($date[0]);
|
||||
return sprintf("%02d/%02d/%04d", $date[2], $date[1], $date[0]);
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 get_today_ymd()
|
||||
|
||||
Devuelve la fecha actual en el formato AAAA-MM-DD.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_today_ymd {
|
||||
my ($y, $m, $d) = Today();
|
||||
return ($y, sprintf("%02d", $m), sprintf("%02d", $d));
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub csv_header {
|
||||
my %arg = @_;
|
||||
check_arguments(\%arg,
|
||||
SEPARATOR => [ ARG_DEFAULT, ';' ],
|
||||
REPLACE => [ ARG_DEFAULT, ',' ],
|
||||
HEADER => [ ARG_OPTIONAL ]
|
||||
);
|
||||
|
||||
return __csv_line($arg{SEPARATOR}, $arg{REPLACE}, $arg{HEADER});
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub csv_line {
|
||||
my %arg = @_;
|
||||
check_arguments(\%arg,
|
||||
SEPARATOR => [ ARG_DEFAULT, ';' ],
|
||||
REPLACE => [ ARG_DEFAULT, ',' ],
|
||||
DATA => [ ARG_OPTIONAL ]
|
||||
);
|
||||
|
||||
return __csv_line($arg{SEPARATOR}, $arg{REPLACE}, $arg{DATA});
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub __csv_line {
|
||||
my ($separator, $replace, $data) = @_;
|
||||
|
||||
my $line = '';
|
||||
foreach my $field (@$data) {
|
||||
if (!is_empty($field)) {
|
||||
$field =~ s/$separator/$replace/g;
|
||||
$line .= trim($field);
|
||||
}
|
||||
$line .= $separator;
|
||||
}
|
||||
chop($line);
|
||||
return strval($line, "\r\n");
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
299
Dam/Var.pm
Normal file
299
Dam/Var.pm
Normal file
|
|
@ -0,0 +1,299 @@
|
|||
=head1 NAME
|
||||
|
||||
Dam::Var
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
API for global variables.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
|
||||
package Dam::Var;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT = qw(
|
||||
UNDEF_VAR
|
||||
DELETE_VAR
|
||||
|
||||
CONFIG
|
||||
GLOBAL
|
||||
RESERVED
|
||||
);
|
||||
|
||||
use constant {
|
||||
UNDEF_VAR => 'K9a(fz=D>vFy3m485jE]:Jm2B@3Ou6',
|
||||
DELETE_VAR => '5s<N0U{R_hNgQn@CyKoD(]rUWO)mbW'
|
||||
};
|
||||
|
||||
use Cwd;
|
||||
|
||||
use Dam::Util;
|
||||
|
||||
|
||||
|
||||
# CONFIGURATION VARIABLES:
|
||||
|
||||
# Today:
|
||||
my ($y, $m, $d) = get_today_ymd();
|
||||
|
||||
# Version news:
|
||||
my @LAST_CHANGELOG = ();
|
||||
my @PREV_CHANGELOG = ();
|
||||
|
||||
# No access groups:
|
||||
my @ACCESS_GROUPS = ();
|
||||
|
||||
# Menus:
|
||||
my %ROUTES = ();
|
||||
my %USER_MENU = (
|
||||
ID => 'Admin',
|
||||
TEXT => 'User',
|
||||
OPTIONS => {
|
||||
M_01 => { RUN => 'RUN_close', ICON => 'off', ACCESS => [ 1 ], TEXT => 'Close session' }
|
||||
}
|
||||
);
|
||||
|
||||
|
||||
my %CONFIG_VARS = (
|
||||
|
||||
# DEBUG MODE (0 = PRODUCTION, 1 = DEVELOPMENT, 2 = TESTING):
|
||||
|
||||
DEBUG_MODE => 1,
|
||||
|
||||
# APPLICATION NAME AND SLOGAN:
|
||||
|
||||
APP_NAME => 'My Application',
|
||||
APP_MNEMO => 'App',
|
||||
APP_SLOGAN => '',
|
||||
|
||||
# APP FOLDERS & RESOURCE URL:
|
||||
|
||||
DIR_APP => getcwd(),
|
||||
DIR_TEMPLATES => strval(getcwd(), '/templates'),
|
||||
DIR_UPLOADS => strval(getcwd(), '/uploads'),
|
||||
ROOT_WWW => '/',
|
||||
|
||||
# DATABASE ACCESS CONFIGURATION:
|
||||
|
||||
DB_DSN => 'DBI:mysql:database=dbname;host=hostname',
|
||||
DB_USER => 'user',
|
||||
DB_PASSWORD => 'password',
|
||||
|
||||
# LDAP DOMAIN/SERVER:
|
||||
|
||||
LDAP_DOMAIN => '',
|
||||
|
||||
# MESSAGES TRANSLATION:
|
||||
|
||||
l10n => 'EN_en',
|
||||
|
||||
# MAX SIZE FOR UPLOADED FILES (5MB):
|
||||
|
||||
UPLOAD_MAX_FILESIZE => 5 * 1024 * 1024,
|
||||
|
||||
# FOOTER COPYRIGHT:
|
||||
|
||||
FOOTER_COPYRIGHT => strval('© ', $y, ' Made with Dam Framework'),
|
||||
|
||||
# VERSION VARIABLES:
|
||||
|
||||
VERSION => '0.01',
|
||||
REF_LAST_CHANGELOG => \@LAST_CHANGELOG,
|
||||
REF_PREV_CHANGELOG => \@PREV_CHANGELOG,
|
||||
|
||||
# ACCESS GROUPS FOR USERS REFERENCE:
|
||||
|
||||
REF_ACCESS_GROUPS => \@ACCESS_GROUPS,
|
||||
|
||||
# MENU REFERENCES:
|
||||
|
||||
REF_ROUTES => \%ROUTES,
|
||||
REF_USER_MENU => \%USER_MENU
|
||||
);
|
||||
|
||||
|
||||
|
||||
# GLOBAL VARIABLES:
|
||||
|
||||
my %GLOBAL_VARS = ();
|
||||
|
||||
|
||||
|
||||
# RESERVED VARIABLES:
|
||||
|
||||
# Error, warning, information and debug messages:
|
||||
my @REPORT_ERROR = ();
|
||||
my @REPORT_WARNING = ();
|
||||
my @REPORT_INFO = ();
|
||||
my @DEBUG_INFO = ();
|
||||
|
||||
|
||||
my %RESERVED_VARS = (
|
||||
|
||||
# CGI APP:
|
||||
|
||||
CGIAPP => undef,
|
||||
|
||||
# ERROR, WARNING, INFORMATION AND DEBUG MESSAGES:
|
||||
|
||||
REF_REPORT_ERROR => \@REPORT_ERROR,
|
||||
REF_REPORT_WARNING => \@REPORT_WARNING,
|
||||
REF_REPORT_INFO => \@REPORT_INFO,
|
||||
REF_DEBUG_INFO => \@DEBUG_INFO,
|
||||
|
||||
# CURRENT REPORT:
|
||||
|
||||
REF_CURRENT_PACKAGE => undef
|
||||
);
|
||||
|
||||
|
||||
|
||||
=head2 CONFIG($variable, $value)
|
||||
|
||||
Mantiene una estructura global de variables ($variable => $value).
|
||||
|
||||
=cut
|
||||
|
||||
sub CONFIG {
|
||||
push(@_, undef) if @_ % 2;
|
||||
my %variables = @_;
|
||||
|
||||
my @variables = keys(%variables);
|
||||
if (!@variables) {
|
||||
foreach my $var (keys(%CONFIG_VARS)) {
|
||||
info($var, ' => ', strval($CONFIG_VARS{$var}));
|
||||
}
|
||||
fatal('Global configuration variable name is required');
|
||||
}
|
||||
|
||||
my $variable;
|
||||
foreach my $var (@variables) {
|
||||
fatal('Global configuration variable "', $var, '" doesn\'t exist') if !exists($CONFIG_VARS{$var});
|
||||
if (defined($variables{$var})) {
|
||||
fatal('Global configuration variables cannot be deleted (see "', $var, '")') if is_eq($variables{$var}, DELETE_VAR);
|
||||
$CONFIG_VARS{$var} = $variables{$var};
|
||||
}
|
||||
$variable = $var;
|
||||
}
|
||||
return $CONFIG_VARS{$variable};
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 GLOBAL($variable, $value)
|
||||
|
||||
Mantiene una estructura global de variables ($variable => $value).
|
||||
|
||||
=cut
|
||||
|
||||
sub GLOBAL {
|
||||
push(@_, undef) if @_ % 2;
|
||||
my %variables = @_;
|
||||
|
||||
my @variables = keys(%variables);
|
||||
if (!@variables) {
|
||||
foreach my $var (keys(%GLOBAL_VARS)) {
|
||||
info($var, ' => ', strval($GLOBAL_VARS{$var}));
|
||||
}
|
||||
fatal('Global variable name is required');
|
||||
}
|
||||
|
||||
my $variable;
|
||||
foreach my $var (@variables) {
|
||||
__assign(\%GLOBAL_VARS, \%variables, $var);
|
||||
$variable = $var;
|
||||
}
|
||||
return exists($GLOBAL_VARS{$variable}) ? $GLOBAL_VARS{$variable} : undef;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=head2 RESERVED($variable, $value)
|
||||
|
||||
Mantiene una estructura global de variables ($variable => $value).
|
||||
|
||||
=cut
|
||||
|
||||
sub RESERVED {
|
||||
my $caller = caller();
|
||||
$caller = substr($caller, 0, index($caller, '::'));
|
||||
fatal('Reserved variables can only be used by Dam framework') if !is_eq($caller, 'Dam');
|
||||
|
||||
push(@_, undef) if @_ % 2;
|
||||
my %variables = @_;
|
||||
|
||||
my @variables = keys(%variables);
|
||||
if (!@variables) {
|
||||
foreach my $var (keys(%RESERVED_VARS)) {
|
||||
info($var, ' => ', strval($RESERVED_VARS{$var}));
|
||||
}
|
||||
fatal('Reserved variable name is required');
|
||||
}
|
||||
|
||||
my $variable;
|
||||
foreach my $var (@variables) {
|
||||
__assign(\%RESERVED_VARS, \%variables, $var);
|
||||
$variable = $var;
|
||||
}
|
||||
return exists($RESERVED_VARS{$variable}) ? $RESERVED_VARS{$variable} : undef;
|
||||
}
|
||||
|
||||
|
||||
# PRIVATE FUNCTIONS:
|
||||
|
||||
|
||||
sub __assign {
|
||||
my ($VARS_ref, $variables_ref, $var) = @_;
|
||||
|
||||
if (defined($$variables_ref{$var})) {
|
||||
if (is_eq($$variables_ref{$var}, UNDEF_VAR)) {
|
||||
$$VARS_ref{$var} = undef;
|
||||
}
|
||||
elsif (is_eq($$variables_ref{$var}, DELETE_VAR)) {
|
||||
delete($$VARS_ref{$var});
|
||||
}
|
||||
else {
|
||||
$$VARS_ref{$var} = $$variables_ref{$var};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Manuel Cillero C<< <manuel@cillero.es> >>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2004-2020 Manuel Cillero. All rights reserved.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
|
||||
=cut
|
||||
Reference in a new issue