root/branches/release-33/lib/MT/Util.pm @ 1744

Revision 1744, 70.5 kB (checked in by fumiakiy, 20 months ago)

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