root/branches/release-27/lib/MT/Util.pm @ 1233

Revision 1233, 69.3 kB (checked in by fumiakiy, 23 months ago)

Fixed regex to successfully replace form to span of assets in entry text and more. BugId:65452
  • 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 archive_file_for {
913    MT->instance->publisher->archive_file_for(@_);
914}
915
916sub strip_index {
917    my ($link, $blog) = @_;
918    my $index = MT->instance->config('IndexBasename');
919    my $ext = $blog->file_extension || '';
920    $ext = '.' . $ext if $ext ne '';
921    $index .= $ext;
922    if ($link =~ /^(.*?)\/\Q$index\E(#.*)?$/) {
923        $link = $1 . '/' . ($2 || '');
924    }
925    $link;
926}
927
928sub get_entry {
929    MT->instance->publisher->get_entry(@_);
930}
931
932sub is_valid_date {
933    my ($ts) = @_;
934    unless ($ts =~
935        m!(\d{4})-?(\d{2})-?(\d{2})\s*(\d{2}):?(\d{2})(?::?(\d{2}))?!) {
936        return 0;
937    }
938    my $s = $6 || 0;
939    return 0
940        if ($s > 59 || $s < 0  || $5 > 59 || $5 < 0 || $4 > 23 || $4 < 0
941            || $2 > 12 || $2 < 1 || $3 < 1
942            || (days_in($2, $1) < $3 && !leap_day($0, $1, $2)));
943    1;
944}
945
946sub is_valid_email {
947    my($addr) = @_;
948    return 0 if $addr =~ /[\n\r]/;
949    my $specials = '\(\)<>\@,;:\[\]';
950    if ($addr =~ /^\s*([^\" \t\n\r$specials]+@[^ \t\n\r$specials]+\.[^ \t\n\r$specials][^ \t\n\r$specials]+)\s*$/)
951    {
952        return $1;
953    } else {
954        return 0;
955    }   
956}
957
958sub is_valid_url {
959    my($url, $stringent) = @_;
960
961    $url ||= "";
962
963    # strip spaces
964    $url =~ s/^\s*//;
965    $url =~ s/\s*$//;
966
967    return '' if ($url =~ /[ \"]/);
968
969    # help fat-finger typists.
970    $url =~ s,http;//,http://,;
971    $url =~ s,http//,http://,;
972
973    $url = "http://$url" unless ($url =~ m,https?://,);
974
975    my ($scheme, $host, $path, $query, $fragment) =
976        $url =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
977    if ($scheme && $host) {
978        # Note: no stringent checks; localhost is a legit hostname, for example.
979        return $url;
980    } else {
981        return '';
982    }
983}
984
985sub is_url {
986    my($url) = @_;
987
988    return $url =~ /s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+/;
989}
990
991sub discover_tb {
992    my($url, $find_all, $contents) = @_;
993    my $c = '';
994    if ($contents) {
995        $c = $$contents;
996    } else {
997        my $ua = MT->new_ua;
998        ## Wrap this in an eval in case some versions don't support it.
999        my $req = HTTP::Request->new(GET => $url);
1000        eval {
1001            $ua->timeout(30);     # limit timeout to 30 seconds
1002            $ua->parse_head(0);
1003        };
1004        # prevent downloads of non-text content
1005        my $res = $ua->request($req, sub {
1006            my ($data, $res, $po) = @_;
1007            die unless $c ne '' or $res->header('Content-Type') =~ m!^text/!;
1008            $c .= $data;
1009        }, 16384);
1010        return unless $res->is_success;
1011    }
1012    (my $url_no_anchor = $url) =~ s/#.*$//;
1013    (my $url_no_host = $url_no_anchor) =~ s!^https?://.*/!!i;
1014    my(@items);
1015    while ($c =~ m!(<rdf:RDF.*?</rdf:RDF>)!sg) {
1016        my $rdf = $1;
1017        my($perm_url) = $rdf =~ m!dc:identifier="([^"]+)"!;   #"
1018        $perm_url ||= "";
1019        (my $perm_url_no_host = $perm_url) =~ s!https?://.*/!!i;
1020        $perm_url_no_host =~ s/#.*$//;
1021        next unless $find_all ||
1022            $perm_url eq $url ||
1023            $perm_url eq $url_no_anchor ||
1024            $perm_url_no_host eq $url_no_host;
1025        (my $inner = $rdf) =~ s!^.*?<rdf:Description!!s;
1026        my $item = { permalink => $perm_url };
1027        while ($inner =~ /([\w:]+)="([^"]*)"/gs) {            #"
1028            $item->{$1} = $2;
1029        }
1030        $item->{ping_url} = $item->{'trackback:ping'};
1031        next unless $item->{ping_url};
1032        $item->{title} = decode_xml($item->{'dc:title'});
1033        if (!$item->{title} && $rdf =~ m!dc:description="([^"]+)"!) { #"
1034            $item->{title} = MT::I18N::first_n_text($1, MT::I18N::const('LENGTH_ENTRY_TITLE_FROM_TEXT')) . '...';
1035        }
1036        push @items, $item;
1037        last unless $find_all;
1038    }
1039    return unless @items;
1040    $find_all ? \@items : $items[0];
1041}
1042
1043{
1044    my %Data = (
1045        'by' => {
1046              name => 'Attribution',
1047              requires => [ qw( Attribution Notice ) ],
1048              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1049         },
1050        'by-nd' => {
1051              name => 'Attribution-NoDerivs',
1052              requires => [ qw( Attribution Notice ) ],
1053              permits => [ qw( Reproduction Distribution ) ],
1054         },
1055        'by-nd-nc' => {
1056              name => 'Attribution-NoDerivs-NonCommercial',
1057              requires => [ qw( Attribution Notice ) ],
1058              permits => [ qw( Reproduction Distribution ) ],
1059              prohibits => [ qw( CommercialUse) ],
1060         },
1061        'by-nc' => {
1062              name => 'Attribution-NonCommercial',
1063              requires => [ qw( Attribution Notice ) ],
1064              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1065              prohibits => [ qw( CommercialUse ) ],
1066         },
1067        'by-nc-sa' => {
1068              name => 'Attribution-NonCommercial-ShareAlike',
1069              requires => [ qw( Attribution Notice ShareAlike ) ],
1070              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1071              prohibits => [ qw( CommercialUse ) ],
1072         },
1073        'by-sa' => {
1074              name => 'Attribution-ShareAlike',
1075              requires => [ qw( Attribution Notice ShareAlike ) ],
1076              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1077         },
1078        'nd' => {
1079              name => 'NonDerivative',
1080              requires => [ qw( Notice ) ],
1081              permits => [ qw( Reproduction Distribution ) ],
1082         },
1083        'nd-nc' => {
1084              name => 'NonDerivative-NonCommercial',
1085              requires => [ qw( Notice ) ],
1086              permits => [ qw( Reproduction Distribution ) ],
1087              prohibits => [ qw( CommercialUse ) ],
1088         },
1089        'nc' => {
1090              name => 'NonCommercial',
1091              requires => [ qw( Notice ) ],
1092              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1093              prohibits => [ qw( CommercialUse ) ],
1094         },
1095        'nc-sa' => {
1096              name => 'NonCommercial-ShareAlike',
1097              requires => [ qw( Notice ShareAlike ) ],
1098              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1099              prohibits => [ qw( CommercialUse ) ],
1100         },
1101        'sa' => {
1102              name => 'ShareAlike',
1103              requires => [ qw( Notice ShareAlike ) ],
1104              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1105         },
1106        'pd' => {
1107              name => 'PublicDomain',
1108              permits => [ qw( Reproduction Distribution DerivativeWorks ) ],
1109         },
1110    );
1111    sub cc_url {
1112        my($code) = @_;
1113        my $url;
1114        my ($real_code, $license_url, $image_url);
1115        if (($real_code, $license_url, $image_url)
1116            = $code =~ /(\S+) (\S+) (\S+)/) {
1117            return $license_url;
1118        }
1119        $code eq 'pd' ?
1120            "http://web.resource.org/cc/PublicDomain" :
1121            "http://creativecommons.org/licenses/$code/1.0/";
1122    }
1123    sub cc_rdf {
1124        my($code) = @_;
1125        my $url = cc_url($code);
1126        my $rdf = <<RDF;
1127<License rdf:about="$url">
1128RDF
1129        for my $type (qw( requires permits prohibits )) {
1130            for my $item (@{ $Data{$code}{$type} }) {
1131                $rdf .= <<RDF;
1132<$type rdf:resource="http://web.resource.org/cc/$item" />
1133RDF
1134            }
1135        }
1136        $rdf . "</License>\n";
1137    }
1138    sub cc_name {
1139        my ($code) = ($_[0] =~ /(\S+) \S+ \S+/);
1140        $code ||= $_[0];
1141        $Data{$code}{name};
1142    }
1143    sub cc_image {
1144        my($code) = @_;
1145        my $url;
1146        my ($real_code, $license_url, $image_url);
1147        if (($real_code, $license_url, $image_url)
1148            = $code =~ /(\S+) (\S+) (\S+)/) {
1149            return $image_url;
1150        }
1151        "http://creativecommons.org/images/public/" .
1152            ($code eq 'pd' ? 'norights' : 'somerights');
1153    }
1154}
1155
1156sub mark_odd_rows {
1157    my($list) = @_;
1158    my $i = 1;
1159    for my $row (@$list) {
1160        $row->{is_odd} = $i++ % 2 == 1;
1161    }
1162}
1163
1164%Languages = (
1165    'en' => [
1166            [ qw( Sunday Monday Tuesday Wednesday Thursday Friday Saturday ) ],
1167            [ qw( January February March April May June
1168                  July August September October November December ) ],
1169            [ qw( AM PM ) ],
1170          ],
1171
1172    'fr' => [
1173            [ qw( dimanche lundi mardi mercredi jeudi vendredi samedi ) ],
1174            [ ('janvier', "f&#xe9;vrier", 'mars', 'avril', 'mai', 'juin',
1175               'juillet', "ao&#xfb;t", 'septembre', 'octobre', 'novembre',
1176               "d&#xe9;cembre") ],
1177            [ qw( AM PM ) ],
1178              "%e %B %Y %kh%M",
1179              "%e %B %Y",
1180              "%kh%M",
1181          ],
1182
1183    'es' => [
1184            [ ('Domingo', 'Lunes', 'Martes', "Mi&#xe9;rcoles", 'Jueves',
1185               'Viernes', "S&#xe1;bado") ],
1186            [ qw( Enero Febrero Marzo Abril Mayo Junio Julio Agosto
1187                  Septiembre Octubre Noviembre Diciembre ) ],
1188            [ qw( AM PM ) ],
1189              "%e de %B %Y a las %I:%M %p",
1190              "%e de %B %Y",
1191          ],
1192
1193    'pt' => [
1194            [ ('domingo', 'segunda-feira', "ter&#xe7;a-feira", 'quarta-feira',
1195               'quinta-feira', 'sexta-feira', "s&#xe1;bado") ],
1196            [ ('janeiro', 'fevereiro', "mar&#xe7;o", 'abril', 'maio', 'junho',
1197               'julho', 'agosto', 'setembro', 'outubro', 'novembro',
1198               'dezembro' ) ],
1199            [ qw( AM PM ) ],
1200          ],
1201
1202    'nl' => [
1203            [ qw( zondag maandag dinsdag woensdag donderdag vrijdag
1204                  zaterdag ) ],
1205            [ qw( januari februari maart april mei juni juli augustus
1206                  september oktober november december ) ],
1207            [ qw( am pm ) ],
1208              "%e %B %Y %k:%M",
1209              "%e %B %Y",
1210              "%k:%M",
1211          ],
1212
1213    'dk' => [
1214            [ ("s&#xf8;ndag", 'mandag', 'tirsdag', 'onsdag', 'torsdag',
1215               'fredag', "l&#xf8;rdag") ],
1216            [ qw( januar februar marts april maj juni juli august
1217                  september oktober november december ) ],
1218            [ qw( am pm ) ],
1219            "%d.%m.%Y %H:%M",
1220            "%d.%m.%Y",
1221            "%H:%M",
1222          ],
1223
1224    'se' => [
1225            [ ("s&#xf6;ndag", "m&#xe5;ndag", 'tisdag', 'onsdag', 'torsdag',
1226               'fredag', "l&#xf6;rdag") ],
1227            [ qw( januari februari mars april maj juni juli augusti
1228                  september oktober november december ) ],
1229            [ qw( FM EM ) ],
1230          ],
1231
1232    'no' => [
1233            [ ("S&#xf8;ndag", "Mandag", 'Tirsdag', 'Onsdag', 'Torsdag',
1234               'Fredag', "L&#xf8;rdag") ],
1235            [ qw( Januar Februar Mars April Mai Juni Juli August
1236                  September Oktober November Desember ) ],
1237            [ qw( FM EM ) ],
1238          ],
1239
1240    'de' => [
1241            [ qw( Sonntag Montag Dienstag Mittwoch Donnerstag Freitag
1242                  Samstag ) ],
1243            [ ('Januar', 'Februar', "M&#xe4;rz", 'April', 'Mai', 'Juni',
1244               'Juli', 'August', 'September', 'Oktober', 'November',
1245               'Dezember') ],
1246            [ qw( FM EM ) ],
1247            "%e.%m.%y %k:%M",
1248            "%e.%m.%y",
1249            "%k:%M",
1250          ],
1251
1252    'it' => [
1253            [ ('Domenica', "Luned&#xec;", "Marted&#xec;", "Mercoled&#xec;",
1254               "Gioved&#xec;", "Venerd&#xec;", 'Sabato') ],
1255            [ qw( Gennaio Febbraio Marzo Aprile Maggio Giugno Luglio
1256                  Agosto Settembre Ottobre Novembre Dicembre ) ],
1257            [ qw( AM PM ) ],
1258            "%d.%m.%y %H:%M",
1259            "%d.%m.%y",
1260            "%H:%M",
1261          ],
1262
1263    'pl' => [
1264            [ ('niedziela', "poniedzia&#322;ek", 'wtorek', "&#347;roda",
1265               'czwartek', "pi&#261;tek", 'sobota') ],
1266            [ ('stycznia', 'lutego', 'marca', 'kwietnia', 'maja', 'czerwca',
1267               'lipca', 'sierpnia', "wrze&#347;nia", "pa&#378;dziernika",
1268               'listopada', 'grudnia') ],
1269            [ qw( AM PM ) ],
1270            "%e %B %Y %k:%M",
1271            "%e %B %Y",
1272            "%k:%M",
1273          ],
1274
1275    'fi' => [
1276            [ qw( sunnuntai maanantai tiistai keskiviikko torstai perjantai
1277                  lauantai ) ],
1278            [ ('tammikuu', 'helmikuu', 'maaliskuu', 'huhtikuu', 'toukokuu',
1279               "kes&#xe4;kuu", "hein&#xe4;kuu", 'elokuu', 'syyskuu', 'lokakuu',
1280               'marraskuu', 'joulukuu') ],
1281            [ qw( AM PM ) ],
1282            "%d.%m.%y %H:%M",
1283          ],
1284
1285    'is' => [
1286            [ ('Sunnudagur', "M&#xe1;nudagur", "&#xde;ri&#xf0;judagur",
1287               "Mi&#xf0;vikudagur", 'Fimmtudagur', "F&#xf6;studagur",
1288               'Laugardagur') ],
1289            [ ("jan&#xfa;ar", "febr&#xfa;ar", 'mars', "apr&#xed;l", "ma&#xed;",
1290               "j&#xfa;n&#xed;", "j&#xfa;l&#xed;", "&#xe1;g&#xfa;st", 'september',
1291               "okt&#xf3;ber", "n&#xf3;vember", 'desember') ],
1292            [ qw( FH EH ) ],
1293            "%d.%m.%y %H:%M",
1294          ],
1295
1296    'si' => [
1297            [ ('nedelja', 'ponedeljek', 'torek', 'sreda', "&#xe3;etrtek",
1298               'petek', 'sobota',) ],
1299            [ qw( januar februar marec april maj junij julij avgust
1300                  september oktober november december ) ],
1301            [ qw( AM PM ) ],
1302            "%d.%m.%y %H:%M",
1303          ],
1304
1305    'cz' => [
1306            [ ('Ned&#283;le', 'Pond&#283;l&#237;', '&#218;ter&#253;',
1307               'St&#345;eda', '&#268;tvrtek', 'P&#225;tek', 'Sobota') ],
1308            [ ('Leden', '&#218;nor', 'B&#345;ezen', 'Duben', 'Kv&#283;ten',
1309               '&#268;erven', '&#268;ervenec', 'Srpen', 'Z&#225;&#345;&#237;',
1310               '&#216;&#237;jen', 'Listopad', 'Prosinec') ],
1311            [ qw( AM PM ) ],
1312            "%e. %B %Y %k:%M",
1313            "%e. %B %Y",
1314            "%k:%M",
1315          ],
1316
1317    'sk' => [
1318            [ ('nede&#318;a', 'pondelok', 'utorok', 'streda',
1319               '&#353;tvrtok', 'piatok', 'sobota') ],
1320            [ ('janu&#225;r', 'febru&#225;r', 'marec', 'apr&#237;l',
1321               'm&#225;j', 'j&#250;n', 'j&#250;l', 'august', 'september',
1322               'okt&#243;ber', 'november', 'december') ],
1323            [ qw( AM PM ) ],
1324            "%e. %B %Y %k:%M",
1325            "%e. %B %Y",
1326            "%k:%M",
1327          ],
1328
1329    'jp' => [
1330            [ '&#26085;&#26332;&#26085;', '&#26376;&#26332;&#26085;',
1331              '&#28779;&#26332;&#26085;', '&#27700;&#26332;&#26085;',
1332              '&#26408;&#26332;&#26085;', '&#37329;&#26332;&#26085;',
1333              '&#22303;&#26332;&#26085;'],
1334            [ qw( 1 2 3 4 5 6 7 8 9 10 11 12 ) ],
1335            [ qw( AM PM ) ],
1336            "%Y&#24180;%b&#26376;%e&#26085; %H:%M",
1337            "%Y&#24180;%b&#26376;%e&#26085;",
1338            "%H:%M",
1339            "%Y&#24180;%b&#26376;",
1340            "%b&#26376;%e&#26085;",
1341          ],
1342
1343    'et' => [
1344            [ qw( p&uuml;hap&auml;ev esmasp&auml;ev teisip&auml;ev
1345                  kolmap&auml;ev neljap&auml;ev reede laup&auml;ev ) ],
1346            [ ('jaanuar', 'veebruar', 'm&auml;rts', 'aprill', 'mai',
1347               'juuni', 'juuli', 'august', 'september', 'oktoober',
1348              'november', 'detsember') ],
1349            [ qw( AM PM ) ],
1350            "%m.%d.%y %H:%M",
1351            "%e. %B %Y",
1352            "%H:%M",
1353          ],
1354);
1355
1356$Languages{en_US} = $Languages{en_us} = $Languages{"en-us"} = $Languages{en};
1357$Languages{ja} = $Languages{jp};
1358
1359sub launch_background_tasks {
1360    return !($ENV{MOD_PERL} || $ENV{FAST_CGI}
1361        || !MT->config->LaunchBackgroundTasks);
1362}
1363
1364sub start_background_task {
1365    my ($func) = @_;
1366    if (!launch_background_tasks()) { $func->(); }
1367    else {
1368        $| = 1;            # Flush open filehandles
1369        my $pid = fork();
1370        if (!$pid) {
1371            # child
1372            close STDIN; open STDIN, "</dev/null";
1373            close STDOUT; open STDOUT, ">/dev/null"; 
1374            close STDERR; open STDERR, ">/dev/null"; 
1375
1376            MT::ObjectDriverFactory->init();
1377            MT::ObjectDriverFactory->configure();
1378            $func->();
1379            CORE::exit(0) if defined($pid) && !$pid;
1380        } else {
1381            MT::ObjectDriverFactory->init();
1382            MT::ObjectDriverFactory->configure();
1383            return 1;
1384        }
1385    }
1386}
1387
1388{
1389    eval { require bytes; 1; };
1390
1391    sub addbin {
1392        #local $ENV{LANG} = undef;
1393        my ($a, $b) = @_;
1394        my $length = (length $a > length $b ? length $a : length $b);
1395
1396        $a = "\0" x ($length - (length $a)) . $a;
1397        $b = "\0" x ($length - (length $b)) . $b;
1398        my $carry = 0;
1399        my $result = '';
1400        for (my $i=1; $i <= $length; $i++) {
1401            my $adigit = ord(substr($a, -$i, 1));
1402            my $bdigit = ord(substr($b, -$i, 1));
1403            my $rdigit = $adigit + $bdigit + $carry;
1404            $carry = $rdigit / 256;
1405            $result = chr($rdigit % 256) . $result;
1406       }
1407       if ($carry) {
1408           return $result = chr($carry) . $result;
1409       } else {
1410           return $result;
1411       }
1412    }
1413
1414    sub multbindec {
1415        my ($a, $b) = @_;
1416        # $b is decimal-ascii, $b < 256
1417        my @result;
1418        $result[(length $a)] = 0;
1419        for (my $i=1; $i <= length $a; $i++) {
1420            my $adigit = substr($a, -$i, 1);
1421            $result[-$i] = ord($adigit) * $b;
1422        }
1423
1424        for (my $i=2; $i <= scalar @result; $i++) {
1425            $result[-$i] += int($result[-$i+1] / 256);
1426            $result[-$i+1] = $result[-$i+1] % 256;
1427        }
1428
1429        shift @result while (@result && ($result[0] == 0));
1430
1431        pack('C*', @result);
1432    }
1433
1434    sub divbindec {
1435        # local $ENV{LANG} = undef;
1436        my ($a, $b) = @_;
1437        # $b is decimal-ascii, $b < 256
1438
1439        my $acc = ord(substr($a, 0, 1));
1440        my $quot;
1441        while (length $a) {
1442            $a = substr($a, 1);
1443            $quot .= chr($acc / $b);
1444            $acc = $acc % $b;
1445            if (length $a) {
1446                $acc = $acc * 256 + ord(substr($a, 0, 1));
1447            }
1448        }
1449        return ($quot, $acc);
1450    }
1451
1452    sub dec2bin {
1453        my ($decimal) = @_;
1454        my @digits = split //, $decimal;
1455        my $result = "";
1456        foreach my $d (@digits) {
1457            $result = multbindec($result, 10);
1458            $result = addbin(pack('c', $d), $result);
1459        }
1460        while (substr($result, 0, 1) eq "\0") {
1461            $result = substr($result, 1);
1462        }
1463        $result;
1464    }
1465
1466    sub bin2dec {
1467        my $bin = $_[0];
1468        my $result = '';
1469        my $rem = 0;
1470        while ((length $bin) && ($bin ne "\0")) {
1471            ($bin, $rem) = divbindec($bin, 10);
1472            $result = $rem . $result;
1473            $bin = substr($bin, 1) if (substr($bin, 0, 1) eq "\0");
1474        }
1475        $result;
1476    }
1477
1478
1479    sub perl_sha1_digest {   # thanks to Adam Back for the starting point of this
1480        my ($message) = @_;
1481        my $init_string = 'D9T4C`>_-JXF8NMS^$#)4=L/2X?!:@GF9;MGKH8\;O-S*8L\'6';
1482        # 67452301 efcdab89 98badcfe 10325476 c3d2e1f0
1483        my @A = unpack"N*", unpack 'u', $init_string;
1484        my @K = splice @A, 5, 4;
1485        sub M{my ($x, $m); ($x=pop)-($m=1+~0)*int$x/$m};   # modulo 0x100000000
1486        sub L{my ($n, $x); $n=pop;(($x=pop)<<$n|2**$n-1&$x>>32-$n) & (0xffffffff)} # left-rotate bit vector
1487        # magic SHA1 functions
1488        my @F = (sub { my ($a, $b, $c, $d) = @_; $b&($c^$d)^$d },
1489                 sub { my ($a, $b, $c, $d) = @_; $b^$c ^$d},
1490                 sub { my ($a, $b, $c, $d) = @_; ($b|$c)&$d|$b&$c},
1491                 sub { my ($a, $b, $c, $d) = @_; $b^$c ^$d});
1492        my $F = sub {
1493            my $which = shift;
1494            my ($a, $b, $c, $d) = @_; 
1495            if ($which == 0)
1496                { $b&($c^$d)^$d }
1497            elsif ($which == 1)
1498                { $b^$c ^$d }
1499            elsif ($which == 2)
1500                { ($b|$c)&$d|$b&$c }
1501            elsif ($which == 3) 
1502                { $b^$c ^$d }
1503        };
1504
1505        my ($l, $r, $p, $t, $S, @W, $P);
1506        do {
1507            $P = substr($message, 0, 64);
1508            $message = length$message >= 64 ? substr($message, 64) : "";
1509            $l += $r = length $P;
1510            $r++, $P .= "\x80" if $r < 64 && !$p++;
1511            @W = unpack 'N16', $P."\0"x(64-length($P));
1512            $W[15] = $l*8 if $r < 57;
1513            for (16..79) {
1514                push @W, L($W[$_-3]^$W[$_-8]^$W[$_-14]^$W[$_-16], 1);
1515            }
1516            my ($a,$b,$c,$d,$e)=@A;
1517            for(0..79) {
1518                $t = M(($F->(int($_/ 20), $a, $b, $c, $d))+$e+$W[$_]+$K[$_/20]+L$a,5);
1519                $e = $d;
1520                $d = $c;
1521                $c = L($b, 30);
1522                $b = $a;
1523                $a = $t;
1524            }
1525            $A[0] = M($A[0] + $a);
1526            $A[1] = M($A[1] + $b);
1527            $A[2] = M($A[2] + $c);
1528            $A[3] = M($A[3] + $d);
1529            $A[4] = M($A[4] + $e);
1530        } while $r > 56;
1531
1532        pack('N*', @A[0..4]);
1533    }
1534}
1535
1536sub perl_sha1_digest_hex {
1537    sprintf("%.8x"x5, unpack('N*', &perl_sha1_digest(@_)));
1538}
1539
1540sub perl_sha1_digest_base64 {
1541    require MIME::Base64;
1542    MIME::Base64::encode_base64(perl_sha1_digest(@_), '');
1543}
1544
1545sub dsa_verify {
1546    my %param = @_;
1547
1548    eval {
1549        require Crypt::DSA;
1550    };
1551    my $has_crypt_dsa = $@ ? 0 : 1;
1552    $has_crypt_dsa = 0 if $param{ForcePerl};
1553    if ($has_crypt_dsa) {
1554        $param{Key} = bless $param{Key}, 'Crypt::DSA::Key';
1555        $param{Signature} = bless $param{Signature}, 'Crypt::DSA::Signature';
1556        Crypt::DSA->new->verify(%param);
1557    } else {
1558        require Math::BigInt;
1559
1560        my($key, $dgst, $sig);
1561
1562        Carp::croak __PACKAGE__ . "dsa_verify: Need a Key" 
1563            unless $key = $param{Key};
1564
1565        unless ($dgst = $param{Digest}) {
1566            Carp::croak "dsa_verify: Need either Message or Digest"
1567                unless $param{Message};
1568            $dgst = perl_sha1_digest($param{Message});
1569        }
1570    Carp::croak "dsa_verify: Need a Signature"
1571        unless $sig = $param{Signature};
1572    my $r = new Math::BigInt($sig->{r});
1573    my $s = new Math::BigInt($sig->{'s'});
1574    my $p = new Math::BigInt($key->{p});
1575    my $q = new Math::BigInt($key->{'q'});
1576    my $g = new Math::BigInt($key->{g});
1577    my $pub_key = new Math::BigInt($key->{pub_key});
1578    my $u2 = $s->bmodinv($q);
1579
1580    my $u1 = new Math::BigInt("0x" . unpack("H*", $dgst));
1581
1582    $u1 = $u1->bmul($u2)->bmod($q);
1583    $u2 = $r->bmul($u2)->bmod($q);
1584    my $t1 = $g->bmodpow($u1, $p);
1585    my $t2 = $pub_key->bmodpow($u2, $p);
1586    $u1 = $t1->bmul($t2)->bmod($key->{p});
1587    $u1 = $u1->bmod($key->{'q'});
1588    my $result = $u1->bcmp($sig->{r});
1589    return defined($result) ? $result == 0 : 0;
1590    }
1591}
1592
1593# TBD: fill in the contracts of these.
1594sub sanitize_input {
1595    my $str = shift;
1596
1597    # Convert decimal entities (&#112; => p)
1598    $str =~ s/&#(\d{1,3});/chr($1)/eg;
1599
1600    # Convert hex entities (&#x70; => p)
1601    $str =~ s/&#x(\d{2});/chr(hex($1))/eg;
1602
1603    # Convert URL encodings (%70 => p)
1604    $str =~ s/\%([0-9A-Z]{2})/chr(hex($1))/eig;
1605
1606# Remove any HTML comments in the form of <! ... >
1607    $str =~ s/\x3c\!.+?\x3e//g;
1608
1609# Remove any #'s since we will be using it as a delimiter
1610# This is safe since it isn't something that would
1611# be included in a blacklist.
1612    $str =~ tr/#//d;
1613
1614    return $str;
1615}
1616
1617sub extract_domain {
1618    my $str = shift;
1619    $str =~ s#^(.*?)/.*$#$1#;
1620    lc($str);
1621}
1622
1623sub extract_urls {
1624    my @strings = @_;
1625    my (%domain,@urls);
1626    foreach (@strings) {
1627        next unless ($_ and $_ ne '');
1628        local $_ = sanitize_input($_);
1629        while (m#(?:https?:)?//(?:www.)?([^\s'"<>]+)#gi) {
1630            my $u = $1;
1631            $u =~ s#/$##;
1632            next if $domain{$u};
1633            $domain{$u} = extract_domain($u);
1634        }
1635    }
1636    return (%domain);
1637}
1638
1639sub extract_domains {
1640    my %u = extract_urls(@_); values %u;
1641}
1642
1643sub escape_unicode {
1644    my $text = shift;
1645    $text =~ s/((?:[\xc2-\xdf][\x80-\xbf])|
1646                (?:(?:(?:\xe0[\xa0-\xbf])|
1647                      (?:[\xe1-\xec][\x80-\xbf])|
1648                      (?:\xed[\x80-\x9f])|
1649                      (?:[\xee-\xef][\x80-\xbf]))[\x80-\xbf])|
1650                (?:(?:\xf0[\x90-\xbf])|
1651                   (?:[\xf1-\xf3][\x80-\xbf])|
1652                   (?:\xf4[\x80-\x8f])[\x80-\xbf]{2}))/
1653                '&#'.hex(unpack("H*", MT::I18N::encode_text($1, 'utf-8', 'ucs2'))).';'
1654            /egx;
1655    $text;
1656}
1657
1658sub unescape_unicode {
1659    my $text = shift;
1660    $text =~ s/\&\#(\d+);/pack("H*", sprintf("%X",$1))/egx;
1661    $text = MT::I18N::encode_text($text, 'ucs2', undef);
1662}
1663
1664{
1665    my $initialized_sax;
1666
1667    sub init_sax {
1668        require XML::SAX;
1669        if (@{XML::SAX->parsers} == 1) {
1670            map { eval { XML::SAX->add_parser($_) } }
1671                qw( XML::SAX::Expat XML::LibXML::SAX::Parser
1672                    XML::LibXML::SAX
1673                    XML::SAX::ExpatXS );
1674        }
1675        $initialized_sax = 1;
1676    }
1677
1678    sub sax_parser {
1679        init_sax() unless $initialized_sax;
1680        require XML::SAX::ParserFactory;
1681        my $f = XML::SAX::ParserFactory->new;
1682        $f->parser();
1683    }
1684}
1685
1686sub multi_iter {
1687    my ($iters, $picker) = @_;
1688    my @streams;
1689    foreach my $iter (@$iters) {
1690        my $head = $iter->();
1691        push @streams, { iter => $iter, head => $head };
1692    }
1693    sub {
1694        my ($f) = @_;
1695        if ($f && ($f eq 'finish')) {
1696            foreach my $iter (@streams) {
1697                $iter->{iter}->('finish');
1698            }
1699            return;
1700        }
1701        # find the head with greatest created_on
1702        my $which;
1703        foreach my $iter (@streams) {
1704            next unless defined($iter->{head});
1705            if (!$which) {
1706                $which = $iter;
1707                last unless $picker;
1708            } else {
1709                if (!$picker || ($picker && $picker->($iter->{head}, $which->{head}))) {
1710                    $which = $iter;
1711                }
1712            }
1713        }
1714        return unless $which;
1715
1716        # Advance the chosen one
1717        my $result = $which->{head};
1718        if (defined $result) {
1719            $which->{head} = $which->{iter}->();
1720        }
1721        $result;
1722    };
1723}
1724
1725sub trim {
1726    my $string = shift;
1727    $string = ltrim($string);
1728    $string = rtrim($string);
1729    $string;
1730}
1731
1732sub ltrim {
1733    my $string = shift;
1734    $string =~ s/^\s+//;
1735    $string;
1736}
1737
1738sub rtrim {
1739    my $string = shift;
1740    $string =~ s/\s+$//;
1741    $string;
1742}
1743
1744sub asset_cleanup {
1745    my ($str) = @_;
1746    $str =~ s/
1747        <(?:[Ff][Oo][Rr][Mm]|[Ss][Pp][Aa][Nn])
1748        ([^>]*?)
1749        \s
1750        mt:asset-id="\d+"
1751        ([^>]*?>)(.*?)
1752        <\/(?:[Ff][Oo][Rr][Mm]|[Ss][Pp][Aa][Nn])>
1753    /
1754    my $attr = $1 . $2;
1755    my $inner = $3;
1756    $attr =~ s!\s[Cc][Oo][Nn][Tt][Ee][Nn][Tt][Ee][Dd][Ii][Tt][Aa][Bb][Ll][Ee]=(['"][^'"]*?['"]|[Ff][Aa][Ll][Ss][Ee])!!;
1757    '<span' . $attr . $inner . '<\/span>'
1758    /gsex;
1759    return $str;
1760}
1761
1762sub caturl {
1763    return '' unless @_;
1764 
1765    my $url = shift;
1766    foreach (@_) {
1767        my $u = $_;
1768        next unless $u;
1769        $u =~ s!^/!!;
1770        $url .= '/' unless $url =~ m!/$!;
1771        $url .= $u;
1772    }
1773    return $url;
1774}
1775
1776sub get_newsbox_html {
1777    my ($newsbox_url, $kind, $cached_only) = @_;
1778
1779    return unless $newsbox_url;
1780    return unless is_url($newsbox_url);
1781    return unless $kind && (length($kind) == 2);
1782    $cached_only ||= 0;
1783
1784    my $NEWSCACHE_TIMEOUT = 60 * 60 * 24;
1785    my $sess_class        = MT->model('session');
1786    my ($news_object)     = ("");
1787    my $retries           = 0;
1788    $news_object = $sess_class->load( { id => $kind } );
1789    my $refresh_news;
1790    if ( $news_object
1791        && ( $news_object->start() < ( time - $NEWSCACHE_TIMEOUT ) ) )
1792    {
1793        $refresh_news = 1;
1794    }
1795    my $last_available_news = MT::I18N::encode_text( $news_object->data(), 'utf-8', undef )
1796      if $news_object;
1797    return $last_available_news unless $refresh_news || !$news_object;
1798    return q() if $cached_only;
1799
1800    # don't block the dashboard for more than 10 seconds to fetch
1801    # the news feed...
1802    my $ua = MT->new_ua( { timeout => 10 } );
1803    return $last_available_news unless $ua;
1804
1805    my $req = new HTTP::Request( GET => $newsbox_url );
1806    my $resp = $ua->request($req);
1807    my $result = $resp->content();
1808    if ( !$resp->is_success() || !$result ) {
1809        # failure; either timeout or worse
1810        # if news_object is available, bump up it's expiration
1811        # so we don't attempt to hit the server again
1812        # for an hour
1813        if (! $news_object ) {
1814            $news_object = MT::Session->new;
1815            $news_object->set_values(
1816                {
1817                    id    => $kind,
1818                    kind  => $kind,
1819                    data  => ''
1820                }
1821            );
1822            $last_available_news = '';
1823            $refresh_news = 1;
1824        }
1825        if (defined($last_available_news) && $refresh_news) {
1826            $news_object->start( ( time - $NEWSCACHE_TIMEOUT ) + 60 * 60 );
1827            $news_object->save;
1828        }
1829        return $last_available_news;
1830    }
1831    require MT::Sanitize;
1832
1833    # allowed html
1834    my $spec = 'a href,* style class id,ul,li,div,span,br';
1835    $result = MT::Sanitize->sanitize( $result, $spec );
1836    $news_object = MT::Session->new();
1837    $news_object->set_values(
1838        {
1839            id    => $kind,
1840            kind  => $kind,
1841            start => time(),
1842            data  => $result
1843        }
1844    );
1845    $news_object->save();
1846    $result = MT::I18N::encode_text( $result, 'utf-8', undef );
1847    return $result;
1848}
1849
1850## FIXME
1851# This method is to supplement CGI.pm's lack of read method.
1852# Some XML parsers (XML::SAX::ExpatXS and XML::LibXML to name a few)
1853# requires OO access to filehandles.
1854# Once CGI solved this issue, this method will be removed.
1855*Fh::read = sub {
1856    read($_[0], $_[1], $_[2], $_[3] || 0);
1857};
1858
18591;
1860
1861__END__
1862
1863=head1 NAME
1864
1865MT::Util - Movable Type utility functions
1866
1867=head1 SYNOPSIS
1868
1869    use MT::Util qw( functions );
1870
1871=head1 DESCRIPTION
1872
1873I<MT::Util> provides a variety of utility functions used by the Movable Type
1874libraries.
1875
1876=head1 USAGE
1877
1878=head2 start_end_day($ts)
1879
1880Given I<$ts>, a timestamp in form C<YYYYMMDDHHMMSS>, calculates the timestamp
1881corresponding to the start of the same day, and, if called in list context,
1882the end of the day. If called in scalar context, returns one timestamp
1883corresponding to the start of the day; if called in list context, returns two
1884timestamps, for the start and end of the day.
1885
1886For example, given C<20020410160406>, returns C<20020410000000> in scalar
1887context, and C<20020410000000> and C<20020410235959> in list context.
1888
1889=head2 start_end_week($ts)
1890
1891Given I<$ts>, a timestamp in form C<YYYYMMDDHHMMSS>, calculates the timestamp
1892corresponding to the start of the week, and, if called in list context, the
1893end of the week. If called in scalar context, returns one timestamp
1894corresponding to the start of the week; if called in list context, returns two
1895timestamps, for the start and end of the week.
1896
1897A week is defined as starting on Sunday.
1898
1899For example, given C<20020410160406>, returns C<20020407000000> in scalar
1900context, and C<20020407000000> and C<20020413235959> in list context.
1901
1902=head2 start_end_month($ts)
1903
1904Given I<$ts>, a timestamp in form C<YYYYMMDDHHMMSS>, calculates the timestamp
1905corresponding to the start of the month, and, if called in list context,
1906the end of the month. If called in scalar context, returns one timestamp
1907corresponding to the start of the month; if called in list context, returns two
1908timestamps, for the start and end of the month.
1909
1910For example, given C<20020410160406>, returns C<20020401000000> in scalar
1911context, and C<20020401000000> and C<20020430235959> in list context.
1912
1913=head2 offset_time_list($unix_ts, $blog [, $direction ])
1914
1915Given I<$unix_ts>, a timestamp in Unix epoch format (seconds since 1970),
1916applies the timezone offset specified in the blog I<$blog> (either an
1917I<MT::Blog> object or a numeric blog ID). If daylight saving time is in
1918effect in the local time zone (determined using the return value from
1919I<localtime()>), the offset is automatically adjusted.
1920
1921Returns the return value of I<gmtime()> given the adjusted Unix timestamp.
1922
1923=head2 format_ts($format, $ts, $blog)
1924
1925Given a timestamp I<$ts> in form C<YYYYMMDDHHMMSS>, applies the format
1926specified in I<$format> and returns the formatted string.
1927
1928If specified, I<$blog> should be an I<MT::Blog> object, from which the
1929date/time formatting language preference is taken (e.g. English, French, etc.).
1930If unspecified, English formatting is used.
1931
1932If I<$format> is C<undef>, and I<$blog> is specified, I<format_ts> will
1933use a language-specific default format; if a language-specific format is not
1934defined, or if I<$blog> is unspecified, the default format used is
1935C<%B %e, %Y %I:%M %p>.
1936
1937=head2 days_in($month, $year)
1938
1939Returns the number of days in the month I<$month> in the year I<$year>.
1940I<$month> should be numeric, starting at C<1> for C<January>. I<$year> should
1941be a 4-digit year. The number of days is automatically adjusted in a leap
1942year.
1943
1944=head2 wday_from_ts($year, $month, $day)
1945
1946Returns the numeric day of the week, in the range C<0>-C<6>, where C<0> is
1947C<Sunday>, for the date specified in I<$year>, I<$month>, and I<$day>.
1948I<$year> should be a 4-digit year; I<$month> a numeric value in the range
1949C<1>-C<12>; and I<$day> the numeric day of the month.
1950
1951=head2 first_n_words($str, $n)
1952
1953Given a string I<$str>, returns the first I<$n> words in the string, after
1954removing any HTML tags.
1955
1956=head2 dirify($str)
1957
1958Munges a string I<$str> so that it is suitable for use as a file/directory
1959name. HTML is removed; HTML-entities are removed; non-word/space characters
1960are removed; spaces are changed to underscores; the entire string is
1961converted to lower-case.
1962
1963For 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>.
1964
1965=head2 encode_html($str)
1966
1967Encodes any special characters in I<$str> into HTML entities and returns the
1968transformed string.
1969
1970If I<HTML::Entities> is available, and if the configuration setting
1971I<NoHTMLEntities> is not set, uses I<HTML::Entities> for entity-encoding.
1972Otherwise, very simple encoding is done to catch the most common characters
1973that need encoding.
1974
1975=head2 decode_html($str)
1976
1977Decodes any HTML entities in I<$str> into the corresponding characters and
1978returns the transformed string.
1979
1980If I<HTML::Entities> is available, and if the configuration setting
1981I<NoHTMLEntities> is not set, uses I<HTML::Entities> for entity-decoding.
1982Otherwise, very simple decoding is done to catch the most common entities
1983that need decoding.
1984
1985=head2 remove_html($str)
1986
1987Removes any HTML tags from I<$str> and returns the result.
1988
1989=head2 encode_js($str)
1990
1991Escapes/encodes any special characters in I<$str> so that the string can be
1992used safely as the value in Javascript; returns the transformed string.
1993
1994=head2 encode_php($str [, $type ])
1995
1996Escapes/encodes any special characters in I<$str> so that the string can be
1997used safely as the value in PHP code; returns the transformed string.
1998
1999I<$type> can be either C<qq> (double-quote interpolation), C<here> (heredoc
2000interpolation), or C<q> (single-quote interpolation). C<q> is the default.
2001
2002=head2 spam_protect($email_address)
2003
2004Given an email address I<$email_address>, encodes any characters that will
2005identify it as an email address (C<:>, C<@>, and C<.>) into HTML entities,
2006so that spam harvesters will not see the email address as easily. Returns
2007the transformed address.
2008
2009=head2 is_valid_email($email_address)
2010
2011Checks the email address I<$email_address> for syntax validity; if the
2012address--or part of it--is valid, I<is_valid_email> returns the valid (part
2013of) the email address. Otherwise, it returns C<0>.
2014
2015=head2 perl_sha1_digest($msg)
2016
2017Returns a SHA1 digest of $msg. The result is the usual packed binary
2018representation. Use perl_sha1_digest_hex to get a printable string.
2019
2020=head2 perl_sha1_digest_hex($msg)
2021
2022Returns a SHA1 digest of $msg. The result is an ASCII string of hex
2023digits. Use perl_sha1_digest to get a binary representation.
2024
2025=head2 dsa_verify(Key => $key, Signature => $sig,
2026    [ Message => $msg | $Digest => $dgst ])
2027
2028Verifies that sig is a DSA signature of $msg (or $dgst) produced using
2029the private half of the public key given in $key. Requires
2030Math::BigInt but doesn't call for any non-perl libraries.
2031
2032=head2 get_newsbox_html($newsbox_url, $kind)
2033
2034Retrieves newsbox content from the specified URL.  Content retrieved is
2035cached in MT::Session for 24 hours under the key specified in I<$kind>.
2036Content will be sanitized based on pre-defined rules.
2037
2038=head1 AUTHOR & COPYRIGHTS
2039
2040Please see the I<MT> manpage for author, copyright, and license information.
2041
2042=cut
Note: See TracBrowser for help on using the browser.