2014-10-13 14:17:14 +04:00
|
|
|
#!/usr/bin/perl
|
|
|
|
|
|
|
|
package VMXTemplate::Utils;
|
|
|
|
|
|
|
|
use strict;
|
2014-10-14 02:37:29 +04:00
|
|
|
use utf8;
|
2014-10-13 14:17:14 +04:00
|
|
|
use Encode;
|
|
|
|
use base qw(Exporter);
|
|
|
|
|
|
|
|
our @EXPORT = qw(
|
|
|
|
TS_UNIX TS_DB TS_DB_DATE TS_MW TS_EXIF TS_ORACLE TS_ISO_8601 TS_RFC822
|
2014-10-14 02:37:29 +04:00
|
|
|
timestamp plural_ru strlimit htmlspecialchars urlencode urldecode strip_tags strip_unsafe_tags
|
2014-10-13 14:17:14 +04:00
|
|
|
addcslashes requote quotequote sql_quote regex_replace str_replace
|
|
|
|
array_slice array_div encode_json trim html_pbr array_items utf8on
|
2015-01-09 18:58:50 +03:00
|
|
|
exec_subst exec_pairs exec_is_array exec_get exec_cmp min max str_min str_max round var_dump
|
2014-10-13 14:17:14 +04:00
|
|
|
);
|
|
|
|
|
|
|
|
use constant {
|
|
|
|
TS_UNIX => 0,
|
|
|
|
TS_DB => 1,
|
|
|
|
TS_DB_DATE => 2,
|
|
|
|
TS_MW => 3,
|
|
|
|
TS_EXIF => 4,
|
|
|
|
TS_ORACLE => 5,
|
|
|
|
TS_ISO_8601 => 6,
|
|
|
|
TS_RFC822 => 7,
|
|
|
|
};
|
|
|
|
|
|
|
|
my @Mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
|
|
|
|
my %mon = qw(jan 0 feb 1 mar 2 apr 3 may 4 jun 5 jul 6 aug 7 sep 8 oct 9 nov 10 dec 11);
|
|
|
|
my @Wday = qw(Sun Mon Tue Wed Thu Fri Sat);
|
|
|
|
|
|
|
|
our $safe_tags = 'div|blockquote|span|a|b|i|u|p|h1|h2|h3|h4|h5|h6|strike|strong|small|big|blink'.
|
|
|
|
'|center|ol|pre|sub|sup|font|br|table|tr|td|th|tbody|tfoot|thead|tt|ul|li|em|img|marquee|cite';
|
|
|
|
|
|
|
|
# Date parser for some common formats
|
|
|
|
sub timestamp
|
|
|
|
{
|
|
|
|
my ($ts, $format) = @_;
|
|
|
|
|
|
|
|
require POSIX;
|
|
|
|
if (int($ts) eq $ts)
|
|
|
|
{
|
|
|
|
# TS_UNIX or Epoch
|
|
|
|
$ts = time if !$ts;
|
|
|
|
}
|
|
|
|
|
|
|
|
elsif ($ts =~ /^\D*(\d{4,}?)\D*(\d{2})\D*(\d{2})\D*(?:(\d{2})\D*(\d{2})\D*(\d{2})\D*([\+\- ]\d{2}\D*)?)?$/so)
|
|
|
|
{
|
|
|
|
# TS_DB, TS_DB_DATE, TS_MW, TS_EXIF, TS_ISO_8601
|
|
|
|
$ts = POSIX::mktime($6||0, $5||0, $4||0, $3, $2-1, $1-1900);
|
|
|
|
}
|
|
|
|
elsif ($ts =~ /^\s*(\d\d?)-(...)-(\d\d(?:\d\d)?)\s*(\d\d)\.(\d\d)\.(\d\d)/so)
|
|
|
|
{
|
|
|
|
# TS_ORACLE
|
|
|
|
$ts = POSIX::mktime($6, $5, $4, int($1), $mon{lc $2}, $3 < 100 ? $3 : $3-1900);
|
|
|
|
}
|
|
|
|
elsif ($ts =~ /^\s*..., (\d\d?) (...) (\d{4,}) (\d\d):(\d\d):(\d\d)\s*([\+\- ]\d\d)\s*$/so)
|
|
|
|
{
|
|
|
|
# TS_RFC822
|
|
|
|
$ts = POSIX::mktime($6, $5, $4, int($1), $mon{lc $2}, $3-1900);
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
# Bogus value, return undef
|
|
|
|
return undef;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (!$format)
|
|
|
|
{
|
|
|
|
# TS_UNIX
|
|
|
|
return $ts;
|
|
|
|
}
|
|
|
|
elsif ($format == TS_MW)
|
|
|
|
{
|
|
|
|
return POSIX::strftime("%Y%m%d%H%M%S", localtime($ts));
|
|
|
|
}
|
|
|
|
elsif ($format == TS_DB)
|
|
|
|
{
|
|
|
|
return POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime($ts));
|
|
|
|
}
|
|
|
|
elsif ($format == TS_DB_DATE)
|
|
|
|
{
|
|
|
|
return POSIX::strftime("%Y-%m-%d", localtime($ts));
|
|
|
|
}
|
|
|
|
elsif ($format == TS_ISO_8601)
|
|
|
|
{
|
|
|
|
return POSIX::strftime("%Y-%m-%dT%H:%M:%SZ", localtime($ts));
|
|
|
|
}
|
|
|
|
elsif ($format == TS_EXIF)
|
|
|
|
{
|
|
|
|
return POSIX::strftime("%Y:%m:%d %H:%M:%S", localtime($ts));
|
|
|
|
}
|
|
|
|
elsif ($format == TS_RFC822)
|
|
|
|
{
|
|
|
|
my @l = localtime($ts);
|
|
|
|
return POSIX::strftime($Wday[$l[6]].", %d ".$Mon[$l[4]]." %Y %H:%M:%S %z", @l);
|
|
|
|
}
|
|
|
|
elsif ($format == TS_ORACLE)
|
|
|
|
{
|
|
|
|
my @l = localtime($ts);
|
|
|
|
return POSIX::strftime("%d-".$Mon[$l[4]]."-%Y %H.%M.%S %p", @l);
|
|
|
|
}
|
|
|
|
return $ts;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Select one of 3 plural forms for russian language
|
|
|
|
sub plural_ru
|
|
|
|
{
|
|
|
|
my ($count, $one, $few, $many) = @_;
|
|
|
|
my $sto = $count % 100;
|
|
|
|
if ($sto >= 10 && $sto <= 20)
|
|
|
|
{
|
|
|
|
return $many;
|
|
|
|
}
|
|
|
|
my $r = $count % 10;
|
|
|
|
if ($r == 1)
|
|
|
|
{
|
|
|
|
return $one;
|
|
|
|
}
|
|
|
|
elsif ($r >= 2 && $r <= 4)
|
|
|
|
{
|
|
|
|
return $few;
|
|
|
|
}
|
|
|
|
return $many;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Limit string to $maxlen
|
|
|
|
sub strlimit
|
|
|
|
{
|
|
|
|
my ($str, $maxlen, $dots) = @_;
|
|
|
|
if (!$maxlen || $maxlen < 1 || length($str) <= $maxlen)
|
|
|
|
{
|
|
|
|
return $str;
|
|
|
|
}
|
|
|
|
$str = substr($str, 0, $maxlen);
|
|
|
|
my $p = rindex($str, ' ');
|
|
|
|
if ($p < 0 || (my $pt = rindex($str, "\t")) > $p)
|
|
|
|
{
|
|
|
|
$p = $pt;
|
|
|
|
}
|
|
|
|
if ($p > 0)
|
|
|
|
{
|
|
|
|
$str = substr($str, 0, $p);
|
|
|
|
}
|
|
|
|
return $str . (defined $dots ? $dots : '...');
|
|
|
|
}
|
|
|
|
|
|
|
|
# Escape HTML special chars
|
|
|
|
sub htmlspecialchars
|
|
|
|
{
|
|
|
|
local $_ = $_[0];
|
|
|
|
s/&/&/gso;
|
|
|
|
s/</</gso;
|
|
|
|
s/>/>/gso;
|
|
|
|
s/\"/"/gso;
|
|
|
|
s/\'/'/gso;
|
|
|
|
return $_;
|
|
|
|
}
|
|
|
|
|
2014-10-14 02:37:29 +04:00
|
|
|
# URL-encode
|
|
|
|
sub urlencode
|
|
|
|
{
|
|
|
|
my ($param) = @_;
|
|
|
|
utf8::encode($param) if utf8::is_utf8($param);
|
|
|
|
$param =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
|
|
|
|
return $param;
|
|
|
|
}
|
|
|
|
|
|
|
|
# URL-decode
|
|
|
|
sub urldecode
|
|
|
|
{
|
|
|
|
my ($param) = @_;
|
|
|
|
$param =~ tr/+/ /;
|
|
|
|
$param =~ s/%([0-9a-fA-F]{2})/pack("C",hex($1))/ge;
|
|
|
|
utf8::decode($param); # try to decode it
|
|
|
|
return $param;
|
|
|
|
}
|
|
|
|
|
2014-10-13 14:17:14 +04:00
|
|
|
# Replace (some) tags with whitespace
|
|
|
|
sub strip_tags
|
|
|
|
{
|
|
|
|
my ($str, $allowed) = @_;
|
|
|
|
my $allowed = $allowed ? '(?!/?('.$allowed.'))' : '';
|
|
|
|
$str =~ s/(<$allowed\/?[a-z][a-z0-9-]*(\s+[^<>]*)?>\s*)+/ /gis;
|
|
|
|
return $str;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Strip unsafe tags
|
|
|
|
sub strip_unsafe_tags
|
|
|
|
{
|
|
|
|
return strip_tags($_[0], $safe_tags);
|
|
|
|
}
|
|
|
|
|
|
|
|
# Add '\' before specified chars
|
|
|
|
sub addcslashes
|
|
|
|
{
|
|
|
|
my ($str, $escape) = @_;
|
|
|
|
$str =~ s/([$escape\\])/\\$1/gs;
|
|
|
|
return $str;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Quote regexp-special characters in $_[0]
|
|
|
|
sub requote
|
|
|
|
{
|
|
|
|
"\Q$_[0]\E";
|
|
|
|
}
|
|
|
|
|
|
|
|
# Escape quotes in C style, also \n and \r
|
|
|
|
sub quotequote
|
|
|
|
{
|
|
|
|
my ($a) = @_;
|
|
|
|
$a =~ s/[\\\'\"]/\\$&/gso;
|
|
|
|
$a =~ s/\n/\\n/gso;
|
|
|
|
$a =~ s/\r/\\r/gso;
|
|
|
|
return $a;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Escape quotes in SQL or CSV style (" --> "")
|
|
|
|
sub sql_quote
|
|
|
|
{
|
|
|
|
my ($a) = @_;
|
|
|
|
$a =~ s/\"/\"\"/gso;
|
|
|
|
return $a;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Replace regular expression, returning result
|
|
|
|
sub regex_replace
|
|
|
|
{
|
|
|
|
my ($re, $repl, $s) = @_;
|
|
|
|
$re = qr/$re/s if !ref $re;
|
|
|
|
# Escape \ @ $ % /, but allow $n replacements ($1 $2 $3 ...)
|
|
|
|
$repl =~ s!([\\\@\%/]|\$(?\!\d))!\\$1!gso;
|
|
|
|
eval("\$s =~ s/\$re/$repl/gs");
|
|
|
|
return $s;
|
|
|
|
}
|
|
|
|
|
|
|
|
# Replace strings
|
|
|
|
sub str_replace
|
|
|
|
{
|
|
|
|
my ($str, $repl, $s) = @_;
|
|
|
|
$s =~ s/\Q$str\E/$repl/gs;
|
|
|
|
return $s;
|
|
|
|
}
|
|
|
|
|
|
|
|
# extract elements from array
|
|
|
|
# array_slice([], 0, 10)
|
|
|
|
# array_slice([], 2)
|
|
|
|
# array_slice([], 0, -1)
|
|
|
|
sub array_slice
|
|
|
|
{
|
|
|
|
my ($array, $from, $to) = @_;
|
|
|
|
return $array unless $from;
|
|
|
|
$to ||= 0;
|
|
|
|
$from += @$array if $from < 0;
|
|
|
|
$to += @$array if $to <= 0;
|
|
|
|
return [ @$array[$from..$to] ];
|
|
|
|
}
|
|
|
|
|
|
|
|
# extract each $div'th element from array, starting with $mod
|
|
|
|
# array_div([], 2)
|
|
|
|
# array_div([], 2, 1)
|
|
|
|
sub array_div
|
|
|
|
{
|
|
|
|
my ($array, $div, $mod) = @_;
|
|
|
|
return $array unless $div;
|
|
|
|
$mod ||= 0;
|
|
|
|
return [ @$array[grep { $_ % $div == $mod } 0..$#$array] ];
|
|
|
|
}
|
|
|
|
|
|
|
|
# JSON encoding
|
|
|
|
sub encode_json
|
|
|
|
{
|
|
|
|
require JSON;
|
2014-11-28 17:54:56 +03:00
|
|
|
my $s = JSON->new->utf8->allow_nonref->encode(@_);
|
|
|
|
Encode::_utf8_on($s);
|
|
|
|
return $s;
|
2014-10-13 14:17:14 +04:00
|
|
|
}
|
|
|
|
|
|
|
|
# Remove whitespace from the beginning and the end of the line
|
|
|
|
sub trim
|
|
|
|
{
|
|
|
|
local $_ = $_[0];
|
|
|
|
if ($_[1])
|
|
|
|
{
|
|
|
|
s/^$_[1]//s;
|
|
|
|
s/$_[1]$//s;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
s/^\s+//so;
|
|
|
|
s/\s+$//so;
|
|
|
|
}
|
|
|
|
$_;
|
|
|
|
}
|
|
|
|
|
|
|
|
# htmlspecialchars + turn \n into <br />
|
|
|
|
sub html_pbr
|
|
|
|
{
|
|
|
|
my ($s) = @_;
|
|
|
|
$s = htmlspecialchars($s);
|
|
|
|
$s =~ s/\n/<br \/>/gso;
|
|
|
|
return $s;
|
|
|
|
}
|
|
|
|
|
|
|
|
# helper - returns array elements or just scalar, if it's not an arrayref
|
|
|
|
sub array_items
|
|
|
|
{
|
|
|
|
ref($_[0]) && $_[0] =~ /ARRAY/ ? @{$_[0]} : (defined $_[0] ? ($_[0]) : ());
|
|
|
|
}
|
|
|
|
|
|
|
|
# recursive utf8_on and return result
|
|
|
|
sub utf8on
|
|
|
|
{
|
|
|
|
if (ref($_[0]) && $_[0] =~ /HASH/so)
|
|
|
|
{
|
|
|
|
utf8on($_[0]->{$_}) for keys %{$_[0]};
|
|
|
|
}
|
|
|
|
elsif (ref($_[0]) && $_[0] =~ /ARRAY/so)
|
|
|
|
{
|
|
|
|
utf8on($_) for @{$_[0]};
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
Encode::_utf8_on($_[0]);
|
|
|
|
}
|
|
|
|
return $_[0];
|
|
|
|
}
|
|
|
|
|
|
|
|
# function subst()
|
|
|
|
sub exec_subst
|
|
|
|
{
|
|
|
|
my $str = shift;
|
|
|
|
$str =~ s/(?<!\\)((?:\\\\)*)\$(?:([1-9]\d*)|\{([1-9]\d*)\})/$_[($2||$3)-1]/gisoe;
|
|
|
|
return $str;
|
|
|
|
}
|
|
|
|
|
|
|
|
# array of sorted key-value pairs for hash: [ { key => ..., value => ... }, ... ]
|
|
|
|
sub exec_pairs
|
|
|
|
{
|
|
|
|
my $hash = shift;
|
|
|
|
return [ map { { key => $_, value => $hash->{$_} } } sort keys %{ $hash || {} } ];
|
|
|
|
}
|
|
|
|
|
|
|
|
# check if the argument is an arrayref
|
|
|
|
sub exec_is_array
|
|
|
|
{
|
|
|
|
return ref $_[1] && $_[1] =~ /ARRAY/;
|
|
|
|
}
|
|
|
|
|
|
|
|
# get array or hash element
|
|
|
|
sub exec_get
|
|
|
|
{
|
|
|
|
defined $_[1] && ref $_[0] || return $_[0];
|
|
|
|
$_[0] =~ /ARRAY/ && return $_[0]->[$_[1]];
|
|
|
|
return $_[0]->{$_[1]};
|
|
|
|
}
|
|
|
|
|
|
|
|
# type-dependent comparison
|
|
|
|
sub exec_cmp
|
|
|
|
{
|
|
|
|
my ($a, $b) = @_;
|
|
|
|
my $n = grep /^-?\d+(\.\d+)?$/, $a, $b;
|
|
|
|
return $n ? $a <=> $b : $a cmp $b;
|
|
|
|
}
|
|
|
|
|
2015-01-06 16:51:02 +03:00
|
|
|
# min
|
|
|
|
sub min
|
|
|
|
{
|
|
|
|
my $r = shift @_;
|
|
|
|
for (@_)
|
|
|
|
{
|
|
|
|
$r = $_ if $_ < $r;
|
|
|
|
}
|
|
|
|
return $r;
|
|
|
|
}
|
|
|
|
|
|
|
|
sub str_min
|
|
|
|
{
|
|
|
|
my $r = shift @_;
|
|
|
|
for (@_)
|
|
|
|
{
|
|
|
|
$r = $_ if $_ lt $r;
|
|
|
|
}
|
|
|
|
return $r;
|
|
|
|
}
|
|
|
|
|
|
|
|
# max
|
|
|
|
sub max
|
|
|
|
{
|
|
|
|
my $r = shift @_;
|
|
|
|
for (@_)
|
|
|
|
{
|
|
|
|
$r = $_ if $_ > $r;
|
|
|
|
}
|
|
|
|
return $r;
|
|
|
|
}
|
|
|
|
|
|
|
|
sub str_max
|
|
|
|
{
|
|
|
|
my $r = shift @_;
|
|
|
|
for (@_)
|
|
|
|
{
|
|
|
|
$r = $_ if $_ gt $r;
|
|
|
|
}
|
|
|
|
return $r;
|
|
|
|
}
|
|
|
|
|
2015-01-09 18:58:50 +03:00
|
|
|
# round
|
|
|
|
sub round
|
|
|
|
{
|
|
|
|
my $i = int($_[0]);
|
|
|
|
my $a = $_[0]-$i;
|
|
|
|
return $a >= 0.5 ? $i+1 : ($a <= -0.5 ? $i-1 : $i);
|
|
|
|
}
|
|
|
|
|
2014-11-28 16:18:18 +03:00
|
|
|
# Quote strings without transforming UTF-8 to \x{...}
|
|
|
|
sub _dumper_qquote
|
|
|
|
{
|
|
|
|
my $s = $_[0];
|
|
|
|
$s = '' unless defined $s;
|
|
|
|
$s =~ s/\"/\\"/gs;
|
|
|
|
return '"'.$s.'"';
|
|
|
|
}
|
|
|
|
|
2014-10-14 02:37:29 +04:00
|
|
|
# Data::Dumper
|
|
|
|
sub var_dump
|
|
|
|
{
|
|
|
|
require Data::Dumper;
|
|
|
|
local $Data::Dumper::Indent = 1;
|
|
|
|
local $Data::Dumper::Varname = '';
|
|
|
|
local $Data::Dumper::Sortkeys = 1;
|
2014-11-28 16:18:18 +03:00
|
|
|
local $Data::Dumper::Useperl = 1;
|
|
|
|
no warnings 'redefine';
|
|
|
|
*Data::Dumper::qquote = \&_dumper_qquote;
|
2014-10-14 02:37:29 +04:00
|
|
|
return scalar Data::Dumper::Dumper(@_);
|
|
|
|
}
|
|
|
|
|
2014-10-13 14:17:14 +04:00
|
|
|
package VMXTemplate::Exception;
|
|
|
|
|
|
|
|
use overload '' => sub { $_[0]->{message} };
|
|
|
|
|
|
|
|
sub new
|
|
|
|
{
|
|
|
|
my $class = shift;
|
|
|
|
$class = ref($class) || $class;
|
|
|
|
my ($msg) = @_;
|
|
|
|
return bless { message => $msg }, $class;
|
|
|
|
}
|
|
|
|
|
|
|
|
1;
|