root/veekun/trunk/lib/Vee/Utils.pm

package Vee::Utils;

use Socket qw//;
use List::Util qw/first/;
use Digest::SHA1 qw/sha1_hex/;

=head1 NAME

Vee::Utils - Assorted utility functions

=head1 SYNOPSIS

Coming soon

=head1 DESCRIPTION

Just a collection of small C<sub>s I've written that tend to be more useful
than I expected.

=head1 FUNCTIONS

Coming soon

=cut

sub hsv2rgb {
    my ($h, $s, $v) = @_;
    $h /= 360; $s /= 256; $v /= 256;

    if ($s <= 0.0) { return tohex(int $v * 256) x 3 }
    else {
        if ($h >= 1.0) { $h = 0.0 }
        $h *= 6;
        my $f = $h - int $h;
        my $p = int(256 * $v * (1.0 - $s));
        my $q = int(256 * $v * (1.0 - ($s * $f)));
        my $t = int(256 * $v * (1.0 - ($s * (1.0 - $f))));
        $v = int(256 * $v);
        if (int $h == 0) { return hexcolor($v, $t, $p) }
        elsif (int $h == 1) { return hexcolor($q, $v, $p) }
        elsif (int $h == 2) { return hexcolor($p, $v, $t) }
        elsif (int $h == 3) { return hexcolor($p, $q, $v) }
        elsif (int $h == 4) { return hexcolor($t, $p, $v) }
        elsif (int $h == 5) { return hexcolor($v, $p, $q) }
    }
}

# get the postrank for a postcount
# IN: user post count, OUT: post rank based on user post count

sub postrank {
    my ($post_count) = @_;
    $post_count ||= 0;
    for my $rank (
        sort { $b <=> $a }
        keys %{ Vee->config->{site}->{post_ranks} }
    ) {
        return Vee->config->{site}->{post_ranks}->{$rank} if $rank <= $post_count;
    }
    return "ERRORZ0RZ";
}

# get the percent width of the postbar for a given postcount
# XXX: decide the best way to do this, preferably a smooth log curve
sub post_width {
    my ($post_count) = @_;
    return $post_count / 1000;
}

# converts input to Linux-style newlines
sub fix_newlines {
    my $text = shift;
    $text =~ s/\x0d\x0a?/\x0a/g;
    $text =~ s/^\x0a+|\x0a+$//g;
    return $text;
}

# remove all HTML
sub cleanse {
    my $text = shift;
    return undef unless defined $text;
    $text =~ s/&/&amp;/g;
    $text =~ s/&amp;(#x?[0-9a-f]+;)/&$1/gi;
    $text =~ s/</&lt;/g;
    $text =~ s/>/&gt;/g;
    $text =~ s/\"/&quot;/g;
    $text =~ s:\x0D\x0A:<br/>:g;
    $text =~ s:\x0D|\x0A:<br/>:g;
    return $text;
}

# URL-validation regex
# Inferred from the W3's BNF: http://www.w3.org/Addressing/URL/5_BNF.html
# n.b.: Technically, the BNF says hostname parts (as delimited by dots)
# should begin with a letter, but given that 'xalpha' includes dot this was
# a bit clumsy to pull off in practice, so I left it lazy.
my $url_xalphas = qr/[-_@.&+!*"'(),a-zA-Z0-9\$]/;
our $IsValidURL = qr/ ^
    (?: http | https | ftp ) :\/\/          # protocol
    (?:
        [a-zA-Z] $url_xalphas*              # hostname
        | (?: \d{1,3} \. ){3} \d{1,3}       # IP
    )
    (?: : [0-9]+ )?                         # port
    (?: \/                                  # path: leading slash
        (?: $url_xalphas*                   # path: path part name
          | %[a-fA-F][a-fA-F] )*            # path: escape
    )*                                      # path: as many as you want
    (?: \? $url_xalphas+ )?                 # query string
    (?: \# $url_xalphas+ )?                 # anchor
$ /x;


sub pad { sprintf "%0$_[1]d", $_[0] }
sub round { $_[1] ||= 0; return int($_[0] * 10 ** $_[1] + .5) / 10 ** $_[1]; }
sub hexcolor { return tohex($_[0]).tohex($_[1]).tohex($_[2]); }
sub tohex { return sprintf("%02x", $_[0]); }
sub isnum { return (defined $_[0] and $_[0] =~ /^ [+-]? \d+ (?:\. [0-9]*)? $/x) }
sub max { my ($i, $max); while (!defined $max) { $max = shift; } for $i (@_) { next unless defined $i; if ($i > $max) { $max = $i } } return $max; }
sub min { my ($i, $min); while (!defined $min) { $min = shift; }  for $i (@_) { next unless defined $i; if ($i < $min) { $min = $i } } return $min; }
sub sum { my $x; $x += $_ for (@_); return $x; }
sub num { return (&isnum($_[0])) ? $_[0] : 0 }
sub wordcap { my $text = $_[0]; $text =~ s#\b(.*?)\b#ucfirst $1#eg; return $text; }
sub in { my $tmp = shift; for (@_) { return 1 if $tmp eq $_ } return 0 }
sub urlencode { my $str = shift; $str =~ s/([^-_a-zA-Z0-9])/'%' . tohex(ord $1)/ge; return $str; }
sub array { ref $_[0] ? @{ $_[0] } : ( $_[0] ) }

sub inet_ntoa { Socket::inet_ntoa(pack 'N*', shift) }
sub inet_aton { unpack 'N*', Socket::inet_aton(shift) }

# name comes from what imageboards do, but really it's just a short hash
sub tripcode { substr sha1_hex(shift), 0, 12 }

=head1 AUTHOR

Maintainer: Alex "Eevee" Munroe (C<veekun@veekun.com>)

See the included F<AUTHORS> file for a full list of contributers.

=head1 LICENSE

See the included F<LICENSE> file.

=cut

1;