Line # Revision Author
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;