perl-dam/Dam/Util.pm

=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 format_date_ymd 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 { (defined($_) ? $_ : '') => 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, '&infin;', '~');
	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]);
}



sub format_date_ymd {
	my @date = @_;

	return '' if !@date;

	@date = split('-', $date[0]) if scalar @date == 1;
	return '' if is_empty($date[2]) || is_empty($date[1]) || is_empty($date[0]);
	return sprintf("%04d-%02d-%02d", $date[0], $date[1], $date[2]);
}



=head2 get_today_ymd()

Returns current date using the format YYYY-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