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

Revision 1425, 70.1 kB (checked in by mpaschal, 21 months ago)

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