package Utils::HTML; # ---------------------------------------------------------------------------- # Здесь хранятся процедуры для удобства верстки # ---------------------------------------------------------------------------- use strict; use vars qw($VERSION @ISA @EXPORT $state $HTML $request); use HTML::TokeParser; use Contenido::Globals; use utf8; use Exporter; @ISA = qw(Exporter); @EXPORT = qw( &help &spacer &tlontl &word_ending &math_percent &wrap_long_words &break_word &error_catch &top100 &top100js &top100old &color &server_name &text_trim &limit_words &email &url &banner &banner2 &js_escape &html_escape &html_unescape &cgiescape &url_escape &url_unescape &format_date ); $VERSION = '0.1'; # Всякие удобные функции, которые будут импортированы в HTML::Mason::Commands # Набор уродиков - для совместимости sub format_date { my ($date, $format) = @_; my ($year, $month, $day, $hour, $min, $sec, $msec) = split(/[T\-\.\:\s]+/, $date); $year = substr($year, -2) if $format =~ /(^[yY]{2}$|[^yY][yY]{2}$|^[yY]{2}[^yY])/; my %formats = ( d => '%3$d', D => '%3$d', h => '%4$d', H => '%4$d', m => '%5$d', M => '%2$d', dd => '%3$02d', DD => '%3$02d', mm => '%5$02d', MM => '%2$02d', hh => '%4$02d', HH => '%4$02d', ss => '%6$02d', SS => '%6$02d', yyyy => '%1$04d', YYYY => '%1$04d', ); $format =~ s/([yYmMdDhHsS]+)/$formats{$1}/gi; my $result = sprintf($format, $year, $month, $day, $hour, $min, $sec, $msec); return $result; } sub spacer { my %opts = @_; my $w = $opts{w} || 1; my $h = $opts{h} || 1; return '
'; } sub tlontl { my %opts = @_; my $src_link = $opts{link}; my $param = $opts{param}; my $object = $opts{object}; my $absolute = $opts{absolute}; my $skip_args = $opts{skip_args}; my $request_uri = $absolute ? 'http://'.$ENV{SERVER_NAME} : ''; $request_uri .= $skip_args ? $ENV{SCRIPT_NAME} : $ENV{REQUEST_URI}; my $link = $src_link; if ($skip_args) { $link =~ s/\?.*$//; } if ($link eq '') { return $object; } elsif($request_uri eq $link || $request_uri eq $link.'index.html') { return $object; } else { return ''.$object.''; } } sub word_ending { my %opts = @_; my $amount = $opts{'amount'}; # количество my $one = $opts{'one'}; # негрятенок my $two = $opts{'two'}; # негрятенка my $ten = $opts{'ten'}; # негрятят my $word = $ten; my $last_num = $amount; my $next_to_last_num = 0; return $word unless defined $amount && $amount =~ /^\d+$/; if (length($last_num) >= 2) { $last_num =~ s/.*(\d)(\d)$/$2/; $next_to_last_num = $1; } # 10 <= ? < 20 if ($next_to_last_num == 1) { $word = $ten; # 1,21,31,...,n1 } elsif ($last_num == 1) { $word = $one; # 5,6,7,8,9,10,25,26,.....,n5,n6,n7,n8,n9,n0 } elsif ($last_num > 4 || $last_num == 0) { $word = $ten; # other } else { $word = $two; } return $word; } # Нужен для постоения таблиц, ширина которых задается посредством конфигурационных файлов # <% math_percent('100%+200%-25%/2') %> результат: 288% # <% math_percent($project_conf->{left}+$project_conf->{center}) %> sub math_percent { my $exp = shift; $exp =~ s/\%//g; $exp = eval($exp); $exp = sprintf("%.0f", $exp); return $exp.'%'; } # Вставка тега wbr в длинные слова # Получает ссылку на строку (будьте внимательны - оригинальная строка будет изменена) sub wrap_long_words { my $string = shift; my %opts = @_; unless ($string && ref($string) eq 'SCALAR' && length($$string)) { return; } my $wordlength = $opts{'wordlength'} || 40; if (length($$string) <= $opts{'wordlength'}) { return $$string; } my $newstring = ''; my $p = HTML::TokeParser->new($string); $p->{textify} = {}; while (my $token = $p->get_token()) { my $type = $token->[0]; if ( $type eq 'S' ) { $newstring .= $token->[4]; } elsif ( $type eq 'E' ) { $newstring .= $token->[2]; } elsif ( $type eq 'T') { $token->[1] =~ s/\S{$wordlength,}/break_word($&,$wordlength)/eg; $newstring .= $token->[1]; } } $$string = $newstring; return $$string; } # Вставка тега wbr в одно длинное слово sub break_word { my ($word, $wordlength) = @_; $word =~ s/((?:[^&\s]|(&\#?\w{1,7};)){$wordlength})\B/$1/g; return $word; } # Отлов ошибок sub error_catch { unless ( $state->development ) { return <if(escape('а')!='%u0430') { var cs_i2=new Image; cs_i2.src='http://err.rambler.ru/cs/'; }function globalCsChErr(a,b,c) {var i=new Image; i.src='http://err.rambler.ru/js/?'+escape(a)+','+escape(b)+','+escape(c)+'/'; return true;}window.onerror=globalCsChErr; HTML } else { return ''; } } # Rambler's Top100 sub top100 { my $top100id = shift || $HTML->{top100}; unless ( $state->development ) { return ''; } else { return ''; } } sub top100old { unless ( $state->development ) { return 'Rambler\'s Top100 Service'; } else { return ''; } } sub top100js { unless ( $state->development ) { return ''; } else { return ''; } } # Раскрас строк зеброй sub color { return ++$request->{HTML_color_count} % 2 ? $_[0] : $_[1] } # универсальная замена $ENV{'SERVER_NAME'} sub server_name { return $ENV{'HTTP_X_HOST'} || $state->httpd_server() } # обрезает текст до нужной длины, предварительно удаляя html-теги (бывшая /inc/text_trim.msn) sub text_trim { my %opts = @_; my $text = Encode::decode('utf-8', $opts{'text'}); my $length = $opts{'length'} || 200; my $ellipsis = Encode::decode('utf-8', $opts{'ellipsis'}) || '…'; $text =~ s/<[^>]*>//g; if (length($text) > $length) { $text = substr($text, 0, $length); $text =~ s/\s+\S*$//; $text .= $ellipsis; } return Encode::encode('utf-8', $text); } # limit_words('text', { min_words => 70, max_words => 100, ending => '...' }) sub limit_words { my $text = shift; my ($t1, $t2) = (); my %args = ref($_[0]) ? %{ $_[0] } : @_; my @words = split ' ', $text; $args{max_words} ||= 50; $args{min_words} ||= 10; return $text if $#words < $args{max_words}; $t1 = $t2 = join ' ', @words[0 .. $args{max_words}-1]; # magic ! s/^(.+\w{3,}[»")]?[.!?]+)\s*[А-ЯA-Z«"].+?$/$1/s and (()=/(\s+)/g)>$args{min_words} and return$_ for $t1; $t2 =~ s/[.,:;!?\s—-]+$//; $t2.($args{ending} || ''); } sub email { my $email = shift; $email =~ s/[<>'"\\]*//g; if ($email =~ /\@/) { return ''.$email.''; } else { return $email; } } sub url { my $url = shift; $url =~ s/[<>'"\\]*//g; $url =~ s/^\s+//; $url =~ s/\/$//; return unless $url; $url =~ s/^((https?|ftp):\/\/)//; my $protocol = $1; unless ($protocol) { $protocol = 'http://'; } return ''.$url.''; } sub banner { my %opts = @_; my $id = $opts{'id'}; return ''; } sub banner2 { my %opts = @_; my $id = $opts{'id'}; my $div_class = $opts{'div_class'}; return ''; } sub help() { use Data::Dumper; my $opt = shift; my $data = ''; if ($opt) { } else { foreach (@EXPORT){ $data .= '
  • '.$_; } } return $data; } sub js_escape { my $string = shift; $string =~ s/([\"\'\\])/\\$1/g; $string =~ s/\r?\n/\\n/gs; $string =~ s/\r//gs; return $string; } sub html_escape { my $string = shift; $string =~ s/&/&/g; $string =~ s/"/"/g; $string =~ s/>/>/g; $string =~ s//g; $string =~ s/</