ONO::Lib::Basic
package ONO::Lib::Basic;
################################################################################
# COPYRIGHT / LICENSE #
################################################################################
#
# This file is part of the ONO Software Project.
#
# Copyright (C) 2000-2025 Jos KIRPS [ www.kirps.com | jos_AT_kirps_DOT_com ]
# and The Joopita Project [ www.joopita.org | contact_AT_joopita_DOT_com ]
#
# This file, as well as other parts of the ONO Software Project or related
# elements, are FREE SOFTWARE available under the ARTISTIC LICENSE 2.0.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# For the full license, see /ono/osr/license/LICENSE.txt, or write to
# jos_AT_kirps_DOT_com or contact_AT_joopita_DOT_com.
#
################################################################################
# END OF COPYRIGHT / LICENSE, HERE COMES THE CODE ... #
################################################################################
use strict;
###############################################################################
# ADD / REMOVE STUFF
###############################################################################
sub add_leading_zeroes {
#: Add leading zeroes to a string.
my (
$self,
$num,
$length,
) = @_;
if ($length > 256) {
$length = 256;
}
my $whilecounter;
while (length $num < $length && $whilecounter < 256) {
$whilecounter++;
$num = "0$num";
}
return $num;
}
sub add_tailing_zeroes {
#: Add tailing zeroes to a string.
my $num = $_[1];
for (my $i = 0; $i < $_[2]; $i++) {
$num .= "0";
}
return $num
}
sub remove_leading_spaces {
#: Remove leading spaces from a string.
#: See also remove_bad_spaces() and remove_bad_spaces_sentence().
my $string = $_[1];
$string =~ s/^\s+//;
return $string;
}
sub remove_leading_zeroes {
#: Remove leading zeroes from a string.
#: See also remove_leading_zeroes_comma().
my $num = $_[1];
$num =~ s/^0+(?=[0-9])//;
return $num;
}
sub remove_leading_zeroes_comma {
#: Remove leading zeroes from a string, respecting comma numbers.
my $num = $_[1];
if ($num =~ /(\.|\,)/) {
my $whilecounter;
while ($num =~ s/^0// && $whilecounter < 256) {
$num =~ s/^0//;
$whilecounter++;
}
if ($num =~ /^(\.|\,)/) {
$num = "0$num";
}
} else {
$num =~ s/^0+(?=[0-9])//;
}
return $num;
}
sub remove_tailing_spaces {
#: Remove tailing spaces from a string.
#: See also remove_bad_spaces() and remove_bad_spaces_sentence().
my $string = $_[1];
$string =~ s/\s+$//;
return $string;
}
###############################################################################
# NUMBERS
###############################################################################
sub num_human_readable {
#: Make numbers human readable by adding separators.
#: This does NOT work with comma numbers!
my $num = $_[1];
my $lang = $_[2];
my $length = length $num;
my $sep = ",";
if ($lang =~ /^(de|fr|lu)$/) {
$sep = ".";
}
if ($length > 3) {
$num = substr($num,0,$length-3).$sep.substr($num,$length-3,3);
if ($length > 6) {
$num = substr($num,0,$length-6).$sep.substr($num,$length-6,8);
}
}
return $num;
}
sub num_round_up {
#: Not implemented yet.
#: See also num_round_down().
}
sub num_round_down {
#: Round number down.
#: See also num_round_up().
my $num = $_[1];
my $len = $_[2];
my $length = length $num;
if (!$len) {
$len = 3;
}
if ($length > $len) {
$num = substr($num,0,$length-$len);
$num = &add_tailing_zeroes("",$num,$len);
}
return $num;
}
###############################################################################
# ARRAY STUFF
###############################################################################
sub array_flip {
#: Flip two strings in an array (a,b -> b,a).
#: See also array_flip_random().
my @array = @_;
return ($array[2],$array[1]);
}
sub array_flip_random {
#: Flip two strings in an array (a,b -> b,a) width a 50/50 chance.
#: See also array_flip().
my @array = @_;
if (int(rand(100)) > 49) {
return ($array[1],$array[2]);
} else {
return ($array[2],$array[1]);
}
}
sub array_limit {
#: Limit the number of elements in an array.
my $limit = $_[1];
my (@array,$counter);
foreach my $item (@_) {
$counter++;
if ($counter > 2 && $counter < $limit+3) {
@array = (@array,$item);
}
}
return @array;
}
sub array_randomize {
#: Randomize array.
#: Same as randomize_array().
my (
$self,
@array
) = @_;
return &randomize_array("",@array);
}
sub array_sortbylength {
#: Sort an array by the length of its elements.
my (
$self,
@array
) = @_;
return reverse sort { length $a <=> length $b } @array;
}
sub array_sortbynumber {
#: Sort an array by number.
my (
$self,
@array
) = @_;
return sort { $a <=> $b } @array;
}
###############################################################################
# CLEAN STRINGS
###############################################################################
sub cleanstring {
#: Clean up a string, allowing only numbers, letters, umlauts, and some special characters.
my $string = $_[1];
$string =~ s~[^A-Za-z0-9\ \'\-\_\,\;\.\:\Ä\Ë\Ö\Ü\ä\à\â\ã\é\è\ë\ê\ï\î\ö\ô\ü\ç]~~g;
return $string;
}
sub cleanmail {
#: Clean up an e-mail address.
#: Other characters are technically allowed, but ONO doesn't like or allow them!
my $string = lc $_[1];
$string =~ s~[^a-z0-9\-\_\@\.]~~g;
return $string;
}
sub cleanurl {
#: Clean up an URL.
my $string = $_[1];
my $add_http = $_[2];
$string =~ s~[^A-Za-z0-9\_\-\.\,\:\?\&\;\/\%\#]~~g;
if ($add_http && $string !~ m~^(http|https)://~) {
$string = "http://$string";
}
return $string;
}
###############################################################################
# COMPACT HTML CODE
###############################################################################
sub compact_code {
#: Compress HTML code.
#: Same as html_compress().
return &html_compress("",$_[1]);
}
sub html_compress {
#: Compress HTML code, by removing non-required spaces and line feeds,
#: returns, and tabs.
my $HTML = $_[1];
$HTML =~ s~(\n|\r|\t)~~g;
my $whilecounter;
while ($whilecounter < 256 && $HTML =~ s/ / /g) {
$whilecounter++;
$HTML =~ s/ / /g;
$HTML =~ s/ / /g;
$HTML =~ s/ / /g;
$HTML =~ s/ / /g;
$HTML =~ s/ / /g;
}
$HTML =~ s~\> \<~\>\<~g;
return $HTML;
}
###############################################################################
# CSS CODE GENERATORS
###############################################################################
sub css_rotate {
#: Rotate an HTML element using CSS code.
return qq~-ms-transform:rotate($_[1]deg);-webkit-transform:rotate($_[1]deg);transform:rotate($_[1]deg);~;
}
###############################################################################
# DOMAIN EXAMPLE
###############################################################################
sub domain_example {
#: Generate a localized example domain.
my $BLK_ref = $_[1];
my %BLK = %$BLK_ref;
my $tld = "com";
if ($BLK{'lang'} =~ /^(lu|de|fr)$/) {
$tld = $BLK{'lang'};
}
return lc "www.$BLK{'example'}.$tld";
}
###############################################################################
# EMAIL TOOLS
###############################################################################
sub email_valid {
#: Check if email address is valid.
if (&valid_email($_[1])) {
return 1;
} else {
return 0;
}
}
sub email_example {
#: Generate a localized example email address.
my $BLK_ref = $_[1];
my %BLK = %$BLK_ref;
my $tld = "com";
if ($BLK{'lang'} =~ /^(lu|de|fr)$/) {
$tld = $BLK{'lang'};
}
return lc "$BLK{'you'}\@$BLK{'example'}.$tld";
}
###############################################################################
# INPUT FIELD CLEANUP
###############################################################################
sub inputfield {
#: Clean up an input field, and trim it if required.
my $input = $_[1];
$input =~ s~"~"~g;
$input =~ s~\[\[~###OPEN###~g;
$input =~ s~\]\]~###CLOSE###~g;
if ($_[2]) {
$input = substr($input,0,$_[2]);
}
return $input;
}
sub inputtext {
#: Clean up an text field.
my $input = $_[1];
$input =~ s~"~"~g;
$input =~ s~\[\[~###OPEN###~g;
$input =~ s~\]\]~###CLOSE###~g;
return $input;
}
###############################################################################
# PATH BREAKS
###############################################################################
sub pathbreaks {
#: Make a path breakable, to display it on responsive pages for example.
#: See also pathbreaks_mail().
my $path = $_[1];
my $http;
if ($path =~ s~^(http|https)(://)~~) {
$http = "$1$2";
}
$path =~ s~//~/~;
$path =~ s~(_|-|\/)~$1~g;
return "$http$path";
}
sub pathbreaks_mail {
#: Make an email address breakable, to display it on responsive pages for example.
#: This will automatically turn it into a clickable link.
#: See also pathbreaks().
return qq~<a href="mailto:$_[1]" class="$_[2]">~.&pathbreaks("",$_[1]).qq~</a>~;
}
###############################################################################
# RANDOM STUFF
###############################################################################
sub randomize_array {
#: Randomize array.
#: Same as array_randomize().
my (
$self,
@array
) = @_;
my (@new,$whilecounter);
while (@array && $whilecounter < 8192) {
$whilecounter++;
my $i = int(rand() * @array);
push @new, $array[$i];
splice(@array, $i, 1);
}
return @new;
}
sub random_100 {
#: Return a random number between 0 and 99.
return int(rand(100));
}
sub random_percent {
#: Will return 1 on an X-to-100 percent chance
my $threshold = $_[1];
if (&random_100 > 99-$threshold) {
return 1;
} else {
return 0;
}
}
###############################################################################
# REMOVE DOUBLE CHARS
###############################################################################
sub remove_bad_spaces {
#: Remove bad spaces from a string, which includes leading and tailing spaces,
#: as well as double spaces anywhere.
#: See also remove_bad_spaces_sentence().
my (
$self,
$input,
$max,
) = @_;
$max = &_remove_max("",$max);
my $whilecounter;
while (($input =~ s~ ~ ~g || $input =~ s~^ ~~g || $input =~ s~ $~~g) && $whilecounter < $max) {
$whilecounter++;
$input =~ s~ ~ ~g;
$input =~ s~ ~ ~g;
$input =~ s~^ ~~g;
$input =~ s~ $~~g;
}
return $input;
}
sub remove_bad_spaces_sentence {
#: Remove bad spaces from a sentence or a text, respecing dots, commas, etc.
#: This automatically includes the remove_bad_spaces routine.
#: See also remove_bad_spaces().
my (
$self,
$input,
$max,
) = @_;
$max = &_remove_max("",$max);
$input = &remove_bad_spaces("",$input,$max);
my $whilecounter;
while (($input =~ s~ (\.|\!|\?)$~$1~g || $input =~ s~ (\.|\,|\;)~$1~g) && $whilecounter < $max) {
$whilecounter++;
$input =~ s~ (\.|\!|\?)$~$1~g;
$input =~ s~ (\.|\,|\;)~$1~g;
}
return $input;
}
sub remove_double_returns {
my (
$self,
$input,
$max,
$ext,
) = @_;
#: Automatically remove returns and tabs, optionally remove leading and tailing returns
$max = &_remove_max("",$max);
$input =~ s~(\r|\t)~~g;
my $whilecounter;
while ($input =~ s~\n\n~\n~g && $whilecounter < $max) {
$whilecounter++;
$input =~ s~\n\n\n~\n~g;
$input =~ s~\n\n~\n~g;
}
if ($ext) {
$input =~ s~^\n~~;
$input =~ s~\n$~~;
}
return $input;
}
sub remove_doubles {
my (
$self,
$input,
$char,
$max,
$ext,
) = @_;
#: Remove doubles or a specific char.
$max = &_remove_max("",$max);
my $whilecounter;
while ($input =~ s~$char$char~$char~g && $whilecounter < $max) {
$whilecounter++;
$input =~ s~$char$char$char~$char~g;
$input =~ s~$char$char~$char~g;
}
if ($ext) {
$input =~ s~^$char~~;
$input =~ s~${char}$~~;
}
return $input;
}
sub _remove_max {
#: Internal subroutine.
my $max = $_[1];
if (!$max || $max > 65536) {
$max = 1024;
}
return $max;
}
###############################################################################
# SAFE URLs
###############################################################################
sub safeurl {
#: Make a string safe to be displayed on an HTML page.
my $URL = $_[1];
$URL =~ s~\<~<~gi;
$URL =~ s~\>~>~gi;
$URL =~ s~\"~"~gi;
return $URL;
}
###############################################################################
# SHORT STRING
###############################################################################
sub shortstring {
my (
$self,
$input,
$max,
$switches,
) = @_;
#: Limit the length of a string, replace the middle of the string by dots if required.
#:
#: -c cleanup, will remove double stuff
#: -P remove path, only keep everything behind the last slash (always applied, even if string not long)
if (!$max) {
$max = 48;
}
if ($switches =~ /c/) {
$input =~ s~\'\'~\'~g;
}
if ($switches =~ /P/) {
$input =~ s~^(.*)/~~;
}
if (length $input > $max) {
return substr($input,0,int($max/2))." ... ".substr($input,(length $input)-int($max/2),int($max/2));
} else {
return $input;
}
}
###############################################################################
# SORT STRING
###############################################################################
sub sortstring {
#: Generate a sort string, which can be used to sort arrays for example.
#: See also sortstring_wrapped().
my $sort = lc $_[1];
$sort =~ s~[^a-z0-9]~~gi;
return $sort;
}
sub sortstring_wrapped {
#: Generate a sort string, make it usable within HTML code.
#: See also sortstring().
return "<!-- sort:".&sortstring("",$_[1])." -->";
}
sub sort_case_insensitive {
#: Sort an array, case insensitive.
my ($dump,@list) = @_;
return sort { lc($a) cmp lc($b) } @list;
}
###############################################################################
# SUBSTR
###############################################################################
sub substr_first_digit {
#: Return the first digit of a string.
return substr($_[1],0,1);
}
sub substr_last_digit {
#: Return the last digit of a string.
return substr($_[1],(length $_[1])-1,1);
}
###############################################################################
# TEXT FIELD
###############################################################################
sub textfield {
#: Clean up text field.
#: See also inputtext().
return &inputtext("",$_[1]);
}
###############################################################################
# UPPER CASE
###############################################################################
sub uc {
#: A better upper case, which also supports some international strings (umlauts).
my $input = $_[1];
$input =~ s~(ë|é|è|ê)~E~g;
$input =~ s~(ä|à|â)~A~g;
$input =~ s~(ï|î)~I~g;
$input =~ s~(ö|ô)~O~g;
return uc $input;
}
sub ucfirstletters {
#: Uppercase the first letter of each word in a string.
#: See also ucfirstletters_mkspaces().
my $input = $_[1];
$input =~ s/([\w']+)/\u\L$1/g;
return $input;
}
sub ucfirstletters_mkspaces {
#: Uppercase the first letter of each word in a string,
#: but first replace underscores by spaces.
#: See also ucfirstletters().
my $input = $_[1];
$input =~ s~_~ ~g;
return &ucfirstletters("",$input);
}
###############################################################################
# UMLAUTS
###############################################################################
sub umlaut {
#: Count the number of different umlauts in a string.
#: Can be used to test if a string contains umlauts at all (returns zero if not).
my $umlaut;
foreach my $um (¨auts) {
if ($_[1] =~ /$um/) {
$umlaut++;
}
}
return $umlaut;
}
sub umlauts {
#: Array of often used umlaut characters.
return ('Ä','Ë','Ö','Ü', 'ä','à','â','ã', 'é','è','ë','ê', 'ï','î', 'ö','ô', 'ü','û', 'ç','ß');
}
sub umlaut_make_uppercase {
#: Make character or string uppercase, also make umlauts uppercase.
#: Note that this is NOT EXACTLY the reverse of umlaut_make_lowercase.
my $UC = uc $_[1];
$UC =~ s~ä~Ä~g;
$UC =~ s~ë~Ë~g;
$UC =~ s~ï~Ï~g;
$UC =~ s~ö~Ö~g;
$UC =~ s~ü~Ü~g;
$UC =~ s~(à|â|ã)~A~g;
$UC =~ s~(é|è|ê)~E~g;
$UC =~ s~î~I~g;
$UC =~ s~ô~O~g;
$UC =~ s~û~U~g;
return $UC;
}
sub umlaut_make_lowercase {
#: Make character or string lowercase, also make umlauts uppercase.
#: Note that this is NOT EXACTLY the reverse of umlaut_make_uppercase.
my $LC = lc $_[1];
$LC =~ s~Ä~ä~g;
$LC =~ s~Ë~ë~g;
$LC =~ s~Ï~ï~g;
$LC =~ s~Ö~ö~g;
$LC =~ s~Ü~ü~g;
$LC =~ s~É~é~g;
$LC =~ s~Î~î~g;
$LC =~ s~Ô~ô~g;
return $LC;
}
sub umlaut_string_length {
#: Count the number of elements in umlaut_string_to_array().
my @array = ¨aut_string_to_array("",$_[1]);
my $length = @array;
return $length;
}
sub umlaut_string_to_array {
#: Return an array of all letters used in an array, respecting umlauts.
my $input = $_[1];
my (@letters,$is_umlaut);
for (my $a = 0; $a < length $input; $a++) {
if ($is_umlaut) {
$is_umlaut = 0;
} else {
my $letter = substr($input,$a,1);
my $umlaut = substr($input,$a,2);
if ($umlaut !~ /[A-Za-z]/) {
if (¨aut("",$umlaut)) {
$letter = $umlaut;
$is_umlaut = 1;
}
}
@letters = (@letters,$letter);
}
}
return @letters;
}
sub umlaut_simplify {
my (
$self,
$input,
$mode
) = @_;
#: Deal with umlauts in a string in various ways, using different modes:
#:
#: -0 default mode
#: -1 use single letters only (warning: 'ß' will also be replaced by single 's')
#: -2 same as 0, but will replace 'ß' by 'SS'
#: -3 mark umlauts: ä -> ae_, useful for exported speech files for example
my $input = $_[1];
if ($mode == 3) {
$input =~ s~Ä~Ae_~g;
$input =~ s~ä~ae_~g;
$input =~ s~Ö~Oe_~g;
$input =~ s~ö~oe_~g;
$input =~ s~Ü~Ue_~g;
$input =~ s~ü~ue_~g;
$input =~ s~ß~ss_~g;
$input =~ s~É~E_~g;
$input =~ s~Î~I_~g;
$input =~ s~(à|â|ã)~a_~g;
$input =~ s~(é|è|ë|ê)~e_~g;
$input =~ s~(ï|î)~i_~g;
$input =~ s~ô~o_~g;
$input =~ s~û~u_~g;
$input =~ s~ç~c_~g;
} else {
if ($mode == 1) {
$input =~ s~Ä~A~g;
$input =~ s~ä~a~g;
$input =~ s~Ö~O~g;
$input =~ s~ö~o~g;
$input =~ s~Ü~U~g;
$input =~ s~ü~u~g;
$input =~ s~ß~s~g;
} else {
$input =~ s~Ä~Ae~g;
$input =~ s~ä~ae~g;
$input =~ s~Ö~Oe~g;
$input =~ s~ö~oe~g;
$input =~ s~Ü~Ue~g;
$input =~ s~ü~ue~g;
if ($mode == 2) {
$input =~ s~ß~SS~g;
} else {
$input =~ s~ß~ss~g;
}
}
$input =~ s~É~E~g;
$input =~ s~Î~I~g;
$input =~ s~(à|â|ã)~a~g;
$input =~ s~(é|è|ë|ê)~e~g;
$input =~ s~(ï|î)~i~g;
$input =~ s~ô~o~g;
$input =~ s~û~u~g;
$input =~ s~ç~c~g;
}
return $input;
}
sub umlaut_transform {
#: Transform crappy 2-byte string to real utf-8 umlaut code
return ¨aut_reverse("",¨aut_simplify("",$_[1],2));
}
sub umlaut_reverse {
#: Restore umlauts in simplified string.
#: This will ONLY work for german umlauts, and not for SS
my $input = $_[1];
$input =~ s~ue~ü~g;
$input =~ s~ae~ä~g;
$input =~ s~oe~ö~g;
$input =~ s~SS~ß~g;
return $input;
}
###############################################################################
# VALIDATORS
###############################################################################
sub valid_email {
#: Test if email address is valid.
# if ($_[1] =~ /^(.*?)\@(.*?)\.(.*?)$/) {
if ($_[1] =~ /^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,}$/) {
return 1;
} else {
return 0;
}
}
sub valid_url {
#: Test if URL is valid.
if ($_[1] =~ /^(.*?)\.(.*?)$/) {
my ($one,$two) = ($1,$2);
if ($one =~ /[A-Za-z0-9]/ && $two =~ /[A-Za-z0-9]/) {
return 1;
} else {
return 0;
}
} else {
return 0;
}
}
sub valid_ip {
#: Test if IP address is valid.
if ($_[1] =~ /^((25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3}(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)$/) {
return 1;
} else {
return 0;
}
# if ($_[1] =~ /^(.*?)\.(.*?)\.(.*?)\.(.*?)$/) {
# my $err;
# foreach my $part ($1,$2,$3,$4) {
# if ($part > 255 || $part !~ /[0-9]/) {
# $err++;
# } else {
# my $test = $part;
# $test =~ s~[^0-9]~~g;
# if ($part ne $test) {
# $err++;
# }
# }
# }
# if ($err) {
# return 0;
# } else {
# return 1;
# }
# } else {
# return 0;
# }
}
sub valid_ip_range {
#: Test if IP range is valid.
if (&valid_ip("",$_[1])) {
return 1;
} else {
if ($_[1] =~ /^(.*?)\.(.*?)$/ && $_[1] =~ /[0-9]/ && $_[1] !~ /[A-Za-z\-\_\,\:\;]/ && $_[1] !~ /^\./ && $_[1] !~ /\.$/) {
if ($_[1] =~ /^(.*?)\.(.*?)\.(.*?)$/) {
if ($1 > -1 && $1 < 256 && $2 > -1 && $2 < 256 && $3 > -1 && $3 < 256) {
return 3;
} else {
return 0;
}
} else {
if ($_[1] =~ /^(.*?)\.(.*?)$/) {
if ($1 > -1 && $1 < 256 && $2 > -1 && $2 < 256) {
return 2;
} else {
return 0;
}
} else {
return 0;
}
}
} else {
return 0;
}
}
}
###############################################################################
# end of script
###############################################################################
1;
__END__
################################################################################
# COPYRIGHT / LICENSE #
################################################################################
#
# This file is part of the ONO Software Project.
#
# Copyright (C) 2000-2025 Jos KIRPS [ www.kirps.com | jos_AT_kirps_DOT_com ]
# and The Joopita Project [ www.joopita.org | contact_AT_joopita_DOT_com ]
#
# This file, as well as other parts of the ONO Software Project or related
# elements, are FREE SOFTWARE available under the ARTISTIC LICENSE 2.0.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# For the full license, see /ono/osr/license/LICENSE.txt, or write to
# jos_AT_kirps_DOT_com or contact_AT_joopita_DOT_com.
#
################################################################################
# END OF COPYRIGHT / LICENSE, HERE COMES THE CODE ... #
################################################################################
use strict;
###############################################################################
# ADD / REMOVE STUFF
###############################################################################
sub add_leading_zeroes {
#: Add leading zeroes to a string.
my (
$self,
$num,
$length,
) = @_;
if ($length > 256) {
$length = 256;
}
my $whilecounter;
while (length $num < $length && $whilecounter < 256) {
$whilecounter++;
$num = "0$num";
}
return $num;
}
sub add_tailing_zeroes {
#: Add tailing zeroes to a string.
my $num = $_[1];
for (my $i = 0; $i < $_[2]; $i++) {
$num .= "0";
}
return $num
}
sub remove_leading_spaces {
#: Remove leading spaces from a string.
#: See also remove_bad_spaces() and remove_bad_spaces_sentence().
my $string = $_[1];
$string =~ s/^\s+//;
return $string;
}
sub remove_leading_zeroes {
#: Remove leading zeroes from a string.
#: See also remove_leading_zeroes_comma().
my $num = $_[1];
$num =~ s/^0+(?=[0-9])//;
return $num;
}
sub remove_leading_zeroes_comma {
#: Remove leading zeroes from a string, respecting comma numbers.
my $num = $_[1];
if ($num =~ /(\.|\,)/) {
my $whilecounter;
while ($num =~ s/^0// && $whilecounter < 256) {
$num =~ s/^0//;
$whilecounter++;
}
if ($num =~ /^(\.|\,)/) {
$num = "0$num";
}
} else {
$num =~ s/^0+(?=[0-9])//;
}
return $num;
}
sub remove_tailing_spaces {
#: Remove tailing spaces from a string.
#: See also remove_bad_spaces() and remove_bad_spaces_sentence().
my $string = $_[1];
$string =~ s/\s+$//;
return $string;
}
###############################################################################
# NUMBERS
###############################################################################
sub num_human_readable {
#: Make numbers human readable by adding separators.
#: This does NOT work with comma numbers!
my $num = $_[1];
my $lang = $_[2];
my $length = length $num;
my $sep = ",";
if ($lang =~ /^(de|fr|lu)$/) {
$sep = ".";
}
if ($length > 3) {
$num = substr($num,0,$length-3).$sep.substr($num,$length-3,3);
if ($length > 6) {
$num = substr($num,0,$length-6).$sep.substr($num,$length-6,8);
}
}
return $num;
}
sub num_round_up {
#: Not implemented yet.
#: See also num_round_down().
}
sub num_round_down {
#: Round number down.
#: See also num_round_up().
my $num = $_[1];
my $len = $_[2];
my $length = length $num;
if (!$len) {
$len = 3;
}
if ($length > $len) {
$num = substr($num,0,$length-$len);
$num = &add_tailing_zeroes("",$num,$len);
}
return $num;
}
###############################################################################
# ARRAY STUFF
###############################################################################
sub array_flip {
#: Flip two strings in an array (a,b -> b,a).
#: See also array_flip_random().
my @array = @_;
return ($array[2],$array[1]);
}
sub array_flip_random {
#: Flip two strings in an array (a,b -> b,a) width a 50/50 chance.
#: See also array_flip().
my @array = @_;
if (int(rand(100)) > 49) {
return ($array[1],$array[2]);
} else {
return ($array[2],$array[1]);
}
}
sub array_limit {
#: Limit the number of elements in an array.
my $limit = $_[1];
my (@array,$counter);
foreach my $item (@_) {
$counter++;
if ($counter > 2 && $counter < $limit+3) {
@array = (@array,$item);
}
}
return @array;
}
sub array_randomize {
#: Randomize array.
#: Same as randomize_array().
my (
$self,
@array
) = @_;
return &randomize_array("",@array);
}
sub array_sortbylength {
#: Sort an array by the length of its elements.
my (
$self,
@array
) = @_;
return reverse sort { length $a <=> length $b } @array;
}
sub array_sortbynumber {
#: Sort an array by number.
my (
$self,
@array
) = @_;
return sort { $a <=> $b } @array;
}
###############################################################################
# CLEAN STRINGS
###############################################################################
sub cleanstring {
#: Clean up a string, allowing only numbers, letters, umlauts, and some special characters.
my $string = $_[1];
$string =~ s~[^A-Za-z0-9\ \'\-\_\,\;\.\:\Ä\Ë\Ö\Ü\ä\à\â\ã\é\è\ë\ê\ï\î\ö\ô\ü\ç]~~g;
return $string;
}
sub cleanmail {
#: Clean up an e-mail address.
#: Other characters are technically allowed, but ONO doesn't like or allow them!
my $string = lc $_[1];
$string =~ s~[^a-z0-9\-\_\@\.]~~g;
return $string;
}
sub cleanurl {
#: Clean up an URL.
my $string = $_[1];
my $add_http = $_[2];
$string =~ s~[^A-Za-z0-9\_\-\.\,\:\?\&\;\/\%\#]~~g;
if ($add_http && $string !~ m~^(http|https)://~) {
$string = "http://$string";
}
return $string;
}
###############################################################################
# COMPACT HTML CODE
###############################################################################
sub compact_code {
#: Compress HTML code.
#: Same as html_compress().
return &html_compress("",$_[1]);
}
sub html_compress {
#: Compress HTML code, by removing non-required spaces and line feeds,
#: returns, and tabs.
my $HTML = $_[1];
$HTML =~ s~(\n|\r|\t)~~g;
my $whilecounter;
while ($whilecounter < 256 && $HTML =~ s/ / /g) {
$whilecounter++;
$HTML =~ s/ / /g;
$HTML =~ s/ / /g;
$HTML =~ s/ / /g;
$HTML =~ s/ / /g;
$HTML =~ s/ / /g;
}
$HTML =~ s~\> \<~\>\<~g;
return $HTML;
}
###############################################################################
# CSS CODE GENERATORS
###############################################################################
sub css_rotate {
#: Rotate an HTML element using CSS code.
return qq~-ms-transform:rotate($_[1]deg);-webkit-transform:rotate($_[1]deg);transform:rotate($_[1]deg);~;
}
###############################################################################
# DOMAIN EXAMPLE
###############################################################################
sub domain_example {
#: Generate a localized example domain.
my $BLK_ref = $_[1];
my %BLK = %$BLK_ref;
my $tld = "com";
if ($BLK{'lang'} =~ /^(lu|de|fr)$/) {
$tld = $BLK{'lang'};
}
return lc "www.$BLK{'example'}.$tld";
}
###############################################################################
# EMAIL TOOLS
###############################################################################
sub email_valid {
#: Check if email address is valid.
if (&valid_email($_[1])) {
return 1;
} else {
return 0;
}
}
sub email_example {
#: Generate a localized example email address.
my $BLK_ref = $_[1];
my %BLK = %$BLK_ref;
my $tld = "com";
if ($BLK{'lang'} =~ /^(lu|de|fr)$/) {
$tld = $BLK{'lang'};
}
return lc "$BLK{'you'}\@$BLK{'example'}.$tld";
}
###############################################################################
# INPUT FIELD CLEANUP
###############################################################################
sub inputfield {
#: Clean up an input field, and trim it if required.
my $input = $_[1];
$input =~ s~"~"~g;
$input =~ s~\[\[~###OPEN###~g;
$input =~ s~\]\]~###CLOSE###~g;
if ($_[2]) {
$input = substr($input,0,$_[2]);
}
return $input;
}
sub inputtext {
#: Clean up an text field.
my $input = $_[1];
$input =~ s~"~"~g;
$input =~ s~\[\[~###OPEN###~g;
$input =~ s~\]\]~###CLOSE###~g;
return $input;
}
###############################################################################
# PATH BREAKS
###############################################################################
sub pathbreaks {
#: Make a path breakable, to display it on responsive pages for example.
#: See also pathbreaks_mail().
my $path = $_[1];
my $http;
if ($path =~ s~^(http|https)(://)~~) {
$http = "$1$2";
}
$path =~ s~//~/~;
$path =~ s~(_|-|\/)~$1~g;
return "$http$path";
}
sub pathbreaks_mail {
#: Make an email address breakable, to display it on responsive pages for example.
#: This will automatically turn it into a clickable link.
#: See also pathbreaks().
return qq~<a href="mailto:$_[1]" class="$_[2]">~.&pathbreaks("",$_[1]).qq~</a>~;
}
###############################################################################
# RANDOM STUFF
###############################################################################
sub randomize_array {
#: Randomize array.
#: Same as array_randomize().
my (
$self,
@array
) = @_;
my (@new,$whilecounter);
while (@array && $whilecounter < 8192) {
$whilecounter++;
my $i = int(rand() * @array);
push @new, $array[$i];
splice(@array, $i, 1);
}
return @new;
}
sub random_100 {
#: Return a random number between 0 and 99.
return int(rand(100));
}
sub random_percent {
#: Will return 1 on an X-to-100 percent chance
my $threshold = $_[1];
if (&random_100 > 99-$threshold) {
return 1;
} else {
return 0;
}
}
###############################################################################
# REMOVE DOUBLE CHARS
###############################################################################
sub remove_bad_spaces {
#: Remove bad spaces from a string, which includes leading and tailing spaces,
#: as well as double spaces anywhere.
#: See also remove_bad_spaces_sentence().
my (
$self,
$input,
$max,
) = @_;
$max = &_remove_max("",$max);
my $whilecounter;
while (($input =~ s~ ~ ~g || $input =~ s~^ ~~g || $input =~ s~ $~~g) && $whilecounter < $max) {
$whilecounter++;
$input =~ s~ ~ ~g;
$input =~ s~ ~ ~g;
$input =~ s~^ ~~g;
$input =~ s~ $~~g;
}
return $input;
}
sub remove_bad_spaces_sentence {
#: Remove bad spaces from a sentence or a text, respecing dots, commas, etc.
#: This automatically includes the remove_bad_spaces routine.
#: See also remove_bad_spaces().
my (
$self,
$input,
$max,
) = @_;
$max = &_remove_max("",$max);
$input = &remove_bad_spaces("",$input,$max);
my $whilecounter;
while (($input =~ s~ (\.|\!|\?)$~$1~g || $input =~ s~ (\.|\,|\;)~$1~g) && $whilecounter < $max) {
$whilecounter++;
$input =~ s~ (\.|\!|\?)$~$1~g;
$input =~ s~ (\.|\,|\;)~$1~g;
}
return $input;
}
sub remove_double_returns {
my (
$self,
$input,
$max,
$ext,
) = @_;
#: Automatically remove returns and tabs, optionally remove leading and tailing returns
$max = &_remove_max("",$max);
$input =~ s~(\r|\t)~~g;
my $whilecounter;
while ($input =~ s~\n\n~\n~g && $whilecounter < $max) {
$whilecounter++;
$input =~ s~\n\n\n~\n~g;
$input =~ s~\n\n~\n~g;
}
if ($ext) {
$input =~ s~^\n~~;
$input =~ s~\n$~~;
}
return $input;
}
sub remove_doubles {
my (
$self,
$input,
$char,
$max,
$ext,
) = @_;
#: Remove doubles or a specific char.
$max = &_remove_max("",$max);
my $whilecounter;
while ($input =~ s~$char$char~$char~g && $whilecounter < $max) {
$whilecounter++;
$input =~ s~$char$char$char~$char~g;
$input =~ s~$char$char~$char~g;
}
if ($ext) {
$input =~ s~^$char~~;
$input =~ s~${char}$~~;
}
return $input;
}
sub _remove_max {
#: Internal subroutine.
my $max = $_[1];
if (!$max || $max > 65536) {
$max = 1024;
}
return $max;
}
###############################################################################
# SAFE URLs
###############################################################################
sub safeurl {
#: Make a string safe to be displayed on an HTML page.
my $URL = $_[1];
$URL =~ s~\<~<~gi;
$URL =~ s~\>~>~gi;
$URL =~ s~\"~"~gi;
return $URL;
}
###############################################################################
# SHORT STRING
###############################################################################
sub shortstring {
my (
$self,
$input,
$max,
$switches,
) = @_;
#: Limit the length of a string, replace the middle of the string by dots if required.
#:
#: -c cleanup, will remove double stuff
#: -P remove path, only keep everything behind the last slash (always applied, even if string not long)
if (!$max) {
$max = 48;
}
if ($switches =~ /c/) {
$input =~ s~\'\'~\'~g;
}
if ($switches =~ /P/) {
$input =~ s~^(.*)/~~;
}
if (length $input > $max) {
return substr($input,0,int($max/2))." ... ".substr($input,(length $input)-int($max/2),int($max/2));
} else {
return $input;
}
}
###############################################################################
# SORT STRING
###############################################################################
sub sortstring {
#: Generate a sort string, which can be used to sort arrays for example.
#: See also sortstring_wrapped().
my $sort = lc $_[1];
$sort =~ s~[^a-z0-9]~~gi;
return $sort;
}
sub sortstring_wrapped {
#: Generate a sort string, make it usable within HTML code.
#: See also sortstring().
return "<!-- sort:".&sortstring("",$_[1])." -->";
}
sub sort_case_insensitive {
#: Sort an array, case insensitive.
my ($dump,@list) = @_;
return sort { lc($a) cmp lc($b) } @list;
}
###############################################################################
# SUBSTR
###############################################################################
sub substr_first_digit {
#: Return the first digit of a string.
return substr($_[1],0,1);
}
sub substr_last_digit {
#: Return the last digit of a string.
return substr($_[1],(length $_[1])-1,1);
}
###############################################################################
# TEXT FIELD
###############################################################################
sub textfield {
#: Clean up text field.
#: See also inputtext().
return &inputtext("",$_[1]);
}
###############################################################################
# UPPER CASE
###############################################################################
sub uc {
#: A better upper case, which also supports some international strings (umlauts).
my $input = $_[1];
$input =~ s~(ë|é|è|ê)~E~g;
$input =~ s~(ä|à|â)~A~g;
$input =~ s~(ï|î)~I~g;
$input =~ s~(ö|ô)~O~g;
return uc $input;
}
sub ucfirstletters {
#: Uppercase the first letter of each word in a string.
#: See also ucfirstletters_mkspaces().
my $input = $_[1];
$input =~ s/([\w']+)/\u\L$1/g;
return $input;
}
sub ucfirstletters_mkspaces {
#: Uppercase the first letter of each word in a string,
#: but first replace underscores by spaces.
#: See also ucfirstletters().
my $input = $_[1];
$input =~ s~_~ ~g;
return &ucfirstletters("",$input);
}
###############################################################################
# UMLAUTS
###############################################################################
sub umlaut {
#: Count the number of different umlauts in a string.
#: Can be used to test if a string contains umlauts at all (returns zero if not).
my $umlaut;
foreach my $um (¨auts) {
if ($_[1] =~ /$um/) {
$umlaut++;
}
}
return $umlaut;
}
sub umlauts {
#: Array of often used umlaut characters.
return ('Ä','Ë','Ö','Ü', 'ä','à','â','ã', 'é','è','ë','ê', 'ï','î', 'ö','ô', 'ü','û', 'ç','ß');
}
sub umlaut_make_uppercase {
#: Make character or string uppercase, also make umlauts uppercase.
#: Note that this is NOT EXACTLY the reverse of umlaut_make_lowercase.
my $UC = uc $_[1];
$UC =~ s~ä~Ä~g;
$UC =~ s~ë~Ë~g;
$UC =~ s~ï~Ï~g;
$UC =~ s~ö~Ö~g;
$UC =~ s~ü~Ü~g;
$UC =~ s~(à|â|ã)~A~g;
$UC =~ s~(é|è|ê)~E~g;
$UC =~ s~î~I~g;
$UC =~ s~ô~O~g;
$UC =~ s~û~U~g;
return $UC;
}
sub umlaut_make_lowercase {
#: Make character or string lowercase, also make umlauts uppercase.
#: Note that this is NOT EXACTLY the reverse of umlaut_make_uppercase.
my $LC = lc $_[1];
$LC =~ s~Ä~ä~g;
$LC =~ s~Ë~ë~g;
$LC =~ s~Ï~ï~g;
$LC =~ s~Ö~ö~g;
$LC =~ s~Ü~ü~g;
$LC =~ s~É~é~g;
$LC =~ s~Î~î~g;
$LC =~ s~Ô~ô~g;
return $LC;
}
sub umlaut_string_length {
#: Count the number of elements in umlaut_string_to_array().
my @array = ¨aut_string_to_array("",$_[1]);
my $length = @array;
return $length;
}
sub umlaut_string_to_array {
#: Return an array of all letters used in an array, respecting umlauts.
my $input = $_[1];
my (@letters,$is_umlaut);
for (my $a = 0; $a < length $input; $a++) {
if ($is_umlaut) {
$is_umlaut = 0;
} else {
my $letter = substr($input,$a,1);
my $umlaut = substr($input,$a,2);
if ($umlaut !~ /[A-Za-z]/) {
if (¨aut("",$umlaut)) {
$letter = $umlaut;
$is_umlaut = 1;
}
}
@letters = (@letters,$letter);
}
}
return @letters;
}
sub umlaut_simplify {
my (
$self,
$input,
$mode
) = @_;
#: Deal with umlauts in a string in various ways, using different modes:
#:
#: -0 default mode
#: -1 use single letters only (warning: 'ß' will also be replaced by single 's')
#: -2 same as 0, but will replace 'ß' by 'SS'
#: -3 mark umlauts: ä -> ae_, useful for exported speech files for example
my $input = $_[1];
if ($mode == 3) {
$input =~ s~Ä~Ae_~g;
$input =~ s~ä~ae_~g;
$input =~ s~Ö~Oe_~g;
$input =~ s~ö~oe_~g;
$input =~ s~Ü~Ue_~g;
$input =~ s~ü~ue_~g;
$input =~ s~ß~ss_~g;
$input =~ s~É~E_~g;
$input =~ s~Î~I_~g;
$input =~ s~(à|â|ã)~a_~g;
$input =~ s~(é|è|ë|ê)~e_~g;
$input =~ s~(ï|î)~i_~g;
$input =~ s~ô~o_~g;
$input =~ s~û~u_~g;
$input =~ s~ç~c_~g;
} else {
if ($mode == 1) {
$input =~ s~Ä~A~g;
$input =~ s~ä~a~g;
$input =~ s~Ö~O~g;
$input =~ s~ö~o~g;
$input =~ s~Ü~U~g;
$input =~ s~ü~u~g;
$input =~ s~ß~s~g;
} else {
$input =~ s~Ä~Ae~g;
$input =~ s~ä~ae~g;
$input =~ s~Ö~Oe~g;
$input =~ s~ö~oe~g;
$input =~ s~Ü~Ue~g;
$input =~ s~ü~ue~g;
if ($mode == 2) {
$input =~ s~ß~SS~g;
} else {
$input =~ s~ß~ss~g;
}
}
$input =~ s~É~E~g;
$input =~ s~Î~I~g;
$input =~ s~(à|â|ã)~a~g;
$input =~ s~(é|è|ë|ê)~e~g;
$input =~ s~(ï|î)~i~g;
$input =~ s~ô~o~g;
$input =~ s~û~u~g;
$input =~ s~ç~c~g;
}
return $input;
}
sub umlaut_transform {
#: Transform crappy 2-byte string to real utf-8 umlaut code
return ¨aut_reverse("",¨aut_simplify("",$_[1],2));
}
sub umlaut_reverse {
#: Restore umlauts in simplified string.
#: This will ONLY work for german umlauts, and not for SS
my $input = $_[1];
$input =~ s~ue~ü~g;
$input =~ s~ae~ä~g;
$input =~ s~oe~ö~g;
$input =~ s~SS~ß~g;
return $input;
}
###############################################################################
# VALIDATORS
###############################################################################
sub valid_email {
#: Test if email address is valid.
# if ($_[1] =~ /^(.*?)\@(.*?)\.(.*?)$/) {
if ($_[1] =~ /^[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,}$/) {
return 1;
} else {
return 0;
}
}
sub valid_url {
#: Test if URL is valid.
if ($_[1] =~ /^(.*?)\.(.*?)$/) {
my ($one,$two) = ($1,$2);
if ($one =~ /[A-Za-z0-9]/ && $two =~ /[A-Za-z0-9]/) {
return 1;
} else {
return 0;
}
} else {
return 0;
}
}
sub valid_ip {
#: Test if IP address is valid.
if ($_[1] =~ /^((25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)\.){3}(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)$/) {
return 1;
} else {
return 0;
}
# if ($_[1] =~ /^(.*?)\.(.*?)\.(.*?)\.(.*?)$/) {
# my $err;
# foreach my $part ($1,$2,$3,$4) {
# if ($part > 255 || $part !~ /[0-9]/) {
# $err++;
# } else {
# my $test = $part;
# $test =~ s~[^0-9]~~g;
# if ($part ne $test) {
# $err++;
# }
# }
# }
# if ($err) {
# return 0;
# } else {
# return 1;
# }
# } else {
# return 0;
# }
}
sub valid_ip_range {
#: Test if IP range is valid.
if (&valid_ip("",$_[1])) {
return 1;
} else {
if ($_[1] =~ /^(.*?)\.(.*?)$/ && $_[1] =~ /[0-9]/ && $_[1] !~ /[A-Za-z\-\_\,\:\;]/ && $_[1] !~ /^\./ && $_[1] !~ /\.$/) {
if ($_[1] =~ /^(.*?)\.(.*?)\.(.*?)$/) {
if ($1 > -1 && $1 < 256 && $2 > -1 && $2 < 256 && $3 > -1 && $3 < 256) {
return 3;
} else {
return 0;
}
} else {
if ($_[1] =~ /^(.*?)\.(.*?)$/) {
if ($1 > -1 && $1 < 256 && $2 > -1 && $2 < 256) {
return 2;
} else {
return 0;
}
} else {
return 0;
}
}
} else {
return 0;
}
}
}
###############################################################################
# end of script
###############################################################################
1;
__END__