Line # Revision Author
1 3 ahitrov@rambler.ru package Utils::HTML;
2
3 # ----------------------------------------------------------------------------
4 # ����� �������� ��������� ��� �������� �������
5 # ----------------------------------------------------------------------------
6
7 use strict;
8 use vars qw($VERSION @ISA @EXPORT);
9 use HTML::TokeParser;
10 use Contenido::Globals;
11
12 use Exporter;
13 @ISA = qw(Exporter);
14 @EXPORT = qw(
15 &help
16 &spacer
17 &tlontl
18 &word_ending
19 &math_percent
20 &wrap_long_words
21 &break_word
22 &error_catch
23 &top100
24 &top100js
25 &top100old
26 &color
27 &server_name
28 &text_trim
29 &limit_words
30 &email
31 &url
32 &banner
33 &banner2
34 &js_escape
35 &html_escape
36 &html_unescape
37 &cgiescape
38 &url_escape
39 &url_unescape
40 &rss_unescape
41 );
42
43 $VERSION = '0.1';
44
45 # ������ ������� �������, ������� ����� ������������� � HTML::Mason::Commands
46 # ����� �������� - ��� �������������
47
48 sub spacer {
49 my %opts = @_;
50 my $w = $opts{w} || 1;
51 my $h = $opts{h} || 1;
52
53 return '<div style="width:'.$w.'px; height:'.$h.'px"><!-- --></div>';
54 }
55
56
57 sub tlontl {
58 my %opts = @_;
59 my $src_link = $opts{link};
60 my $param = $opts{param};
61 my $object = $opts{object};
62 my $absolute = $opts{absolute};
63 my $skip_args = $opts{skip_args};
64
65 my $request_uri = $absolute ? 'http://'.$ENV{SERVER_NAME} : '';
66 $request_uri .= $skip_args ? $ENV{SCRIPT_NAME} : $ENV{REQUEST_URI};
67
68 my $link = $src_link;
69 if ($skip_args) {
70 $link =~ s/\?.*$//;
71 }
72
73 if ($link eq '') {
74 return $object;
75 } elsif($request_uri eq $link || $request_uri eq $link.'index.html') {
76 return $object;
77 } else {
78 return '<a href="'.$src_link.'"'.($param ? ' '.$param : '' ).'>'.$object.'</a>';
79 }
80 }
81
82
83 sub word_ending {
84 my %opts = @_;
85
86 my $amount = $opts{'amount'}; # ����������
87 my $one = $opts{'one'}; # ����������
88 my $two = $opts{'two'}; # ����������
89 my $ten = $opts{'ten'}; # ��������
90
91 my $word = $ten;
92 my $last_num = $amount;
93 my $next_to_last_num = 0;
94
95 return $word unless defined $amount && $amount =~ /^\d+$/;
96
97 if (length($last_num) >= 2) {
98 $last_num =~ s/.*(\d)(\d)$/$2/;
99 $next_to_last_num = $1;
100 }
101
102 # 10 <= ? < 20
103 if ($next_to_last_num == 1) {
104 $word = $ten;
105
106 # 1,21,31,...,n1
107 } elsif ($last_num == 1) {
108 $word = $one;
109
110 # 5,6,7,8,9,10,25,26,.....,n5,n6,n7,n8,n9,n0
111 } elsif ($last_num > 4 || $last_num == 0) {
112 $word = $ten;
113
114 # other
115 } else {
116 $word = $two;
117 }
118
119 return $word;
120 }
121
122 # ����� ��� ��������� ������, ������ ������� �������� ����������� ���������������� ������
123 # <% math_percent('100%+200%-25%/2') %> ���������: 288%
124 # <% math_percent($project_conf->{left}+$project_conf->{center}) %>
125 sub math_percent {
126 my $exp = shift;
127 $exp =~ s/\%//g;
128 $exp = eval($exp);
129 $exp = sprintf("%.0f", $exp);
130 return $exp.'%';
131 }
132
133 # ������� ���� wbr � ������� �����
134 # �������� ������ �� ������ (������ ����������� - ������������ ������ ����� ��������)
135 sub wrap_long_words {
136 my $string = shift;
137 my %opts = @_;
138
139 unless ($string && ref($string) eq 'SCALAR' && length($$string)) {
140 return;
141 }
142
143 my $wordlength = $opts{'wordlength'} || 40;
144
145 if (length($$string) <= $opts{'wordlength'}) {
146 return $$string;
147 }
148
149 my $newstring = '';
150
151 my $p = HTML::TokeParser->new($string);
152 $p->{textify} = {};
153
154 while (my $token = $p->get_token()) {
155 my $type = $token->[0];
156 if ( $type eq 'S' ) {
157 $newstring .= $token->[4];
158 } elsif ( $type eq 'E' ) {
159 $newstring .= $token->[2];
160 } elsif ( $type eq 'T') {
161 $token->[1] =~ s/\S{$wordlength,}/break_word($&,$wordlength)/eg;
162 $newstring .= $token->[1];
163 }
164 }
165 $$string = $newstring;
166 return $$string;
167 }
168
169 # ������� ���� wbr � ���� ������� �����
170 sub break_word {
171 my ($word, $wordlength) = @_;
172 $word =~ s/((?:[^&\s]|(&\#?\w{1,7};)){$wordlength})\B/$1<wbr \/>/g;
173 return $word;
174 }
175
176 # ����� ������
177 sub error_catch {
178 unless ( $state->development ) {
179 return <<HTML;
180 <script type="text/javascript">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;</script>
181 HTML
182 } else {
183 return '<!--// sub &error_catch(); //-->';
184 }
185 }
186
187 # Rambler's Top100
188 sub top100 {
189 my $top100id = shift || $HTML->{top100};
190 unless ( $state->development ) {
191 return '<!-- top100 --><script type="text/javascript">new Image().src = "http://counter.rambler.ru/top100.scn?'.$top100id.'&amp;rn="+Math.random()+"&amp;rf="+escape(document.referrer);</script><noscript><a href="http://top100.rambler.ru/"><img src="http://counter.rambler.ru/top100.cnt?'.$top100id.'" alt="Rambler\'s Top100 Service" width="1" height="1" border="0"></a></noscript><!-- // top100 -->';
192 } else {
193 return '<!--// sub &top100('.$top100id.'); (� �������������� new Image().src) //-->';
194 }
195 }
196
197 sub top100old {
198 unless ( $state->development ) {
199 return '<!-- top100 --><a href="http://top100.rambler.ru/"><img src="http://counter.rambler.ru/top100.cnt?'.$HTML->{top100}.'" alt="Rambler\'s Top100 Service" width="1" height="1" border="0"></a><!-- // top100 -->';
200 } else {
201 return '<!--// sub &top100old('.$HTML->{top100}.'); (��� ������������� js) //-->';
202 }
203 }
204
205 sub top100js {
206 unless ( $state->development ) {
207 return '<!-- begin of Top100 code --><script type="text/javascript" src="http://counter.rambler.ru/top100.jcn?'.$HTML->{top100}.'"></script><noscript><img src="http://counter.rambler.ru/top100.cnt?'.$HTML->{top100}.'" alt="Rambler\'s Top100 Service" width="1" height="1" border="0" /></noscript><!-- end of Top100 code -->';
208 } else {
209 return '<!--// sub &top100js('.$HTML->{top100}.'); (� �������������� js) //-->';
210 }
211 }
212
213 # ������� ����� ������
214 sub color { return ++$request->{HTML_color_count} % 2 ? $_[0] : $_[1] }
215
216 # ������������� ������ $ENV{'SERVER_NAME'}
217 sub server_name { return $ENV{'HTTP_X_HOST'} || $state->httpd_server() }
218
219 # �������� ����� �� ������ �����, �������������� ������ html-���� (������ /inc/text_trim.msn)
220 sub text_trim {
221 my %opts = @_;
222 my $text = $opts{'text'};
223 my $length = $opts{'length'} || 200;
224 267 ahitrov my $ellipsis = $opts{'ellipsis'} || '&hellip;';
225 3 ahitrov@rambler.ru $text =~ s/<[^>]*>//g;
226 if (length($text) > $length) {
227 $text = substr($text, 0, $length);
228 $text =~ s/\s+\S*$//;
229 $text .= $ellipsis;
230 }
231 return $text;
232 }
233 # limit_words('text', { min_words => 70, max_words => 100, ending => '...' })
234 sub limit_words {
235 my $text = shift; my ($t1, $t2) = ();
236 my %args = ref($_[0]) ? %{ $_[0] } : @_;
237
238 my @words = split ' ', $text; $args{max_words} ||= 50; $args{min_words} ||= 10;
239
240 return $text if $#words < $args{max_words};
241 $t1 = $t2 = join ' ', @words[0 .. $args{max_words}-1];
242
243 # magic !
244 my @wds = split ' ', $t1;
245 return $t1 if $t1 =~ s/^(.+[\w")]{3,}[.!?])+\s?[�-�A-Z"].+?$/$1/ and scalar(@wds) > $args{min_words};
246
247 $t2 =~ s/[.,:;!?\s-]+$//;
248 $t2.($args{ending} || '');
249 }
250
251 sub email {
252 my $email = shift;
253 $email =~ s/[<>'"\\]*//g;
254 if ($email =~ /\@/) {
255 return '<a href="mailto:'.$email.'">'.$email.'</a>';
256 } else {
257 return $email;
258 }
259 }
260
261 sub url {
262 my $url = shift;
263 $url =~ s/[<>'"\\]*//g;
264 $url =~ s/^\s+//;
265 $url =~ s/\/$//;
266 return unless $url;
267 $url =~ s/^((https?|ftp):\/\/)//;
268 my $protocol = $1;
269 unless ($protocol) {
270 $protocol = 'http://';
271 }
272 return '<a href="'.$protocol.$url.'" target="_blank">'.$url.'</a>';
273 }
274
275 sub banner {
276 my %opts = @_;
277 my $id = $opts{'id'};
278 return '<!-- &banner(id=>'.$id.'); --><!--#include virtual="/ibanOsurg?rip=$remote_addr&place_id='.$id.'&sid=2" --><!-- // banner -->';
279 }
280
281 sub banner2 {
282 my %opts = @_;
283 my $id = $opts{'id'};
284 my $div_class = $opts{'div_class'};
285 return '<!-- &banner2(id=>'.$id.'); --><!--#include virtual="/iban1?rip=$remote_addr&pg='.$id.'&ifr=5&wxh=&divclass='.$div_class.'"--><!-- // banner2 -->';
286 }
287
288 sub help() {
289 use Data::Dumper;
290 my $opt = shift;
291 my $data = '';
292
293 if ($opt) {
294
295 } else {
296 foreach (@EXPORT){
297 $data .= '<li>'.$_;
298 }
299 }
300 return $data;
301 }
302
303 sub js_escape {
304 my $string = shift;
305 $string =~ s/([\"\'\\])/\\$1/g;
306 $string =~ s/\r?\n/\\n/gs;
307 $string =~ s/\r//gs;
308 return $string;
309 }
310
311 sub html_escape {
312 my $string = shift;
313 $string =~ s/&/&amp;/g;
314 $string =~ s/"/&quot;/g;
315 $string =~ s/>/&gt;/g;
316 $string =~ s/</&lt;/g;
317 return $string;
318 }
319
320 sub html_unescape {
321 my $string = shift;
322 $string =~ s/&amp;/&/g;
323 $string =~ s/&quot;/"/g;
324 $string =~ s/&gt;/>/g;
325 $string =~ s/&lt;/</g;
326 return $string;
327 }
328
329 sub rss_unescape {
330 my $string = shift;
331 my %opts = @_;
332
333 if ( ref($string) eq 'SCALAR' ) {
334 for ( $$string ) {
335 s/&raquo;/"/gi;
336 s/&laquo;/"/gi;
337 s/&rdquo;/"/gi;
338 s/&ldquo;/"/gi;
339 s/&rsquo;/\'/gi;
340 s/&lsquo;/\'/gi;
341 s/&nbsp;/\ /gi;
342 s/&quot;/"/gi;
343 s/&copy;/(c)/gi;
344 s/&reg;/(r)/gi;
345 }
346 } elsif ( length($string) ) {
347 for ( $string ) {
348 s/&raquo;/"/gi;
349 s/&laquo;/"/gi;
350 s/&rdquo;/"/gi;
351 s/&ldquo;/"/gi;
352 s/&rsquo;/\'/gi;
353 s/&lsquo;/\'/gi;
354 s/&nbsp;/\ /gi;
355 s/&quot;/"/gi;
356 s/&copy;/(c)/gi;
357 s/&reg;/(r)/gi;
358 }
359 return $string;
360 }
361 }
362
363 sub cgiescape {
364 my $string = shift;
365 $string =~ s/([^a-zA-Z_0-9.-])/sprintf "\%\%\%02x",ord($1)/ge;
366 return $string;
367 }
368
369 sub url_escape {
370 return URI::Escape::uri_escape(shift);
371 }
372
373 sub url_unescape {
374 return URI::Escape::uri_unescape(shift);
375 }
376
377 1;