root/branches/athena/lib/MT/Util.pm @ 1092

Revision 1092, 65.6 kB (checked in by hachi, 2 years ago)

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