root/branches/release-38/lib/MT/Util.pm @ 2317

Revision 2317, 73.6 kB (checked in by fumiakiy, 19 months ago)

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