summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Multi/API.pm14
-rw-r--r--lib/Multi/IRC.pm2
-rw-r--r--lib/Multi/Maintenance.pm2
-rw-r--r--lib/VNDB/Func.pm153
-rw-r--r--lib/VNDBUtil.pm153
-rw-r--r--lib/VNWeb/Auth.pm2
-rw-r--r--lib/VNWeb/Prelude.pm6
7 files changed, 161 insertions, 171 deletions
diff --git a/lib/Multi/API.pm b/lib/Multi/API.pm
index 287a7a53..c41e9873 100644
--- a/lib/Multi/API.pm
+++ b/lib/Multi/API.pm
@@ -15,7 +15,7 @@ use POE::Filter::VNDBAPI 'encode_filters';
use Encode 'encode_utf8', 'decode_utf8';
use Crypt::URandom 'urandom';
use Crypt::ScryptKDF 'scrypt_raw';;
-use VNDBUtil 'normalize_query', 'norm_ip', 'resolution';
+use VNDB::Func 'imgurl', 'normalize_query', 'norm_ip', 'resolution';
use VNDB::Types;
use VNDB::Config;
use JSON::XS;
@@ -433,7 +433,7 @@ my %GET_VN = (
},
},
details => {
- select => 'vndbid_num(v.image) as image, i.c_sexual_avg, i.c_violence_avg, i.c_votecount, v.alias AS aliases, v.length, v.desc AS description, v.l_wp, v.l_encubed, v.l_renai, l_wikidata',
+ select => 'v.image, i.c_sexual_avg, i.c_violence_avg, i.c_votecount, v.alias AS aliases, v.length, v.desc AS description, v.l_wp, v.l_encubed, v.l_renai, l_wikidata',
proc => sub {
$_[0]{aliases} ||= undef;
$_[0]{length} *= 1;
@@ -445,7 +445,7 @@ my %GET_VN = (
renai => delete($_[0]{l_renai}) ||undef,
wikidata => formatwd(delete $_[0]{l_wikidata}),
};
- $_[0]{image} = $_[0]{image} ? sprintf '%s/cv/%02d/%d.jpg', config->{url_static}, $_[0]{image}%100, $_[0]{image} : undef;
+ $_[0]{image} = $_[0]{image} ? imgurl $_[0]{image} : undef;
$_[0]{image_nsfw} = !$_[0]{image} ? FALSE : !$_[0]{c_votecount} || $_[0]{c_sexual_avg} > 0.4 || $_[0]{c_violence_avg} > 0.4 ? TRUE : FALSE;
$_[0]{image_flagging} = image_flagging $_[0]{image}, $_[0];
},
@@ -507,14 +507,14 @@ my %GET_VN = (
]],
},
screens => {
- fetch => [[ 'id', 'SELECT vs.id AS vid, vndbid_num(vs.scr) AS image, vs.rid, s.width, s.height, s.c_sexual_avg, s.c_violence_avg, s.c_votecount
+ fetch => [[ 'id', 'SELECT vs.id AS vid, vs.scr, vs.rid, s.width, s.height, s.c_sexual_avg, s.c_violence_avg, s.c_votecount
FROM vn_screenshots vs JOIN images s ON s.id = vs.scr WHERE vs.id IN(%s)',
sub { my($r, $n) = @_;
for my $i (@$r) {
$i->{screens} = [ grep $i->{id} == $_->{vid}, @$n ];
}
for (@$n) {
- $_->{image} = sprintf '%s/sf/%02d/%d.jpg', config->{url_static}, $_->{image}%100, $_->{image};
+ $_->{image} = imgurl delete $_->{scr};
$_->{rid} *= 1;
$_->{nsfw} = !$_->{c_votecount} || $_->{c_sexual_avg} > 0.4 || $_->{c_violence_avg} > 0.4 ? TRUE : FALSE;
$_->{width} *= 1;
@@ -837,11 +837,11 @@ my %GET_CHARACTER = (
},
},
details => {
- select => 'c.alias AS aliases, vndbid_num(c.image) as image, i.c_sexual_avg, i.c_violence_avg, i.c_votecount, c."desc" AS description, c.age',
+ select => 'c.alias AS aliases, c.image, i.c_sexual_avg, i.c_violence_avg, i.c_votecount, c."desc" AS description, c.age',
proc => sub {
$_[0]{aliases} ||= undef;
$_[0]{description} ||= undef;
- $_[0]{image} = $_[0]{image} ? sprintf '%s/ch/%02d/%d.jpg', config->{url_static}, $_[0]{image}%100, $_[0]{image} : undef;
+ $_[0]{image} = $_[0]{image} ? imgurl $_[0]{image} : undef;
$_[0]{image_flagging} = image_flagging $_[0]{image}, $_[0];
$_[0]{age}*=1 if defined $_[0]{age};
},
diff --git a/lib/Multi/IRC.pm b/lib/Multi/IRC.pm
index 765fe0dc..02228d9d 100644
--- a/lib/Multi/IRC.pm
+++ b/lib/Multi/IRC.pm
@@ -10,7 +10,7 @@ use warnings;
use Multi::Core;
use AnyEvent::IRC::Client;
use AnyEvent::IRC::Util 'prefix_nick';
-use VNDBUtil 'normalize_query';
+use VNDB::Func 'normalize_query';
use VNDB::Config;
use TUWF::Misc 'uri_escape';
use POSIX 'strftime';
diff --git a/lib/Multi/Maintenance.pm b/lib/Multi/Maintenance.pm
index 57684f37..8515357d 100644
--- a/lib/Multi/Maintenance.pm
+++ b/lib/Multi/Maintenance.pm
@@ -9,7 +9,7 @@ use strict;
use warnings;
use Multi::Core;
use PerlIO::gzip;
-use VNDBUtil 'normalize_titles';
+use VNDB::Func 'normalize_titles';
use VNDB::Config;
diff --git a/lib/VNDB/Func.pm b/lib/VNDB/Func.pm
index a1ce84e5..3211f346 100644
--- a/lib/VNDB/Func.pm
+++ b/lib/VNDB/Func.pm
@@ -1,16 +1,23 @@
-
package VNDB::Func;
use strict;
use warnings;
-use TUWF 'uri_escape';
+use TUWF::Misc 'uri_escape';
use Exporter 'import';
use POSIX 'strftime';
-use VNDBUtil;
+use Encode 'encode_utf8';
+use Unicode::Normalize 'NFKD', 'compose';
+use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6';
use VNDB::Config;
use VNDB::Types;
use VNDB::BBCode;
-our @EXPORT = (@VNDBUtil::EXPORT, 'bb_format', qw|
+our @EXPORT = ('bb_format', qw|
+ shorten
+ resolution
+ gtintype
+ normalize_titles normalize_query
+ imgsize
+ norm_ip
minage
fmtvote fmtmedia fmtage fmtdate fmtrating fmtspoil
imgpath imgurl
@@ -20,6 +27,144 @@ our @EXPORT = (@VNDBUtil::EXPORT, 'bb_format', qw|
|);
+sub shorten {
+ my($str, $len) = @_;
+ return length($str) > $len ? substr($str, 0, $len-3).'...' : $str;
+}
+
+
+sub resolution {
+ my($x,$y) = @_;
+ ($x,$y) = ($x->{reso_x}, $x->{reso_y}) if ref $x;
+ $x ? "${x}x${y}" : $y == 1 ? 'Non-standard' : undef
+}
+
+
+# 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+//;
+ return undef if $_[0] !~ /^[0-9]{10,13}$/; # I've yet to see a UPC code shorter than 10 digits assigned to a game
+ $_[0] = ('0'x(12-length $_[0])) . $_[0] if length($_[0]) < 12; # pad with zeros to GTIN-12
+ my $c = shift;
+ return undef if $c !~ /^[0-9]{12,13}$/;
+ $c = "0$c" if length($c) == 12; # pad with another zero for GTIN-13
+
+ # 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 :)
+}
+
+
+# a rather aggressive normalization
+sub normalize {
+ local $_ = lc shift;
+ use utf8;
+ # Remove combining markings, except for kana.
+ # This effectively removes all accents from the characters (e.g. é -> e)
+ $_ = compose(NFKD($_) =~ s/(?<=[^ア-ンあ-ん])\pM//rg);
+ # remove some characters that have no significance when searching
+ tr/\r\n\t,_\-.~～〜∼ー῀:[]()%+!?#$"'`♥★☆♪†「」『』【】・‟“”‛’‘‚„«‹»›//d;
+ tr/@/a/;
+ tr/ı/i/; # Turkish lowercase i
+ s/&/and/;
+ # Consider wo and o the same thing (when used as separate word)
+ s/(?:^| )o(?:$| )/wo/g;
+ # Remove spaces. We're doing substring search, so let it cross word boundary to find more stuff
+ tr/ //d;
+ # remove commonly used release titles ("x Edition" and "x Version")
+ # this saves some space and speeds up the search
+ s/(?:
+ first|firstpress|firstpresslimited|limited|regular|standard
+ |package|boxed|download|complete|popular
+ |lowprice|best|cheap|budget
+ |special|trial|allages|fullvoice
+ |cd|cdr|cdrom|dvdrom|dvd|dvdpack|dvdpg|windows
+ |初回限定|初回|限定|通常|廉価|パッケージ|ダウンロード
+ )(?:edition|version|版|生産)//xg;
+ # other common things
+ s/fandisk/fandisc/g;
+ s/sempai/senpai/g;
+ no utf8;
+ return $_;
+}
+
+
+# normalizes each title and returns a concatenated string of unique titles
+sub normalize_titles {
+ my %t = map +(normalize($_), 1), @_;
+ return join ' ', grep $_, keys %t;
+}
+
+
+sub normalize_query {
+ my $q = shift;
+ # Consider wo and o the same thing (when used as separate word). Has to be
+ # done here (in addition to normalize()) to make it work in combination with
+ # double quote search.
+ $q =~ s/(^| )o($| )/$1wo$2/ig;
+ # remove spaces within quotes, so that it's considered as one search word
+ $q =~ s/"([^"]+)"/(my $s=$1)=~y{ }{}d;$s/ge;
+ # split into search words, normalize, and remove too short words
+ return map length($_)>=(/^[\x01-\x7F]+$/?2:1) ? quotemeta($_) : (), map normalize($_), split / /, $q;
+}
+
+
+# arguments: <image size>, <max dimensions>
+# returns the size of the thumbnail with the same aspect ratio as the full-size
+# image, but fits within the specified maximum dimensions
+sub imgsize {
+ my($ow, $oh, $sw, $sh) = @_;
+ return ($ow, $oh) if $ow <= $sw && $oh <= $sh;
+ if($ow/$oh > $sw/$sh) { # width is the limiting factor
+ $oh *= $sw/$ow;
+ $ow = $sw;
+ } else {
+ $ow *= $sh/$oh;
+ $oh = $sh;
+ }
+ return (int $ow, int $oh);
+}
+
+
+# Normalized IP address to use for duplicate detection/throttling. For IPv4
+# this is the /23 subnet (is this enough?), for IPv6 the /48 subnet, with the
+# least significant bits of the address zero'd.
+sub norm_ip {
+ my $ip = shift;
+
+ # There's a whole bunch of IP manipulation modules on CPAN, but many seem
+ # quite bloated and still don't offer the functionality to return an IP
+ # with its mask applied (admittedly not a common operation). The libc
+ # socket functions will do fine in parsing and formatting addresses, and
+ # the actual masking is quite trivial in binary form.
+ my $v4 = inet_pton AF_INET, $ip;
+ if($v4) {
+ $v4 =~ s/(..)(.)./$1 . chr(ord($2) & 254) . "\0"/se;
+ return inet_ntop AF_INET, $v4;
+ }
+
+ $ip = inet_pton AF_INET6, $ip;
+ return '::' if !$ip;
+ $ip =~ s/^(.{6}).+$/$1 . "\0"x10/se;
+ return inet_ntop AF_INET6, $ip;
+}
+
+
sub minage {
my($a, $ex) = @_;
$a = $AGE_RATING{$a};
diff --git a/lib/VNDBUtil.pm b/lib/VNDBUtil.pm
deleted file mode 100644
index b9b94a3c..00000000
--- a/lib/VNDBUtil.pm
+++ /dev/null
@@ -1,153 +0,0 @@
-# Misc. utility functions, these do not rely on TUWF or AnyEvent and can be used from any script
-
-package VNDBUtil;
-
-use strict;
-use warnings;
-use Exporter 'import';
-use Encode 'encode_utf8';
-use Unicode::Normalize 'NFKD', 'compose';
-use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6';
-
-our @EXPORT = qw|shorten resolution gtintype normalize_titles normalize_query imgsize norm_ip|;
-
-
-sub shorten {
- my($str, $len) = @_;
- return length($str) > $len ? substr($str, 0, $len-3).'...' : $str;
-}
-
-
-sub resolution {
- my($x,$y) = @_;
- ($x,$y) = ($x->{reso_x}, $x->{reso_y}) if ref $x;
- $x ? "${x}x${y}" : $y == 1 ? 'Non-standard' : undef
-}
-
-
-# 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+//;
- return undef if $_[0] !~ /^[0-9]{10,13}$/; # I've yet to see a UPC code shorter than 10 digits assigned to a game
- $_[0] = ('0'x(12-length $_[0])) . $_[0] if length($_[0]) < 12; # pad with zeros to GTIN-12
- my $c = shift;
- return undef if $c !~ /^[0-9]{12,13}$/;
- $c = "0$c" if length($c) == 12; # pad with another zero for GTIN-13
-
- # 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 :)
-}
-
-
-# a rather aggressive normalization
-sub normalize {
- local $_ = lc shift;
- use utf8;
- # Remove combining markings, except for kana.
- # This effectively removes all accents from the characters (e.g. é -> e)
- $_ = compose(NFKD($_) =~ s/(?<=[^ア-ンあ-ん])\pM//rg);
- # remove some characters that have no significance when searching
- tr/\r\n\t,_\-.~～〜∼ー῀:[]()%+!?#$"'`♥★☆♪†「」『』【】・‟“”‛’‘‚„«‹»›//d;
- tr/@/a/;
- tr/ı/i/; # Turkish lowercase i
- s/&/and/;
- # Consider wo and o the same thing (when used as separate word)
- s/(?:^| )o(?:$| )/wo/g;
- # Remove spaces. We're doing substring search, so let it cross word boundary to find more stuff
- tr/ //d;
- # remove commonly used release titles ("x Edition" and "x Version")
- # this saves some space and speeds up the search
- s/(?:
- first|firstpress|firstpresslimited|limited|regular|standard
- |package|boxed|download|complete|popular
- |lowprice|best|cheap|budget
- |special|trial|allages|fullvoice
- |cd|cdr|cdrom|dvdrom|dvd|dvdpack|dvdpg|windows
- |初回限定|初回|限定|通常|廉価|パッケージ|ダウンロード
- )(?:edition|version|版|生産)//xg;
- # other common things
- s/fandisk/fandisc/g;
- s/sempai/senpai/g;
- no utf8;
- return $_;
-}
-
-
-# normalizes each title and returns a concatenated string of unique titles
-sub normalize_titles {
- my %t = map +(normalize($_), 1), @_;
- return join ' ', grep $_, keys %t;
-}
-
-
-sub normalize_query {
- my $q = shift;
- # Consider wo and o the same thing (when used as separate word). Has to be
- # done here (in addition to normalize()) to make it work in combination with
- # double quote search.
- $q =~ s/(^| )o($| )/$1wo$2/ig;
- # remove spaces within quotes, so that it's considered as one search word
- $q =~ s/"([^"]+)"/(my $s=$1)=~y{ }{}d;$s/ge;
- # split into search words, normalize, and remove too short words
- return map length($_)>=(/^[\x01-\x7F]+$/?2:1) ? quotemeta($_) : (), map normalize($_), split / /, $q;
-}
-
-
-# arguments: <image size>, <max dimensions>
-# returns the size of the thumbnail with the same aspect ratio as the full-size
-# image, but fits within the specified maximum dimensions
-sub imgsize {
- my($ow, $oh, $sw, $sh) = @_;
- return ($ow, $oh) if $ow <= $sw && $oh <= $sh;
- if($ow/$oh > $sw/$sh) { # width is the limiting factor
- $oh *= $sw/$ow;
- $ow = $sw;
- } else {
- $ow *= $sh/$oh;
- $oh = $sh;
- }
- return (int $ow, int $oh);
-}
-
-
-# Normalized IP address to use for duplicate detection/throttling. For IPv4
-# this is the /23 subnet (is this enough?), for IPv6 the /48 subnet, with the
-# least significant bits of the address zero'd.
-sub norm_ip {
- my $ip = shift;
-
- # There's a whole bunch of IP manipulation modules on CPAN, but many seem
- # quite bloated and still don't offer the functionality to return an IP
- # with its mask applied (admittedly not a common operation). The libc
- # socket functions will do fine in parsing and formatting addresses, and
- # the actual masking is quite trivial in binary form.
- my $v4 = inet_pton AF_INET, $ip;
- if($v4) {
- $v4 =~ s/(..)(.)./$1 . chr(ord($2) & 254) . "\0"/se;
- return inet_ntop AF_INET, $v4;
- }
-
- $ip = inet_pton AF_INET6, $ip;
- return '::' if !$ip;
- $ip =~ s/^(.{6}).+$/$1 . "\0"x10/se;
- return inet_ntop AF_INET6, $ip;
-}
-
-1;
-
diff --git a/lib/VNWeb/Auth.pm b/lib/VNWeb/Auth.pm
index 5231d80e..694ea18a 100644
--- a/lib/VNWeb/Auth.pm
+++ b/lib/VNWeb/Auth.pm
@@ -30,7 +30,7 @@ use Crypt::ScryptKDF 'scrypt_raw';
use Encode 'encode_utf8';
use MIME::Base64 'encode_base64url';
-use VNDBUtil 'norm_ip';
+use VNDB::Func 'norm_ip';
use VNDB::Config;
use VNWeb::DB;
diff --git a/lib/VNWeb/Prelude.pm b/lib/VNWeb/Prelude.pm
index f00c009b..a2bef7a5 100644
--- a/lib/VNWeb/Prelude.pm
+++ b/lib/VNWeb/Prelude.pm
@@ -10,11 +10,10 @@
# use List::Util 'min', 'max', 'sum';
# use POSIX 'ceil', 'floor', 'strftime';
#
-# use VNDBUtil;
# use VNDB::BBCode;
# use VNDB::Types;
# use VNDB::Config;
-# use VNDB::Func qw/fmtdate fmtage fmtvote fmtspoil fmtmedia minage resolution query_encode lang_attr md2html imgurl imgpath/;
+# use VNDB::Func;
# use VNDB::ExtLinks;
# use VNWeb::Auth;
# use VNWeb::HTML;
@@ -55,11 +54,10 @@ sub import {
use List::Util 'min', 'max', 'sum';
use POSIX 'ceil', 'floor', 'strftime';
- use VNDBUtil;
use VNDB::BBCode;
use VNDB::Types;
use VNDB::Config;
- use VNDB::Func qw/fmtdate fmtage fmtvote fmtspoil fmtmedia minage resolution query_encode lang_attr md2html imgurl imgpath/;
+ use VNDB::Func;
use VNDB::ExtLinks;
use VNWeb::Auth;
use VNWeb::HTML;
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-16 22:48:26 +0000