root/branches/release-29/lib/MT/Util.pm @ 1333

Revision 1333, 69.9 kB (checked in by takayama, 22 months ago)

Fixed BugId:65812
* Changed scheme_version to 4.0037
* Added basename column to MT_Author

  • Assigning basename when author saved

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