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