8a19841edf2e8307e6146efc74fa28fc99c2c0aa
[pr0n] / perl / update-image-cache.pl
1 #! /usr/bin/perl
2
3 # A small hack to recalculate all existing thumbnails (including mipmaps
4 # if you so desire), for use when we change something in the scaling/encoding
5 # pipeline.  You may want to run it piece by piece if you don't want huge
6 # incremental backups, though.
7
8 # Run as www-data, e.g. with "sudo -u www-data ./update-image-cache.pl".
9 # You can also give it arguments if you want to use multiple threads, with
10 # something like "update-image-cache.pl 0 4" to run as core 0 of four cores.
11 # Remember to adjust $threshold first in any case.
12
13 use lib qw(.);
14 use DBI;
15 use strict;
16 use warnings;
17
18 use Sesse::pr0n::Config;
19 eval {
20         require Sesse::pr0n::Config_local;
21 };
22
23 # Hack :-)
24 package Apache2::ServerUtil;
25 sub server {
26         return bless {};
27 }
28 sub log_error {
29         print STDERR $_[1], "\n";
30 }
31
32 package FakeApacheReq;
33 sub dir_config {
34         my $key = $_[1];
35         my %config = (
36                 ImageBase => '../',
37                 OverloadMode => 'off',
38                 OverloadEnableThreshold => '100000.0',
39         );
40         return $config{$key};
41 }
42 sub log {
43         return bless {};
44 }
45 sub info {
46         print STDERR $_[1], "\n";
47 }
48 sub warn {
49         print STDERR $_[1], "\n";
50 }
51 sub error {
52         print STDERR $_[1], "\n";
53 }
54 package main;
55 use Sesse::pr0n::Common;
56
57 sub byres {
58         my ($a, $b) = @_;
59         if ($a == -1 && $b != -1) {
60                 return -1;
61         }       
62         if ($a != -1 && $b == -1) {
63                 return 1;
64         }
65         return ($a <=> $b);
66 }
67
68 sub sort_res {
69         my (@res) = @_;
70         my @sr = sort { ($a->[0] != $b->[0]) ? (byres($a->[0], $b->[0])) : (byres($a->[1], $b->[1])) } @res;
71         my @ret = ();
72         for my $r (@sr) {
73                 push @ret, @$r;
74         }
75         return @ret;
76 }
77         
78 # Don't regenerate thumbnails that were made after this. Set this to approximately
79 # when you upgraded pr0n to the version with the new image processing code.
80 my $threshold = `date +%s -d '2009-10-24 11:30'`;
81 chomp $threshold;
82 my $regen_mipmaps = 0;
83 my $core_id = $ARGV[0] // 0;
84 my $num_cores = $ARGV[1] // 1;
85
86 my $dbh = DBI->connect("dbi:Pg:dbname=pr0n;host=" . $Sesse::pr0n::Config::db_host,
87         $Sesse::pr0n::Config::db_username, $Sesse::pr0n::Config::db_password)
88         or die "Couldn't connect to PostgreSQL database: " . DBI->errstr;
89 $dbh->{RaiseError} = 1;
90
91 my $r = bless {}, 'FakeApacheReq';
92
93 my $q = $dbh->prepare('SELECT id,filename,width,height FROM images WHERE id % ? = ? ORDER BY id DESC');
94 $q->execute($num_cores, $core_id);
95
96 while (my $ref = $q->fetchrow_hashref) {
97         my $id = $ref->{'id'};
98         my $dir = POSIX::floor($id / 256);
99
100         my @files = glob("../cache/$dir/$id-*.jpg");
101         if (!$regen_mipmaps) {
102                 @files = grep { !/mipmap/ } @files;
103         }
104         my @bothres = ();
105         my @boxres = ();
106         my @noboxres = ();
107         my $any_old = 0;
108         for my $c (@files) {
109                 my $mtime = (stat($c))[9];
110                 if ($mtime < $threshold) {
111                         $any_old = 1;
112                 }
113                 if ($c =~ /$id-(\d+)-(\d+)\.jpg/ || $c =~ /$id-(-1)-(-1)\.jpg/) {
114                         push @bothres, [$1, $2];
115                 } elsif ($c =~ /$id-(\d+)-(\d+)-nobox\.jpg/ || $c =~ /$id-(-1)-(-1)-nobox\.jpg/) {
116                         push @noboxres, [$1, $2];
117                 } elsif ($c =~ /$id-(\d+)-(\d+)-box\.png/ || $c =~ /$id-(-1)-(-1)-box\.png/) {
118                         push @boxres, [$1, $2];
119                 }
120         }
121         next unless $any_old;
122         unlink (@files);
123         if (scalar @bothres > 0) {
124                 Sesse::pr0n::Common::ensure_cached($r, $ref->{'filename'}, $id, $ref->{'width'}, $ref->{'height'}, 'both', 1, sort_res(@bothres));
125         }
126         if (scalar @noboxres > 0) {
127                 Sesse::pr0n::Common::ensure_cached($r, $ref->{'filename'}, $id, $ref->{'width'}, $ref->{'height'}, 'nobox', 1, sort_res(@noboxres));
128         }
129         if (scalar @boxres > 0) {
130                 Sesse::pr0n::Common::ensure_cached($r, $ref->{'filename'}, $id, $ref->{'width'}, $ref->{'height'}, 'box', 1, sort_res(@boxres));
131         }
132         
133         my @newfiles = glob("../cache/$dir/$id-*.jpg");
134         my %a = map { $_ => 1 } @files;
135         my %b = map { $_ => 1 } @newfiles;
136
137         for my $f (@files) {
138                 if (!exists($b{$f})) {
139                         print STDERR "Garbage-collected $f\n";
140                 }
141         }
142 }
143