| 1 |
8 |
ahitrov@rambler.ru |
package Utils; |
| 2 |
|
|
|
| 3 |
|
|
use strict; |
| 4 |
|
|
use vars qw ($VERSION @ISA @EXPORT); |
| 5 |
|
|
use base 'Utils::HTML'; |
| 6 |
|
|
|
| 7 |
|
|
require Exporter; |
| 8 |
|
|
@ISA = qw(Exporter); |
| 9 |
|
|
@EXPORT = qw( &eval_config_file |
| 10 |
|
|
&dump_config_file |
| 11 |
823 |
ahitrov |
&decode_struct |
| 12 |
|
|
&encode_struct |
| 13 |
8 |
ahitrov@rambler.ru |
&_mkdir |
| 14 |
|
|
&looks_like_id |
| 15 |
|
|
&time_unix_to_timestamp |
| 16 |
|
|
&time_timestamp_to_unix |
| 17 |
|
|
&abort404 |
| 18 |
|
|
&abort403 |
| 19 |
|
|
&abort503 |
| 20 |
|
|
&http_abort |
| 21 |
|
|
); |
| 22 |
|
|
$VERSION = '0.1'; |
| 23 |
|
|
|
| 24 |
|
|
use Data::Dumper; |
| 25 |
|
|
use locale; |
| 26 |
|
|
use File::Find; |
| 27 |
|
|
use Time::Local; |
| 28 |
|
|
use URI::Escape; |
| 29 |
|
|
use Contenido::Init; |
| 30 |
|
|
use Convert::Cyrillic; |
| 31 |
|
|
|
| 32 |
|
|
sub looks_like_id { shift =~ /^\d+$/ ? 1 : 0 } |
| 33 |
|
|
|
| 34 |
|
|
|
| 35 |
|
|
# ---------------------------------------------------------------------------- |
| 36 |
|
|
# Рекурсивное создание директории |
| 37 |
|
|
# ---------------------------------------------------------------------------- |
| 38 |
|
|
sub _mkdir |
| 39 |
|
|
{ |
| 40 |
|
|
my $directory = shift; |
| 41 |
|
|
|
| 42 |
|
|
return -1 if (! defined($directory)); |
| 43 |
|
|
|
| 44 |
|
|
# Создаем необходимые промежуточные директории |
| 45 |
|
|
if (! -d $directory) { |
| 46 |
|
|
my $e = `mkdir -p $directory`; |
| 47 |
|
|
unless(-d $directory) { |
| 48 |
|
|
warn "Contenido Warning: Не могу создать директорию $directory по причине $! ($e)"; |
| 49 |
|
|
return -1; |
| 50 |
|
|
} |
| 51 |
|
|
} |
| 52 |
|
|
|
| 53 |
|
|
return 1; |
| 54 |
|
|
} |
| 55 |
|
|
|
| 56 |
|
|
sub eval_config_file |
| 57 |
|
|
{ |
| 58 |
|
|
my $config_file = shift; |
| 59 |
|
|
|
| 60 |
|
|
open (FILE, "< $config_file") || do { |
| 61 |
|
|
warn "Utils: Не могу прочитать файл $config_file по причине $!\n"; |
| 62 |
|
|
return undef; |
| 63 |
|
|
}; |
| 64 |
|
|
my @CFILE = <FILE>; |
| 65 |
|
|
my $eval_line = join(' ', @CFILE); |
| 66 |
|
|
close (FILE); |
| 67 |
|
|
|
| 68 |
|
|
my $CONFIG = {}; |
| 69 |
|
|
{ |
| 70 |
|
|
local $SIG{'__DIE__'}; |
| 71 |
|
|
$CONFIG = eval ('use vars qw($VAR1); '. $eval_line); |
| 72 |
|
|
|
| 73 |
|
|
}; |
| 74 |
|
|
if ($@) |
| 75 |
|
|
{ |
| 76 |
|
|
warn "Utils: При обработке файла $config_file произошла ошибка $@\n"; |
| 77 |
|
|
return undef; |
| 78 |
|
|
} |
| 79 |
|
|
|
| 80 |
|
|
return $CONFIG; |
| 81 |
|
|
} |
| 82 |
|
|
|
| 83 |
|
|
|
| 84 |
|
|
|
| 85 |
|
|
|
| 86 |
|
|
|
| 87 |
|
|
sub dump_config_file |
| 88 |
|
|
{ |
| 89 |
|
|
my ($config_file, $data) = @_; |
| 90 |
|
|
my $DumpStr = Dumper($data); |
| 91 |
|
|
|
| 92 |
|
|
# Осуществляем моментальный dump... |
| 93 |
|
|
|
| 94 |
|
|
open (FILE, "> $config_file") || do { |
| 95 |
|
|
warn "Utils: Не могу открыть файл $config_file по причине $!\n"; |
| 96 |
|
|
return -100; |
| 97 |
|
|
}; |
| 98 |
|
|
print FILE $DumpStr; |
| 99 |
|
|
close (FILE); |
| 100 |
|
|
|
| 101 |
|
|
return 1; |
| 102 |
|
|
} |
| 103 |
|
|
|
| 104 |
|
|
|
| 105 |
|
|
sub query_string |
| 106 |
|
|
{ |
| 107 |
|
|
my ($args, $newargs, $no_urlencode) = @_; |
| 108 |
|
|
return '' unless ($args || $newargs || $no_urlencode); |
| 109 |
|
|
|
| 110 |
|
|
my %Args = ref($args) eq 'HASH' ? %$args: @_; # Возмем аргументы |
| 111 |
|
|
%Args = () unless %Args; |
| 112 |
|
|
my %no_encode; |
| 113 |
|
|
|
| 114 |
|
|
if (ref($args) eq 'HASH') |
| 115 |
|
|
{ |
| 116 |
|
|
@Args{ keys %$newargs } = values %$newargs; # Наложим на них новые |
| 117 |
|
|
%no_encode = map { $_ => 1; } @$no_urlencode if $no_urlencode ; |
| 118 |
|
|
} |
| 119 |
|
|
|
| 120 |
601 |
ahitrov |
my $one_param = sub { my ($k,$v)=@_; "$k=". ($no_encode{$k} ? $v : URI::Escape::uri_escape($v)) }; |
| 121 |
8 |
ahitrov@rambler.ru |
|
| 122 |
|
|
my $params = join('&', |
| 123 |
|
|
map { my $k=$_; ref ($Args{$k}) eq 'ARRAY' ? join('&', map { &$one_param($k, $_) } @{$Args{$k}}) : &$one_param($k, $Args{$k}) } |
| 124 |
|
|
grep { $Args{$_} =~ /\S/ } |
| 125 |
|
|
keys %Args |
| 126 |
|
|
); |
| 127 |
|
|
|
| 128 |
|
|
$params = '?'.$params if $params; # Припишем вопросительный знак, если строка непуста |
| 129 |
|
|
return $params; |
| 130 |
|
|
} |
| 131 |
|
|
|
| 132 |
|
|
|
| 133 |
|
|
|
| 134 |
|
|
# ---------------------------------------------------------------------------- |
| 135 |
|
|
# Вспомогательная процедура. Получает массив в PostgreSQL-формате, а |
| 136 |
|
|
# возвращает простой массив |
| 137 |
|
|
# ---------------------------------------------------------------------------- |
| 138 |
|
|
sub split_array |
| 139 |
|
|
{ |
| 140 |
|
|
my $array_string = shift; |
| 141 |
|
|
|
| 142 |
|
|
my @R = (); |
| 143 |
|
|
if ($array_string =~ /^{([^}]+)}$/) |
| 144 |
|
|
{ |
| 145 |
|
|
my (@S) = split(/,/,$1); |
| 146 |
|
|
@R = @S; |
| 147 |
|
|
} |
| 148 |
|
|
|
| 149 |
|
|
return @R; |
| 150 |
|
|
} |
| 151 |
|
|
|
| 152 |
|
|
# Перекодировка параметров запроса из WIN|UTF в KOI8 |
| 153 |
|
|
sub recode_args { |
| 154 |
|
|
my $opts = shift; |
| 155 |
|
|
my %args = ( |
| 156 |
|
|
to_charset => 'UTF8', |
| 157 |
|
|
@_ |
| 158 |
|
|
); |
| 159 |
|
|
|
| 160 |
|
|
return undef unless $opts && ref($opts) eq 'HASH'; |
| 161 |
|
|
|
| 162 |
|
|
if ( $opts->{'control_charset'} ) { |
| 163 |
|
|
|
| 164 |
|
|
my $charset = undef; |
| 165 |
|
|
my $is_escaped = undef; |
| 166 |
|
|
|
| 167 |
|
|
if ( $opts->{'control_charset'} eq 'Контроль' ) { |
| 168 |
|
|
$charset = 'UTF8'; |
| 169 |
|
|
|
| 170 |
|
|
} elsif ( recode_string('WIN', 'UTF8', $opts->{'control_charset'}) eq 'Контроль' ) { |
| 171 |
|
|
$charset = 'WIN'; |
| 172 |
|
|
|
| 173 |
|
|
} elsif ( recode_string('KOI', 'UTF8', $opts->{'control_charset'}) eq 'Контроль' ) { |
| 174 |
|
|
$charset = 'KOI'; |
| 175 |
|
|
|
| 176 |
|
|
} elsif ( url_unescape($opts->{'control_charset'}) eq 'Контроль' ) { |
| 177 |
|
|
$charset = 'UTF8'; |
| 178 |
|
|
$is_escaped = 1; |
| 179 |
|
|
|
| 180 |
|
|
} elsif ( recode_string('WIN', 'UTF8', url_unescape($opts->{'control_charset'})) eq 'Контроль' ) { |
| 181 |
|
|
$charset = 'WIN'; |
| 182 |
|
|
$is_escaped = 1; |
| 183 |
|
|
|
| 184 |
|
|
} elsif ( recode_string('KOI', 'UTF8', url_unescape($opts->{'control_charset'})) eq 'Контроль' ) { |
| 185 |
|
|
$charset = 'KOI'; |
| 186 |
|
|
$is_escaped = 1; |
| 187 |
|
|
} |
| 188 |
|
|
|
| 189 |
|
|
if ($charset && ($is_escaped || $charset ne $args{'to_charset'})) { |
| 190 |
|
|
while ( my ($key, $val) = each %$opts ) { |
| 191 |
|
|
if ( ref($val) eq 'ARRAY' ) { |
| 192 |
|
|
foreach ( @{$val} ) { |
| 193 |
|
|
$_ = recode_string( $charset, $args{'to_charset'}, $is_escaped ? url_unescape($_) : $_ ); |
| 194 |
|
|
} |
| 195 |
|
|
} else { |
| 196 |
|
|
$opts->{$key} = recode_string( $charset, $args{'to_charset'}, $is_escaped ? url_unescape($val) : $val ); |
| 197 |
|
|
} |
| 198 |
|
|
} |
| 199 |
|
|
} |
| 200 |
|
|
} |
| 201 |
|
|
return $opts; |
| 202 |
|
|
} |
| 203 |
|
|
|
| 204 |
|
|
# Перекодировка строки |
| 205 |
|
|
sub recode_string { |
| 206 |
|
|
my ($from, $to, $str) = @_; |
| 207 |
|
|
return Convert::Cyrillic::cstocs($from, $to, $str); |
| 208 |
|
|
} |
| 209 |
|
|
|
| 210 |
823 |
ahitrov |
sub encode_struct { |
| 211 |
|
|
return recode_struct_recursive($_[0], 'encode'); |
| 212 |
|
|
} |
| 213 |
|
|
|
| 214 |
|
|
sub decode_struct { |
| 215 |
|
|
return recode_struct_recursive($_[0], 'decode'); |
| 216 |
|
|
} |
| 217 |
|
|
|
| 218 |
|
|
sub recode_struct_recursive { |
| 219 |
|
|
my ($struct, $action) = @_; |
| 220 |
|
|
return unless ref $struct; |
| 221 |
|
|
|
| 222 |
|
|
my @stack; |
| 223 |
|
|
if ( ref $struct eq 'HASH' ) { |
| 224 |
|
|
foreach my $key ( keys %$struct ) { |
| 225 |
|
|
push @stack, { root => $struct, type => 'hash', key => $key }; |
| 226 |
|
|
} |
| 227 |
|
|
} elsif ( ref $struct eq 'ARRAY' ) { |
| 228 |
|
|
for( my $i == 0; $i < scalar @$struct; $i++ ) { |
| 229 |
|
|
push @stack, { root => $struct, type => 'array', index => $i }; |
| 230 |
|
|
} |
| 231 |
|
|
} else { |
| 232 |
|
|
return; |
| 233 |
|
|
} |
| 234 |
|
|
while ( @stack ) { |
| 235 |
|
|
my $data = pop @stack; |
| 236 |
|
|
if ( $data->{type} eq 'hash' ) { |
| 237 |
|
|
if ( ref $data->{root}{$data->{key}} eq 'HASH' ) { |
| 238 |
|
|
foreach my $key ( keys %{$data->{root}{$data->{key}}} ) { |
| 239 |
|
|
push @stack, { root => $data->{root}{$data->{key}}, type => 'hash', key => $key }; |
| 240 |
|
|
} |
| 241 |
|
|
} elsif ( ref $data->{root}{$data->{key}} eq 'ARRAY' ) { |
| 242 |
|
|
for( my $i == 0; $i < scalar @{$data->{root}{$data->{key}}}; $i++ ) { |
| 243 |
|
|
push @stack, { root => $data->{root}{$data->{key}}, type => 'array', index => $i }; |
| 244 |
|
|
} |
| 245 |
|
|
} else { |
| 246 |
|
|
if ( $action eq 'encode' ) { |
| 247 |
|
|
$data->{root}{$data->{key}} = Encode::encode('utf-8', $data->{root}{$data->{key}}, Encode::FB_HTMLCREF); |
| 248 |
|
|
} else { |
| 249 |
|
|
$data->{root}{$data->{key}} = Encode::decode('utf-8', $data->{root}{$data->{key}}, Encode::FB_HTMLCREF); |
| 250 |
|
|
} |
| 251 |
|
|
} |
| 252 |
|
|
} else { |
| 253 |
|
|
if ( ref $data->{root}->[$data->{index}] eq 'HASH' ) { |
| 254 |
|
|
foreach my $key ( keys %{$data->{root}->[$data->{index}]} ) { |
| 255 |
|
|
push @stack, { root => $data->{root}->[$data->{index}], type => 'hash', key => $key }; |
| 256 |
|
|
} |
| 257 |
|
|
} elsif ( ref $data->{root}->[$data->{index}] eq 'ARRAY' ) { |
| 258 |
|
|
for( my $i == 0; $i < scalar @{$data->{root}->[$data->{index}]}; $i++ ) { |
| 259 |
|
|
push @stack, { root => $data->{root}->[$data->{index}], type => 'array', index => $i }; |
| 260 |
|
|
} |
| 261 |
|
|
} else { |
| 262 |
|
|
if ( $action eq 'encode' ) { |
| 263 |
|
|
$data->{root}->[$data->{key}] = Encode::encode('utf-8', $data->{root}->[$data->{key}], Encode::FB_HTMLCREF); |
| 264 |
|
|
} else { |
| 265 |
|
|
$data->{root}->[$data->{key}] = Encode::decode('utf-8', $data->{root}->[$data->{key}], Encode::FB_HTMLCREF); |
| 266 |
|
|
} |
| 267 |
|
|
} |
| 268 |
|
|
} |
| 269 |
|
|
} |
| 270 |
|
|
return $struct; |
| 271 |
|
|
} |
| 272 |
|
|
|
| 273 |
8 |
ahitrov@rambler.ru |
# загрузка модулей |
| 274 |
|
|
sub load_modules { |
| 275 |
|
|
my $list = shift; |
| 276 |
|
|
unless (ref($list) eq 'ARRAY') { |
| 277 |
|
|
return undef; |
| 278 |
|
|
} |
| 279 |
|
|
foreach my $module (@$list) { |
| 280 |
|
|
eval ("use $module"); |
| 281 |
|
|
if ( $@ ) { |
| 282 |
|
|
die __PACKAGE__.": ошибка загрузки модуля $module.\n $@"; |
| 283 |
|
|
} |
| 284 |
|
|
{ |
| 285 |
|
|
package HTML::Mason::Commands; |
| 286 |
|
|
eval ("use $module"); |
| 287 |
|
|
} |
| 288 |
|
|
} |
| 289 |
|
|
return 1; |
| 290 |
|
|
} |
| 291 |
|
|
|
| 292 |
|
|
# поиск модулей в заданной директории |
| 293 |
|
|
# абсолютной, относительно установочной директории Contenido |
| 294 |
|
|
sub find_modules { |
| 295 |
|
|
my %opts = @_; |
| 296 |
|
|
|
| 297 |
|
|
my $relative_dir = $opts{relative_dir}; |
| 298 |
|
|
my $recursive_flag = $opts{recursive}; |
| 299 |
|
|
my $absolute_dir = $opts{absolute_dir}; |
| 300 |
|
|
|
| 301 |
|
|
$relative_dir .= '/' unless $relative_dir =~ /\/$/; |
| 302 |
|
|
|
| 303 |
|
|
my $dir = $absolute_dir.'/'.$relative_dir; |
| 304 |
|
|
|
| 305 |
|
|
return undef unless -d $dir; |
| 306 |
|
|
|
| 307 |
|
|
my @res = (); |
| 308 |
|
|
$relative_dir =~ s/\//::/g; |
| 309 |
|
|
|
| 310 |
|
|
if ($recursive_flag) { |
| 311 |
|
|
|
| 312 |
|
|
my $sub = sub {if (/\.pm$/i) { s/\.pm//i; my $d = $File::Find::dir.'/'; $d =~ s/$dir//; $d =~ s/\//::/g; push @res, $relative_dir.$d.$_; } }; |
| 313 |
|
|
File::Find::find({ wanted => $sub, no_chdir => 0}, $dir); |
| 314 |
|
|
|
| 315 |
|
|
} else { |
| 316 |
|
|
opendir(DIR, $dir) || do { warn __PACKAGE__.": не могу прочесть директорию модулей $dir."; return undef; } ; |
| 317 |
|
|
my @modules = grep {/\.pm$/} readdir(DIR); |
| 318 |
|
|
closedir(DIR); |
| 319 |
|
|
|
| 320 |
|
|
|
| 321 |
|
|
foreach my $module (@modules) { |
| 322 |
|
|
$module =~ /(.*)\.pm/; |
| 323 |
|
|
push @res, $relative_dir.$1; |
| 324 |
|
|
} |
| 325 |
|
|
} |
| 326 |
|
|
return @res ? \@res : undef; |
| 327 |
|
|
} |
| 328 |
|
|
#------------------------------------------------------------------------------- |
| 329 |
|
|
# Время из unixtime в timestamp |
| 330 |
|
|
sub time_unix_to_timestamp { |
| 331 |
|
|
my ($time) = @_; |
| 332 |
|
|
$time ||= time; |
| 333 |
|
|
my @localtime = localtime($time); |
| 334 |
|
|
my $timestamp = ($localtime[5] + 1900).'-'.(sprintf('%02d', $localtime[4] + 1)).'-'.(sprintf('%02d', $localtime[3])).' '.(sprintf('%02d', $localtime[2])).':'.(sprintf('%02d', $localtime[1])).':'.(sprintf('%02d', $localtime[0])); |
| 335 |
|
|
return $timestamp; |
| 336 |
|
|
} |
| 337 |
|
|
#------------------------------------------------------------------------------- |
| 338 |
|
|
# Время из timestamp в unixtime |
| 339 |
|
|
sub time_timestamp_to_unix { |
| 340 |
|
|
my ($time) = @_; |
| 341 |
|
|
return undef unless $time; |
| 342 |
|
|
my @time = $time =~ /(\d+)/g; |
| 343 |
|
|
@time = reverse @time; |
| 344 |
|
|
shift @time if $time =~ /\.\d+$/; |
| 345 |
|
|
$time[4]--; |
| 346 |
|
|
$time = timelocal(@time); |
| 347 |
|
|
return $time |
| 348 |
|
|
} |
| 349 |
|
|
|
| 350 |
|
|
sub abort404 { |
| 351 |
|
|
http_abort(404); |
| 352 |
|
|
} |
| 353 |
|
|
|
| 354 |
|
|
sub abort403 { |
| 355 |
|
|
http_abort(403); |
| 356 |
|
|
} |
| 357 |
|
|
|
| 358 |
|
|
sub abort503 { |
| 359 |
|
|
http_abort(503); |
| 360 |
|
|
} |
| 361 |
|
|
|
| 362 |
|
|
sub http_abort { |
| 363 |
|
|
my $code = shift; |
| 364 |
|
|
my $m = $HTML::Mason::Commands::m; |
| 365 |
|
|
$m->clear_buffer(); |
| 366 |
|
|
$m->abort($code); |
| 367 |
|
|
} |
| 368 |
|
|
|
| 369 |
|
|
1; |
