package VNDB::Func;
use strict;
use warnings;
use YAWF ':html';
use Exporter 'import';
use POSIX 'strftime';
our @EXPORT = qw| shorten age date datestr monthstr userstr bb2html gtintype liststat clearfloat cssicon |;
# I would've done this as a #define if this was C...
sub shorten {
my($str, $len) = @_;
return length($str) > $len ? substr($str, 0, $len-3).'...' : $str;
}
# Argument: unix timestamp
# Returns: age
sub age {
my $a = time-$_[0];
return sprintf '%d %s ago',
$a > 60*60*24*365*2 ? ( $a/60/60/24/365, 'years' ) :
$a > 60*60*24*(365/12)*2 ? ( $a/60/60/24/(365/12), 'months' ) :
$a > 60*60*24*7*2 ? ( $a/60/60/24/7, 'weeks' ) :
$a > 60*60*24*2 ? ( $a/60/60/24, 'days' ) :
$a > 60*60*2 ? ( $a/60/60, 'hours' ) :
$a > 60*2 ? ( $a/60, 'min' ) :
( $a, 'sec' );
}
# argument: unix timestamp and optional format (compact/full)
# return value: yyyy-mm-dd
# (maybe an idea to use cgit-style ages for recent timestamps)
sub date {
my($t, $f) = @_;
return strftime '%Y-%m-%d', gmtime $t if !$f || $f eq 'compact';
return strftime '%Y-%m-%d at %R', gmtime $t;
}
# argument: database release date format (yyyymmdd)
# y = 0000 -> unkown
# y = 9999 -> TBA
# m = 99 -> month+day unkown
# d = 99 -> day unknown
# return value: (unknown|TBA|yyyy|yyyy-mm|yyyy-mm-dd)
# if date > now: str
sub datestr {
my $date = sprintf '%08d', shift||0;
my $future = $date > strftime '%Y%m%d', gmtime;
my($y, $m, $d) = ($1, $2, $3) if $date =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/;
my $str = $y == 0 ? 'unknown' : $y == 9999 ? 'TBA' :
$m == 99 ? sprintf('%04d', $y) :
$d == 99 ? sprintf('%04d-%02d', $y, $m) :
sprintf('%04d-%02d-%02d', $y, $m, $d);
return $str if !$future;
return qq|$str|;
}
# same as datestr(), but different output format:
# e.g.: 'Jan 2009', '2009', 'unknown', 'TBA'
sub monthstr {
my $date = sprintf '%08d', shift||0;
my($y, $m) = ($1, $2) if $date =~ /^([0-9]{4})([0-9]{2})/;
return 'TBA' if $y == 9999;
return 'unknown' if $y == 0;
return $y if $m == 99;
return strftime '%b %Y', 0, 0, 0, 0, $m-1, $y-1900, 0, 0, 0;
}
# Arguments: (uid, username), or a hashref containing that info
sub userstr {
my($id,$n) = ref($_[0])eq'HASH'?($_[0]{uid}||$_[0]{requester}, $_[0]{username}):@_;
return !$id ? '[deleted]' : ''.$n.'';
}
# Arguments: input, and optionally the maximum length
# Parses:
# [url=..] [/url]
# [raw] .. [/raw]
# [spoiler] .. [/spoiler]
# v+, v+.+
# http://../
sub bb2html {
my $raw = shift;
my $maxlength = shift;
$raw =~ s/\r//g;
return '' if !$raw && $raw ne "0";
my($result, $length, @open) = ('', 0, 'first');
my $e = sub {
local $_ = shift;
tr/A-Za-z/N-ZA-Mn-za-m/ if !@_ && grep /spoiler/, @open;
s/&/&/g;
s/>/>/g;
s/</g;
s/\n/
/g if !$maxlength;
s/\n/ /g if $maxlength;
return $_;
};
for (split /(\s|\n|\[[^\]]+\])/, $raw) {
next if !defined $_;
my $lit = $_;
if($open[$#open] ne 'raw') {
if ($_ eq '[raw]') { push @open, 'raw'; next }
elsif ($_ eq '[spoiler]') { push @open, 'spoiler'; next }
elsif ($_ eq '[/spoiler]') { pop @open if $open[$#open] eq 'spoiler'; next }
elsif ($_ eq '[/url]') {
if($open[$#open] eq 'url') {
$result .= '';
pop @open;
}
next;
} elsif(s{\[url=((https?://|/)[^\]>]+)\]}{}i) {
$result .= $_;
push @open, 'url';
next;
} elsif(!grep(/url/, @open) &&
s{(.*)(http|https)://(.+[0-9a-zA-Z=/])(.*)}
{$e->($1).qq|'.$e->('link').''.$e->($4)}e) {
$length += 4;
last if $maxlength && $length > $maxlength;
$result .= $_;
next;
} elsif(!grep(/url/, @open) && (
s{^(.*[^\w]|)([tdvpr][1-9][0-9]*)\.([1-9][0-9]*)([^\w].*|)$}{$e->($1).qq|$2.$3|.$e->($4)}e ||
s{^(.*[^\w]|)([tduvpr][1-9][0-9]*)([^\w].*|)$}{$e->($1).qq|$2|.$e->($3)}e)) {
$length += length $lit;
last if $maxlength && $length > $maxlength;
$result .= $_;
next;
}
} elsif($_ eq '[/raw]') {
pop @open if $open[$#open] eq 'raw';
next;
}
# normal text processing
$length += length $_;
last if $maxlength && $length > $maxlength;
$result .= $e->($_);
}
$result .= ''
while((local $_ = pop @open) ne 'first');
$result .= '...' if $maxlength && $length > $maxlength;
return $result;
}
# GTIN code as argument,
# Returns 'JAN', 'EAN', 'UPC' or undef,
# Also 'normalizes' the first argument in place
sub gtintype {
$_[0] =~ s/[^\d]+//g;
$_[0] =~ s/^0+//;
my $c = shift;
return undef if $c !~ /^[0-9]{12,13}$/; # only gtin-12 and 13
$c = ('0'x(13-length $c)) . $c; # pad with zeros
# calculate check digit according to
# http://www.gs1.org/productssolutions/barcodes/support/check_digit_calculator.html#how
my @n = reverse split //, $c;
my $n = shift @n;
$n += $n[$_] * ($_ % 2 != 0 ? 1 : 3) for (0..$#n);
return undef if $n % 10 != 0;
# Do some rough guesses based on:
# http://www.gs1.org/productssolutions/barcodes/support/prefix_list.html
# and http://en.wikipedia.org/wiki/List_of_GS1_country_codes
local $_ = $c;
return 'JAN' if /^4[59]/; # prefix code 450-459 & 490-499
return 'UPC' if /^(?:0[01]|0[6-9]|13|75[45])/; # prefix code 000-019 & 060-139 & 754-755
return undef if /(?:0[2-5]|2|97[789]|9[6-9])/; # some codes we don't want: 020–059 & 200-299 & 977-999
return 'EAN'; # let's just call everything else EAN :)
}
# Argument: hashref with rstat and vstat
# Returns: empty string if not in list, otherwise colour-encoded list status
sub liststat {
my $l = shift;
return '' if !$l;
my $rs = $YAWF::OBJ->{vn_rstat}[$l->{rstat}];
$rs = qq|$rs| if $l->{rstat} == 2; # Obtained
$rs = qq|$rs| if $l->{rstat} < 2; # Unknown/pending
my $vs = $YAWF::OBJ->{vn_vstat}[$l->{vstat}];
$vs = qq|$vs| if $l->{vstat} == 2; # Finished
$vs = qq|$vs| if $l->{vstat} == 0 || $l->{vstat} == 4; # Unknown/dropped
return "$rs / $vs";
}
# Clears a float, to make sure boxes always have the correct height
sub clearfloat {
div class => 'clearfloat', '';
}
# Draws a CSS icon, arguments: class, title
sub cssicon {
acronym class => "icons $_[0]", title => $_[1];
lit ' ';
end;
}
1;