Contenido Project
version 7
SVN-репозиторий
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 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;

Небольшая справка по веткам

cnddist – контейнер, в котором хранятся все дистрибутивы всех библиотек и программных пакетов, которые использовались при построении различных версий Contenido. Если какой-то библиотеки в данном хранилище нет, инсталлятор сделает попытку "подтянуть" ее с веба (например, с CPAN). Если библиотека слишком старая, есть очень большая вероятность, что ее там уже нет. Поэтому мы храним весь хлам от всех сборок. Если какой-то дистрибутив вдруг отсутствует в cnddist - напишите нам, мы положим его туда.

koi8 – отмирающая ветка, чей код, выдача и все внутренние библиотеки заточены на кодировку KOI8-R. Вносятся только те дополнения, которые касаются внешнего вида и функционала админки, баги ядра, обязательные обновления портов и мелочи, которые легко скопипастить. В дальнейшем планируется полная остановка поддержки по данной ветке.

utf8 – актуальная ветка, заточенная под UTF-8.

Внутри каждой ветки: core – исходники ядра; install – скрипт установки инсталляции; plugins – плагины; samples – "готовые к употреблению" проекты, которые можно поставить, запустить и посмотреть, как они работают.
© 2003 – 2009 «Рамблер»
© 2010 – 2024 «Андрей (Handy) Хитров»