root/branches/release-30/lib/MT/Util.pm @ 1411

Revision 1411, 69.8 kB (checked in by bchoate, 21 months ago)

Removed some commented out (debugging?) code.
  • Property svn:keywords set to Author Date Id Revision
Line 
1# Movable Type (r) Open Source (C) 2001-2008 Six Apart, Ltd.
2# This program is distributed under the terms of the
3# GNU General Public License, version 2.
4#
5# $Id$
6
7package MT::Util;
8
9use strict;
10use base 'Exporter';
11
12use Time::Local qw( timegm );
13
14our @EXPORT_OK = qw( start_end_day start_end_week start_end_month start_end_year
15                 start_end_period week2ymd munge_comment
16                 rich_text_transform html_text_transform encode_html decode_html
17                 iso2ts ts2iso offset_time offset_time_list first_n_words
18                 archive_file_for format_ts dirify remove_html
19                 days_in wday_from_ts encode_js get_entry spam_protect
20                 is_valid_email encode_php encode_url decode_url encode_xml
21                 decode_xml is_valid_url is_url discover_tb convert_high_ascii
22                 mark_odd_rows dsa_verify perl_sha1_digest relative_date
23                 perl_sha1_digest_hex dec2bin bin2dec xliterate_utf8
24                 start_background_task launch_background_tasks substr_wref
25                 extract_urls extract_domain extract_domains is_valid_date
26                 epoch2ts ts2epoch escape_unicode unescape_unicode
27                 sax_parser trim ltrim rtrim asset_cleanup caturl multi_iter );
28
29sub leap_day {
30    my ($y, $m, $d) = @_;
31    return $m == 2 && $d == 29 &&
32        ($y % 4 == 0) && ($y % 100 != 0 || $y % 400 == 0);
33}
34
35sub leap_year {
36    my $y = shift;
37    return ($y % 4 == 0) && ($y % 100 != 0 || $y % 400 == 0);
38}
39
40{
41    my @In_Year = (
42        [ 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 ],
43        [ 0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366 ],
44    );
45
46    sub wday_from_ts {
47        my($y, $m, $d) = @_;
48        my $leap = leap_year($y) ? 1 : 0;
49        $y--;
50
51        ## Copied from Date::Calc.
52        my $days = $y * 365;
53        $days += $y >>= 2;
54        $days -= int($y /= 25);
55        $days += $y >> 2;
56        $days += $In_Year[$leap][$m-1] + $d;
57        $days % 7;
58    }
59
60    sub yday_from_ts {
61        my($y, $m, $d) = @_;
62        my $leap = $y % 4 == 0 && ($y % 100 != 0 || $y % 400 == 0) ? 1 : 0;
63        $In_Year[$leap][$m-1] + $d;
64    }
65}
66
67sub iso2ts {
68    my($blog, $iso) = @_;
69    return undef
70        unless $iso =~ /^(\d{4})(?:-?(\d{2})(?:-?(\d\d?)(?:T(\d{2}):(\d{2}):(\d{2})(?:\.\d+)?(Z|[+-]\d{2}:\d{2})?)?)?)?/;
71    my($y, $mo, $d, $h, $m, $s, $offset) =
72        ($1, $2 || 1, $3 || 1, $4 || 0, $5 || 0, $6 || 0, $7);
73    if ($offset && !MT->config->IgnoreISOTimezones) {
74        $mo--;
75        my $time = Time::Local::timegm_nocheck($s, $m, $h, $d, $mo, $y);
76        ## If it's not already in UTC, first convert to UTC.
77        if ($offset ne 'Z') {
78            my($sign, $h, $m) = $offset =~ /([+-])(\d{2}):(\d{2})/;
79            $offset = $h * 3600 + $m * 60;
80            $offset *= -1 if $sign eq '-';
81            $time -= $offset;
82        }
83        ## Now apply the offset for this weblog.
84        ($s, $m, $h, $d, $mo, $y) = offset_time_list($time, $blog);
85        $mo++;
86        $y += 1900;
87    }
88    sprintf "%04d%02d%02d%02d%02d%02d", $y, $mo, $d, $h, $m, $s;
89}
90
91sub ts2iso {
92    my ($blog, $ts) = @_;
93    my ($yr, $mo, $dy, $hr, $mn, $sc) = unpack('A4A2A2A2A2A2', $ts);
94    $ts = Time::Local::timegm_nocheck($sc, $mn, $hr, $dy, $mo-1, $yr);
95    ($sc, $mn, $hr, $dy, $mo, $yr) = offset_time_list($ts, $blog, '-');
96    $yr += 1900;
97    $mo += 1;
98    sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ", $yr, $mo, $dy, $hr, $mn, $sc);
99}
100
101sub ts2epoch {
102    my ($blog, $ts) = @_;
103    my ($yr, $mo, $dy, $hr, $mn, $sc) = unpack('A4A2A2A2A2A2', $ts);
104    my $epoch = Time::Local::timegm_nocheck($sc, $mn, $hr, $dy, $mo-1, $yr);
105    return unless $epoch;
106    $epoch = offset_time($epoch, $blog, '-') if ref $blog;
107    $epoch;
108}
109sub epoch2ts {
110    my ($blog, $epoch) = @_;
111    $epoch = offset_time($epoch, $blog) if ref $blog;
112    my ($s, $m, $h, $d, $mo, $y) = gmtime($epoch);
113    sprintf("%04d%02d%02d%02d%02d%02d",
114                     $y+1900, $mo+1, $d, $h, $m, $s);
115}
116
117# substring treating HTML character-entity references as single characters
118sub substr_wref {
119   my ($str, $start, $width) = @_;
120   return '' if $start < 0;
121   my @ent = $str =~ /(&[^;]*;|.)/g;
122   return '' if ($#ent < $start);
123   $width = $#ent - $start + 1 if $start+$width > $#ent;;
124   join '', @ent[$start..$start+$width-1];
125}
126
127sub relative_date {
128    my ($ts1, $ts2, $blog, $fmt, $style) = @_;
129
130    $style ||= 1;
131
132    # TBD: Fix this
133    my $ts = $ts1;
134    $ts1 = ts2epoch($blog, $ts1);
135    return unless $ts1;
136
137    my $future = 0;
138    my $delta = $ts2 - $ts1;
139    if ($delta < 0) {
140        $future = 1;
141        $delta = $ts1 - $ts2;
142    }
143    if ($style == 1) {
144        if ($delta <= 60) {
145            return $future ? MT->translate("moments from now") : MT->translate("moments ago");
146        } elsif ($delta <= 86400) {
147            # less than 1 day
148            my $hours = int($delta / 3600);
149            my $min = int(($delta % 3600) / 60);
150            if ($hours) {
151                return $future ? MT->translate("[quant,_1,hour,hours] from now", $hours, $min) : MT->translate("[quant,_1,hour,hours] ago", $hours, $min);
152            } else {
153                return $future ? MT->translate("[quant,_1,minute,minutes] from now", $min) : MT->translate("[quant,_1,minute,minutes] ago", $min);
154            }
155        } elsif ($delta <= 604800) {
156            # less than 1 week
157            my $days = int($delta / 86400);
158            my $hours = int(($delta % 86400) / 3600);
159            my $result;
160            if ($days) {
161                return $future ? MT->translate("[quant,_1,day,days] from now", $days, $hours) : MT->translate("[quant,_1,day,days] ago", $days, $hours);
162            } else {
163                return $future ? MT->translate("[quant,_1,hour,hours] from now", $hours) : MT->translate("[quant,_1,hour,hours] ago", $hours);
164            }
165        } else {
166            # more than a week, same year
167            if ((localtime($ts1))[5] == (localtime($ts2))[5]) {
168                $fmt ||= "%b %e";
169            } else {
170                $fmt ||= "%b %e %Y";
171            }
172        }
173    } elsif ($style == 2) {
174        if ($delta <= 60) {
175            return $future ? MT->translate("less than 1 minute from now") : MT->translate("less than 1 minute ago");
176        } elsif ($delta <= 86400) {
177            # less than 1 day
178            my $hours = int($delta / 3600);
179            my $min = int(($delta % 3600) / 60);
180            my $result;
181            if ($hours && $min) {
182                $result = $future ? MT->translate("[quant,_1,hour,hours], [quant,_2,minute,minutes] from now", $hours, $min) : MT->translate("[quant,_1,hour,hours], [quant,_2,minute,minutes] ago", $hours, $min);
183            } elsif ($hours) {
184                $result = $future ? MT->translate("[quant,_1,hour,hours] from now", $hours) : MT->translate("[quant,_1,hour,hours] ago", $hours);
185            } elsif ($min) {
186                $result = $future ? MT->translate("[quant,_1,minute,minutes] from now", $min) : MT->translate("[quant,_1,minute,minutes] ago", $min);
187            }
188            return $result;
189        } elsif ($delta <= 604800) {
190            # less than 1 week
191            my $days = int($delta / 86400);
192            my $hours = int(($delta % 86400) / 3600);
193            my $result;
194            if ($days && $hours) {
195                $result = $future ? MT->translate("[quant,_1,day,days], [quant,_2,hour,hours] from now", $days, $hours) : MT->translate("[quant,_1,day,days], [quant,_2,hour,hours] ago", $days, $hours);
196            } elsif ($days) {
197                $result = $future ? MT->translate("[quant,_1,day,days] from now", $days) : MT->translate("[quant,_1,day,days] ago", $days);
198            } elsif ($hours) {
199                $result = $future ? MT->translate("[quant,_1,hour,hours] from now", $hours) : MT->translate("[quant,_1,hour,hours] ago", $hours);
200            }
201            return $result;
202        }
203    }
204    my $mt = MT->instance;
205    my $user = $mt->user if $mt;
206    return $fmt ? format_ts($fmt, $ts, $blog, $user ? $user->preferred_language : undef ) : "";
207}
208
209use vars qw( %Languages );
210sub format_ts {
211    my($format, $ts, $blog, $lang, $is_mail) = @_;
212    return '' unless defined $ts;
213    my %f;
214    unless ($lang) {
215        $lang = $blog && $blog->language ? $blog->language : 
216            MT->config->DefaultLanguage;
217    }
218    if ($lang eq 'jp') {
219        $lang = 'ja';
220    }
221    unless (defined $format) {
222        $format = $Languages{$lang}[3] || "%B %e, %Y %l:%M %p";
223    }
224    my $cache = MT->request->cache('formats');
225    unless ($cache) {
226        MT::Request->instance->cache('formats', $cache = {});
227    }
228    if (my $f_ref = $cache->{$ts . $lang}) {
229        %f = %$f_ref;
230    } else {
231        my $L = $Languages{$lang};
232        my @ts = @f{qw( Y m d H M S )} = unpack 'A4A2A2A2A2A2', $ts;
233        $f{w} = wday_from_ts(@ts[0..2]);
234        $f{j} = yday_from_ts(@ts[0..2]);
235        $f{'y'} = substr $f{Y}, 2;
236        $f{b} = substr_wref $L->[1][$f{'m'}-1] || '', 0, 3;
237        $f{B} = $L->[1][$f{'m'}-1];
238        if ($lang eq 'ja') {
239            $f{a} = substr $L->[0][$f{w}] || '', 0, 8;
240        } else {
241            $f{a} = substr_wref $L->[0][$f{w}] || '', 0, 3;
242        }
243        $f{A} = $L->[0][$f{w}];
244        ($f{e} = $f{d}) =~ s!^0! !;
245        $f{I} = $f{H};
246        if ($f{I} > 12) {
247            $f{I} -= 12;
248            $f{p} = $L->[2][1];
249        } elsif ($f{I} == 0) {
250            $f{I} = 12;
251            $f{p} = $L->[2][0];
252        } elsif ($f{I} == 12) {
253            $f{p} = $L->[2][1];
254        } else {
255            $f{p} = $L->[2][0];
256        }
257        $f{I} = sprintf "%02d", $f{I};
258        ($f{k} = $f{H}) =~ s!^0! !;
259        ($f{l} = $f{I}) =~ s!^0! !;
260        $f{j} = sprintf "%03d", $f{j};
261        $f{Z} = '';
262        $cache->{$ts . $lang} = \%f;
263    }
264    my $date_format = $Languages{$lang}->[4] || "%B %e, %Y";
265    my $time_format = $Languages{$lang}->[5] || "%l:%M %p";
266    $format =~ s!%x!$date_format!g;
267    $format =~ s!%X!$time_format!g;
268    ## This is a dreadful hack. I can't think of a good format specifier
269    ## for "%B %Y" (which is used for monthly archives, for example) so
270    ## I'll just hardcode this, for Japanese dates.
271    if ($lang eq 'ja') {
272        $format =~ s!%B %Y!$Languages{$lang}->[6]!g;
273        $format =~ s!%B %E,? %Y!$Languages{$lang}->[4]!ig;
274        $format =~ s!%B %E!$Languages{$lang}->[7]!ig;
275    }
276    $format =~ s!%(\w)!$f{$1}!g if defined $format;
277
278    if ($is_mail) {
279        $format =~ s!&#([0-9]+);!chr($1)!ge;
280        $format =~ s!&#[xX]([0-9A-Fa-f]+);!chr(hex $1)!ge;
281
282        require MT::I18N;
283        my $enc   = MT->config->PublishCharset;
284        $format = MT::I18N::encode_text( $format, undef, 'utf-8' );
285        $format = MT::I18N::encode_text( $format, 'utf-8', $enc )
286            unless 'utf-8' eq lc $enc;
287    }
288    $format;
289}
290
291{
292    my @Days_In = ( -1, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
293    sub days_in {
294        my($m, $y) = @_;
295        return $Days_In[$m] unless $m == 2;
296        return $y % 4 == 0 && ($y % 100 != 0 || $y % 400 == 0) ?
297            29 : 28;
298    }
299}
300
301sub start_end_period {
302    my $at = shift;
303    if ($at eq 'Individual') {
304        return $_[0];
305    } elsif ($at eq 'Daily') {
306        return start_end_day(@_);
307    } elsif ($at eq 'Weekly') {
308        return start_end_week(@_);
309    } elsif ($at eq 'Monthly') {
310        return start_end_month(@_);
311    } 
312}
313
314sub start_end_day {
315    my $day = substr $_[0], 0, 8;
316    return $day . '000000' unless wantarray;
317    ($day . "000000", $day . "235959");
318}
319
320sub start_end_week {
321    my($ts) = @_;
322    my($y, $mo, $d, $h, $m, $s) = unpack 'A4A2A2A2A2A2', $ts;
323    my $wday = wday_from_ts($y, $mo, $d);
324    my($sd, $sm, $sy) = ($d - $wday, $mo, $y);
325    if ($sd < 1) {
326        $sm--;
327        $sm = 12, $sy-- if $sm < 1;
328        $sd += days_in($sm, $sy);
329    }
330    my $start = sprintf "%04d%02d%02d%s", $sy, $sm, $sd, "000000";
331    return $start unless wantarray;
332    my($ed, $em, $ey) = ($d + 6 - $wday, $mo, $y);
333    if ($ed > days_in($em, $ey)) {
334        $ed -= days_in($em, $ey);
335        $em++;
336        $em = 1, $ey++ if $em > 12;
337    }
338    my $end = sprintf "%04d%02d%02d%s", $ey, $em, $ed, "235959";
339    ($start, $end);
340}
341
342sub is_leap_year {
343    (!($_[0] % 4) && ($_[0] % 100)) || !($_[0] % 400);
344}
345
346my @prev_month_doy = (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334);
347my @prev_month_doly = (0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335);
348sub week2ymd {
349    my($y, $week) = @_;
350    require MT::DateTime;
351    my $jan_one_dow_m1 = (MT::DateTime->ymd2rd($y, 1, 1) + 6) % 7;
352    ($y, $week) = unpack 'A4A2', $week if $week > $y;
353    $week-- if $jan_one_dow_m1 < 4;
354    my $day_of_year = $week * 7 - $jan_one_dow_m1;
355    my $leap_year = is_leap_year($y);
356    if ($day_of_year < 1) {
357        $y--;
358        $day_of_year = ($leap_year ? 366 : 365) + $day_of_year;
359    }
360    my $ref = $leap_year ? \@prev_month_doly : \@prev_month_doy;
361    my $m;
362    my $i = @$ref;
363    for my $days (reverse @$ref) {
364        if ($day_of_year > $days) {
365            $m = $i;
366            last;
367        }
368        $i--;
369    }
370    ($y, $m, $day_of_year - $ref->[$m-1]);
371}
372
373sub start_end_month {
374    my($ts) = @_;
375    my($y, $mo) = unpack 'A4A2', $ts;
376    my $start = sprintf "%04d%02d01000000", $y, $mo;
377    return $start unless wantarray;
378    my $end = sprintf "%04d%02d%02d235959", $y, $mo, days_in($mo, $y);
379    ($start, $end);
380}
381
382sub start_end_year {
383    my($ts) = @_;
384    my($y) = unpack 'A4', $ts;
385    my $start = sprintf "%04d0101000000", $y;
386    return $start unless wantarray;
387    my $end = sprintf "%04d1231235959", $y;
388    ($start, $end);
389}
390
391sub offset_time_list { gmtime offset_time(@_) }
392
393sub offset_time {
394    my($ts, $blog, $dir) = @_;
395    my $offset;
396    if (defined $blog) {
397        if (!ref($blog)) {
398            require MT::Blog;
399            $blog = MT::Blog->load($blog);
400        }
401        $offset = $blog && $blog->server_offset ? $blog->server_offset : 0;
402    } else {
403        $offset = MT->config->TimeOffset;
404    }
405    $offset += 1 if (localtime $ts)[8];
406    $offset *= -1 if $dir && $dir eq '-';
407    $ts += $offset * 3600;
408    $ts;
409}
410
411sub rich_text_transform {
412    my $str = shift;
413    return $str;
414}
415
416sub html_text_transform {
417    my $str = shift;
418    $str = '' unless defined $str;
419    my @paras = split /\r?\n\r?\n/, $str;
420    for my $p (@paras) {
421        if ($p !~ m@^</?(?:h1|h2|h3|h4|h5|h6|table|ol|dl|ul|menu|dir|p|pre|center|form|fieldset|select|blockquote|address|div|hr)@) {
422            $p =~ s!\r?\n!<br />\n!g;
423            $p = "<p>$p</p>";
424        }
425    }
426    join "\n\n", @paras;
427}
428
429{
430    my %Map = (':' => '&#58;', '@' => '&#64;', '.' => '&#46;');
431    sub spam_protect {
432        my($str) = @_;
433        my $look = join '', keys %Map;
434        $str =~ s!([$look])!$Map{$1}!g;
435        $str;
436    }
437}
438
439sub encode_js {
440    my($str) = @_;
441    return '' unless defined $str;
442    $str =~ s!\\!\\\\!g;
443    $str =~ s!>!\\>!g;
444    $str =~ s!<!\\<!g;
445    $str =~ s!(s)(cript)!$1\\$2!gi;
446    $str =~ s!</!<\\/!g; # </ is supposed to be the end of Javascript (</script in most UA)
447    $str =~ s!(['"])!\\$1!g;
448    $str =~ s!\n!\\n!g;
449    $str =~ s!\0!\\0!g;
450    $str =~ s!\f!\\f!g;
451    $str =~ s!\r!\\r!g;
452    $str =~ s!\t!\\t!g;
453    $str;
454}
455
456sub encode_php {
457    my($str, $meth) = @_;
458    return '' unless defined $str;
459    if ($meth eq 'qq') {
460        $str = encode_phphere($str);
461        $str =~ s!"!\\"!g;    ## Replace " with \"
462    } elsif (substr($meth, 0, 4) eq 'here') {
463        $str = encode_phphere($str);
464    } else {
465        $str =~ s!\\!\\\\!g;  ## Replace \ with \\
466        $str =~ s!'!\\'!g;    ## Replace ' with \'
467    }
468    $str;
469}
470
471sub encode_phphere {
472    my($str) = @_;
473    $str =~ s!\\!\\\\!g;      ## Replace \ with \\
474    $str =~ s!\$!\\\$!g;      ## Replace $ with \$
475    $str =~ s!\n!\\n!g;       ## Replace character \n with string \n
476    $str =~ s!\r!\\r!g;       ## Replace character \r with string \r
477    $str =~ s!\t!\\t!g;       ## Replace character \t with string \t
478    $str;
479}
480
481sub encode_url {
482    my($str) = @_;
483    $str =~ s!([^a-zA-Z0-9_.~-])!uc sprintf "%%%02x", ord($1)!eg;
484    $str;
485}
486
487sub decode_url {
488    my($str) = @_;
489    $str =~ s!%([0-9a-fA-F][0-9a-fA-F])!pack("H*",$1)!eg;
490    $str;
491}
492
493{
494    my $Have_Entities = eval 'use HTML::Entities; 1' ? 1 : 0;
495
496    sub encode_html {
497        my($html, $can_double_encode) = @_;
498        return '' unless defined $html;
499        $html =~ tr!\cM!!d;
500        #Encode::_utf8_on($html) if MT->instance->charset eq 'utf-8';
501        if ($Have_Entities && !MT->config->NoHTMLEntities) {
502            $html = HTML::Entities::encode_entities($html);
503        } else {
504            if ($can_double_encode) {
505                $html =~ s!&!&amp;!g;
506            } else {
507                ## Encode any & not followed by something that looks like
508                ## an entity, numeric or otherwise.
509                $html =~ s/&(?!#?[xX]?(?:[0-9a-fA-F]+|\w{1,8});)/&amp;/g;
510            }
511            $html =~ s!"!&quot;!g;    #"
512            $html =~ s!<!&lt;!g;
513            $html =~ s!>!&gt;!g;
514        }
515        #Encode::_utf8_off($html) if MT->instance->charset eq 'utf-8';
516        $html;
517    }
518
519    sub decode_html {
520        my($html) = @_;
521        return '' unless defined $html;
522        $html =~ tr!\cM!!d;
523        if ($Have_Entities && !MT->config->NoHTMLEntities) {
524            $html = HTML::Entities::decode_entities($html);
525        } else {
526            $html =~ s!&quot;!"!g;  #"
527            $html =~ s!&lt;!<!g;
528            $html =~ s!&gt;!>!g;
529            $html =~ s!&amp;!&!g;
530        }
531        $html;
532    }
533}
534
535{
536    my %Map = ('&' => '&amp;', '"' => '&quot;', '<' => '&lt;', '>' => '&gt;',
537               '\'' => '&apos;');
538    my %Map_Decode = reverse %Map;
539    my $RE = join '|', keys %Map;
540    my $RE_D = join '|', keys %Map_Decode;
541
542    sub encode_xml {
543        my($str, $nocdata) = @_;
544        return '' unless defined $str;
545        $nocdata ||= MT->config->NoCDATA;
546        if (!$nocdata && $str =~ m/
547            <[^>]+>  ## HTML markup
548            |        ## or
549            &(?:(?!(\#([0-9]+)|\#x([0-9a-fA-F]+))).*?);
550                     ## something that looks like an HTML entity.
551        /x) {
552            ## If ]]> exists in the string, encode the > to &gt;.
553            $str =~ s/]]>/]]&gt;/g;
554            $str = '<![CDATA[' . $str . ']]>';
555        } else {
556            $str =~ s!($RE)!$Map{$1}!g;
557            # re-replace &amp;#nnnn => &#nnnn
558            $str =~ s/&amp;((\#([0-9]+)|\#x([0-9a-fA-F]+)).*?);/&$1;/g;
559        }
560        $str;
561    }
562    sub decode_xml {
563        my($str) = @_;
564        return '' unless defined $str;
565        if ($str =~ s/<!\[CDATA\[(.*?)]]>/$1/g) {
566            ## Decode encoded ]]&gt;
567            $str =~ s/]]&(gt|#62);/]]>/g;
568        } else {
569            $str =~ s!($RE_D)!$Map_Decode{$1}!g;
570        }
571        $str;
572    }
573}
574
575sub remove_html {
576    my($text) = @_;
577    return $text if !defined $text;  # suppress warnings
578    return $text if $text =~ m/^<\!\[CDATA\[/i; 
579    $text =~ s!<[^>]+>!!gs;
580    $text =~ s!<!&lt;!gs;
581    $text;
582}
583
584sub iso_dirify {
585    my $s = $_[0];
586    my $sep;
587    if ((defined $_[1]) && ($_[1] ne '1')) {
588        $sep = $_[1];
589    } else {
590        $sep = '_';
591    }
592    $s = convert_high_ascii($s);  ## convert high-ASCII chars to 7bit.
593    $s = lc $s;                   ## lower-case.
594    $s = remove_html($s);         ## remove HTML tags.
595    $s =~ s!&[^;\s]+;!!gs;        ## remove HTML entities.
596    $s =~ s![^\w\s]!!gs;          ## remove non-word/space chars.
597    $s =~ s!\s+!$sep!gs;          ## change space chars to underscores.
598    $s;   
599}
600
601sub utf8_dirify {
602    my $s = $_[0];
603    my $sep;
604    if ((defined $_[1]) && ($_[1] ne '1')) {
605        $sep = $_[1];
606    } else {
607        $sep = '_';
608    }
609    $s = xliterate_utf8($s);      ## convert two-byte UTF-8 chars to 7bit ASCII
610    $s = lc $s;                   ## lower-case.
611    $s = remove_html($s);         ## remove HTML tags.
612    $s =~ s!&[^;\s]+;!!gs;        ## remove HTML entities.
613    $s =~ s![^\w\s]!!gs;          ## remove non-word/space chars.
614    $s =~ s!\s+!$sep!gs;          ## change space chars to underscores.
615    $s;   
616}
617
618sub dirify {
619    ($MT::VERSION && MT->instance->{cfg}->PublishCharset =~ m/utf-?8/i)
620        ? utf8_dirify(@_) : iso_dirify(@_);
621}
622
623sub convert_high_ascii {
624    require MT::I18N;
625    MT::I18N::convert_high_ascii(@_);
626}
627
628sub xliterate_utf8 {
629    my ($str) = @_;
630    my %utf8_table = (
631          "\xc3\x80" => 'A',    # A`
632          "\xc3\xa0" => 'a',    # a`
633          "\xc3\x81" => 'A',    # A'
634          "\xc3\xa1" => 'a',    # a'
635          "\xc3\x82" => 'A',    # A^
636          "\xc3\xa2" => 'a',    # a^
637          "\xc4\x82" => 'A',    # latin capital letter a with breve
638          "\xc4\x83" => 'a',    # latin small letter a with breve
639          "\xc3\x86" => 'AE',   # latin capital letter AE
640          "\xc3\xa6" => 'ae',   # latin small letter ae
641          "\xc3\x85" => 'A',    # latin capital letter a with ring above
642          "\xc3\xa5" => 'a',    # latin small letter a with ring above
643          "\xc4\x80" => 'A',    # latin capital letter a with macron
644          "\xc4\x81" => 'a',    # latin small letter a with macron
645          "\xc4\x84" => 'A',    # latin capital letter a with ogonek
646          "\xc4\x85" => 'a',    # latin small letter a with ogonek
647          "\xc3\x84" => 'A',    # A:
648          "\xc3\xa4" => 'a',    # a:
649          "\xc3\x83" => 'A',    # A~
650          "\xc3\xa3" => 'a',    # a~
651          "\xc3\x88" => 'E',    # E`
652          "\xc3\xa8" => 'e',    # e`
653          "\xc3\x89" => 'E',    # E'
654          "\xc3\xa9" => 'e',    # e'
655          "\xc3\x8a" => 'E',    # E^
656          "\xc3\xaa" => 'e',    # e^
657          "\xc3\x8b" => 'E',    # E:
658          "\xc3\xab" => 'e',    # e:
659          "\xc4\x92" => 'E',    # latin capital letter e with macron
660          "\xc4\x93" => 'e',    # latin small letter e with macron
661          "\xc4\x98" => 'E',    # latin capital letter e with ogonek
662          "\xc4\x99" => 'e',    # latin small letter e with ogonek
663          "\xc4\x9a" => 'E',    # latin capital letter e with caron
664          "\xc4\x9b" => 'e',    # latin small letter e with caron
665          "\xc4\x94" => 'E',    # latin capital letter e with breve
666          "\xc4\x95" => 'e',    # latin small letter e with breve
667          "\xc4\x96" => 'E',    # latin capital letter e with dot above
668          "\xc4\x97" => 'e',    # latin small letter e with dot above
669          "\xc3\x8c" => 'I',    # I`
670          "\xc3\xac" => 'i',    # i`
671          "\xc3\x8d" => 'I',    # I'
672          "\xc3\xad" => 'i',    # i'
673          "\xc3\x8e" => 'I',    # I^
674          "\xc3\xae" => 'i',    # i^
675          "\xc3\x8f" => 'I',    # I:
676          "\xc3\xaf" => 'i',    # i:
677          "\xc4\xaa" => 'I',    # latin capital letter i with macron
678          "\xc4\xab" => 'i',    # latin small letter i with macron
679          "\xc4\xa8" => 'I',    # latin capital letter i with tilde
680          "\xc4\xa9" => 'i',    # latin small letter i with tilde
681          "\xc4\xac" => 'I',    # latin capital letter i with breve
682          "\xc4\xad" => 'i',    # latin small letter i with breve
683          "\xc4\xae" => 'I',    # latin capital letter i with ogonek
684          "\xc4\xaf" => 'i',    # latin small letter i with ogonek
685          "\xc4\xb0" => 'I',    # latin capital letter with dot above
686          "\xc4\xb1" => 'i',    # latin small letter dotless i
687          "\xc4\xb2" => 'IJ',   # latin capital ligature ij
688          "\xc4\xb3" => 'ij',   # latin small ligature ij
689          "\xc4\xb4" => 'J',    # latin capital letter j with circumflex
690          "\xc4\xb5" => 'j',    # latin small letter j with circumflex
691          "\xc4\xb6" => 'K',    # latin capital letter k with cedilla
692          "\xc4\xb7" => 'k',    # latin small letter k with cedilla
693          "\xc4\xb8" => 'k',    # latin small letter kra
694          "\xc5\x81" => 'L',    # latin capital letter l with stroke
695          "\xc5\x82" => 'l',    # latin small letter l with stroke
696          "\xc4\xbd" => 'L',    # latin capital letter l with caron
697          "\xc4\xbe" => 'l',    # latin small letter l with caron
698          "\xc4\xb9" => 'L',    # latin capital letter l with acute
699          "\xc4\xba" => 'l',    # latin small letter l with acute
700          "\xc4\xbb" => 'L',    # latin capital letter l with cedilla
701          "\xc4\xbc" => 'l',    # latin small letter l with cedilla
702          "\xc4\xbf" => 'l',    # latin capital letter l with middle dot
703          "\xc5\x80" => 'l',    # latin small letter l with middle dot
704          "\xc3\x92" => 'O',    # O`
705          "\xc3\xb2" => 'o',    # o`
706          "\xc3\x93" => 'O',    # O'
707          "\xc3\xb3" => 'o',    # o'
708          "\xc3\x94" => 'O',    # O^
709          "\xc3\xb4" => 'o',    # o^
710          "\xc3\x96" => 'O',    # O:
711          "\xc3\xb6" => 'o',    # o:
712          "\xc3\x95" => 'O',    # O~
713          "\xc3\xb5" => 'o',    # o~
714          "\xc3\x98" => 'O',    # O/
715          "\xc3\xb8" => 'o',    # o/
716          "\xc5\x8c" => 'O',    # latin capital letter o with macron
717          "\xc5\x8d" => 'o',    # latin small letter o with macron
718          "\xc5\x90" => 'O',    # latin capital letter o with double acute
719          "\xc5\x91" => 'o',    # latin small letter o with double acute
720          "\xc5\x8e" => 'O',    # latin capital letter o with breve
721          "\xc5\x8f" => 'o',    # latin small letter o with breve
722          "\xc5\x92" => 'OE',   # latin capital ligature oe
723          "\xc5\x93" => 'oe',   # latin small ligature oe
724          "\xc5\x94" => 'R',    # latin capital letter r with acute
725          "\xc5\x95" => 'r',    # latin small letter r with acute
726          "\xc5\x98" => 'R',    # latin capital letter r with caron
727          "\xc5\x99" => 'r',    # latin small letter r with caron
728          "\xc5\x96" => 'R',    # latin capital letter r with cedilla
729          "\xc5\x97" => 'r',    # latin small letter r with cedilla
730          "\xc3\x99" => 'U',    # U`
731          "\xc3\xb9" => 'u',    # u`
732          "\xc3\x9a" => 'U',    # U'
733          "\xc3\xba" => 'u',    # u'
734          "\xc3\x9b" => 'U',    # U^
735          "\xc3\xbb" => 'u',    # u^
736          "\xc3\x9c" => 'U',    # U:
737          "\xc3\xbc" => 'u',    # u:
738          "\xc5\xaa" => 'U',    # latin capital letter u with macron
739          "\xc5\xab" => 'u',    # latin small letter u with macron
740          "\xc5\xae" => 'U',    # latin capital letter u with ring above
741          "\xc5\xaf" => 'u',    # latin small letter u with ring above
742          "\xc5\xb0" => 'U',    # latin capital letter u with double acute
743          "\xc5\xb1" => 'u',    # latin small letter u with double acute
744          "\xc5\xac" => 'U',    # latin capital letter u with breve
745          "\xc5\xad" => 'u',    # latin small letter u with breve
746          "\xc5\xa8" => 'U',    # latin capital letter u with tilde
747          "\xc5\xa9" => 'u',    # latin small letter u with tilde
748          "\xc5\xb2" => 'U',    # latin capital letter u with ogonek
749          "\xc5\xb3" => 'u',    # latin small letter u with ogonek
750          "\xc3\x87" => 'C',    # ,C
751          "\xc3\xa7" => 'c',    # ,c
752          "\xc4\x86" => 'C',    # latin capital letter c with acute
753          "\xc4\x87" => 'c',    # latin small letter c with acute
754          "\xc4\x8c" => 'C',    # latin capital letter c with caron
755          "\xc4\x8d" => 'c',    # latin small letter c with caron
756          "\xc4\x88" => 'C',    # latin capital letter c with circumflex
757          "\xc4\x89" => 'c',    # latin small letter c with circumflex
758          "\xc4\x8a" => 'C',    # latin capital letter c with dot above
759          "\xc4\x8b" => 'c',    # latin small letter c with dot above
760          "\xc4\x8e" => 'D',    # latin capital letter d with caron
761          "\xc4\x8f" => 'd',    # latin small letter d with caron
762          "\xc4\x90" => 'D',    # latin capital letter d with stroke
763          "\xc4\x91" => 'd',    # latin small letter d with stroke
764          "\xc3\x91" => 'N',    # N~
765          "\xc3\xb1" => 'n',    # n~
766          "\xc5\x83" => 'N',    # latin capital letter n with acute
767          "\xc5\x84" => 'n',    # latin small letter n with acute
768          "\xc5\x87" => 'N',    # latin capital letter n with caron
769          "\xc5\x88" => 'n',    # latin small letter n with caron
770          "\xc5\x85" => 'N',    # latin capital letter n with cedilla
771          "\xc5\x86" => 'n',    # latin small letter n with cedilla
772          "\xc5\x89" => 'n',    # latin small letter n preceded by apostrophe
773          "\xc5\x8a" => 'N',    # latin capital letter eng
774          "\xc5\x8b" => 'n',    # latin small letter eng
775          "\xc3\x9f" => 'ss',   # double-s
776          "\xc5\x9a" => 'S',    # latin capital letter s with acute
777          "\xc5\x9b" => 's',    # latin small letter s with acute
778          "\xc5\xa0" => 'S',    # latin capital letter s with caron
779          "\xc5\xa1" => 's',    # latin small letter s with caron
780          "\xc5\x9e" => 'S',    # latin capital letter s with cedilla
781          "\xc5\x9f" => 's',    # latin small letter s with cedilla
782          "\xc5\x9c" => 'S',    # latin capital letter s with circumflex
783          "\xc5\x9d" => 's',    # latin small letter s with circumflex
784          "\xc8\x98" => 'S',    # latin capital letter s with comma below
785          "\xc8\x99" => 's',    # latin small letter s with comma below
786          "\xc5\xa4" => 'T',    # latin capital letter t with caron
787          "\xc5\xa5" => 't',    # latin small letter t with caron
788          "\xc5\xa2" => 'T',    # latin capital letter t with cedilla
789          "\xc5\xa3" => 't',    # latin small letter t with cedilla
790          "\xc5\xa6" => 'T',    # latin capital letter t with stroke
791          "\xc5\xa7" => 't',    # latin small letter t with stroke
792          "\xc8\x9a" => 'T',    # latin capital letter t with comma below
793          "\xc8\x9b" => 't',    # latin small letter t with comma below
794          "\xc6\x92" => 'f',    # latin small letter f with hook
795          "\xc4\x9c" => 'G',    # latin capital letter g with circumflex
796          "\xc4\x9d" => 'g',    # latin small letter g with circumflex
797          "\xc4\x9e" => 'G',    # latin capital letter g with breve
798          "\xc4\x9f" => 'g',    # latin small letter g with breve
799          "\xc4\xa0" => 'G',    # latin capital letter g with dot above
800          "\xc4\xa1" => 'g',    # latin small letter g with dot above
801          "\xc4\xa2" => 'G',    # latin capital letter g with cedilla
802          "\xc4\xa3" => 'g',    # latin small letter g with cedilla
803          "\xc4\xa4" => 'H',    # latin capital letter h with circumflex
804          "\xc4\xa5" => 'h',    # latin small letter h with circumflex
805          "\xc4\xa6" => 'H',    # latin capital letter h with stroke
806          "\xc4\xa7" => 'h',    # latin small letter h with stroke
807          "\xc5\xb4" => 'W',    # latin capital letter w with circumflex
808          "\xc5\xb5" => 'w',    # latin small letter w with circumflex
809          "\xc3\x9d" => 'Y',    # latin capital letter y with acute
810          "\xc3\xbd" => 'y',    # latin small letter y with acute
811          "\xc5\xb8" => 'Y',    # latin capital letter y with diaeresis
812          "\xc3\xbf" => 'y',    # latin small letter y with diaeresis
813          "\xc5\xb6" => 'Y',    # latin capital letter y with circumflex
814          "\xc5\xb7" => 'y',    # latin small letter y with circumflex
815          "\xc5\xbd" => 'Z',    # latin capital letter z with caron
816          "\xc5\xbe" => 'z',    # latin small letter z with caron
817          "\xc5\xbb" => 'Z',    # latin capital letter z with dot above
818          "\xc5\xbc" => 'z',    # latin small letter z with dot above
819          "\xc5\xb9" => 'Z',    # latin capital letter z with acute
820          "\xc5\xba" => 'z',    # latin small letter z with acute
821    );
822
823    $str =~ s/([\200-\377]{2})/$utf8_table{$1}||''/ge;
824    $str;
825}
826
827sub first_n_words {
828    my($text, $n) = @_;
829    $text = remove_html($text) || '';
830    my @words = split /\s+/, $text;
831    my $max = @words > $n ? $n : @words;
832    return join ' ', @words[0..$max-1];
833}
834
835sub munge_comment {
836    my($text, $blog) = @_;
837    unless ($blog->allow_comment_html) {
838        $text = remove_html($text);
839    }
840    if ($blog->autolink_urls) {
841        $text =~ s!(^|\s)(https?://\S+)!$1<a href="$2">$2</a>!gs;
842    }
843    $text;
844}
845
846my %DynamicURIs = (
847    'Individual' => 'entry/<$MTEntryID$>',
848    'Weekly'     => 'archives/week/<$MTArchiveDate format="%Y/%m/%d"$>',
849    'Monthly'    => 'archives/<$MTArchiveDate format="%Y/%m"$>',
850    'Daily'      => 'archives/<$MTArchiveDate format="%Y/%m/%d"$>',
851    'Category'   => 'section/<$MTCategoryID$>',
852);
853
854
855# basename must be unique across the entire blog it starts as dirified
856# title and, if that already exists, an appended ctr is incremented
857# until we get a non-existent basename
858sub make_unique_basename {
859    my ($entry) = @_;
860    my $blog = $entry->blog;
861    my $title = $entry->title;
862    $title = '' if !defined $title;
863    $title =~ s/^\s+|\s+$//gs;
864    if ($title eq '') {
865        if (my $text = $entry->text) {
866            $title = MT::I18N::first_n_text($text, MT::I18N::const('LENGTH_ENTRY_TITLE_FROM_TEXT'));
867        }
868        $title = 'Post' if $title eq '';
869    }
870    my $limit = $blog->basename_limit || 30; # FIXME
871    $limit = 15 if $limit < 15; $limit = 250 if $limit > 250;
872    my $base = substr(dirify($title), 0, $limit);
873    $base =~ s/_+$//;
874    $base = 'post' if $base eq '';
875    my $i = 1;
876    my $base_copy = $base;
877
878    my $class = ref $entry; 
879    while ($class->count({ blog_id => $blog->id,
880                           basename => $base })) {
881        $base = $base_copy . '_' . $i++;
882    }
883    $base;
884}
885
886sub make_unique_category_basename {
887    my ($cat) = @_;
888    require MT::Blog;
889    my $blog = MT::Blog->load($cat->blog_id);
890    my $label = $cat->label;
891    $label = '' if !defined $label;
892    $label =~ s/^\s+|\s+$//gs;
893
894    my $name = MT::Util::dirify($label) || ($cat->basename_prefix(1) . $cat->id);
895
896    my $limit = $blog->basename_limit || 30;
897    $limit = 15 if $limit < 15; $limit = 250 if $limit > 250;
898    my $base = substr($name, 0, $limit);
899    $base =~ s/_+$//;
900    $base = $cat->basename_prefix(0) if $base eq ''; #FIXME when does this happen?
901    my $i = 1;
902    my $base_copy = $base;
903
904    my $cat_class = ref $cat;
905    while ($cat_class->count({ blog_id => $cat->blog_id,
906                               basename => $base })) {
907        $base = $base_copy . '_' . $i++;
908    }
909    $base;
910}
911
912sub make_unique_author_basename {
913    my ($author) = @_;
914    my $name = MT::Util::dirify($author->nickname);
915    return "author" . $author->id if $name !~ /\w/;
916
917    my $limit = MT->instance->config('AuthorBasenameLimit');
918    $limit = 15 if $limit < 15; $limit = 250 if $limit > 250;
919    my $base = substr($name, 0, $limit);
920    $base =~ s/_+$//;
921    my $i = 1;
922    my $base_copy = $base;
923
924    my $author_class = ref $author;
925    while ($author_class->count({ basename => $base })) {
926        $base = $base_copy . '_' . $i++;
927    }
928    $base;
929}
930
931sub archive_file_for {
932    MT->instance->publisher->archive_file_for(@_);
933}
934
935sub strip_index {
936    my ($link, $blog) = @_;
937    my $index = MT->instance->config('IndexBasename');
938    my $ext = $blog->file_extension || '';
939    $ext = '.' . $ext if $ext ne '';
940    $index .= $ext;
941    if ($link =~ /^(.*?)\/\Q$index\E(#.*)?$/) {
942        $link = $1 . '/' . ($2 || '');
943    }
944    $link;
945}
946
947sub get_entry {
948    MT->instance->publisher->get_entry(@_);
949}
950
951sub is_valid_date {
952    my ($ts) = @_;
953    unless ($ts =~
954        m!(\d{4})-?(\d{2})-?(\d{2})\s*(\d{2}):?(\d{2})(?::?(\d{2}))?!) {
955        return 0;
956    }
957    my $s = $6 || 0;
958    return 0
959        if ($s > 59 || $s < 0  || $5 > 59 || $5 < 0 || $4 > 23 || $4 < 0
960            || $2 > 12 || $2 < 1 || $3 < 1
961            || (days_in($2, $1) < $3 && !leap_day($0, $1, $2)));
962    1;
963}
964
965sub is_valid_email {
966    my($addr) = @_;
967    return 0 if $addr =~ /[\n\r]/;
968    my $specials = '\(\)<>\@,;:\[\]';
969    if ($addr =~ /^\s*([^\" \t\n\r$specials]+@[^ \t\n\r$specials]+\.[^ \t\n\r$specials][^ \t\n\r$specials]+)\s*$/)
970    {
971        return $1;
972    } else {
973        return 0;
974    }   
975}
976
977sub is_valid_url {
978    my($url, $stringent) = @_;
979
980    $url ||= "";
981
982    # strip spaces
983    $url =~ s/^\s*//;
984    $url =~ s/\s*$//;
985
986    return '' if ($url =~ /[ \"]/);
987
988    # help fat-finger typists.
989    $url =~ s,http;//,http://,;
990    $url =~ s,http//,http://,;
991
992    $url = "http://$url" unless ($url =~ m,https?://,);
993
994    my ($scheme, $host, $path, $query, $fragment) =
995        $url =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
996    if ($scheme && $host) {
997        # Note: no stringent checks; localhost is a legit hostname, for example.
998        return $url;
999    } else {
1000        return '';
1001    }
1002}
1003
1004sub is_url {
1005    my($url) = @_;
1006
1007    return $url =~ /s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+/;
1008}
1009
1010sub discover_tb {
1011    my($url, $find_all, $contents) = @_;
1012    my $c = '';
1013    if ($contents) {
1014        $c = $$contents;
1015    } else {
1016        my $ua = MT->new_ua;
1017        ## Wrap this in an eval in case some versions don't support it.
1018        my $req = HTTP::Request->new(GET => $url);
1019        eval {
1020            $ua->timeout(30);     # limit timeout to 30 seconds
1021            $ua->parse_head(0);
1022        };
1023        # prevent downloads of non-text content
1024        my $res = $ua->request($req, sub {
1025            my ($data, $res, $po) = @_;
1026            die unless $c ne '' or $res->header('Content-Type') =~ m!^text/!;
1027            $c .= $data;
1028        }, 16384);
1029        return unless $res->is_success;
1030    }
1031    (my $url_no_anchor = $url) =~ s/#.*$//;
1032    (my $url_no_host = $url_no_anchor) =~ s!^https?://.*/!!i;
1033    my(@items);
1034    while ($c =~ m!(<rdf:RDF.*?</rdf:RDF>)!sg) {
1035        my $rdf = $1;
1036        my($perm_url) = $rdf =~ m!dc:identifier="([^"]+)"!;   #"
1037        $perm_url ||= "";
1038        (my $perm_url_no_host = $perm_url) =~ s!https?://.*/!!i;
1039        $perm_url_no_host =~ s/#.*$//;
1040        next unless $find_all ||
1041            $perm_url eq $url ||
1042            $perm_url eq $url_no_anchor ||
1043            $perm_url_no_host eq $url_no_host;
1044        (my $inner = $rdf) =~ s!^.*?<rdf:Description!!s;
1045        my $item = { permalink => $perm_url };
1046        while ($inner =~ /([\w:]+)="([^"]*)"/gs) {            #"
1047            $item->{$1} = $2;
1048        }
1049        $item->{ping_url} = $item->{'trackback:ping'};
1050        next unless $item->{ping_url};
1051        $item->{title} = decode_xml($item->{'dc:title'});
1052        if (!$item->{title} && $rdf =~ m!dc:description="([^"]+)"!) { #"
1053            $item->{title} = MT::I18N::first_n_text($1, MT::I18N::const('LENGTH_ENTRY_TITLE_FROM_TEXT')) . '...';
1054        }
1055        push @items, $item;
1056        last unless $find_all;
1057    }
1058    return unless @items;
1059    $find_all ? \@items : $items[0];
1060}
1061
1062{
1063    my %Data = (
1064        'by' => {
1065              name => 'Attribution',
1066              requires => [ qw( Attribution Notice ) ],
1067              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1068         },
1069        'by-nd' => {
1070              name => 'Attribution-NoDerivs',
1071              requires => [ qw( Attribution Notice ) ],
1072              permits => [ qw( Reproduction Distribution ) ],
1073         },
1074        'by-nd-nc' => {
1075              name => 'Attribution-NoDerivs-NonCommercial',
1076              requires => [ qw( Attribution Notice ) ],
1077              permits => [ qw( Reproduction Distribution ) ],
1078              prohibits => [ qw( CommercialUse) ],
1079         },
1080        'by-nc' => {
1081              name => 'Attribution-NonCommercial',
1082              requires => [ qw( Attribution Notice ) ],
1083              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1084              prohibits => [ qw( CommercialUse ) ],
1085         },
1086        'by-nc-sa' => {
1087              name => 'Attribution-NonCommercial-ShareAlike',
1088              requires => [ qw( Attribution Notice ShareAlike ) ],
1089              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1090              prohibits => [ qw( CommercialUse ) ],
1091         },
1092        'by-sa' => {
1093              name => 'Attribution-ShareAlike',
1094              requires => [ qw( Attribution Notice ShareAlike ) ],
1095              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1096         },
1097        'nd' => {
1098              name => 'NonDerivative',
1099              requires => [ qw( Notice ) ],
1100              permits => [ qw( Reproduction Distribution ) ],
1101         },
1102        'nd-nc' => {
1103              name => 'NonDerivative-NonCommercial',
1104              requires => [ qw( Notice ) ],
1105              permits => [ qw( Reproduction Distribution ) ],
1106              prohibits => [ qw( CommercialUse ) ],
1107         },
1108        'nc' => {
1109              name => 'NonCommercial',
1110              requires => [ qw( Notice ) ],
1111              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1112              prohibits => [ qw( CommercialUse ) ],
1113         },
1114        'nc-sa' => {
1115              name => 'NonCommercial-ShareAlike',
1116              requires => [ qw( Notice ShareAlike ) ],
1117              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1118              prohibits => [ qw( CommercialUse ) ],
1119         },
1120        'sa' => {
1121              name => 'ShareAlike',
1122              requires => [ qw( Notice ShareAlike ) ],
1123              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1124         },
1125        'pd' => {
1126              name => 'PublicDomain',
1127              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1128         },
1129    );
1130    sub cc_url {
1131        my($code) = @_;
1132        my $url;
1133        my ($real_code, $license_url, $image_url);
1134        if (($real_code, $license_url, $image_url)
1135            = $code =~ /(\S+) (\S+) (\S+)/) {
1136            return $license_url;
1137        }
1138        $code eq 'pd' ?
1139            "http://web.resource.org/cc/PublicDomain" :
1140            "http://creativecommons.org/licenses/$code/1.0/";
1141    }
1142    sub cc_rdf {
1143        my($code) = @_;
1144        my $url = cc_url($code);
1145        my $rdf = <<RDF;
1146<License rdf:about="$url">
1147RDF
1148        for my $type (qw( requires permits prohibits )) {
1149            for my $item (@{ $Data{$code}{$type} }) {
1150                $rdf .= <<RDF;
1151<$type rdf:resource="http://web.resource.org/cc/$item" />
1152RDF
1153            }
1154        }
1155        $rdf . "</License>\n";
1156    }
1157    sub cc_name {
1158        my ($code) = ($_[0] =~ /(\S+) \S+ \S+/);
1159        $code ||= $_[0];
1160        $Data{$code}{name};
1161    }
1162    sub cc_image {
1163        my($code) = @_;
1164        my $url;
1165        my ($real_code, $license_url, $image_url);
1166        if (($real_code, $license_url, $image_url)
1167            = $code =~ /(\S+) (\S+) (\S+)/) {
1168            return $image_url;
1169        }
1170        "http://creativecommons.org/images/public/" .
1171            ($code eq 'pd' ? 'norights' : 'somerights');
1172    }
1173}
1174
1175sub mark_odd_rows {
1176    my($list) = @_;
1177    my $i = 1;
1178    for my $row (@$list) {
1179        $row->{is_odd} = $i++ % 2 == 1;
1180    }
1181}
1182
1183%Languages = (
1184    'en' => [
1185            [ qw( Sunday Monday Tuesday Wednesday Thursday Friday Saturday ) ],
1186            [ qw( January February March April May June
1187                  July August September October November December ) ],
1188            [ qw( AM PM ) ],
1189          ],
1190
1191    'fr' => [
1192            [ qw( dimanche lundi mardi mercredi jeudi vendredi samedi ) ],
1193            [ ('janvier', "f&#xe9;vrier", 'mars', 'avril', 'mai', 'juin',
1194               'juillet', "ao&#xfb;t", 'septembre', 'octobre', 'novembre',
1195               "d&#xe9;cembre") ],
1196            [ qw( AM PM ) ],
1197              "%e %B %Y %kh%M",
1198              "%e %B %Y",
1199              "%kh%M",
1200          ],
1201
1202    'es' => [
1203            [ ('Domingo', 'Lunes', 'Martes', "Mi&#xe9;rcoles", 'Jueves',
1204               'Viernes', "S&#xe1;bado") ],
1205            [ qw( Enero Febrero Marzo Abril Mayo Junio Julio Agosto
1206                  Septiembre Octubre Noviembre Diciembre ) ],
1207            [ qw( AM PM ) ],
1208              "%e de %B %Y a las %I:%M %p",
1209              "%e de %B %Y",
1210          ],
1211
1212    'pt' => [
1213            [ ('domingo', 'segunda-feira', "ter&#xe7;a-feira", 'quarta-feira',
1214               'quinta-feira', 'sexta-feira', "s&#xe1;bado") ],
1215            [ ('janeiro', 'fevereiro', "mar&#xe7;o", 'abril', 'maio', 'junho',
1216               'julho', 'agosto', 'setembro', 'outubro', 'novembro',
1217               'dezembro' ) ],
1218            [ qw( AM PM ) ],
1219          ],
1220
1221    'nl' => [
1222            [ qw( zondag maandag dinsdag woensdag donderdag vrijdag
1223                  zaterdag ) ],
1224            [ qw( januari februari maart april mei juni juli augustus
1225                  september oktober november december ) ],
1226            [ qw( am pm ) ],
1227              "%e %B %Y %k:%M",
1228              "%e %B %Y",
1229              "%k:%M",
1230          ],
1231
1232    'dk' => [
1233            [ ("s&#xf8;ndag", 'mandag', 'tirsdag', 'onsdag', 'torsdag',
1234               'fredag', "l&#xf8;rdag") ],
1235            [ qw( januar februar marts april maj juni juli august
1236                  september oktober november december ) ],
1237            [ qw( am pm ) ],
1238            "%d.%m.%Y %H:%M",
1239            "%d.%m.%Y",
1240            "%H:%M",
1241          ],
1242
1243    'se' => [
1244            [ ("s&#xf6;ndag", "m&#xe5;ndag", 'tisdag', 'onsdag', 'torsdag',
1245               'fredag', "l&#xf6;rdag") ],
1246            [ qw( januari februari mars april maj juni juli augusti
1247                  september oktober november december ) ],
1248            [ qw( FM EM ) ],
1249          ],
1250
1251    'no' => [
1252            [ ("S&#xf8;ndag", "Mandag", 'Tirsdag', 'Onsdag', 'Torsdag',
1253               'Fredag', "L&#xf8;rdag") ],
1254            [ qw( Januar Februar Mars April Mai Juni Juli August
1255                  September Oktober November Desember ) ],
1256            [ qw( FM EM ) ],
1257          ],
1258
1259    'de' => [
1260            [ qw( Sonntag Montag Dienstag Mittwoch Donnerstag Freitag
1261                  Samstag ) ],
1262            [ ('Januar', 'Februar', "M&#xe4;rz", 'April', 'Mai', 'Juni',
1263               'Juli', 'August', 'September', 'Oktober', 'November',
1264               'Dezember') ],
1265            [ qw( FM EM ) ],
1266            "%e.%m.%y %k:%M",
1267            "%e.%m.%y",
1268            "%k:%M",
1269          ],
1270
1271    'it' => [
1272            [ ('Domenica', "Luned&#xec;", "Marted&#xec;", "Mercoled&#xec;",
1273               "Gioved&#xec;", "Venerd&#xec;", 'Sabato') ],
1274            [ qw( Gennaio Febbraio Marzo Aprile Maggio Giugno Luglio
1275                  Agosto Settembre Ottobre Novembre Dicembre ) ],
1276            [ qw( AM PM ) ],
1277            "%d.%m.%y %H:%M",
1278            "%d.%m.%y",
1279            "%H:%M",
1280          ],
1281
1282    'pl' => [
1283            [ ('niedziela', "poniedzia&#322;ek", 'wtorek', "&#347;roda",
1284               'czwartek', "pi&#261;tek", 'sobota') ],
1285            [ ('stycznia', 'lutego', 'marca', 'kwietnia', 'maja', 'czerwca',
1286               'lipca', 'sierpnia', "wrze&#347;nia", "pa&#378;dziernika",
1287               'listopada', 'grudnia') ],
1288            [ qw( AM PM ) ],
1289            "%e %B %Y %k:%M",
1290            "%e %B %Y",
1291            "%k:%M",
1292          ],
1293
1294    'fi' => [
1295            [ qw( sunnuntai maanantai tiistai keskiviikko torstai perjantai
1296                  lauantai ) ],
1297            [ ('tammikuu', 'helmikuu', 'maaliskuu', 'huhtikuu', 'toukokuu',
1298               "kes&#xe4;kuu", "hein&#xe4;kuu", 'elokuu', 'syyskuu', 'lokakuu',
1299               'marraskuu', 'joulukuu') ],
1300            [ qw( AM PM ) ],
1301            "%d.%m.%y %H:%M",
1302          ],
1303
1304    'is' => [
1305            [ ('Sunnudagur', "M&#xe1;nudagur", "&#xde;ri&#xf0;judagur",
1306               "Mi&#xf0;vikudagur", 'Fimmtudagur', "F&#xf6;studagur",
1307               'Laugardagur') ],
1308            [ ("jan&#xfa;ar", "febr&#xfa;ar", 'mars', "apr&#xed;l", "ma&#xed;",
1309               "j&#xfa;n&#xed;", "j&#xfa;l&#xed;", "&#xe1;g&#xfa;st", 'september',
1310               "okt&#xf3;ber", "n&#xf3;vember", 'desember') ],
1311            [ qw( FH EH ) ],
1312            "%d.%m.%y %H:%M",
1313          ],
1314
1315    'si' => [
1316            [ ('nedelja', 'ponedeljek', 'torek', 'sreda', "&#xe3;etrtek",
1317               'petek', 'sobota',) ],
1318            [ qw( januar februar marec april maj junij julij avgust
1319                  september oktober november december ) ],
1320            [ qw( AM PM ) ],
1321            "%d.%m.%y %H:%M",
1322          ],
1323
1324    'cz' => [
1325            [ ('Ned&#283;le', 'Pond&#283;l&#237;', '&#218;ter&#253;',
1326               'St&#345;eda', '&#268;tvrtek', 'P&#225;tek', 'Sobota') ],
1327            [ ('Leden', '&#218;nor', 'B&#345;ezen', 'Duben', 'Kv&#283;ten',
1328               '&#268;erven', '&#268;ervenec', 'Srpen', 'Z&#225;&#345;&#237;',
1329               '&#216;&#237;jen', 'Listopad', 'Prosinec') ],
1330            [ qw( AM PM ) ],
1331            "%e. %B %Y %k:%M",
1332            "%e. %B %Y",
1333            "%k:%M",
1334          ],
1335
1336    'sk' => [
1337            [ ('nede&#318;a', 'pondelok', 'utorok', 'streda',
1338               '&#353;tvrtok', 'piatok', 'sobota') ],
1339            [ ('janu&#225;r', 'febru&#225;r', 'marec', 'apr&#237;l',
1340               'm&#225;j', 'j&#250;n', 'j&#250;l', 'august', 'september',
1341               'okt&#243;ber', 'november', 'december') ],
1342            [ qw( AM PM ) ],
1343            "%e. %B %Y %k:%M",
1344            "%e. %B %Y",
1345            "%k:%M",
1346          ],
1347
1348    'jp' => [
1349            [ '&#26085;&#26332;&#26085;', '&#26376;&#26332;&#26085;',
1350              '&#28779;&#26332;&#26085;', '&#27700;&#26332;&#26085;',
1351              '&#26408;&#26332;&#26085;', '&#37329;&#26332;&#26085;',
1352              '&#22303;&#26332;&#26085;'],
1353            [ qw( 1 2 3 4 5 6 7 8 9 10 11 12 ) ],
1354            [ qw( AM PM ) ],
1355            "%Y&#24180;%b&#26376;%e&#26085; %H:%M",
1356            "%Y&#24180;%b&#26376;%e&#26085;",
1357            "%H:%M",
1358            "%Y&#24180;%b&#26376;",
1359            "%b&#26376;%e&#26085;",
1360          ],
1361
1362    'et' => [
1363            [ qw( p&uuml;hap&auml;ev esmasp&auml;ev teisip&auml;ev
1364                  kolmap&auml;ev neljap&auml;ev reede laup&auml;ev ) ],
1365            [ ('jaanuar', 'veebruar', 'm&auml;rts', 'aprill', 'mai',
1366               'juuni', 'juuli', 'august', 'september', 'oktoober',
1367              'november', 'detsember') ],
1368            [ qw( AM PM ) ],
1369            "%m.%d.%y %H:%M",
1370            "%e. %B %Y",
1371            "%H:%M",
1372          ],
1373);
1374
1375$Languages{en_US} = $Languages{en_us} = $Languages{"en-us"} = $Languages{en};
1376$Languages{ja} = $Languages{jp};
1377
1378sub launch_background_tasks {
1379    return !($ENV{MOD_PERL} || $ENV{FAST_CGI}
1380        || !MT->config->LaunchBackgroundTasks);
1381}
1382
1383sub start_background_task {
1384    my ($func) = @_;
1385    if (!launch_background_tasks()) { $func->(); }
1386    else {
1387        $| = 1;            # Flush open filehandles
1388        my $pid = fork();
1389        if (!$pid) {
1390            # child
1391            close STDIN; open STDIN, "</dev/null";
1392            close STDOUT; open STDOUT, ">/dev/null"; 
1393            close STDERR; open STDERR, ">/dev/null"; 
1394
1395            MT::ObjectDriverFactory->init();
1396            MT::ObjectDriverFactory->configure();
1397            $func->();
1398            CORE::exit(0) if defined($pid) && !$pid;
1399        } else {
1400            MT::ObjectDriverFactory->init();
1401            MT::ObjectDriverFactory->configure();
1402            return 1;
1403        }
1404    }
1405}
1406
1407{
1408    eval { require bytes; 1; };
1409
1410    sub addbin {
1411        my ($a, $b) = @_;
1412        my $length = (length $a > length $b ? length $a : length $b);
1413
1414        $a = "\0" x ($length - (length $a)) . $a;
1415        $b = "\0" x ($length - (length $b)) . $b;
1416        my $carry = 0;
1417        my $result = '';
1418        for (my $i=1; $i <= $length; $i++) {
1419            my $adigit = ord(substr($a, -$i, 1));
1420            my $bdigit = ord(substr($b, -$i, 1));
1421            my $rdigit = $adigit + $bdigit + $carry;
1422            $carry = $rdigit / 256;
1423            $result = chr($rdigit % 256) . $result;
1424       }
1425       if ($carry) {
1426           return $result = chr($carry) . $result;
1427       } else {
1428           return $result;
1429       }
1430    }
1431
1432    sub multbindec {
1433        my ($a, $b) = @_;
1434        # $b is decimal-ascii, $b < 256
1435        my @result;
1436        $result[(length $a)] = 0;
1437        for (my $i=1; $i <= length $a; $i++) {
1438            my $adigit = substr($a, -$i, 1);
1439            $result[-$i] = ord($adigit) * $b;
1440        }
1441
1442        for (my $i=2; $i <= scalar @result; $i++) {
1443            $result[-$i] += int($result[-$i+1] / 256);
1444            $result[-$i+1] = $result[-$i+1] % 256;
1445        }
1446
1447        shift @result while (@result && ($result[0] == 0));
1448
1449        pack('C*', @result);
1450    }
1451
1452    sub divbindec {
1453        my ($a, $b) = @_;
1454        # $b is decimal-ascii, $b < 256
1455
1456        my $acc = ord(substr($a, 0, 1));
1457        my $quot;
1458        while (length $a) {
1459            $a = substr($a, 1);
1460            $quot .= chr($acc / $b);
1461            $acc = $acc % $b;
1462            if (length $a) {
1463                $acc = $acc * 256 + ord(substr($a, 0, 1));
1464            }
1465        }
1466        return ($quot, $acc);
1467    }
1468
1469    sub dec2bin {
1470        my ($decimal) = @_;
1471        my @digits = split //, $decimal;
1472        my $result = "";
1473        foreach my $d (@digits) {
1474            $result = multbindec($result, 10);
1475            $result = addbin(pack('c', $d), $result);
1476        }
1477        while (substr($result, 0, 1) eq "\0") {
1478            $result = substr($result, 1);
1479        }
1480        $result;
1481    }
1482
1483    sub bin2dec {
1484        my $bin = $_[0];
1485        my $result = '';
1486        my $rem = 0;
1487        while ((length $bin) && ($bin ne "\0")) {
1488            ($bin, $rem) = divbindec($bin, 10);
1489            $result = $rem . $result;
1490            $bin = substr($bin, 1) if (substr($bin, 0, 1) eq "\0");
1491        }
1492        $result;
1493    }
1494
1495
1496    sub perl_sha1_digest {   # thanks to Adam Back for the starting point of this
1497        my ($message) = @_;
1498        my $init_string = 'D9T4C`>_-JXF8NMS^$#)4=L/2X?!:@GF9;MGKH8\;O-S*8L\'6';
1499        # 67452301 efcdab89 98badcfe 10325476 c3d2e1f0
1500        my @A = unpack"N*", unpack 'u', $init_string;
1501        my @K = splice @A, 5, 4;
1502        sub M{my ($x, $m); ($x=pop)-($m=1+~0)*int$x/$m};   # modulo 0x100000000
1503        sub L{my ($n, $x); $n=pop;(($x=pop)<<$n|2**$n-1&$x>>32-$n) & (0xffffffff)} # left-rotate bit vector
1504        # magic SHA1 functions
1505        my @F = (sub { my ($a, $b, $c, $d) = @_; $b&($c^$d)^$d },
1506                 sub { my ($a, $b, $c, $d) = @_; $b^$c ^$d},
1507                 sub { my ($a, $b, $c, $d) = @_; ($b|$c)&$d|$b&$c},
1508                 sub { my ($a, $b, $c, $d) = @_; $b^$c ^$d});
1509        my $F = sub {
1510            my $which = shift;
1511            my ($a, $b, $c, $d) = @_; 
1512            if ($which == 0)
1513                { $b&($c^$d)^$d }
1514            elsif ($which == 1)
1515                { $b^$c ^$d }
1516            elsif ($which == 2)
1517                { ($b|$c)&$d|$b&$c }
1518            elsif ($which == 3) 
1519                { $b^$c ^$d }
1520        };
1521
1522        my ($l, $r, $p, $t, $S, @W, $P);
1523        do {
1524            $P = substr($message, 0, 64);
1525            $message = length$message >= 64 ? substr($message, 64) : "";
1526            $l += $r = length $P;
1527            $r++, $P .= "\x80" if $r < 64 && !$p++;
1528            @W = unpack 'N16', $P."\0"x(64-length($P));
1529            $W[15] = $l*8 if $r < 57;
1530            for (16..79) {
1531                push @W, L($W[$_-3]^$W[$_-8]^$W[$_-14]^$W[$_-16], 1);
1532            }
1533            my ($a,$b,$c,$d,$e)=@A;
1534            for(0..79) {
1535                $t = M(($F->(int($_/ 20), $a, $b, $c, $d))+$e+$W[$_]+$K[$_/20]+L$a,5);
1536                $e = $d;
1537                $d = $c;
1538                $c = L($b, 30);
1539                $b = $a;
1540                $a = $t;
1541            }
1542            $A[0] = M($A[0] + $a);
1543            $A[1] = M($A[1] + $b);
1544            $A[2] = M($A[2] + $c);
1545            $A[3] = M($A[3] + $d);
1546            $A[4] = M($A[4] + $e);
1547        } while $r > 56;
1548
1549        pack('N*', @A[0..4]);
1550    }
1551}
1552
1553sub perl_sha1_digest_hex {
1554    sprintf("%.8x"x5, unpack('N*', &perl_sha1_digest(@_)));
1555}
1556
1557sub perl_sha1_digest_base64 {
1558    require MIME::Base64;
1559    MIME::Base64::encode_base64(perl_sha1_digest(@_), '');
1560}
1561
1562sub dsa_verify {
1563    my %param = @_;
1564
1565    eval {
1566        require Crypt::DSA;
1567    };
1568    my $has_crypt_dsa = $@ ? 0 : 1;
1569    $has_crypt_dsa = 0 if $param{ForcePerl};
1570    if ($has_crypt_dsa) {
1571        $param{Key} = bless $param{Key}, 'Crypt::DSA::Key';
1572        $param{Signature} = bless $param{Signature}, 'Crypt::DSA::Signature';
1573        Crypt::DSA->new->verify(%param);
1574    } else {
1575        require Math::BigInt;
1576
1577        my($key, $dgst, $sig);
1578
1579        Carp::croak __PACKAGE__ . "dsa_verify: Need a Key" 
1580            unless $key = $param{Key};
1581
1582        unless ($dgst = $param{Digest}) {
1583            Carp::croak "dsa_verify: Need either Message or Digest"
1584                unless $param{Message};
1585            $dgst = perl_sha1_digest($param{Message});
1586        }
1587    Carp::croak "dsa_verify: Need a Signature"
1588        unless $sig = $param{Signature};
1589    my $r = new Math::BigInt($sig->{r});
1590    my $s = new Math::BigInt($sig->{'s'});
1591    my $p = new Math::BigInt($key->{p});
1592    my $q = new Math::BigInt($key->{'q'});
1593    my $g = new Math::BigInt($key->{g});
1594    my $pub_key = new Math::BigInt($key->{pub_key});
1595    my $u2 = $s->bmodinv($q);
1596
1597    my $u1 = new Math::BigInt("0x" . unpack("H*", $dgst));
1598
1599    $u1 = $u1->bmul($u2)->bmod($q);
1600    $u2 = $r->bmul($u2)->bmod($q);
1601    my $t1 = $g->bmodpow($u1, $p);
1602    my $t2 = $pub_key->bmodpow($u2, $p);
1603    $u1 = $t1->bmul($t2)->bmod($key->{p});
1604    $u1 = $u1->bmod($key->{'q'});
1605    my $result = $u1->bcmp($sig->{r});
1606    return defined($result) ? $result == 0 : 0;
1607    }
1608}
1609
1610# TBD: fill in the contracts of these.
1611sub sanitize_input {
1612    my $str = shift;
1613
1614    # Convert decimal entities (&#112; => p)
1615    $str =~ s/&#(\d{1,3});/chr($1)/eg;
1616
1617    # Convert hex entities (&#x70; => p)
1618    $str =~ s/&#x(\d{2});/chr(hex($1))/eg;
1619
1620    # Convert URL encodings (%70 => p)
1621    $str =~ s/\%([0-9A-Z]{2})/chr(hex($1))/eig;
1622
1623# Remove any HTML comments in the form of <! ... >
1624    $str =~ s/\x3c\!.+?\x3e//g;
1625
1626# Remove any #'s since we will be using it as a delimiter
1627# This is safe since it isn't something that would
1628# be included in a blacklist.
1629    $str =~ tr/#//d;
1630
1631    return $str;
1632}
1633
1634sub extract_domain {
1635    my $str = shift;
1636    $str =~ s#^(.*?)/.*$#$1#;
1637    lc($str);
1638}
1639
1640sub extract_urls {
1641    my @strings = @_;
1642    my (%domain,@urls);
1643    foreach (@strings) {
1644        next unless ($_ and $_ ne '');
1645        local $_ = sanitize_input($_);
1646        while (m#(?:https?:)?//(?:www.)?([^\s'"<>]+)#gi) {
1647            my $u = $1;
1648            $u =~ s#/$##;
1649            next if $domain{$u};
1650            $domain{$u} = extract_domain($u);
1651        }
1652    }
1653    return (%domain);
1654}
1655
1656sub extract_domains {
1657    my %u = extract_urls(@_); values %u;
1658}
1659
1660sub escape_unicode {
1661    my $text = shift;
1662    $text =~ s/((?:[\xc2-\xdf][\x80-\xbf])|
1663                (?:(?:(?:\xe0[\xa0-\xbf])|
1664                      (?:[\xe1-\xec][\x80-\xbf])|
1665                      (?:\xed[\x80-\x9f])|
1666                      (?:[\xee-\xef][\x80-\xbf]))[\x80-\xbf])|
1667                (?:(?:\xf0[\x90-\xbf])|
1668                   (?:[\xf1-\xf3][\x80-\xbf])|
1669                   (?:\xf4[\x80-\x8f])[\x80-\xbf]{2}))/
1670                '&#'.hex(unpack("H*", MT::I18N::encode_text($1, 'utf-8', 'ucs2'))).';'
1671            /egx;
1672    $text;
1673}
1674
1675sub unescape_unicode {
1676    my $text = shift;
1677    $text =~ s/\&\#(\d+);/pack("H*", sprintf("%X",$1))/egx;
1678    $text = MT::I18N::encode_text($text, 'ucs2', undef);
1679}
1680
1681{
1682    my $initialized_sax;
1683
1684    sub init_sax {
1685        require XML::SAX;
1686        if (@{XML::SAX->parsers} == 1) {
1687            map { eval { XML::SAX->add_parser($_) } }
1688                qw( XML::SAX::Expat XML::LibXML::SAX::Parser
1689                    XML::LibXML::SAX
1690                    XML::SAX::ExpatXS );
1691        }
1692        $initialized_sax = 1;
1693    }
1694
1695    sub sax_parser {
1696        init_sax() unless $initialized_sax;
1697        require XML::SAX::ParserFactory;
1698        my $f = XML::SAX::ParserFactory->new;
1699        $f->parser();
1700    }
1701}
1702
1703sub multi_iter {
1704    my ($iters, $picker) = @_;
1705    my @streams;
1706    foreach my $iter (@$iters) {
1707        my $head = $iter->();
1708        push @streams, { iter => $iter, head => $head };
1709    }
1710    sub {
1711        my ($f) = @_;
1712        if ($f && ($f eq 'finish')) {
1713            foreach my $iter (@streams) {
1714                $iter->{iter}->('finish');
1715            }
1716            return;
1717        }
1718        # find the head with greatest created_on
1719        my $which;
1720        foreach my $iter (@streams) {
1721            next unless defined($iter->{head});
1722            if (!$which) {
1723                $which = $iter;
1724                last unless $picker;
1725            } else {
1726                if (!$picker || ($picker && $picker->($iter->{head}, $which->{head}))) {
1727                    $which = $iter;
1728                }
1729            }
1730        }
1731        return unless $which;
1732
1733        # Advance the chosen one
1734        my $result = $which->{head};
1735        if (defined $result) {
1736            $which->{head} = $which->{iter}->();
1737        }
1738        $result;
1739    };
1740}
1741
1742sub trim {
1743    my $string = shift;
1744    $string = ltrim($string);
1745    $string = rtrim($string);
1746    $string;
1747}
1748
1749sub ltrim {
1750    my $string = shift;
1751    $string =~ s/^\s+//;
1752    $string;
1753}
1754
1755sub rtrim {
1756    my $string = shift;
1757    $string =~ s/\s+$//;
1758    $string;
1759}
1760
1761sub asset_cleanup {
1762    my ($str) = @_;
1763    $str =~ s/
1764        <(?:[Ff][Oo][Rr][Mm]|[Ss][Pp][Aa][Nn])
1765        ([^>]*?)
1766        \s
1767        mt:asset-id="\d+"
1768        ([^>]*?>)(.*?)
1769        <\/(?:[Ff][Oo][Rr][Mm]|[Ss][Pp][Aa][Nn])>
1770    /
1771    my $attr = $1 . $2;
1772    my $inner = $3;
1773    $attr =~ s!\s[Cc][Oo][Nn][Tt][Ee][Nn][Tt][Ee][Dd][Ii][Tt][Aa][Bb][Ll][Ee]=(['"][^'"]*?['"]|[Ff][Aa][Ll][Ss][Ee])!!;
1774    '<span' . $attr . $inner . '<\/span>'
1775    /gsex;
1776    return $str;
1777}
1778
1779sub caturl {
1780    return '' unless @_;
1781 
1782    my $url = shift;
1783    foreach (@_) {
1784        my $u = $_;
1785        next unless $u;
1786        $u =~ s!^/!!;
1787        $url .= '/' unless $url =~ m!/$!;
1788        $url .= $u;
1789    }
1790    return $url;
1791}
1792
1793sub get_newsbox_html {
1794    my ($newsbox_url, $kind, $cached_only) = @_;
1795
1796    return unless $newsbox_url;
1797    return unless is_url($newsbox_url);
1798    return unless $kind && (length($kind) == 2);
1799    $cached_only ||= 0;
1800
1801    my $NEWSCACHE_TIMEOUT = 60 * 60 * 24;
1802    my $sess_class        = MT->model('session');
1803    my ($news_object)     = ("");
1804    my $retries           = 0;
1805    $news_object = $sess_class->load( { id => $kind } );
1806    my $refresh_news;
1807    if ( $news_object
1808        && ( $news_object->start() < ( time - $NEWSCACHE_TIMEOUT ) ) )
1809    {
1810        $refresh_news = 1;
1811    }
1812    my $last_available_news = MT::I18N::encode_text( $news_object->data(), 'utf-8', undef )
1813      if $news_object;
1814    return $last_available_news unless $refresh_news || !$news_object;
1815    return q() if $cached_only;
1816
1817    # don't block the dashboard for more than 10 seconds to fetch
1818    # the news feed...
1819    my $ua = MT->new_ua( { timeout => 10 } );
1820    return $last_available_news unless $ua;
1821
1822    my $req = new HTTP::Request( GET => $newsbox_url );
1823    my $resp = $ua->request($req);
1824    my $result = $resp->content();
1825    if ( !$resp->is_success() || !$result ) {
1826        # failure; either timeout or worse
1827        # if news_object is available, bump up it's expiration
1828        # so we don't attempt to hit the server again
1829        # for an hour
1830        if (! $news_object ) {
1831            $news_object = MT::Session->new;
1832            $news_object->set_values(
1833                {
1834                    id    => $kind,
1835                    kind  => $kind,
1836                    data  => ''
1837                }
1838            );
1839            $last_available_news = '';
1840            $refresh_news = 1;
1841        }
1842        if (defined($last_available_news) && $refresh_news) {
1843            $news_object->start( ( time - $NEWSCACHE_TIMEOUT ) + 60 * 60 );
1844            $news_object->save;
1845        }
1846        return $last_available_news;
1847    }
1848    require MT::Sanitize;
1849
1850    # allowed html
1851    my $spec = 'a href,* style class id,ul,li,div,span,br';
1852    $result = MT::Sanitize->sanitize( $result, $spec );
1853    $news_object = MT::Session->new();
1854    $news_object->set_values(
1855        {
1856            id    => $kind,
1857            kind  => $kind,
1858            start => time(),
1859            data  => $result
1860        }
1861    );
1862    $news_object->save();
1863    $result = MT::I18N::encode_text( $result, 'utf-8', undef );
1864    return $result;
1865}
1866
1867## FIXME
1868# This method is to supplement CGI.pm's lack of read method.
1869# Some XML parsers (XML::SAX::ExpatXS and XML::LibXML to name a few)
1870# requires OO access to filehandles.
1871# Once CGI solved this issue, this method will be removed.
1872*Fh::read = sub {
1873    read($_[0], $_[1], $_[2], $_[3] || 0);
1874};
1875
18761;
1877
1878__END__
1879
1880=head1 NAME
1881
1882MT::Util - Movable Type utility functions
1883
1884=head1 SYNOPSIS
1885
1886    use MT::Util qw( functions );
1887
1888=head1 DESCRIPTION
1889
1890I<MT::Util> provides a variety of utility functions used by the Movable Type
1891libraries.
1892
1893=head1 USAGE
1894
1895=head2 start_end_day($ts)
1896
1897Given I<$ts>, a timestamp in form C<YYYYMMDDHHMMSS>, calculates the timestamp
1898corresponding to the start of the same day, and, if called in list context,
1899the end of the day. If called in scalar context, returns one timestamp
1900corresponding to the start of the day; if called in list context, returns two
1901timestamps, for the start and end of the day.
1902
1903For example, given C<20020410160406>, returns C<20020410000000> in scalar
1904context, and C<20020410000000> and C<20020410235959> in list context.
1905
1906=head2 start_end_week($ts)
1907
1908Given I<$ts>, a timestamp in form C<YYYYMMDDHHMMSS>, calculates the timestamp
1909corresponding to the start of the week, and, if called in list context, the
1910end of the week. If called in scalar context, returns one timestamp
1911corresponding to the start of the week; if called in list context, returns two
1912timestamps, for the start and end of the week.
1913
1914A week is defined as starting on Sunday.
1915
1916For example, given C<20020410160406>, returns C<20020407000000> in scalar
1917context, and C<20020407000000> and C<20020413235959> in list context.
1918
1919=head2 start_end_month($ts)
1920
1921Given I<$ts>, a timestamp in form C<YYYYMMDDHHMMSS>, calculates the timestamp
1922corresponding to the start of the month, and, if called in list context,
1923the end of the month. If called in scalar context, returns one timestamp
1924corresponding to the start of the month; if called in list context, returns two
1925timestamps, for the start and end of the month.
1926
1927For example, given C<20020410160406>, returns C<20020401000000> in scalar
1928context, and C<20020401000000> and C<20020430235959> in list context.
1929
1930=head2 offset_time_list($unix_ts, $blog [, $direction ])
1931
1932Given I<$unix_ts>, a timestamp in Unix epoch format (seconds since 1970),
1933applies the timezone offset specified in the blog I<$blog> (either an
1934I<MT::Blog> object or a numeric blog ID). If daylight saving time is in
1935effect in the local time zone (determined using the return value from
1936I<localtime()>), the offset is automatically adjusted.
1937
1938Returns the return value of I<gmtime()> given the adjusted Unix timestamp.
1939
1940=head2 format_ts($format, $ts, $blog)
1941
1942Given a timestamp I<$ts> in form C<YYYYMMDDHHMMSS>, applies the format
1943specified in I<$format> and returns the formatted string.
1944
1945If specified, I<$blog> should be an I<MT::Blog> object, from which the
1946date/time formatting language preference is taken (e.g. English, French, etc.).
1947If unspecified, English formatting is used.
1948
1949If I<$format> is C<undef>, and I<$blog> is specified, I<format_ts> will
1950use a language-specific default format; if a language-specific format is not
1951defined, or if I<$blog> is unspecified, the default format used is
1952C<%B %e, %Y %I:%M %p>.
1953
1954=head2 days_in($month, $year)
1955
1956Returns the number of days in the month I<$month> in the year I<$year>.
1957I<$month> should be numeric, starting at C<1> for C<January>. I<$year> should
1958be a 4-digit year. The number of days is automatically adjusted in a leap
1959year.
1960
1961=head2 wday_from_ts($year, $month, $day)
1962
1963Returns the numeric day of the week, in the range C<0>-C<6>, where C<0> is
1964C<Sunday>, for the date specified in I<$year>, I<$month>, and I<$day>.
1965I<$year> should be a 4-digit year; I<$month> a numeric value in the range
1966C<1>-C<12>; and I<$day> the numeric day of the month.
1967
1968=head2 first_n_words($str, $n)
1969
1970Given a string I<$str>, returns the first I<$n> words in the string, after
1971removing any HTML tags.
1972
1973=head2 dirify($str)
1974
1975Munges a string I<$str> so that it is suitable for use as a file/directory
1976name. HTML is removed; HTML-entities are removed; non-word/space characters
1977are removed; spaces are changed to underscores; the entire string is
1978converted to lower-case.
1979
1980For example, the string C<Foo E<lt>bE<gt>BarE<lt>/bE<gt> E<amp>quot;BazE<amp>quot;> would be transformed into C<foo_bar_baz>.
1981
1982=head2 encode_html($str)
1983
1984Encodes any special characters in I<$str> into HTML entities and returns the
1985transformed string.
1986
1987If I<HTML::Entities> is available, and if the configuration setting
1988I<NoHTMLEntities> is not set, uses I<HTML::Entities> for entity-encoding.
1989Otherwise, very simple encoding is done to catch the most common characters
1990that need encoding.
1991
1992=head2 decode_html($str)
1993
1994Decodes any HTML entities in I<$str> into the corresponding characters and
1995returns the transformed string.
1996
1997If I<HTML::Entities> is available, and if the configuration setting
1998I<NoHTMLEntities> is not set, uses I<HTML::Entities> for entity-decoding.
1999Otherwise, very simple decoding is done to catch the most common entities
2000that need decoding.
2001
2002=head2 remove_html($str)
2003
2004Removes any HTML tags from I<$str> and returns the result.
2005
2006=head2 encode_js($str)
2007
2008Escapes/encodes any special characters in I<$str> so that the string can be
2009used safely as the value in Javascript; returns the transformed string.
2010
2011=head2 encode_php($str [, $type ])
2012
2013Escapes/encodes any special characters in I<$str> so that the string can be
2014used safely as the value in PHP code; returns the transformed string.
2015
2016I<$type> can be either C<qq> (double-quote interpolation), C<here> (heredoc
2017interpolation), or C<q> (single-quote interpolation). C<q> is the default.
2018
2019=head2 spam_protect($email_address)
2020
2021Given an email address I<$email_address>, encodes any characters that will
2022identify it as an email address (C<:>, C<@>, and C<.>) into HTML entities,
2023so that spam harvesters will not see the email address as easily. Returns
2024the transformed address.
2025
2026=head2 is_valid_email($email_address)
2027
2028Checks the email address I<$email_address> for syntax validity; if the
2029address--or part of it--is valid, I<is_valid_email> returns the valid (part
2030of) the email address. Otherwise, it returns C<0>.
2031
2032=head2 perl_sha1_digest($msg)
2033
2034Returns a SHA1 digest of $msg. The result is the usual packed binary
2035representation. Use perl_sha1_digest_hex to get a printable string.
2036
2037=head2 perl_sha1_digest_hex($msg)
2038
2039Returns a SHA1 digest of $msg. The result is an ASCII string of hex
2040digits. Use perl_sha1_digest to get a binary representation.
2041
2042=head2 dsa_verify(Key => $key, Signature => $sig,
2043    [ Message => $msg | $Digest => $dgst ])
2044
2045Verifies that sig is a DSA signature of $msg (or $dgst) produced using
2046the private half of the public key given in $key. Requires
2047Math::BigInt but doesn't call for any non-perl libraries.
2048
2049=head2 get_newsbox_html($newsbox_url, $kind)
2050
2051Retrieves newsbox content from the specified URL.  Content retrieved is
2052cached in MT::Session for 24 hours under the key specified in I<$kind>.
2053Content will be sanitized based on pre-defined rules.
2054
2055=head1 AUTHOR & COPYRIGHTS
2056
2057Please see the I<MT> manpage for author, copyright, and license information.
2058
2059=cut
Note: See TracBrowser for help on using the browser.