root/branches/release-36/lib/MT/Util.pm @ 2118

Revision 2118, 73.4 kB (checked in by bchoate, 19 months ago)

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