root/branches/release-34/lib/MT/Util.pm @ 1873

Revision 1873, 73.1 kB (checked in by bchoate, 20 months ago)

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