util.pm

1. 记录每个帖子的访问人情况

	    my $bdigit = ord(substr($b, -$i, 1));
	    my $rdigit = $adigit + $bdigit + $carry;
	    $carry = $rdigit / 256;
	    $result = chr($rdigit % 256) . $result;
	}
	if ($carry) {
	    return $result = chr($carry) . $result;
	} else {
	    return $result;
	}
    }

    sub multbindec {
	my ($a, $b) = @_;
	# $b is decimal-ascii, $b < 256
	my @result;
	$result[(length $a)] = 0;
	for (my $i=1; $i <= length $a; $i++) {
	    my $adigit = substr($a, -$i, 1);
	    $result[-$i] = ord($adigit) * $b;
	}
	
	for (my $i=2; $i <= scalar @result; $i++)
	{
	    $result[-$i] += int($result[-$i+1] / 256);
	    $result[-$i+1] = $result[-$i+1] % 256;
	}

	shift @result while (@result && ($result[0] == 0));
	
	pack('C*', @result);
    }

    sub divbindec {
#       local $ENV{LANG} = undef;
	my ($a, $b) = @_;
	# $b is decimal-ascii, $b < 256

	my $acc = ord(substr($a, 0, 1));
	my $quot;
	while (length $a) {
	    $a = substr($a, 1);
	    $quot .= chr($acc / $b);
	    $acc = $acc % $b;
	    if (length $a) {
		$acc = $acc * 256 + ord(substr($a, 0, 1));
	    }
	}
	return ($quot, $acc);
    }

    sub dec2bin {
	my ($decimal) = @_;
	my @digits = split //, $decimal;
	my $result = "";
	foreach my $d (@digits) {
	    $result = multbindec($result, 10);
	    $result = addbin(pack('c', $d), $result);
	}
	while (substr($result, 0, 1) eq "\0") {
	    $result = substr($result, 1);
	}
	$result;
    }

    sub bin2dec {
	my $bin = $_[0];
	my $result = '';
	my $rem = 0;
	while ((length $bin) && ($bin ne "\0")) {
	    ($bin, $rem) = divbindec($bin, 10);
	    $result = $rem . $result;
	    $bin = substr($bin, 1) if (substr($bin, 0, 1) eq "\0");
	}
	$result;
    }


    sub perl_sha1_digest {   # thanks to Adam Back for the starting point of this
	my ($message) = @_;
	my $init_string = 'D9T4C`>_-JXF8NMS^$#)4=L/2X?!:@GF9;MGKH8\;O-S*8L\'6';
	# 67452301 efcdab89 98badcfe 10325476 c3d2e1f0
	my @A = unpack"N*",unpack 'u',$init_string;
	my @K=splice@A,5,4;
	sub M{my ($x, $m); ($x=pop)-($m=1+~0)*int$x/$m};   # modulo 0x100000000
        sub L{my ($n, $x); $n=pop;(($x=pop)<<$n|2**$n-1&$x>>32-$n) & (0xffffffff)} # left-rotate bit vector
	# magic SHA1 functions
	my @F = (sub { my ($a, $b, $c, $d) = @_; $b&($c^$d)^$d },
		 sub { my ($a, $b, $c, $d) = @_; $b^$c ^$d},
		 sub { my ($a, $b, $c, $d) = @_; ($b|$c)&$d|$b&$c},
		 sub { my ($a, $b, $c, $d) = @_; $b^$c ^$d});
	my $F = sub {
	    my $which = shift;
	    my ($a, $b, $c, $d) = @_; 
	    if ($which == 0)
	    { $b&($c^$d)^$d }
	    elsif ($which == 1)
	    { $b^$c ^$d }
	    elsif ($which == 2)
	    { ($b|$c)&$d|$b&$c }
	    elsif ($which == 3) 
	    { $b^$c ^$d }
	};

	my ($l, $r, $p);
	my  $t;
	my $S;
	
	my @W;

	do {
	    $_ = substr($message, 0, 64);
	    $message = length$message >= 64 ? substr($message, 64) : "";
	    $l += $r = length $_;
	    $r++, $_ .= "\x80" if $r < 64 && !$p++;
	    @W = unpack 'N16', $_."\0"x(64-length($_));
	    $W[15] = $l*8 if $r < 57;
	    for (16..79)
	    {
		push @W, L($W[$_-3]^$W[$_-8]^$W[$_-14]^$W[$_-16], 1);
	    }
	    my ($a,$b,$c,$d,$e)=@A;
	    for(0..79)
	    {
		$t=M(($F->(int($_/ 20), $a, $b, $c, $d))+$e+$W[$_]+$K[$_/20]+L$a,5);
		$e=$d;
		$d=$c;
		$c=L$b,30;
		$b=$a;
		$a=$t;
	    }
	    my $v='a';
	    $A[0] = M$A[0]+$a;
	    $A[1] = M$A[1]+$b;
	    $A[2] = M$A[2]+$c;
	    $A[3] = M$A[3]+$d;
	    $A[4] = M$A[4]+$e;
	} while $r > 56;

        pack('N*', @A[0..4]);
    }
}

sub perl_sha1_digest_hex {
    sprintf("%.8x"x5, unpack('N*', &perl_sha1_digest(@_)));
}

sub perl_sha1_digest_base64 {
    require MIME::Base64;
    MIME::Base64::encode_base64(perl_sha1_digest(@_), '');
}

sub dsa_verify {
    my %param = @_;

    eval {
	require Crypt::DSA;
    };
    my $has_crypt_dsa = $@ ? 0 : 1;
    $has_crypt_dsa = 0 if $param{ForcePerl};
    if ($has_crypt_dsa) {
	$param{Key} = bless $param{Key}, 'Crypt::DSA::Key';
	$param{Signature} = bless $param{Signature}, 'Crypt::DSA::Signature';
	Crypt::DSA->new->verify(%param);
    } else {
	require Math::BigInt;

	my($key, $dgst, $sig);

	Carp::croak __PACKAGE__ . "dsa_verify: Need a Key" 
	    unless $key = $param{Key};

	unless ($dgst = $param{Digest}) {
	    Carp::croak "dsa_verify: Need either Message or Digest"
		unless $param{Message};
	      $dgst = perl_sha1_digest($param{Message});
	  }
	Carp::croak "dsa_verify: Need a Signature"
	    unless $sig = $param{Signature};
	my $r = new Math::BigInt($sig->{r});
	my $s = new Math::BigInt($sig->{s});
	my $p = new Math::BigInt($key->{p});
	my $q = new Math::BigInt($key->{q});
	my $g = new Math::BigInt($key->{g});
	my $pub_key = new Math::BigInt($key->{pub_key});
	my $u2 = $s->bmodinv($q);

	my $u1 = new Math::BigInt("0x" . unpack("H*", $dgst));

	$u1 = $u1->bmul($u2)->bmod($q);
	$u2 = $r->bmul($u2)->bmod($q);
	my $t1 = $g->bmodpow($u1, $p);
	my $t2 = $pub_key->bmodpow($u2, $p);
	$u1 = $t1->bmul($t2)->bmod($key->{p});
	$u1 = $u1->bmod($key->{q});
	my $result = $u1->bcmp($sig->{r});
	return defined($result) ? $result == 0 : 0;
    }
}

1;
__END__

=head1 NAME

MT::Util - Movable Type utility functions

=head1 SYNOPSIS

    use MT::Util qw( functions );

=head1 DESCRIPTION

I<MT::Util> provides a variety of utility functions used by the Movable Type
libraries.

=head1 USAGE

=head2 start_end_day($ts)

Given I<$ts>, a timestamp in form C<YYYYMMDDHHMMSS>, calculates the timestamp
corresponding to the start of the same day, and, if called in list context,
the end of the day. If called in scalar context, returns one timestamp
corresponding to the start of the day; if called in list context, returns two
timestamps, for the start and end of the day.

For example, given C<20020410160406>, returns C<20020410000000> in scalar
context, and C<20020410000000> and C<20020410235959> in list context.

=head2 start_end_week($ts)

Given I<$ts>, a timestamp in form C<YYYYMMDDHHMMSS>, calculates the timestamp
corresponding to the start of the week, and, if called in list context, the
end of the week. If called in scalar context, returns one timestamp
corresponding to the start of the week; if called in list context, returns two
timestamps, for the start and end of the week.

A week is defined as starting on Sunday.

For example, given C<20020410160406>, returns C<20020407000000> in scalar
context, and C<20020407000000> and C<20020413235959> in list context.

=head2 start_end_month($ts)

Given I<$ts>, a timestamp in form C<YYYYMMDDHHMMSS>, calculates the timestamp
corresponding to the start of the month, and, if called in list context,
the end of the month. If called in scalar context, returns one timestamp
corresponding to the start of the month; if called in list context, returns two
timestamps, for the start and end of the month.

For example, given C<20020410160406>, returns C<20020401000000> in scalar
context, and C<20020401000000> and C<20020430235959> in list context.

=head2 start_end_period($archive_type, $ts)

Dispatches to one of C<start_end_day>, C<start_end_week>,
C<start_end_month> according to whether $archive_type is equal to
Daily, Weekly, or Monthly. If C<$archive_type> is C<Individual>,
C<$ts> is returned.

=head2 mark_odd_rows($array_ref)

$array_ref is a reference to an array of hash references. For any
element of array, at index I<i>, this sets the C<is_odd> element of
that hash ref to true when I<i> is odd, and false when I<i> is even.

=head2 offset_time_list($unix_ts, $blog [, $direction ])

Given I<$unix_ts>, a timestamp in Unix epoch format (seconds since 1970),
applies the timezone offset specified in the blog I<$blog> (either an
I<MT::Blog> object or a numeric blog ID). If daylight saving time is in
effect in the local time zone (determined using the return value from
I<localtime()>), the offset is automatically adjusted.

Returns the return value of I<gmtime()> given the adjusted Unix timestamp.

=head2 format_ts($format, $ts, $blog)

Given a timestamp I<$ts> in form C<YYYYMMDDHHMMSS>, applies the format
specified in I<$format> and returns the formatted string.

If specified, I<$blog> should be an I<MT::Blog> object, from which the
date/time formatting language preference is taken (e.g. English, French, etc.).
If unspecified, English formatting is used.

If I<$format> is C<undef>, and I<$blog> is specified, I<format_ts> will
use a language-specific default format; if a language-specific format is not
defined, or if I<$blog> is unspecified, the default format used is
C<%B %e, %Y %I:%M %p>.

=head2 days_in($month, $year)

Returns the number of days in the month I<$month> in the year I<$year>.
I<$month> should be numeric, starting at C<1> for C<January>. I<$year> should
be a 4-digit year. The number of days is automatically adjusted in a leap
year.

=head2 wday_from_ts($year, $month, $day)

Returns the numeric day of the week, in the range C<0>-C<6>, where C<0> is
C<Sunday>, for the date specified in I<$year>, I<$month>, and I<$day>.
I<$year> should be a 4-digit year; I<$month> a numeric value in the range
C<1>-C<12>; and I<$day> the numeric day of the month.

=head2 first_n_words($str, $n)

Given a string I<$str>, returns the first I<$n> words in the string, after
removing any HTML tags.

=head2 dirify($str)

Munges a string I<$str> so that it is suitable for use as a file/directory
name. HTML is removed; HTML-entities are removed; non-word/space characters
are removed; spaces are changed to underscores; the entire string is
converted to lower-case.

For 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>.

=head2 encode_html($str)

Encodes any special characters in I<$str> into HTML entities and returns the
transformed string.

If I<HTML::Entities> is available, and if the configuration setting
I<NoHTMLEntities> is not set, uses I<HTML::Entities> for entity-encoding.
Otherwise, very simple encoding is done to catch the most common characters
that need encoding.

=head2 decode_html($str)

Decodes any HTML entities in I<$str> into the corresponding characters and
returns the transformed string.

If I<HTML::Entities> is available, and if the configuration setting
I<NoHTMLEntities> is not set, uses I<HTML::Entities> for entity-decoding.
Otherwise, very simple decoding is done to catch the most common entities
that need decoding.

=head2 remove_html($str)

Removes any HTML tags from I<$str> and returns the result.

=head2 encode_js($str)

Escapes/encodes any special characters in I<$str> so that the string can be
used safely as the value in Javascript; returns the transformed string.

=head2 encode_php($str [, $type ])

Escapes/encodes any special characters in I<$str> so that the string can be
used safely as the value in PHP code; returns the transformed string.

I<$type> can be either C<qq> (double-quote interpolation), C<here> (heredoc
interpolation), or C<q> (single-quote interpolation). C<q> is the default.

=head2 spam_protect($email_address)

Given an email address I<$email_address>, encodes any characters that will
identify it as an email address (C<:>, C<@>, and C<.>) into HTML entities,
so that spam harvesters will not see the email address as easily. Returns
the transformed address.

=head2 is_valid_email($email_address)

Checks the email address I<$email_address> for syntax validity; if the
address--or part of it--is valid, I<is_valid_email> returns the valid (part
of) the email address. Otherwise, it returns C<0>.

=head2 perl_sha1_digest($msg)

Returns a SHA1 digest of $msg. The result is the usual packed binary
representation. Use perl_sha1_digest_hex to get a printable string.

=head2 perl_sha1_digest_hex($msg)

Returns a SHA1 digest of $msg. The result is an ASCII string of hex
digits. Use perl_sha1_digest to get a binary representation.

=head2 dsa_verify(Key => $key, Signature => $sig,
    [ Message => $msg | $Digest => $dgst ])

Verifies that sig is a DSA signature of $msg (or $dgst) produced using
the private half of the public key given in $key. Requires
Math::BigInt but doesn't call for any non-perl libraries.

=head2 MT::Util::launch_background_tasks()

Returns true or false as to whether the application should attempt to
fork background tasks at all, or if it should take the safer course
which is to do such tasks synchronously.

Background tasks should not be forked if either (a) we are running
under mod_perl, or (b) the configuration file instructs us not to.

=head2 MT::Util::start_background_tasks($thunk)

Invokes C<$thunk>. C<$thunk> is executed synchronously, before
returning, if C<launch_background_tasks> gives a false value. If the
latter gives a true value, a process is forked and C<$thunk> is
executed in the child. In that case, C<start_background_tasks> returns
immediately in the parent. The child process terminates once C<$thunk>
returns.

=head1 AUTHOR & COPYRIGHTS

Please see the I<MT> manpage for author, copyright, and license information.

=cut