Move from mod_perl to being a PSGI app.

You can still run under mod_perl if you want to, but the default configuration
is now PSGI via Starlet.

Unfortunately the nice meets_requirement() checks are no longer there,
but Varnish in front should handle that for us.

diff --git a/doc/README b/doc/README
index 6e19b1a32e70ba379be1b9604f1cb49b9d3768e9..ec68afaa5afe37cc1ae16329a58ba65c15426b33 100644 (file)
--- a/doc/README
+++ b/doc/README
@@ -5,85 +5,44 @@ any of the images on pr0n.sesse.net etc.) is licensed under the GNU General
 Public License, version 2. For the full license text, see the COPYING file.
 
 Documentation? Forget it; if you can't set it up, use something else. You can
 Public License, version 2. For the full license text, see the COPYING file.
 
 Documentation? Forget it; if you can't set it up, use something else. You can

-have a typical Apache 2 vhost snippet, though:
+have a typical Varnish snippet, though:
+
+backend pr0n {
+    .host = "127.0.0.1";
+    .port = "5015";
+}
+
+sub vcl_recv {
+    if (req.http.host == "pr0n.sesse.net") {
+        set req.backend_hint = pr0n;
+    }
+}
+
+sub vcl_deliver {
+    if (resp.http.x-varnish-host && resp.http.x-pr0n-purge) {
+        set resp.http.escaped-regex = regsuball(resp.http.x-pr0n-purge, "\\", "\\\\");
+        ban ( "obj.http.x-varnish-host == " + resp.http.x-varnish-host + " && obj.http.x-varnish-url ~ " + resp.http.escaped-regex );
+        unset resp.http.escaped-regex;
+    }
+    unset resp.http.x-varnish-host;
+    unset resp.http.x-varnish-url;
+    unset resp.http.x-pr0n-purge;
+}
+
+sub vcl_backend_response {
+    if (bereq.http.host == "pr0n.sesse.net") {
+        set beresp.ttl = 1w;
+        set beresp.http.x-varnish-host = bereq.http.host;
+        set beresp.http.x-varnish-url = bereq.url;
+        if (beresp.http.content-type ~ "^(text/html|text/plain|text/xml|text/css|application/x-javascript|application/javascript)") {
+            set beresp.do_gzip = true;
+        }
+    } else {
+        unset beresp.http.x-varnish-host;
+    }
+}
+
+To redeploy after changes:
+
+  sudo service pr0n reload && sudo varnishadm 'ban obj.http.x-varnish-host ~ "."'

 
 

-<VirtualHost *:8008>
-    ServerAdmin sgunderson@bigfoot.com
-    DocumentRoot /srv/pr0n.sesse.net
-    ServerName pr0n.sesse.net
-    ServerAlias pr0n.sesse.net bilder.knatten.com pannekake.samfundet.no
-
-    LogLevel info
-    ErrorLog /var/log/apache2/error-pr0n.sesse.net.log
-    CustomLog /var/log/apache2/access-pr0n.sesse.net.log combined
-
-    ServerSignature On
-    PerlSwitches -wT
-    
-    # Keep this on during debugging
-#    PerlModule Apache2::Reload
-#    PerlInitHandler Apache2::Reload
-#    PerlSetVar ReloadAll Off
-#    PerlSetVar ReloadModules "Sesse::pr0n::*"
-#    PerlSetVar ReloadConstantRedefineWarnings Off
-
-    # Share the loadavg module
-    PerlModule Sesse::pr0n::Overload
-
-    PerlSetVar ImageBase /srv/pr0n.sesse.net/
-    PerlSetVar TemplateBase /srv/pr0n.sesse.net/templates
-    PerlSetVar OverloadMode Off
-    PerlSetVar OverloadEnableThreshold 100.0
-    PerlSetVar OverloadDisableThreshold 5.0
-
-    # All URLs are handled by the central pr0n module
-    <Location />
-        SetHandler modperl
-        PerlResponseHandler Sesse::pr0n::pr0n
-    </Location>                                            
-</VirtualHost>
-
-<VirtualHost *:443>
-    ServerAdmin sgunderson@bigfoot.com
-    DocumentRoot /srv/pr0n.sesse.net
-    ServerName pr0n.sesse.net
-    ServerAlias pr0n.sesse.net bilder.knatten.com pannekake.samfundet.no
-
-    LogLevel info
-    ErrorLog /var/log/apache2/error-pr0n.sesse.net.log
-    CustomLog /var/log/apache2/access-pr0n.sesse.net.log combined
-
-    ServerSignature On
-    PerlSwitches -wT
-    
-    SSLEngine on
-    SSLCertificateFile ssl/pr0n.sesse.net.crt
-    SSLCertificateKeyFile ssl/pr0n.sesse.net.key
-    
-    # Keep this on during debugging
-#    PerlModule Apache2::Reload
-#    PerlInitHandler Apache2::Reload
-#    PerlSetVar ReloadAll Off
-#    PerlSetVar ReloadModules "Sesse::pr0n::*"
-#    PerlSetVar ReloadConstantRedefineWarnings Off
-
-    # Share the loadavg module
-    PerlModule Sesse::pr0n::Overload
-
-    PerlSetVar ImageBase /srv/pr0n.sesse.net/
-    PerlSetVar TemplateBase /srv/pr0n.sesse.net/templates
-    PerlSetVar OverloadMode Off
-    PerlSetVar OverloadEnableThreshold 100.0
-    PerlSetVar OverloadDisableThreshold 5.0
-
-    # All URLs are handled by the central pr0n module
-    <Location />
-        SetHandler modperl
-        PerlResponseHandler Sesse::pr0n::pr0n
-    </Location>                                            
-</VirtualHost>
-
-Also, mod_deflate is recommended; just install it and use the default
-configuration, and it will work transparently. (You might want to add
-text/css and application/x-javascript to the list of compressed
-formats, but it's not really _that_ important.)

diff --git a/doc/modules.txt b/doc/modules.txt
index c2acc001395bf7308a23e37c752a4ba667fd1f7b..c0b88a6aeef252e8167695c6b47ea47094cd7b74 100644 (file)
--- a/doc/modules.txt
+++ b/doc/modules.txt
@@ -1,8 +1,8 @@
 Program/module name         Debian package             Usage
 
 Program/module name         Debian package             Usage
 

-mod_perl2                   libapache2-mod-perl2       Running it all :-)
-apreq2                      libapache2-request-perl    Parsing CGI parameters
-                            libapache2-mod-apreq2
+Starlet                     starlet                    PSGI web server
+HTTP::Parser::XS            libhttp-parser-xs-perl     Faster Starlet
+IO::File::WithPath          libio-file-withpath-perl   Sending files

 PerlMagick                  perlmagick                 Scaling etc.
 MIME::Types                 libmime-types-perl         Sending the right MIME types
 DBD::Pg                     libdbd-pg-perl             PostgreSQL connection
 PerlMagick                  perlmagick                 Scaling etc.
 MIME::Types                 libmime-types-perl         Sending the right MIME types
 DBD::Pg                     libdbd-pg-perl             PostgreSQL connection

diff --git a/files/faq.html b/files/faq.html
index 34acc3dece9023773f2761030b731ab1026103f5..b509bd8e18fae503265b900ce92de5f7458cba10 100644 (file)
--- a/files/faq.html
+++ b/files/faq.html
@@ -87,10 +87,11 @@
       
     <p>pr0n currently runs on two Intel E5-2650v3 (2x10 cores at 2.30GHz) with 64GB RAM and
       SATA disks, with some SSDs in front for cache. (The server does a lot of other stuff besides running pr0n, of
       
     <p>pr0n currently runs on two Intel E5-2650v3 (2x10 cores at 2.30GHz) with 64GB RAM and
       SATA disks, with some SSDs in front for cache. (The server does a lot of other stuff besides running pr0n, of

-      course.) pr0n itself is a custom-made system by myself, tightly coupled
-      into <a href="http://www.apache.org/">Apache</a> 2.4,
-      <a href="http://perl.apache.org/">mod_perl</a> 2.0,
-      <a href="http://www.imagemagick.org/">ImageMagick</a> 6.x
+      course.) pr0n itself is a custom-made system by myself,
+      a <a href="http://search.cpan.org/~miyagawa/PSGI-1.102/PSGI.pod">PSGI</a>
+      app server running under <a href="http://search.cpan.org/dist/Starlet/">Starlet</a>
+      behind <a href="https://www.varnish-cache.org/">Varnish</a> 4.1,
+      using <a href="http://www.imagemagick.org/">ImageMagick</a> 6.x

       (as well as various other Perl modules) and
       <a href="http://git.sesse.net/?p=qscale">qscale</a>, using
       <a href="http://www.postgresql.org/">PostgreSQL</a> 9.4 as the back-end
       (as well as various other Perl modules) and
       <a href="http://git.sesse.net/?p=qscale">qscale</a>, using
       <a href="http://www.postgresql.org/">PostgreSQL</a> 9.4 as the back-end


@@ -148,7 +149,7 @@
       on IRC as Sesse on EFnet, IRCnet, Freenode or OFTC.</p>
 
     <hr />
       on IRC as Sesse on EFnet, IRCnet, Freenode or OFTC.</p>
 
     <hr />

-    <p class="footer">pr0n v2.81,
+    <p class="footer">pr0n v3.00-pre,

       &copy; 2004&ndash;2015 <a href="http://www.sesse.net/">Steinar H. Gunderson</a>.</p>
   </body>
 </html>
       &copy; 2004&ndash;2015 <a href="http://www.sesse.net/">Steinar H. Gunderson</a>.</p>
   </body>
 </html>

diff --git a/perl/Sesse/pr0n/Common.pm b/perl/Sesse/pr0n/Common.pm
index 435beeaa27b89653eb5cd17f6454f323374d2061..0569ef90fbd3bdb37a32c97a775e3759ac0ffb49 100644 (file)
--- a/perl/Sesse/pr0n/Common.pm
+++ b/perl/Sesse/pr0n/Common.pm
@@ -6,17 +6,12 @@ use Sesse::pr0n::Overload;
 use Sesse::pr0n::QscaleProxy;
 use Sesse::pr0n::Templates;
 
 use Sesse::pr0n::QscaleProxy;
 use Sesse::pr0n::Templates;
 

-use Apache2::RequestRec (); # for $r->content_type
-use Apache2::RequestIO ();  # for $r->print
-use Apache2::Const -compile => ':common';
-use Apache2::Log;
-use ModPerl::Util;
-

 use Carp;
 use Encode;
 use DBI;
 use DBD::Pg;
 use Image::Magick;
 use Carp;
 use Encode;
 use DBI;
 use DBD::Pg;
 use Image::Magick;

+use IO::String;

 use POSIX;
 use Digest::SHA;
 use Digest::HMAC_SHA1;
 use POSIX;
 use Digest::SHA;
 use Digest::HMAC_SHA1;


@@ -39,7 +34,7 @@ BEGIN {
                require Sesse::pr0n::Config_local;
        };
 
                require Sesse::pr0n::Config_local;
        };
 

-       $VERSION     = "v2.81";
+       $VERSION     = "v3.00-pre";

        @ISA         = qw(Exporter);
        @EXPORT      = qw(&error &dberror);
        %EXPORT_TAGS = qw();
        @ISA         = qw(Exporter);
        @EXPORT      = qw(&error &dberror);
        %EXPORT_TAGS = qw();


@@ -50,7 +45,7 @@ BEGIN {
                or die "Couldn't connect to PostgreSQL database: " . DBI->errstr;
        our $mimetypes = new MIME::Types;
        
                or die "Couldn't connect to PostgreSQL database: " . DBI->errstr;
        our $mimetypes = new MIME::Types;
        

-       Apache2::ServerUtil->server->log_error("Initializing pr0n $VERSION");
+       print STDERR "Initializing pr0n $VERSION\n";

 }
 END {
        our $dbh;
 }
 END {
        our $dbh;


@@ -66,42 +61,46 @@ sub error {
                $status = 500;
                $title = "Internal server error";
        }
                $status = 500;
                $title = "Internal server error";
        }

+
+       my $res = Plack::Response->new($status);
+       my $io = IO::String->new;

        
         $r->content_type('text/html; charset=utf-8');
        
         $r->content_type('text/html; charset=utf-8');

-       $r->status($status);

 
 

-        header($r, $title);
-       $r->print("    <p>Error: $err</p>\n");
-        footer($r);
+       header($r, $io, $title);
+       $io->print("    <p>Error: $err</p>\n");
+       footer($r, $io);

 
 

-       $r->log->error($err);
-       $r->log->error("Stack trace follows: " . Carp::longmess());
+       log_error($r, $err);
+       log_error($r, "Stack trace follows: " . Carp::longmess());

 
 

-       ModPerl::Util::exit();
+       $io->setpos(0);
+       $res->body($io);
+       return $res;

 }
 
 sub dberror {
        my ($r,$err) = @_;
 }
 
 sub dberror {
        my ($r,$err) = @_;

-       error($r, "$err (DB error: " . $dbh->errstr . ")");
+       return error($r, "$err (DB error: " . $dbh->errstr . ")");

 }
 
 sub header {
 }
 
 sub header {

-       my ($r,$title) = @_;
+       my ($r, $io, $title) = @_;

 
        $r->content_type("text/html; charset=utf-8");
 
        # Fetch quote if we're itk-bilder.samfundet.no
        my $quote = "";
 
        $r->content_type("text/html; charset=utf-8");
 
        # Fetch quote if we're itk-bilder.samfundet.no
        my $quote = "";

-       if ($r->get_server_name eq 'itk-bilder.samfundet.no') {
+       if (Sesse::pr0n::Common::get_server_name($r) eq 'itk-bilder.samfundet.no') {

                $quote = LWP::Simple::get("http://itk.samfundet.no/include/quotes.cli.php");
                $quote = "Error: Could not fetch quotes." if (!defined($quote));
        }
                $quote = LWP::Simple::get("http://itk.samfundet.no/include/quotes.cli.php");
                $quote = "Error: Could not fetch quotes." if (!defined($quote));
        }

-       Sesse::pr0n::Templates::print_template($r, "header", { title => $title, quotes => $quote });
+       Sesse::pr0n::Templates::print_template($r, $io, "header", { title => $title, quotes => $quote });

 }
 
 sub footer {
 }
 
 sub footer {

-       my ($r) = @_;
-       Sesse::pr0n::Templates::print_template($r, "footer",
+       my ($r, $io) = @_;
+       Sesse::pr0n::Templates::print_template($r, $io, "footer",

                { version => $Sesse::pr0n::Common::VERSION });
 }
 
                { version => $Sesse::pr0n::Common::VERSION });
 }
 


@@ -183,20 +182,20 @@ sub pretty_unescape {
 }
 
 sub print_link {
 }
 
 sub print_link {

-       my ($r, $title, $baseurl, $param, $defparam, $accesskey) = @_;
+       my ($io, $title, $baseurl, $param, $defparam, $accesskey) = @_;

        my $str = "<a href=\"$baseurl" . get_query_string($param, $defparam) . "\"";
        if (defined($accesskey) && length($accesskey) == 1) {
                $str .= " accesskey=\"$accesskey\"";
        }
        $str .= ">$title</a>";
        my $str = "<a href=\"$baseurl" . get_query_string($param, $defparam) . "\"";
        if (defined($accesskey) && length($accesskey) == 1) {
                $str .= " accesskey=\"$accesskey\"";
        }
        $str .= ">$title</a>";

-       $r->print($str);
+       $io->print($str);

 }
 
 sub get_dbh {
        # Check that we are alive
        if (!(defined($dbh) && $dbh->ping)) {
                # Try to reconnect
 }
 
 sub get_dbh {
        # Check that we are alive
        if (!(defined($dbh) && $dbh->ping)) {
                # Try to reconnect

-               Apache2::ServerUtil->server->log_error("Lost contact with PostgreSQL server, trying to reconnect...");
+               print STDERR "Lost contact with PostgreSQL server, trying to reconnect...\n";

                unless ($dbh = DBI->connect("dbi:Pg:dbname=pr0n;host=" . $Sesse::pr0n::Config::db_host,
                        $Sesse::pr0n::Config::db_username, $Sesse::pr0n::Config::db_password)) {
                        $dbh = undef;
                unless ($dbh = DBI->connect("dbi:Pg:dbname=pr0n;host=" . $Sesse::pr0n::Config::db_host,
                        $Sesse::pr0n::Config::db_username, $Sesse::pr0n::Config::db_password)) {
                        $dbh = undef;


@@ -207,15 +206,10 @@ sub get_dbh {
        return $dbh;
 }
 
        return $dbh;
 }
 

-sub get_base {
-       my $r = shift;
-       return $r->dir_config('ImageBase');
-}
-                               

 sub get_disk_location {
        my ($r, $id) = @_;
         my $dir = POSIX::floor($id / 256);
 sub get_disk_location {
        my ($r, $id) = @_;
         my $dir = POSIX::floor($id / 256);

-       return get_base($r) . "images/$dir/$id.jpg";
+       return $Sesse::pr0n::Config::image_base . "images/$dir/$id.jpg";

 }
 
 sub get_cache_location {
 }
 
 sub get_cache_location {


@@ -223,14 +217,14 @@ sub get_cache_location {
         my $dir = POSIX::floor($id / 256);
 
        if ($infobox eq 'both') {
         my $dir = POSIX::floor($id / 256);
 
        if ($infobox eq 'both') {

-               return get_base($r) . "cache/$dir/$id-$width-$height.jpg";
+               return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height.jpg";

        } elsif ($infobox eq 'nobox') {
        } elsif ($infobox eq 'nobox') {

-               return get_base($r) . "cache/$dir/$id-$width-$height-nobox.jpg";
+               return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-nobox.jpg";

        } else {
                if ($dpr == 1) {
        } else {
                if ($dpr == 1) {

-                       return get_base($r) . "cache/$dir/$id-$width-$height-box.png";
+                       return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-box.png";

                } else {
                } else {

-                       return get_base($r) . "cache/$dir/$id-$width-$height-box\@$dpr.png";
+                       return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-$width-$height-box\@$dpr.png";

                }
        }
 }
                }
        }
 }


@@ -239,15 +233,15 @@ sub ensure_disk_location_exists {
        my ($r, $id) = @_;
        my $dir = POSIX::floor($id / 256);
 
        my ($r, $id) = @_;
        my $dir = POSIX::floor($id / 256);
 

-       my $img_dir = get_base($r) . "/images/$dir/";
+       my $img_dir = $Sesse::pr0n::Config::image_base . "/images/$dir/";

        if (! -d $img_dir) {
        if (! -d $img_dir) {

-               $r->log->info("Need to create new image directory $img_dir");
+               log_info($r, "Need to create new image directory $img_dir");

                mkdir($img_dir) or die "Couldn't create new image directory $img_dir";
        }
 
                mkdir($img_dir) or die "Couldn't create new image directory $img_dir";
        }
 

-       my $cache_dir = get_base($r) . "/cache/$dir/";
+       my $cache_dir = $Sesse::pr0n::Config::image_base . "/cache/$dir/";

        if (! -d $cache_dir) {
        if (! -d $cache_dir) {

-               $r->log->info("Need to create new cache directory $cache_dir");
+               log_info($r, "Need to create new cache directory $cache_dir");

                mkdir($cache_dir) or die "Couldn't create new image directory $cache_dir";
        }
 }
                mkdir($cache_dir) or die "Couldn't create new image directory $cache_dir";
        }
 }


@@ -256,7 +250,7 @@ sub get_mipmap_location {
        my ($r, $id, $width, $height) = @_;
         my $dir = POSIX::floor($id / 256);
 
        my ($r, $id, $width, $height) = @_;
         my $dir = POSIX::floor($id / 256);
 

-       return get_base($r) . "cache/$dir/$id-mipmap-$width-$height.jpg";
+       return $Sesse::pr0n::Config::image_base . "cache/$dir/$id-mipmap-$width-$height.jpg";

 }
 
 sub update_image_info {
 }
 
 sub update_image_info {


@@ -342,25 +336,25 @@ sub check_access {
        
        #return qw(sesse Sesse);
 
        
        #return qw(sesse Sesse);
 

-       my $auth = $r->headers_in->{'authorization'};
+       my $auth = $r->header('authorization');

        if (!defined($auth)) {
        if (!defined($auth)) {

-               output_401($r);

                return undef;
        } 
        if ($auth =~ /^Basic ([a-zA-Z0-9+\/]+=*)$/) {
                return check_basic_auth($r, $1);
        }       
                return undef;
        } 
        if ($auth =~ /^Basic ([a-zA-Z0-9+\/]+=*)$/) {
                return check_basic_auth($r, $1);
        }       

-       output_401($r);

        return undef;
 }
 
        return undef;
 }
 

-sub output_401 {
-       my ($r, %options) = @_;
-       $r->content_type('text/plain; charset=utf-8');
-       $r->status(401);
-       $r->headers_out->{'www-authenticate'} = 'Basic realm="pr0n.sesse.net"';
+sub generate_401 {
+       my ($r) = @_;
+       my $res = Plack::Response->new(401);
+       $res->content_type('text/plain; charset=utf-8');
+       $res->status(401);
+       $res->header('WWW-Authenticate' => 'Basic realm="pr0n.sesse.net"');

 
 

-       $r->print("Need authorization\n");
+       $res->body("Need authorization\n");
+       return $res;

 }
 
 sub check_basic_auth {
 }
 
 sub check_basic_auth {


@@ -370,7 +364,7 @@ sub check_basic_auth {
        my ($user, $takenby) = extract_takenby($raw_user);
 
        my $ref = $dbh->selectrow_hashref('SELECT sha1password,cryptpassword FROM users WHERE username=? AND vhost=?',
        my ($user, $takenby) = extract_takenby($raw_user);
 
        my $ref = $dbh->selectrow_hashref('SELECT sha1password,cryptpassword FROM users WHERE username=? AND vhost=?',

-               undef, $user, $r->get_server_name);
+               undef, $user, Sesse::pr0n::Common::get_server_name($r));

        my ($sha1_matches, $bcrypt_matches) = (0, 0);
        if (defined($ref) && defined($ref->{'sha1password'})) {
                $sha1_matches = (Digest::SHA::sha1_base64($pass) eq $ref->{'sha1password'});
        my ($sha1_matches, $bcrypt_matches) = (0, 0);
        if (defined($ref) && defined($ref->{'sha1password'})) {
                $sha1_matches = (Digest::SHA::sha1_base64($pass) eq $ref->{'sha1password'});


@@ -381,11 +375,10 @@ sub check_basic_auth {
 
        if (!defined($ref) || (!$sha1_matches && !$bcrypt_matches)) {
                $r->content_type('text/plain; charset=utf-8');
 
        if (!defined($ref) || (!$sha1_matches && !$bcrypt_matches)) {
                $r->content_type('text/plain; charset=utf-8');

-               $r->log->warn("Authentication failed for $user/$takenby");
-               output_401($r);
+               log_warn($r, "Authentication failed for $user/$takenby");

                return undef;
        }
                return undef;
        }

-       $r->log->info("Authentication succeeded for $user/$takenby");
+       log_info($r, "Authentication succeeded for $user/$takenby");

 
        # Make sure we can use bcrypt authentication in the future with this password.
        # Also remove old-style SHA1 password when we migrate.
 
        # Make sure we can use bcrypt authentication in the future with this password.
        # Also remove old-style SHA1 password when we migrate.


@@ -394,9 +387,9 @@ sub check_basic_auth {
                my $hash = "\$2a\$07\$" . Crypt::Eksblowfish::Bcrypt::en_base64($salt);
                my $cryptpassword = Crypt::Eksblowfish::Bcrypt::bcrypt($pass, $hash);
                $dbh->do('UPDATE users SET sha1password=NULL,cryptpassword=? WHERE username=? AND vhost=?',
                my $hash = "\$2a\$07\$" . Crypt::Eksblowfish::Bcrypt::en_base64($salt);
                my $cryptpassword = Crypt::Eksblowfish::Bcrypt::bcrypt($pass, $hash);
                $dbh->do('UPDATE users SET sha1password=NULL,cryptpassword=? WHERE username=? AND vhost=?',

-                       undef, $cryptpassword, $user, $r->get_server_name)
+                       undef, $cryptpassword, $user, Sesse::pr0n::Common::get_server_name($r))

                        or die "Couldn't update: " . $dbh->errstr;
                        or die "Couldn't update: " . $dbh->errstr;

-               $r->log->info("Updated bcrypt hash for $user");
+               log_info($r, "Updated bcrypt hash for $user");

        }
 
        return ($user, $takenby);
        }
 
        return ($user, $takenby);


@@ -535,7 +528,7 @@ sub make_mipmap {
                        } else {
                                $cimg = $img->Clone();
                        }
                        } else {
                                $cimg = $img->Clone();
                        }

-                       $r->log->info("Making mipmap for $id: " . $mmres->[0] . " x " . $mmres->[1]);
+                       log_info($r, "Making mipmap for $id: " . $mmres->[0] . " x " . $mmres->[1]);

                        $cimg->Resize(width=>$mmres->[0], height=>$mmres->[1], filter=>'Lanczos', 'sampling-factor'=>'1x1');
                        $cimg->Strip();
                        my $err = $cimg->write(
                        $cimg->Resize(width=>$mmres->[0], height=>$mmres->[1], filter=>'Lanczos', 'sampling-factor'=>'1x1');
                        $cimg->Strip();
                        my $err = $cimg->write(


@@ -605,7 +598,7 @@ sub read_original_image {
        }
        
        if ($err) {
        }
        
        if ($err) {

-               $r->log->warn("$physical_fname: $err");
+               log_warn($r, "$physical_fname: $err");

                $err =~ /(\d+)/;
                if ($1 >= 400) {
                        undef $magick;
                $err =~ /(\d+)/;
                if ($1 >= 400) {
                        undef $magick;


@@ -642,7 +635,7 @@ sub ensure_cached {
                # If we are in overload mode (aka Slashdot mode), refuse to generate
                # new thumbnails.
                if (Sesse::pr0n::Overload::is_in_overload($r)) {
                # If we are in overload mode (aka Slashdot mode), refuse to generate
                # new thumbnails.
                if (Sesse::pr0n::Overload::is_in_overload($r)) {

-                       $r->log->warn("In overload mode, not scaling $id to $xres x $yres");
+                       log_warn($r, "In overload mode, not scaling $id to $xres x $yres");

                        error($r, 'System is in overload mode, not doing any scaling');
                }
 
                        error($r, 'System is in overload mode, not doing any scaling');
                }
 


@@ -692,7 +685,7 @@ sub ensure_cached {
                        }
                                
                        $err = $img->write(filename => $cachename, quality => 90, depth => 8);
                        }
                                
                        $err = $img->write(filename => $cachename, quality => 90, depth => 8);

-                       $r->log->info("New infobox cache: $width x $height for $id.jpg");
+                       log_info($r, "New infobox cache: $width x $height for $id.jpg");

                        
                        return ($cachename, 'image/png');
                }
                        
                        return ($cachename, 'image/png');
                }


@@ -757,12 +750,12 @@ sub ensure_cached {
 
                        ($xres, $yres) = ($nxres, $nyres);
 
 
                        ($xres, $yres) = ($nxres, $nyres);
 

-                       $r->log->info("New cache: $nwidth x $nheight for $id.jpg");
+                       log_info($r, "New cache: $nwidth x $nheight for $id.jpg");

                }
                
                undef $img;
                if ($err) {
                }
                
                undef $img;
                if ($err) {

-                       $r->log->warn("$fname: $err");
+                       log_warn($r, "$fname: $err");

                        $err =~ /(\d+)/;
                        if ($1 >= 400) {
                                #@$magick = ();
                        $err =~ /(\d+)/;
                        if ($1 >= 400) {
                                #@$magick = ();


@@ -773,7 +766,7 @@ sub ensure_cached {
        
        # Update the SQL database if it doesn't contain the required info
        if (!defined($dbwidth) && defined($new_dbwidth)) {
        
        # Update the SQL database if it doesn't contain the required info
        if (!defined($dbwidth) && defined($new_dbwidth)) {

-               $r->log->info("Updating width/height for $id: $new_dbwidth x $new_dbheight");
+               log_info($r, "Updating width/height for $id: $new_dbwidth x $new_dbheight");

                update_image_info($r, $id, $new_dbwidth, $new_dbheight);
        }
 
                update_image_info($r, $id, $new_dbwidth, $new_dbheight);
        }
 


@@ -963,7 +956,7 @@ sub gcd {
 }
 
 sub add_new_event {
 }
 
 sub add_new_event {

-       my ($r, $dbh, $id, $date, $desc) = @_;
+       my ($r, $res, $dbh, $id, $date, $desc) = @_;

        my @errors = ();
 
        if (!defined($id) || $id =~ /^\s*$/ || $id !~ /^([a-zA-Z0-9-]+)$/) {
        my @errors = ();
 
        if (!defined($id) || $id =~ /^\s*$/ || $id !~ /^([a-zA-Z0-9-]+)$/) {


@@ -980,14 +973,14 @@ sub add_new_event {
                return @errors;
        }
                
                return @errors;
        }
                

-       my $vhost = $r->get_server_name;
+       my $vhost = Sesse::pr0n::Common::get_server_name($r);

        $dbh->do("INSERT INTO events (event,date,name,vhost) VALUES (?,?,?,?)",
                undef, $id, $date, $desc, $vhost)
                or return ("Kunne ikke sette inn ny hendelse" . $dbh->errstr);
        $dbh->do("INSERT INTO last_picture_cache (vhost,event,last_picture) VALUES (?,?,NULL)",
                undef, $vhost, $id)
                or return ("Kunne ikke sette inn ny cache-rad" . $dbh->errstr);
        $dbh->do("INSERT INTO events (event,date,name,vhost) VALUES (?,?,?,?)",
                undef, $id, $date, $desc, $vhost)
                or return ("Kunne ikke sette inn ny hendelse" . $dbh->errstr);
        $dbh->do("INSERT INTO last_picture_cache (vhost,event,last_picture) VALUES (?,?,NULL)",
                undef, $vhost, $id)
                or return ("Kunne ikke sette inn ny cache-rad" . $dbh->errstr);

-       purge_cache($r, "/");
+       purge_cache($r, $res, "/");

 
        return ();
 }
 
        return ();
 }


@@ -1011,12 +1004,12 @@ sub guess_charset {
 # regex tacked onto a request into something useful. The elements given in
 # should not be regexes, though, as e.g. Squid will not be able to handle that.
 sub purge_cache {
 # regex tacked onto a request into something useful. The elements given in
 # should not be regexes, though, as e.g. Squid will not be able to handle that.
 sub purge_cache {

-       my ($r, @elements) = @_;
+       my ($r, $res, @elements) = @_;

        return if (scalar @elements == 0);
 
        my @pe = ();
        for my $elem (@elements) {
        return if (scalar @elements == 0);
 
        my @pe = ();
        for my $elem (@elements) {

-               $r->log->info("Purging $elem");
+               log_info($r, "Purging $elem");

                (my $e = $elem) =~ s/[.+*|()]/\\$&/g;
                push @pe, $e;
        }
                (my $e = $elem) =~ s/[.+*|()]/\\$&/g;
                push @pe, $e;
        }


@@ -1028,7 +1021,7 @@ sub purge_cache {
                $regex .= "(" . join('|', @pe) . ")";
        }
        $regex .= "(\\?.*)?\$";
                $regex .= "(" . join('|', @pe) . ")";
        }
        $regex .= "(\\?.*)?\$";

-       $r->headers_out->{'X-Pr0n-Purge'} = $regex;
+       $res->header('X-Pr0n-Purge' => $regex);

 }
                                
 # Find a list of all cache URLs for a given image, given what we have on disk.
 }
                                
 # Find a list of all cache URLs for a given image, given what we have on disk.


@@ -1046,7 +1039,7 @@ sub get_all_cache_urls {
        my $filename = $ref->{'filename'};
        $q->finish;
 
        my $filename = $ref->{'filename'};
        $q->finish;
 

-       my $base = get_base($r) . "cache/$dir";
+       my $base = $Sesse::pr0n::Config::image_base . "cache/$dir";

        for my $file (<$base/$id-*>) {
                my $fname = File::Basename::basename($file);
                if ($fname =~ /^$id-mipmap-.*\.jpg$/) {
        for my $file (<$base/$id-*>) {
                my $fname = File::Basename::basename($file);
                if ($fname =~ /^$id-mipmap-.*\.jpg$/) {


@@ -1062,13 +1055,54 @@ sub get_all_cache_urls {
                } elsif ($fname =~ /^$id-(\d+)-(\d+)-box\.png$/) {
                        push @ret, "/$event/$1x$2/box/$filename";
                } else {
                } elsif ($fname =~ /^$id-(\d+)-(\d+)-box\.png$/) {
                        push @ret, "/$event/$1x$2/box/$filename";
                } else {

-                       $r->log->warn("Couldn't find a purging URL for $fname");
+                       log_warn($r, "Couldn't find a purging URL for $fname");

                }
        }
 
        return @ret;
 }
 
                }
        }
 
        return @ret;
 }
 

+sub set_last_modified {
+       my ($res, $mtime) = @_;
+
+       my $str = POSIX::strftime("%a, %d %b %Y %H:%M:%S %Z", localtime($mtime));
+       $res->headers({ 'Last-Modified' => $str });
+}
+
+sub get_server_name {
+       my $r = shift;
+       my $host = $r->env->{'HTTP_HOST'};
+       $host =~ s/:.*//;
+       return $host;
+}
+
+sub log_info {
+       my ($r, $msg) = @_;
+       if (defined($r->logger)) {
+               $r->logger->({ level => 'info', message => $msg });
+       } else {
+               print STDERR "[INFO] $msg\n";
+       }
+}
+
+sub log_warn {
+       my ($r, $msg) = @_;
+       if (defined($r->logger)) {
+               $r->logger->({ level => 'warn', message => $msg });
+       } else {
+               print STDERR "[WARN] $msg\n";
+       }
+}
+
+sub log_error {
+       my ($r, $msg) = @_;
+       if (defined($r->logger)) {
+               $r->logger->({ level => 'error', message => $msg });
+       } else {
+               print STDERR "[ERROR] $msg\n";
+       }
+}
+

 1;
 
 
 1;
 
 

diff --git a/perl/Sesse/pr0n/Config.pm b/perl/Sesse/pr0n/Config.pm
index e267c99b51cf2388a8b9d08f12bab2194376b222..4e1d50cab9619de5cbd3bab0a1e211f3dd91c99a 100644 (file)
--- a/perl/Sesse/pr0n/Config.pm
+++ b/perl/Sesse/pr0n/Config.pm
@@ -2,10 +2,6 @@
 # Copy this file to Config-local.pm and change the values there to
 # suit your own needs.
 #
 # Copy this file to Config-local.pm and change the values there to
 # suit your own needs.
 #

-# Note that most configuration is done in your vhost; this isn't,
-# because it's persistent between sessions and we don't have access
-# to the Apache configuration data then.
-#

 package Sesse::pr0n::Config;
 use strict;
 use warnings;
 package Sesse::pr0n::Config;
 use strict;
 use warnings;


@@ -14,4 +10,10 @@ our $db_host = '127.0.0.1';
 our $db_username = 'pr0n';
 our $db_password = '';
 
 our $db_username = 'pr0n';
 our $db_password = '';
 

+our $image_base = '/srv/pr0n.sesse.net/';
+our $template_base = '/srv/pr0n.sesse.net/templates';
+our $overload_mode = 0;
+our $overload_enable_threshold = 100.0;
+our $overload_disable_threshold = 30.0;
+

 1;
 1;

diff --git a/perl/Sesse/pr0n/Image.pm b/perl/Sesse/pr0n/Image.pm
index 372a9b19e5756a2ca85bd44949c5c2e2b623c7e0..4f6360a6605f001b1e3a5ace4fc8494490c0f785 100644 (file)
--- a/perl/Sesse/pr0n/Image.pm
+++ b/perl/Sesse/pr0n/Image.pm
@@ -16,12 +16,12 @@ sub handler {
        # Find the event and file name
        my ($event,$filename,$xres,$yres,$dpr);
        my $infobox = 'both';
        # Find the event and file name
        my ($event,$filename,$xres,$yres,$dpr);
        my $infobox = 'both';

-       if ($r->uri =~ m#^/([a-zA-Z0-9-]+)/original/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) {
+       if ($r->path_info =~ m#^/([a-zA-Z0-9-]+)/original/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) {

                $event = $1;
                $filename = $3;
                $infobox = 'nobox' if (defined($2) && $2 eq 'nobox/');
                $infobox = 'box' if (defined($2) && $2 eq 'box/');
                $event = $1;
                $filename = $3;
                $infobox = 'nobox' if (defined($2) && $2 eq 'nobox/');
                $infobox = 'box' if (defined($2) && $2 eq 'box/');

-       } elsif ($r->uri =~ m#^/([a-zA-Z0-9-]+)/(\d+)x(\d+)(?:\@(\d+(?:\.\d+)?))?/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) {
+       } elsif ($r->path_info =~ m#^/([a-zA-Z0-9-]+)/(\d+)x(\d+)(?:\@(\d+(?:\.\d+)?))?/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) {

                $event = $1;
                $filename = $6;
                $xres = $2;
                $event = $1;
                $filename = $6;
                $xres = $2;


@@ -29,7 +29,7 @@ sub handler {
                $dpr = $4;
                $infobox = 'nobox' if (defined($5) && $5 eq 'nobox/');
                $infobox = 'box' if (defined($5) && $5 eq 'box/');
                $dpr = $4;
                $infobox = 'nobox' if (defined($5) && $5 eq 'nobox/');
                $infobox = 'box' if (defined($5) && $5 eq 'box/');

-       } elsif ($r->uri =~ m#^/([a-zA-Z0-9-]+)/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) {
+       } elsif ($r->path_info =~ m#^/([a-zA-Z0-9-]+)/((?:no)?box/)?([a-zA-Z0-9._()-]+)$#) {

                $event = $1;
                $filename = $3;
                $xres = -1;
                $event = $1;
                $filename = $3;
                $xres = -1;


@@ -46,8 +46,8 @@ sub handler {
        
        # Look it up in the database
        my $ref = $dbh->selectrow_hashref('SELECT id,width,height FROM images WHERE event=? AND vhost=? AND filename=?',
        
        # Look it up in the database
        my $ref = $dbh->selectrow_hashref('SELECT id,width,height FROM images WHERE event=? AND vhost=? AND filename=?',

-               undef, $event, $r->get_server_name, $filename);
-       error($r, "Could not find $event/$filename", 404, "File not found") unless (defined($ref));
+               undef, $event, Sesse::pr0n::Common::get_server_name($r), $filename);
+       return error($r, "Could not find $event/$filename", 404, "File not found") unless (defined($ref));

 
        $id = $ref->{'id'};
        $dbwidth = $ref->{'width'};
 
        $id = $ref->{'id'};
        $dbwidth = $ref->{'width'};


@@ -57,25 +57,26 @@ sub handler {
        my ($fname, $mime_type) = Sesse::pr0n::Common::ensure_cached($r, $filename, $id, $dbwidth, $dbheight, $infobox, $dpr, $xres, $yres);
 
        # Output the image to the user
        my ($fname, $mime_type) = Sesse::pr0n::Common::ensure_cached($r, $filename, $id, $dbwidth, $dbheight, $infobox, $dpr, $xres, $yres);
 
        # Output the image to the user

+       my $res = Plack::Response->new(200);
+

        if (!defined($mime_type)) {
                $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename);
        }
        if (!defined($mime_type)) {
                $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename);
        }

-       $r->content_type($mime_type);
+       $res->content_type($mime_type);

        
        my (undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime) = stat($fname)
        
        my (undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime) = stat($fname)

-                or error($r, "stat of $fname: $!");
+                or return error($r, "stat of $fname: $!");

                
                

-       $r->set_content_length($size);
-       $r->set_last_modified($mtime);
-
-       # If the client can use cache, by all means do so
-       if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) {
-               return $rc;
-       }
+       $res->content_length($size);
+       Sesse::pr0n::Common::set_last_modified($res, $mtime);

 
 

-       $r->sendfile($fname);
+       # # If the client can use cache, by all means do so
+       #if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) {
+       #       return $rc;
+       #}

 
 

-       return Apache2::Const::OK;
+       $res->content(IO::File::WithPath->new($fname));
+       return $res;

 }
 
 1;
 }
 
 1;

diff --git a/perl/Sesse/pr0n/Index.pm b/perl/Sesse/pr0n/Index.pm
index fbe6d3f3d9cf0fa63ff4bcd85dce0c64816ea66c..8500f9be457bf88e089db1c2e879f563417e6cb4 100644 (file)
--- a/perl/Sesse/pr0n/Index.pm
+++ b/perl/Sesse/pr0n/Index.pm
@@ -3,22 +3,20 @@ use strict;
 use warnings;
 
 use Sesse::pr0n::Common qw(error dberror);
 use warnings;
 
 use Sesse::pr0n::Common qw(error dberror);

-use Apache2::Request;

 use POSIX;
 
 sub handler {
        my $r = shift;
 use POSIX;
 
 sub handler {
        my $r = shift;

-       my $apr = Apache2::Request->new($r);

        my $dbh = Sesse::pr0n::Common::get_dbh();
 
        my ($event, $abspath, $datesort, $tag);
        my $dbh = Sesse::pr0n::Common::get_dbh();
 
        my ($event, $abspath, $datesort, $tag);

-       if ($r->uri =~ /^\/\+all\/?/) {
+       if ($r->path_info =~ /^\/\+all\/?/) {

                $event = '+all';
                $abspath = 1;
                $tag = undef; 
 
                $datesort = 'DESC NULLS LAST';
                $event = '+all';
                $abspath = 1;
                $tag = undef; 
 
                $datesort = 'DESC NULLS LAST';

-       } elsif ($r->uri =~ /^\/\+tags\/([a-zA-Z0-9-]+)\/?$/) {
+       } elsif ($r->path_info =~ /^\/\+tags\/([a-zA-Z0-9-]+)\/?$/) {

                $tag = $1;
                $event = "+tags/$tag";
                $abspath = 1;
                $tag = $1;
                $event = "+tags/$tag";
                $abspath = 1;


@@ -26,8 +24,8 @@ sub handler {
                $datesort = 'DESC NULLS LAST';
        } else {
                # Find the event
                $datesort = 'DESC NULLS LAST';
        } else {
                # Find the event

-               $r->uri =~ /^\/([a-zA-Z0-9-]+)\/?$/
-                       or error($r, "Could not extract event");
+               $r->path_info =~ /^\/([a-zA-Z0-9-]+)\/?$/
+                       or return error($r, "Could not extract event");

                $event = $1;
                $abspath = 0;
                $tag = undef;
                $event = $1;
                $abspath = 0;
                $tag = undef;


@@ -35,17 +33,18 @@ sub handler {
        }
 
        # Fix common error: pr0n.sesse.net/event -> pr0n.sesse.net/event/
        }
 
        # Fix common error: pr0n.sesse.net/event -> pr0n.sesse.net/event/

-       if ($r->uri !~ /\/$/) {
-               $r->headers_out->{'location'} = $r->uri . "/";
-               return Apache2::Const::REDIRECT;
+       if ($r->path_info !~ /\/$/) {
+               my $res = Plack::Response->new(301);
+               $res->header('Location' => $r->path_info . "/");
+               return $res;

        }
 
        # Internal? (Ugly?) 
        }
 
        # Internal? (Ugly?) 

-       if ($r->get_server_name =~ /internal/ || $r->get_server_name =~ /skoyen\.bilder\.knatten\.com/ || $r->get_server_name =~ /lia\.heimdal\.org/) {
+       if (Sesse::pr0n::Common::get_server_name($r) =~ /internal/ ||
+           Sesse::pr0n::Common::get_server_name($r) =~ /skoyen\.bilder\.knatten\.com/ ||
+           Sesse::pr0n::Common::get_server_name($r) =~ /lia\.heimdal\.org/) {

                my $user = Sesse::pr0n::Common::check_access($r);
                my $user = Sesse::pr0n::Common::check_access($r);

-               if (!defined($user)) {
-                       return Apache2::Const::OK;
-               }
+               return Sesse::pr0n::Common::generate_401($r) if (!defined($user));

        }
 
        # Read the appropriate settings from the query string into the settings hash
        }
 
        # Read the appropriate settings from the query string into the settings hash


@@ -78,7 +77,7 @@ sub handler {
        
        # Any NEF files => default to processing
        my $ref = $dbh->selectrow_hashref("SELECT * FROM images WHERE vhost=? $where AND ( LOWER(filename) LIKE '%.nef' OR LOWER(filename) LIKE '%.cr2' ) LIMIT 1",
        
        # Any NEF files => default to processing
        my $ref = $dbh->selectrow_hashref("SELECT * FROM images WHERE vhost=? $where AND ( LOWER(filename) LIKE '%.nef' OR LOWER(filename) LIKE '%.cr2' ) LIMIT 1",

-               undef, $r->get_server_name)
+               undef, Sesse::pr0n::Common::get_server_name($r))

                and $defsettings{'xres'} = $defsettings{'yres'} = undef;
        
        # Reduce the front page load when in overload mode.
                and $defsettings{'xres'} = $defsettings{'yres'} = undef;
        
        # Reduce the front page load when in overload mode.


@@ -89,7 +88,7 @@ sub handler {
        my %settings = %defsettings;
 
        for my $s (qw(thumbxres thumbyres xres yres start num all infobox rot sel fullscreen model lens author)) {
        my %settings = %defsettings;
 
        for my $s (qw(thumbxres thumbyres xres yres start num all infobox rot sel fullscreen model lens author)) {

-               my $val = $apr->param($s);
+               my $val = $r->param($s);

                if (defined($val) && $val =~ /^(\d+)$/) {
                        $settings{$s} = $val;
                }
                if (defined($val) && $val =~ /^(\d+)$/) {
                        $settings{$s} = $val;
                }


@@ -154,47 +153,49 @@ sub handler {
 
        if ($event eq '+all' || defined($tag)) {
                $ref = $dbh->selectrow_hashref("SELECT EXTRACT(EPOCH FROM MAX(last_update)) AS last_update FROM last_picture_cache WHERE vhost=?",
 
        if ($event eq '+all' || defined($tag)) {
                $ref = $dbh->selectrow_hashref("SELECT EXTRACT(EPOCH FROM MAX(last_update)) AS last_update FROM last_picture_cache WHERE vhost=?",

-                       undef, $r->get_server_name)
-                       or error($r, "Could not list events", 404, "File not found");
+                       undef, Sesse::pr0n::Common::get_server_name($r))
+                       or return error($r, "Could not list events", 404, "File not found");

                $date = undef;
                $name = Sesse::pr0n::Templates::fetch_template($r, 'all-event-title');
                $date = undef;
                $name = Sesse::pr0n::Templates::fetch_template($r, 'all-event-title');

-               $r->set_last_modified($ref->{'last_update'});
+               Sesse::pr0n::Common::set_last_modified($r, $ref->{'last_update'});

        } else {
                $ref = $dbh->selectrow_hashref("SELECT name,date,EXTRACT(EPOCH FROM last_update) AS last_update FROM events NATURAL JOIN last_picture_cache WHERE vhost=? AND event=?",
        } else {
                $ref = $dbh->selectrow_hashref("SELECT name,date,EXTRACT(EPOCH FROM last_update) AS last_update FROM events NATURAL JOIN last_picture_cache WHERE vhost=? AND event=?",

-                       undef, $r->get_server_name, $event)
-                       or error($r, "Could not find event $event", 404, "File not found");
+                       undef, Sesse::pr0n::Common::get_server_name($r), $event)
+                       or return error($r, "Could not find event $event", 404, "File not found");

 
                $date = HTML::Entities::encode_entities($ref->{'date'});
                $name = HTML::Entities::encode_entities($ref->{'name'});
 
                $date = HTML::Entities::encode_entities($ref->{'date'});
                $name = HTML::Entities::encode_entities($ref->{'name'});

-               $r->set_last_modified($ref->{'last_update'});
+               Sesse::pr0n::Common::set_last_modified($r, $ref->{'last_update'});

        }
                                
        }
                                

-       # If the client can use cache, do so
-       if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) {
-               return $rc;
-       }
+       # # If the client can use cache, do so
+       # if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) {
+       #       return $rc;
+       # }

        
        # Count the number of selected images.
        
        # Count the number of selected images.

-       $ref = $dbh->selectrow_hashref("SELECT COUNT(*) AS num_selected FROM images WHERE vhost=? $where AND selected=\'t\'", undef, $r->get_server_name);
+       $ref = $dbh->selectrow_hashref("SELECT COUNT(*) AS num_selected FROM images WHERE vhost=? $where AND selected=\'t\'", undef, Sesse::pr0n::Common::get_server_name($r));

        my $num_selected = $ref->{'num_selected'};
 
        # Find all images related to this event.
        my $limit = (defined($start) && defined($num) && !$settings{'fullscreen'}) ? (" LIMIT $num OFFSET " . ($start-1)) : "";
 
        my $q = $dbh->prepare("SELECT *, (date - INTERVAL '6 hours')::date AS day FROM images WHERE vhost=? $where ORDER BY (date - INTERVAL '6 hours')::date $datesort,takenby,date,filename $limit")
        my $num_selected = $ref->{'num_selected'};
 
        # Find all images related to this event.
        my $limit = (defined($start) && defined($num) && !$settings{'fullscreen'}) ? (" LIMIT $num OFFSET " . ($start-1)) : "";
 
        my $q = $dbh->prepare("SELECT *, (date - INTERVAL '6 hours')::date AS day FROM images WHERE vhost=? $where ORDER BY (date - INTERVAL '6 hours')::date $datesort,takenby,date,filename $limit")

-               or dberror($r, "prepare()");
-       $q->execute($r->get_server_name)
-               or dberror($r, "image enumeration");
+               or return dberror($r, "prepare()");
+       $q->execute(Sesse::pr0n::Common::get_server_name($r))
+               or return dberror($r, "image enumeration");

 
        # Print the page itself
 
        # Print the page itself

+       my $res = Plack::Response->new(200);
+       my $io = IO::String->new;

        if ($settings{'fullscreen'}) {
        if ($settings{'fullscreen'}) {

-               $r->content_type("text/html; charset=utf-8");
+               $res->content_type("text/html; charset=utf-8");

 
                if (defined($tag)) {
 
                if (defined($tag)) {

-                       my $title = Sesse::pr0n::Templates::process_template($r, "tag-title", { tag => $tag });
-                       Sesse::pr0n::Templates::print_template($r, "fullscreen-header", { title => $title });
+                       my $title = Sesse::pr0n::Templates::process_template($res, $io, "tag-title", { tag => $tag });
+                       Sesse::pr0n::Templates::print_template($r, $io, "fullscreen-header", { title => $title });

                } else {
                } else {

-                       Sesse::pr0n::Templates::print_template($r, "fullscreen-header", { title => "$name [$event]" });
+                       Sesse::pr0n::Templates::print_template($r, $io, "fullscreen-header", { title => "$name [$event]" });

                }
 
                my @files = ();
                }
 
                my @files = ();


@@ -207,19 +208,19 @@ sub handler {
                for my $i (0..$#files) {
                        my $line = sprintf "        [ \"%s\", \"%s\", %d, %d ]", @{$files[$i]};
                        $line .= "," unless ($i == $#files);
                for my $i (0..$#files) {
                        my $line = sprintf "        [ \"%s\", \"%s\", %d, %d ]", @{$files[$i]};
                        $line .= "," unless ($i == $#files);

-                       $r->print($line . "\n");
+                       $io->print($line . "\n");

                }
 
                my %settings_no_fullscreen = %settings;
                $settings_no_fullscreen{'fullscreen'} = 0;
 
                }
 
                my %settings_no_fullscreen = %settings;
                $settings_no_fullscreen{'fullscreen'} = 0;
 

-               my $returnurl = "http://" . $r->get_server_name . "/" . $event . "/" .
+               my $returnurl = "http://" . Sesse::pr0n::Common::get_server_name($r) . "/" . $event . "/" .

                        Sesse::pr0n::Common::get_query_string(\%settings_no_fullscreen, \%defsettings);
                
                # *whistle*
                $returnurl =~ s/&/&/g;
 
                        Sesse::pr0n::Common::get_query_string(\%settings_no_fullscreen, \%defsettings);
                
                # *whistle*
                $returnurl =~ s/&/&/g;
 

-               Sesse::pr0n::Templates::print_template($r, "fullscreen-footer", {
+               Sesse::pr0n::Templates::print_template($r, $io, "fullscreen-footer", {

                        returnurl => $returnurl,
                        start => $settings{'start'} - 1,
                        sel => $settings{'sel'},
                        returnurl => $returnurl,
                        start => $settings{'start'} - 1,
                        sel => $settings{'sel'},


@@ -227,26 +228,26 @@ sub handler {
                });
        } else {
                if (defined($tag)) {
                });
        } else {
                if (defined($tag)) {

-                       my $title = Sesse::pr0n::Templates::process_template($r, "tag-title", { tag => $tag });
-                       Sesse::pr0n::Common::header($r, $title);
+                       my $title = Sesse::pr0n::Templates::process_template($r, $io, "tag-title", { tag => $tag });
+                       Sesse::pr0n::Common::header($r, $io, $title);

                } else {
                } else {

-                       Sesse::pr0n::Common::header($r, "$name [$event]");
+                       Sesse::pr0n::Common::header($r, $io, "$name [$event]");

                }
                if (defined($date)) {
                }
                if (defined($date)) {

-                       Sesse::pr0n::Templates::print_template($r, "date", { date => $date });
+                       Sesse::pr0n::Templates::print_template($r, $io, "date", { date => $date });

                }
 
                if (Sesse::pr0n::Overload::is_in_overload($r)) {
                }
 
                if (Sesse::pr0n::Overload::is_in_overload($r)) {

-                       Sesse::pr0n::Templates::print_template($r, "overloadmode");
+                       Sesse::pr0n::Templates::print_template($r, $io, "overloadmode");

                }
 
                }
 

-               print_thumbsize($r, $event, \%settings, \%defsettings);
-               print_viewres($r, $event, \%settings, \%defsettings);
-               print_pagelimit($r, $event, \%settings, \%defsettings);
-               print_infobox($r, $event, \%settings, \%defsettings);
-               print_selected($r, $event, \%settings, \%defsettings) if ($num_selected > 0);
-               print_fullscreen($r, $event, \%settings, \%defsettings);
-               print_nextprev($r, $event, $where, \%settings, \%defsettings);
+               print_thumbsize($r, $io, $event, \%settings, \%defsettings);
+               print_viewres($r, $io, $event, \%settings, \%defsettings);
+               print_pagelimit($r, $io, $event, \%settings, \%defsettings);
+               print_infobox($r, $io, $event, \%settings, \%defsettings);
+               print_selected($r, $io, $event, \%settings, \%defsettings) if ($num_selected > 0);
+               print_fullscreen($r, $io, $event, \%settings, \%defsettings);
+               print_nextprev($r, $io, $event, $where, \%settings, \%defsettings);

        
                if (1 || $event ne '+all') {
                        # Find the equipment used
        
                if (1 || $event ne '+all') {
                        # Find the equipment used


@@ -260,7 +261,7 @@ sub handler {
                                GROUP BY 1,2
                                ORDER BY 1,2")
                                or die "Couldn't prepare to find equipment: $!";
                                GROUP BY 1,2
                                ORDER BY 1,2")
                                or die "Couldn't prepare to find equipment: $!";

-                       $eq->execute($r->get_server_name)
+                       $eq->execute(Sesse::pr0n::Common::get_server_name($r))

                                or die "Couldn't find equipment: $!";
 
                        my @equipment = ();
                                or die "Couldn't find equipment: $!";
 
                        my @equipment = ();


@@ -281,7 +282,7 @@ sub handler {
                        $eq->finish;
 
                        if (scalar @equipment > 0) {
                        $eq->finish;
 
                        if (scalar @equipment > 0) {

-                               Sesse::pr0n::Templates::print_template($r, "equipment-start");
+                               Sesse::pr0n::Templates::print_template($r, $io, "equipment-start");

                                for my $e (@equipment) {
                                        my $eqspec = $e->{'model'};
                                        $eqspec .= ', ' . $e->{'lens'} if (defined($e->{'lens'}));
                                for my $e (@equipment) {
                                        my $eqspec = $e->{'model'};
                                        $eqspec .= ', ' . $e->{'lens'} if (defined($e->{'lens'}));


@@ -306,12 +307,12 @@ sub handler {
 
                                        # This isn't correct for all languages. Fix if we ever need to care. :-)
                                        if ($e->{'num'} == 1) {
 
                                        # This isn't correct for all languages. Fix if we ever need to care. :-)
                                        if ($e->{'num'} == 1) {

-                                               Sesse::pr0n::Templates::print_template($r, "equipment-item-singular", { eqspec => $eqspec, filterurl => $url, action => $action });
+                                               Sesse::pr0n::Templates::print_template($r, $io, "equipment-item-singular", { eqspec => $eqspec, filterurl => $url, action => $action });

                                        } else {
                                        } else {

-                                               Sesse::pr0n::Templates::print_template($r, "equipment-item", { eqspec => $eqspec, num => $e->{'num'}, filterurl => $url, action => $action });
+                                               Sesse::pr0n::Templates::print_template($r, $io, "equipment-item", { eqspec => $eqspec, num => $e->{'num'}, filterurl => $url, action => $action });

                                        }
                                }
                                        }
                                }

-                               Sesse::pr0n::Templates::print_template($r, "equipment-end");
+                               Sesse::pr0n::Templates::print_template($r, $io, "equipment-end");

                        }
                }
 
                        }
                }
 


@@ -321,8 +322,8 @@ sub handler {
                
                # Print out all thumbnails
                if ($rot == 1) {
                
                # Print out all thumbnails
                if ($rot == 1) {

-                       $r->print("    <form method=\"post\" action=\"/rotate\">\n");
-                       $r->print("      <input type=\"hidden\" name=\"event\" value=\"$event\" />\n");
+                       $io->print("    <form method=\"post\" action=\"/rotate\">\n");
+                       $io->print("      <input type=\"hidden\" name=\"event\" value=\"$event\" />\n");

                }
 
                while (my $ref = $q->fetchrow_hashref()) {
                }
 
                while (my $ref = $q->fetchrow_hashref()) {


@@ -336,7 +337,7 @@ sub handler {
                        my $groupkey = $takenby . $day;
 
                        if ($groupkey ne $lastupl) {
                        my $groupkey = $takenby . $day;
 
                        if ($groupkey ne $lastupl) {

-                               $r->print("    </p>\n\n") if ($lastupl ne "" && $rot != 1);
+                               $io->print("    </p>\n\n") if ($lastupl ne "" && $rot != 1);

                                $lastupl = $groupkey;
 
                                my %newsettings = %settings;
                                $lastupl = $groupkey;
 
                                my %newsettings = %settings;


@@ -354,13 +355,13 @@ sub handler {
 
                                my $url = "/$event/" . Sesse::pr0n::Common::get_query_string(\%newsettings, \%defsettings);
                                
 
                                my $url = "/$event/" . Sesse::pr0n::Common::get_query_string(\%newsettings, \%defsettings);
                                

-                               $r->print("    <h2>");
-                               Sesse::pr0n::Templates::print_template($r, "submittedby", { author => $takenby, action => $action, filterurl => $url, date => $day });
-                               print_fullscreen_fromhere($r, $event, \%settings, \%defsettings, $img_num);
-                               $r->print("</h2>\n");
+                               $io->print("    <h2>");
+                               Sesse::pr0n::Templates::print_template($r, $io, "submittedby", { author => $takenby, action => $action, filterurl => $url, date => $day });
+                               print_fullscreen_fromhere($r, $io, $event, \%settings, \%defsettings, $img_num);
+                               $io->print("</h2>\n");

 
                                if ($rot != 1) {
 
                                if ($rot != 1) {

-                                       $r->print("    <p class=\"photos\">\n");
+                                       $io->print("    <p class=\"photos\">\n");

                                }
                        }
 
                                }
                        }
 


@@ -386,20 +387,20 @@ sub handler {
                        }
                
                        if ($rot == 1) {        
                        }
                
                        if ($rot == 1) {        

-                               $r->print("    <p>");
+                               $io->print("    <p>");

                        } else {
                        } else {

-                               $r->print("     ");
+                               $io->print("     ");

                        }
                        }

-                       $r->print("<a href=\"$prefix$uri\"><img src=\"$prefix${thumbxres}x${thumbyres}/$filename\" alt=\"\"$imgsz /></a>\n");
+                       $io->print("<a href=\"$prefix$uri\"><img src=\"$prefix${thumbxres}x${thumbyres}/$filename\" alt=\"\"$imgsz /></a>\n");

                
                        if ($rot == 1) {
                
                        if ($rot == 1) {

-                               $r->print("      90 <input type=\"checkbox\" name=\"rot-" .
+                               $io->print("      90 <input type=\"checkbox\" name=\"rot-" .

                                        $ref->{'id'} . "-90\" />\n");
                                        $ref->{'id'} . "-90\" />\n");

-                               $r->print("      180 <input type=\"checkbox\" name=\"rot-" .
+                               $io->print("      180 <input type=\"checkbox\" name=\"rot-" .

                                        $ref->{'id'} . "-180\" />\n");
                                        $ref->{'id'} . "-180\" />\n");

-                               $r->print("      270 <input type=\"checkbox\" name=\"rot-" .
+                               $io->print("      270 <input type=\"checkbox\" name=\"rot-" .

                                        $ref->{'id'} . "-270\" />\n");
                                        $ref->{'id'} . "-270\" />\n");

-                               $r->print("      &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;" .
+                               $io->print("      &nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;" .

                                        "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;Del <input type=\"checkbox\" name=\"del-" . $ref->{'id'} . "\" /></p>\n");
                        }
                        
                                        "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;Del <input type=\"checkbox\" name=\"del-" . $ref->{'id'} . "\" /></p>\n");
                        }
                        


@@ -407,17 +408,19 @@ sub handler {
                }
 
                if ($rot == 1) {
                }
 
                if ($rot == 1) {

-                       $r->print("      <input type=\"submit\" value=\"Rotate\" />\n");
-                       $r->print("    </form>\n");
+                       $io->print("      <input type=\"submit\" value=\"Rotate\" />\n");
+                       $io->print("    </form>\n");

                } else {
                } else {

-                       $r->print("    </p>\n");
+                       $io->print("    </p>\n");

                }
 
                }
 

-               print_nextprev($r, $event, $where, \%settings, \%defsettings);
-               Sesse::pr0n::Common::footer($r);
+               print_nextprev($r, $io, $event, $where, \%settings, \%defsettings);
+               Sesse::pr0n::Common::footer($r, $io);

        }
 
        }
 

-       return Apache2::Const::OK;
+       $io->setpos(0);
+       $res->body($io);
+       return $res;

 }
 
 sub eq_with_undef {
 }
 
 sub eq_with_undef {


@@ -429,11 +432,11 @@ sub eq_with_undef {
 }
 
 sub print_changes {
 }
 
 sub print_changes {

-       my ($r, $event, $template, $settings, $defsettings, $var1, $var2, $alternatives) = @_;
+       my ($r, $io, $event, $template, $settings, $defsettings, $var1, $var2, $alternatives) = @_;

 
        my $title = Sesse::pr0n::Templates::fetch_template($r, $template);
        chomp $title;
 
        my $title = Sesse::pr0n::Templates::fetch_template($r, $template);
        chomp $title;

-       $r->print("    <p>$title:\n");
+       $io->print("    <p>$title:\n");

 
        for my $a (@$alternatives) {
                my $text;
 
        for my $a (@$alternatives) {
                my $text;


@@ -455,45 +458,45 @@ sub print_changes {
                        $newsettings{$var2} = $v2;
                }
 
                        $newsettings{$var2} = $v2;
                }
 

-               $r->print("      ");
+               $io->print("      ");

 
                # Check if these settings are current (print only label)
                if (eq_with_undef($settings->{$var1}, $newsettings{$var1}) &&
                    eq_with_undef($settings->{$var2}, $newsettings{$var2})) {
 
                # Check if these settings are current (print only label)
                if (eq_with_undef($settings->{$var1}, $newsettings{$var1}) &&
                    eq_with_undef($settings->{$var2}, $newsettings{$var2})) {

-                       $r->print($text);
+                       $io->print($text);

                } else {
                } else {

-                       Sesse::pr0n::Common::print_link($r, $text, "/$event/", \%newsettings, $defsettings);
+                       Sesse::pr0n::Common::print_link($io, $text, "/$event/", \%newsettings, $defsettings);

                }
                }

-               $r->print("\n");
+               $io->print("\n");

        }
        }

-       $r->print("    </p>\n");
+       $io->print("    </p>\n");

 }
 
 sub print_thumbsize {
 }
 
 sub print_thumbsize {

-       my ($r, $event, $settings, $defsettings) = @_;
+       my ($r, $io, $event, $settings, $defsettings) = @_;

        my @alternatives = qw(80x64 120x96 160x128 240x192 320x256);
 
        my @alternatives = qw(80x64 120x96 160x128 240x192 320x256);
 

-       print_changes($r, $event, 'thumbsize', $settings, $defsettings,
+       print_changes($r, $io, $event, 'thumbsize', $settings, $defsettings,

                      'thumbxres', 'thumbyres', \@alternatives);
 }
 sub print_viewres {
                      'thumbxres', 'thumbyres', \@alternatives);
 }
 sub print_viewres {

-       my ($r, $event, $settings, $defsettings) = @_;
+       my ($r, $io, $event, $settings, $defsettings) = @_;

        my @alternatives = qw(320x256 512x384 640x480 800x600 1024x768 1152x864 1280x960 1400x1050 1600x1200 1920x1440 2048x1536 2304x1728);
        chomp (my $unlimited = Sesse::pr0n::Templates::fetch_template($r, 'viewres-unlimited'));
        chomp (my $original = Sesse::pr0n::Templates::fetch_template($r, 'viewres-original'));
        push @alternatives, [ $unlimited, -2, -2 ];
        push @alternatives, [ $original, -1, -1 ];
 
        my @alternatives = qw(320x256 512x384 640x480 800x600 1024x768 1152x864 1280x960 1400x1050 1600x1200 1920x1440 2048x1536 2304x1728);
        chomp (my $unlimited = Sesse::pr0n::Templates::fetch_template($r, 'viewres-unlimited'));
        chomp (my $original = Sesse::pr0n::Templates::fetch_template($r, 'viewres-original'));
        push @alternatives, [ $unlimited, -2, -2 ];
        push @alternatives, [ $original, -1, -1 ];
 

-       print_changes($r, $event, 'viewres', $settings, $defsettings,
+       print_changes($r, $io, $event, 'viewres', $settings, $defsettings,

                      'xres', 'yres', \@alternatives);
 }
 
 sub print_pagelimit {
                      'xres', 'yres', \@alternatives);
 }
 
 sub print_pagelimit {

-       my ($r, $event, $settings, $defsettings) = @_;
+       my ($r, $io, $event, $settings, $defsettings) = @_;

        
        my $title = Sesse::pr0n::Templates::fetch_template($r, 'imgsperpage');
        chomp $title;
        
        my $title = Sesse::pr0n::Templates::fetch_template($r, 'imgsperpage');
        chomp $title;

-       $r->print("    <p>$title:\n");
+       $io->print("    <p>$title:\n");

        
        # Get choices
        chomp (my $unlimited = Sesse::pr0n::Templates::fetch_template($r, 'imgsperpage-unlimited'));
        
        # Get choices
        chomp (my $unlimited = Sesse::pr0n::Templates::fetch_template($r, 'imgsperpage-unlimited'));


@@ -509,49 +512,49 @@ sub print_pagelimit {
                        $newsettings{'num'} = $num;
                }
 
                        $newsettings{'num'} = $num;
                }
 

-               $r->print("      ");
+               $io->print("      ");

                if (eq_with_undef($settings->{'num'}, $newsettings{'num'})) {
                if (eq_with_undef($settings->{'num'}, $newsettings{'num'})) {

-                       $r->print($num);
+                       $io->print($num);

                } else {
                } else {

-                       Sesse::pr0n::Common::print_link($r, $num, "/$event/", \%newsettings, $defsettings);
+                       Sesse::pr0n::Common::print_link($io, $num, "/$event/", \%newsettings, $defsettings);

                }
                }

-               $r->print("\n");
+               $io->print("\n");

        }
        }

-       $r->print("    </p>\n");
+       $io->print("    </p>\n");

 }
 
 sub print_infobox {
 }
 
 sub print_infobox {

-       my ($r, $event, $settings, $defsettings) = @_;
+       my ($r, $io, $event, $settings, $defsettings) = @_;

 
        chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'infobox'));
        chomp (my $on = Sesse::pr0n::Templates::fetch_template($r, 'infobox-on'));
        chomp (my $off = Sesse::pr0n::Templates::fetch_template($r, 'infobox-off'));
 
 
        chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'infobox'));
        chomp (my $on = Sesse::pr0n::Templates::fetch_template($r, 'infobox-on'));
        chomp (my $off = Sesse::pr0n::Templates::fetch_template($r, 'infobox-off'));
 

-        $r->print("    <p>$title:\n");
+        $io->print("    <p>$title:\n");

 
        my %newsettings = %$settings;
 
        if ($settings->{'infobox'} == 1) {
 
        my %newsettings = %$settings;
 
        if ($settings->{'infobox'} == 1) {

-               $r->print($on);
+               $io->print($on);

        } else {
                $newsettings{'infobox'} = 1;
        } else {
                $newsettings{'infobox'} = 1;

-               Sesse::pr0n::Common::print_link($r, $on, "/$event/", \%newsettings, $defsettings);
+               Sesse::pr0n::Common::print_link($io, $on, "/$event/", \%newsettings, $defsettings);

        }
 
        }
 

-       $r->print(' ');
+       $io->print(' ');

 
        if ($settings->{'infobox'} == 0) {
 
        if ($settings->{'infobox'} == 0) {

-               $r->print($off);
+               $io->print($off);

        } else {
                $newsettings{'infobox'} = 0;
        } else {
                $newsettings{'infobox'} = 0;

-               Sesse::pr0n::Common::print_link($r, $off, "/$event/", \%newsettings, $defsettings);
+               Sesse::pr0n::Common::print_link($io, $off, "/$event/", \%newsettings, $defsettings);

        }
        
        }
        

-       $r->print('</p>');
+       $io->print('</p>');

 }
 
 sub print_nextprev {
 }
 
 sub print_nextprev {

-       my ($r, $event, $where, $settings, $defsettings) = @_;
+       my ($r, $io, $event, $where, $settings, $defsettings) = @_;

        my $start = $settings->{'start'};
        my $num = $settings->{'num'};
        my $dbh = Sesse::pr0n::Common::get_dbh();
        my $start = $settings->{'start'};
        my $num = $settings->{'num'};
        my $dbh = Sesse::pr0n::Common::get_dbh();


@@ -561,8 +564,8 @@ sub print_nextprev {
 
        # determine total number
        my $ref = $dbh->selectrow_hashref("SELECT count(*) AS num_images FROM images WHERE vhost=? $where",
 
        # determine total number
        my $ref = $dbh->selectrow_hashref("SELECT count(*) AS num_images FROM images WHERE vhost=? $where",

-               undef, $r->get_server_name)
-               or dberror($r, "image enumeration");
+               undef, Sesse::pr0n::Common::get_server_name($r))
+               or return dberror($r, "image enumeration");

        my $num_images = $ref->{'num_images'};
 
        return if ($start == 1 && $start + $num >= $num_images);
        my $num_images = $ref->{'num_images'};
 
        return if ($start == 1 && $start + $num >= $num_images);


@@ -572,7 +575,7 @@ sub print_nextprev {
                $end = $num_images;
        }
 
                $end = $num_images;
        }
 

-       $r->print("    <p class=\"nextprev\">\n");
+       $io->print("    <p class=\"nextprev\">\n");

 
        # Previous
        if ($start > 1) {
 
        # Previous
        if ($start > 1) {


@@ -589,12 +592,12 @@ sub print_nextprev {
                $newsettings{'start'} = $newstart;
                chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'prevpage'));
                chomp (my $accesskey = Sesse::pr0n::Templates::fetch_template($r, 'prevaccesskey'));
                $newsettings{'start'} = $newstart;
                chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'prevpage'));
                chomp (my $accesskey = Sesse::pr0n::Templates::fetch_template($r, 'prevaccesskey'));

-               Sesse::pr0n::Common::print_link($r, "$title ($newstart-$newend)\n", "/$event/", \%newsettings, $defsettings, $accesskey);
+               Sesse::pr0n::Common::print_link($io, "$title ($newstart-$newend)\n", "/$event/", \%newsettings, $defsettings, $accesskey);

        }
 
        # This
        chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'thispage'));
        }
 
        # This
        chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'thispage'));

-       $r->print("    $title ($start-$end)\n");
+       $io->print("    $title ($start-$end)\n");

 
        # Next
        if ($end < $num_images) {
 
        # Next
        if ($end < $num_images) {


@@ -608,57 +611,57 @@ sub print_nextprev {
                $newsettings{'start'} = $newstart;
                chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'nextpage'));
                chomp (my $accesskey = Sesse::pr0n::Templates::fetch_template($r, 'nextaccesskey'));
                $newsettings{'start'} = $newstart;
                chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'nextpage'));
                chomp (my $accesskey = Sesse::pr0n::Templates::fetch_template($r, 'nextaccesskey'));

-               Sesse::pr0n::Common::print_link($r, "$title ($newstart-$newend)", "/$event/", \%newsettings, $defsettings, $accesskey);
+               Sesse::pr0n::Common::print_link($io, "$title ($newstart-$newend)", "/$event/", \%newsettings, $defsettings, $accesskey);

        }
 
        }
 

-       $r->print("    </p>\n");
+       $io->print("    </p>\n");

 }
 
 sub print_selected {
 }
 
 sub print_selected {

-       my ($r, $event, $settings, $defsettings) = @_;
+       my ($r, $io, $event, $settings, $defsettings) = @_;

 
        chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'show'));
        chomp (my $all = Sesse::pr0n::Templates::fetch_template($r, 'show-all'));
        chomp (my $sel = Sesse::pr0n::Templates::fetch_template($r, 'show-selected'));
 
 
        chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'show'));
        chomp (my $all = Sesse::pr0n::Templates::fetch_template($r, 'show-all'));
        chomp (my $sel = Sesse::pr0n::Templates::fetch_template($r, 'show-selected'));
 

-        $r->print("    <p>$title:\n");
+        $io->print("    <p>$title:\n");

 
        my %newsettings = %$settings;
 
        if ($settings->{'all'} == 0) {
 
        my %newsettings = %$settings;
 
        if ($settings->{'all'} == 0) {

-               $r->print($sel);
+               $io->print($sel);

        } else {
                $newsettings{'all'} = 0;
        } else {
                $newsettings{'all'} = 0;

-               Sesse::pr0n::Common::print_link($r, $sel, "/$event/", \%newsettings, $defsettings);
+               Sesse::pr0n::Common::print_link($io, $sel, "/$event/", \%newsettings, $defsettings);

        }
 
        }
 

-       $r->print(' ');
+       $io->print(' ');

 
        if ($settings->{'all'} == 1) {
 
        if ($settings->{'all'} == 1) {

-               $r->print($all);
+               $io->print($all);

        } else {
                $newsettings{'all'} = 1;
        } else {
                $newsettings{'all'} = 1;

-               Sesse::pr0n::Common::print_link($r, $all, "/$event/", \%newsettings, $defsettings);
+               Sesse::pr0n::Common::print_link($io, $all, "/$event/", \%newsettings, $defsettings);

        }
        
        }
        

-       $r->print('</p>');
+       $io->print('</p>');

 }
 
 sub print_fullscreen {
 }
 
 sub print_fullscreen {

-       my ($r, $event, $settings, $defsettings) = @_;
+       my ($r, $io, $event, $settings, $defsettings) = @_;

 
        chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'fullscreen'));
 
        my %newsettings = %$settings;
        $newsettings{'fullscreen'} = 1;
 
 
        chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'fullscreen'));
 
        my %newsettings = %$settings;
        $newsettings{'fullscreen'} = 1;
 

-        $r->print("    <p>");
-       Sesse::pr0n::Common::print_link($r, $title, "/$event/", \%newsettings, $defsettings);
-       $r->print("</p>\n");
+        $io->print("    <p>");
+       Sesse::pr0n::Common::print_link($io, $title, "/$event/", \%newsettings, $defsettings);
+       $io->print("</p>\n");

 }
 
 sub print_fullscreen_fromhere {
 }
 
 sub print_fullscreen_fromhere {

-       my ($r, $event, $settings, $defsettings, $start) = @_;
+       my ($r, $io, $event, $settings, $defsettings, $start) = @_;

 
        chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'fullscreen-fromhere'));
 
 
        chomp (my $title = Sesse::pr0n::Templates::fetch_template($r, 'fullscreen-fromhere'));
 


@@ -666,9 +669,9 @@ sub print_fullscreen_fromhere {
        $newsettings{'fullscreen'} = 1;
        $newsettings{'start'} = $start;
 
        $newsettings{'fullscreen'} = 1;
        $newsettings{'start'} = $start;
 

-        $r->print("    <span class=\"fsfromhere\">");
-       Sesse::pr0n::Common::print_link($r, $title, "/$event/", \%newsettings, $defsettings);
-       $r->print("</span>\n");
+        $io->print("    <span class=\"fsfromhere\">");
+       Sesse::pr0n::Common::print_link($io, $title, "/$event/", \%newsettings, $defsettings);
+       $io->print("</span>\n");

 }
        
 1;
 }
        
 1;

diff --git a/perl/Sesse/pr0n/Listing.pm b/perl/Sesse/pr0n/Listing.pm
index c8f93f249fae58c2ef8ba34ea9c093bf7e58eb5e..9f75fefd2bb7da15deef07fe9d3edef3b5ac5cf4 100644 (file)
--- a/perl/Sesse/pr0n/Listing.pm
+++ b/perl/Sesse/pr0n/Listing.pm
@@ -10,40 +10,44 @@ sub handler {
        my $dbh = Sesse::pr0n::Common::get_dbh();
 
         # Internal? (Ugly?)
        my $dbh = Sesse::pr0n::Common::get_dbh();
 
         # Internal? (Ugly?)

-       if ($r->get_server_name =~ /internal/ || $r->get_server_name =~ /skoyen\.bilder\.knatten\.com/ || $r->get_server_name =~ /lia\.heimdal\.org/) {
+       if (Sesse::pr0n::Common::get_server_name($r) =~ /internal/ ||
+           Sesse::pr0n::Common::get_server_name($r) =~ /skoyen\.bilder\.knatten\.com/ ||
+           Sesse::pr0n::Common::get_server_name($r) =~ /lia\.heimdal\.org/) {

                my $user = Sesse::pr0n::Common::check_access($r);
                my $user = Sesse::pr0n::Common::check_access($r);

-               if (!defined($user)) {
-                       return Apache2::Const::OK;
-               }
+               return Sesse::pr0n::Common::generate_401($r) if (!defined($user));

        }
        
        # Fix common error: pr0n.sesse.net/+foo -> pr0n.sesse.net/+foo/
        }
        
        # Fix common error: pr0n.sesse.net/+foo -> pr0n.sesse.net/+foo/

-       if ($r->uri !~ /\/$/) {
-               $r->headers_out->{'location'} = $r->uri . "/";
-               return Apache2::Const::REDIRECT;
+       if ($r->path_info !~ /\/$/) {
+               my $res = Plack::Response->new(301);
+               $res->header('Location' => $r->path_info . "/");
+               return $res;

        }
        }

+
+       my $res = Plack::Response->new(200);
+       my $io = IO::String->new;

        
        # find the last modification
        my $ref = $dbh->selectrow_hashref('SELECT EXTRACT(EPOCH FROM last_update) AS last_update FROM last_picture_cache WHERE vhost=? ORDER BY last_update DESC LIMIT 1',
        
        # find the last modification
        my $ref = $dbh->selectrow_hashref('SELECT EXTRACT(EPOCH FROM last_update) AS last_update FROM last_picture_cache WHERE vhost=? ORDER BY last_update DESC LIMIT 1',

-               undef, $r->get_server_name)
-               or error($r, "Could not find any events", 404, "File not found");
-       $r->set_last_modified($ref->{'last_update'});
-       $r->content_type('text/html; charset=utf-8');
+               undef, Sesse::pr0n::Common::get_server_name($r))
+               or return error($r, "Could not find any events", 404, "File not found");
+       Sesse::pr0n::Common::set_last_modified($r, $ref->{'last_update'});
+       $res->content_type('text/html; charset=utf-8');

                                
                                

-       # If the client can use cache, do so
-       if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) {
-               return $rc;
-       }
+       # # If the client can use cache, do so
+       # if ((my $rc = $r->meets_conditions) != Apache2::Const::OK) {
+       #       return $rc;
+       # }

        
        

-       if ($r->uri =~ /^\/\+tags\/?/) {
+       if ($r->path_info =~ /^\/\+tags\/?/) {

                # Tag cloud
                my $q = $dbh->prepare('SELECT tag,COUNT(*) AS frequency FROM tags t JOIN images i ON t.image=i.id WHERE vhost=? GROUP BY tag ORDER BY COUNT(*) DESC LIMIT 75')
                # Tag cloud
                my $q = $dbh->prepare('SELECT tag,COUNT(*) AS frequency FROM tags t JOIN images i ON t.image=i.id WHERE vhost=? GROUP BY tag ORDER BY COUNT(*) DESC LIMIT 75')

-                       or dberror($r, "Couldn't list events");
-               $q->execute($r->get_server_name)
-                       or dberror($r, "Couldn't get events");
+                       or return dberror($r, "Couldn't list events");
+               $q->execute(Sesse::pr0n::Common::get_server_name($r))
+                       or return dberror($r, "Couldn't get events");

                
                

-               Sesse::pr0n::Common::header($r, Sesse::pr0n::Templates::fetch_template($r, 'tag-listing'));
-               Sesse::pr0n::Templates::print_template($r, 'mainmenu-tags');
+               Sesse::pr0n::Common::header($r, $io, Sesse::pr0n::Templates::fetch_template($r, 'tag-listing'));
+               Sesse::pr0n::Templates::print_template($r, $io, 'mainmenu-tags');

 
                my $cloud = HTML::TagCloud->new;
 
 
                my $cloud = HTML::TagCloud->new;
 


@@ -55,8 +59,8 @@ sub handler {
                        $cloud->add($html, "/+tags/$uri/", $ref->{'frequency'});
                }
 
                        $cloud->add($html, "/+tags/$uri/", $ref->{'frequency'});
                }
 

-               $r->print($cloud->html_and_css());
-               Sesse::pr0n::Common::footer($r);
+               $io->print($cloud->html_and_css());
+               Sesse::pr0n::Common::footer($r, $io);

 
                $q->finish();
        } else {
 
                $q->finish();
        } else {


@@ -64,41 +68,43 @@ sub handler {
 #              my $q = $dbh->prepare('SELECT t1.id,t1.date,t1.name FROM events t1 LEFT JOIN images t2 ON t1.id=t2.event WHERE t1.vhost=? GROUP BY t1.id,t1.date,t1.name ORDER BY COALESCE(MAX(t2.date),\'1970-01-01 00:00:00\'),t1.id') or
 #                      dberror($r, "Couldn't list events");
                my $q = $dbh->prepare('SELECT event,date,name FROM events e JOIN last_picture_cache c USING (vhost,event) WHERE vhost=? ORDER BY last_picture DESC NULLS LAST')
 #              my $q = $dbh->prepare('SELECT t1.id,t1.date,t1.name FROM events t1 LEFT JOIN images t2 ON t1.id=t2.event WHERE t1.vhost=? GROUP BY t1.id,t1.date,t1.name ORDER BY COALESCE(MAX(t2.date),\'1970-01-01 00:00:00\'),t1.id') or
 #                      dberror($r, "Couldn't list events");
                my $q = $dbh->prepare('SELECT event,date,name FROM events e JOIN last_picture_cache c USING (vhost,event) WHERE vhost=? ORDER BY last_picture DESC NULLS LAST')

-                       or dberror($r, "Couldn't list events");
-               $q->execute($r->get_server_name)
-                       or dberror($r, "Couldn't get events");
+                       or return dberror($r, "Couldn't list events");
+               $q->execute(Sesse::pr0n::Common::get_server_name($r))
+                       or return dberror($r, "Couldn't get events");

                
                

-               Sesse::pr0n::Common::header($r, Sesse::pr0n::Templates::fetch_template($r, 'event-listing'));
+               Sesse::pr0n::Common::header($r, $io, Sesse::pr0n::Templates::fetch_template($r, 'event-listing'));

 
                # See if there are any tags related to this vhost
                my $ref = $dbh->selectrow_hashref('SELECT * FROM tags t JOIN images i ON t.image=i.id WHERE vhost=? LIMIT 1',
 
                # See if there are any tags related to this vhost
                my $ref = $dbh->selectrow_hashref('SELECT * FROM tags t JOIN images i ON t.image=i.id WHERE vhost=? LIMIT 1',

-                       undef, $r->get_server_name);
+                       undef, Sesse::pr0n::Common::get_server_name($r));

                if (defined($ref)) {
                if (defined($ref)) {

-                       Sesse::pr0n::Templates::print_template($r, 'mainmenu-events');
+                       Sesse::pr0n::Templates::print_template($r, $io, 'mainmenu-events');

                }
 
                my $allcaption = Sesse::pr0n::Templates::fetch_template($r, 'all-event-title');
                }
 
                my $allcaption = Sesse::pr0n::Templates::fetch_template($r, 'all-event-title');

-               $r->print("    <ul>\n");
-               $r->print("      <li><a href=\"+all/\">$allcaption</a></li>\n");
-               $r->print("    </ul>\n");
+               $io->print("    <ul>\n");
+               $io->print("      <li><a href=\"+all/\">$allcaption</a></li>\n");
+               $io->print("    </ul>\n");

                
                

-               $r->print("    <ul>\n");
+               $io->print("    <ul>\n");

 
                while (my $ref = $q->fetchrow_hashref()) {
                        my $id = $ref->{'event'};
                        my $date = HTML::Entities::encode_entities($ref->{'date'});
                        my $name = HTML::Entities::encode_entities($ref->{'name'});
                        
 
                while (my $ref = $q->fetchrow_hashref()) {
                        my $id = $ref->{'event'};
                        my $date = HTML::Entities::encode_entities($ref->{'date'});
                        my $name = HTML::Entities::encode_entities($ref->{'name'});
                        

-                       $r->print("      <li><a href=\"$id/\">$name</a> ($date)</li>\n");
+                       $io->print("      <li><a href=\"$id/\">$name</a> ($date)</li>\n");

                }
 
                }
 

-               $r->print("    </ul>\n");
-               Sesse::pr0n::Common::footer($r);
+               $io->print("    </ul>\n");
+               Sesse::pr0n::Common::footer($r, $io);

 
                $q->finish();
        }
 
 
                $q->finish();
        }
 

-       return Apache2::Const::OK;
+       $io->setpos(0);
+       $res->body($io);
+       return $res;

 }
 
 1;
 }
 
 1;

diff --git a/perl/Sesse/pr0n/NewEvent.pm b/perl/Sesse/pr0n/NewEvent.pm
index 2aac990d02fc7dee685249f17c8a3a9b0096b367..8f4d6cef4ed5fa98600f159195477ac0ccb5af92 100644 (file)
--- a/perl/Sesse/pr0n/NewEvent.pm
+++ b/perl/Sesse/pr0n/NewEvent.pm
@@ -3,37 +3,37 @@ use strict;
 use warnings;
 
 use Sesse::pr0n::Common qw(error dberror);
 use warnings;
 
 use Sesse::pr0n::Common qw(error dberror);

-use Apache2::Request;

 
 sub handler {
        my $r = shift;
 
 sub handler {
        my $r = shift;

-       my $apr = Apache2::Request->new($r);

        my $dbh = Sesse::pr0n::Common::get_dbh();
        my $user = Sesse::pr0n::Common::check_access($r);
        my $dbh = Sesse::pr0n::Common::get_dbh();
        my $user = Sesse::pr0n::Common::check_access($r);

-       if (!defined($user)) {
-               return Apache2::Const::OK;
-       }
+       return Sesse::pr0n::Common::generate_401($r) if (!defined($user));

 
 

-       Sesse::pr0n::Common::header($r, "Legger til ny hendelse");
+       my $res = Plack::Response->new(200);
+       my $io = IO::String->new;
+       Sesse::pr0n::Common::header($r, $io, "Legger til ny hendelse");

        
        

-       my $id = $apr->param('id');
-       my $date = $apr->param('date');
-       my $desc = $apr->param('desc');
+       my $id = $r->param('id');
+       my $date = Encode::decode_utf8($r->param('date'));
+       my $desc = Encode::decode_utf8($r->param('desc'));

 
 

-       my @errors = Sesse::pr0n::Common::add_new_event($r, $dbh, $id, $date, $desc);
+       my @errors = Sesse::pr0n::Common::add_new_event($r, $res, $dbh, $id, $date, $desc);

        
        if (scalar @errors > 0) {
                for my $err (@errors) {
        
        if (scalar @errors > 0) {
                for my $err (@errors) {

-                       $r->print("    <p>Feil: $err</p>\n");
+                       $io->print("    <p>Feil: $err</p>\n");

                }
                }

-               $r->print("    <p>Rett opp i feilene over før du går videre.</p>\n");
+               $io->print("    <p>Rett opp i feilene over før du går videre.</p>\n");

        } else {
        } else {

-               $r->print("    <p>Hendelsen '$id' lagt til.</p>");
+               $io->print("    <p>Hendelsen '$id' lagt til.</p>");

        }
        
        }
        

-       Sesse::pr0n::Common::footer($r);
+       Sesse::pr0n::Common::footer($r, $io);

 
 

-       return Apache2::Const::OK;
+       $io->setpos(0);
+       $res->body($io);
+       return $res;

 }
 
 1;
 }
 
 1;

diff --git a/perl/Sesse/pr0n/Overload.pm b/perl/Sesse/pr0n/Overload.pm
index 0adce7cc55ec755391ef561b2bb48b42ed0b209c..e36489df5fa482114537f37e4d1251a9a47a3772 100644 (file)
--- a/perl/Sesse/pr0n/Overload.pm
+++ b/perl/Sesse/pr0n/Overload.pm
@@ -22,7 +22,7 @@ sub is_in_overload {
        my $r = shift;
 
        # Manually set overload mode
        my $r = shift;
 
        # Manually set overload mode

-       if (lc($r->dir_config('OverloadMode')) eq 'on') {
+       if ($Sesse::pr0n::Config::overload_mode) {

                return 1;
        }
 
                return 1;
        }
 


@@ -31,8 +31,8 @@ sub is_in_overload {
                $in_overload = 0;
        }
 
                $in_overload = 0;
        }
 

-       my $enable_threshold = $r->dir_config('OverloadEnableThreshold') || 10.0;
-       my $disable_threshold = $r->dir_config('OverloadDisableThreshold') || 5.0;
+       my $enable_threshold = $Sesse::pr0n::Config::overload_enable_threshold // 10.0;
+       my $disable_threshold = $Sesse::pr0n::Config::overload_disable_threshold // 5.0;

        
        # Check if our load average estimate is more than a minute old
        if (!defined($last_update) || (time - $last_update) > 60) {
        
        # Check if our load average estimate is more than a minute old
        if (!defined($last_update) || (time - $last_update) > 60) {


@@ -48,17 +48,17 @@ sub is_in_overload {
 
                if ($in_overload) {
                        if ($loadavg < $disable_threshold) {
 
                if ($in_overload) {
                        if ($loadavg < $disable_threshold) {

-                               $r->log->info("Current load average is $loadavg (threshold: $disable_threshold), leaving overload mode");
+                               Sesse::pr0n::Common::log_info($r, "Current load average is $loadavg (threshold: $disable_threshold), leaving overload mode");

                                $in_overload = 0;
                        } else {
                                $in_overload = 0;
                        } else {

-                               $r->log->warn("Current load average is $loadavg (threshold: $disable_threshold), staying in overload mode");
+                               Sesse::pr0n::Common::log_warn($r, "Current load average is $loadavg (threshold: $disable_threshold), staying in overload mode");

                        }
                } else {
                        if ($loadavg > $enable_threshold) {
                        }
                } else {
                        if ($loadavg > $enable_threshold) {

-                               $r->log->warn("Current load average is $loadavg (threshold: $enable_threshold), entering overload mode");
+                               Sesse::pr0n::Common::log_warn($r, "Current load average is $loadavg (threshold: $enable_threshold), entering overload mode");

                                $in_overload = 1;
                        } else {
                                $in_overload = 1;
                        } else {

-                               $r->log->info("Current load average is $loadavg (threshold: $enable_threshold)");
+                               Sesse::pr0n::Common::log_info($r, "Current load average is $loadavg (threshold: $enable_threshold)");

                        }
                }
        }
                        }
                }
        }

diff --git a/perl/Sesse/pr0n/QscaleProxy.pm b/perl/Sesse/pr0n/QscaleProxy.pm
index 69d7c76d8f6a4e8daf24bc862f6460cfa05f30aa..f62690247e4fe4f9189860dc3a436924ef53e33a 100644 (file)
--- a/perl/Sesse/pr0n/QscaleProxy.pm
+++ b/perl/Sesse/pr0n/QscaleProxy.pm
@@ -16,7 +16,7 @@ BEGIN {
                $has_qscale = 1;
        };
        if ($@) {
                $has_qscale = 1;
        };
        if ($@) {

-               Apache2::ServerUtil->server->log_error("Could not load the qscale module ($@); continuing with ImageMagick only.");
+               print STDERR "Could not load the qscale module ($@); continuing with ImageMagick only.\n";

        }
 }
 
        }
 }
 

diff --git a/perl/Sesse/pr0n/Rotate.pm b/perl/Sesse/pr0n/Rotate.pm
index 80c25521600c3c4dead844db64bb248a2ca94ac7..d5086ecc7b8715053067b1110b3053fba3f3d3ce 100644 (file)
--- a/perl/Sesse/pr0n/Rotate.pm
+++ b/perl/Sesse/pr0n/Rotate.pm
@@ -3,16 +3,12 @@ use strict;
 use warnings;
 
 use Sesse::pr0n::Common qw(error dberror);
 use warnings;
 
 use Sesse::pr0n::Common qw(error dberror);

-use Apache2::Request;

 
 sub handler {
        my $r = shift;
 
 sub handler {
        my $r = shift;

-       my $apr = Apache2::Request->new($r);

        my $dbh = Sesse::pr0n::Common::get_dbh();
        my ($user, $takenby) = Sesse::pr0n::Common::check_access($r);
        my $dbh = Sesse::pr0n::Common::get_dbh();
        my ($user, $takenby) = Sesse::pr0n::Common::check_access($r);

-       if (!defined($user)) {
-               return Apache2::Const::OK;
-       }
+       return Sesse::pr0n::Common::generate_401($r) if (!defined($user));

 
        # FIXME: People can rotate and delete across vhosts using this interface.
        # We should add some sanity checks.
 
        # FIXME: People can rotate and delete across vhosts using this interface.
        # We should add some sanity checks.


@@ -21,34 +17,37 @@ sub handler {
 
        Sesse::pr0n::Common::header($r, "Rotation/deletion results");
 
 
        Sesse::pr0n::Common::header($r, "Rotation/deletion results");
 

+       my $res = Plack::Response->new(200);
+       my $io = IO::String->new;
+

        {
                # Enable transactions and error raising temporarily
                local $dbh->{RaiseError} = 1;
 
        {
                # Enable transactions and error raising temporarily
                local $dbh->{RaiseError} = 1;
 

-               my @params = $apr->param();
+               my @params = $r->param();

                my $key;
                for $key (@params) {
                        local $dbh->{AutoCommit} = 0;
 
                        # Rotation
                my $key;
                for $key (@params) {
                        local $dbh->{AutoCommit} = 0;
 
                        # Rotation

-                       if ($key =~ /^rot-(\d+)-(90|180|270)$/ && $apr->param($key) eq 'on') {
+                       if ($key =~ /^rot-(\d+)-(90|180|270)$/ && $r->param($key) eq 'on') {

                                my ($id, $rotval) = ($1,$2);
                                my $fname = Sesse::pr0n::Common::get_disk_location($r, $id);
                                push @to_purge, Sesse::pr0n::Common::get_all_cache_urls($r, $dbh, $id);
                                (my $tmpfname = $fname) =~ s/\.jpg$/-tmp.jpg/;
 
                                system("/usr/bin/jpegtran -rotate $rotval -copy all < '$fname' > '$tmpfname' && /bin/mv '$tmpfname' '$fname'") == 0
                                my ($id, $rotval) = ($1,$2);
                                my $fname = Sesse::pr0n::Common::get_disk_location($r, $id);
                                push @to_purge, Sesse::pr0n::Common::get_all_cache_urls($r, $dbh, $id);
                                (my $tmpfname = $fname) =~ s/\.jpg$/-tmp.jpg/;
 
                                system("/usr/bin/jpegtran -rotate $rotval -copy all < '$fname' > '$tmpfname' && /bin/mv '$tmpfname' '$fname'") == 0

-                                       or error($r, "Rotation of $id [/usr/bin/jpegtran -rotate $rotval -copy all < '$fname' > '$tmpfname' && /bin/mv '$tmpfname' '$fname'] failed: $!.");
-                               $r->print("    <p>Rotated image ID `$id' by $rotval degrees.</p>\n");
+                                       or return error($r, "Rotation of $id [/usr/bin/jpegtran -rotate $rotval -copy all < '$fname' > '$tmpfname' && /bin/mv '$tmpfname' '$fname'] failed: $!.");
+                               $io->print("    <p>Rotated image ID `$id' by $rotval degrees.</p>\n");

 
                                if ($rotval == 90 || $rotval == 270) {
                                        my $q = $dbh->do('UPDATE images SET height=width,width=height WHERE id=?', undef, $id)
 
                                if ($rotval == 90 || $rotval == 270) {
                                        my $q = $dbh->do('UPDATE images SET height=width,width=height WHERE id=?', undef, $id)

-                                               or dberror($r, "Size clear of $id failed");
+                                               or return dberror($r, "Size clear of $id failed");

                                        $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE (vhost,event)=( SELECT vhost,event FROM images WHERE id=? )',
                                                undef, $id)
                                        $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE (vhost,event)=( SELECT vhost,event FROM images WHERE id=? )',
                                                undef, $id)

-                                               or dberror($r, "Cache invalidation at $id failed");
+                                               or return dberror($r, "Cache invalidation at $id failed");

                                }
                                }

-                       } elsif ($key =~ /^del-(\d+)$/ && $apr->param($key) eq 'on') {
+                       } elsif ($key =~ /^del-(\d+)$/ && $r->param($key) eq 'on') {

                                my $id = $1;
                                push @to_purge, Sesse::pr0n::Common::get_all_cache_urls($r, $dbh, $id);
                                {
                                my $id = $1;
                                push @to_purge, Sesse::pr0n::Common::get_all_cache_urls($r, $dbh, $id);
                                {


@@ -66,25 +65,26 @@ sub handler {
                                        if ($@) {
 # Some error occurred, rollback and bomb out
                                                $dbh->rollback;
                                        if ($@) {
 # Some error occurred, rollback and bomb out
                                                $dbh->rollback;

-                                               dberror($r, "Transaction aborted because $@");
+                                               return dberror($r, "Transaction aborted because $@");

                                        }
                                }
                                        }
                                }

-                               $r->print("    <p>Deleted image `$id'.</p>\n");
+                               $io->print("    <p>Deleted image `$id'.</p>\n");

                        }
                }
        }
        
                        }
                }
        }
        

-       my $event = $apr->param('event');
-       $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?', undef, $r->get_server_name, $event)
-               or dberror($r, "Cache invalidation failed");
+       my $event = $r->param('event');
+       $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?', undef, Sesse::pr0n::Common::get_server_name($r), $event)
+               or return dberror($r, "Cache invalidation failed");

 
        push @to_purge, "/$event/";
        push @to_purge, "/+all/";
 
        push @to_purge, "/$event/";
        push @to_purge, "/+all/";

-       Sesse::pr0n::Common::purge_cache($r, @to_purge);
-
-       Sesse::pr0n::Common::footer($r);
+       Sesse::pr0n::Common::purge_cache($r, $res, @to_purge);

 
 

-       return Apache2::Const::OK;
+       Sesse::pr0n::Common::footer($r, $io);
+       $io->setpos(0);
+       $res->body($io);
+       return $res;

 }
 
 1;
 }
 
 1;

diff --git a/perl/Sesse/pr0n/Select.pm b/perl/Sesse/pr0n/Select.pm
index 53dc8a019d7695eee5e6fe83b682302800c7f338..9db9d7b045db1ac4506d5d30eb65f77b22cfc0d7 100644 (file)
--- a/perl/Sesse/pr0n/Select.pm
+++ b/perl/Sesse/pr0n/Select.pm
@@ -3,41 +3,41 @@ use strict;
 use warnings;
 
 use Sesse::pr0n::Common qw(error dberror);
 use warnings;
 
 use Sesse::pr0n::Common qw(error dberror);

-use Apache2::Request;

 
 sub handler {
        my $r = shift;
 
 sub handler {
        my $r = shift;

-       my $apr = Apache2::Request->new($r);

        my $dbh = Sesse::pr0n::Common::get_dbh();
        my ($user, $takenby) = Sesse::pr0n::Common::check_access($r);
        my $dbh = Sesse::pr0n::Common::get_dbh();
        my ($user, $takenby) = Sesse::pr0n::Common::check_access($r);

-       if (!defined($user)) {
-               return Apache2::Const::OK;
-       }
+       return Sesse::pr0n::Common::generate_401($r) if (!defined($user));

 
 

-       my $event = $apr->param('event');
+       my $event = $r->param('event');

 
 

-       Sesse::pr0n::Common::header($r, "Selection results");
+       my $res = Plack::Response->new(200);
+       my $io = IO::String->new;
+       Sesse::pr0n::Common::header($r, $io, "Selection results");

 
        {
                # Enable transactions and error raising temporarily
                local $dbh->{AutoCommit} = 0;
                local $dbh->{RaiseError} = 1;
 
 
        {
                # Enable transactions and error raising temporarily
                local $dbh->{AutoCommit} = 0;
                local $dbh->{RaiseError} = 1;
 

-               my $filename = $apr->param('filename');
-               my $selected = $apr->param('selected');
+               my $filename = $r->param('filename');
+               my $selected = $r->param('selected');

                my $sql_selected = 'f';
                if (!defined($selected) || $selected eq '1') {
                        $sql_selected = 't';
                }
                my $sql_selected = 'f';
                if (!defined($selected) || $selected eq '1') {
                        $sql_selected = 't';
                }

-               $dbh->do('UPDATE images SET selected=? WHERE vhost=? AND event=? AND filename=?', undef, $sql_selected, $r->get_server_name, $event, $filename);
+               $dbh->do('UPDATE images SET selected=? WHERE vhost=? AND event=? AND filename=?', undef, $sql_selected, Sesse::pr0n::Common::get_server_name($r), $event, $filename);

        }
 
        }
 

-       $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?', undef, $r->get_server_name, $event)
-               or dberror($r, "Cache invalidation failed");
-       Sesse::pr0n::Common::purge_cache($r, "/$event/");
-       Sesse::pr0n::Common::footer($r);
+       $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?', undef, Sesse::pr0n::Common::get_server_name($r), $event)
+               or return dberror($r, "Cache invalidation failed");
+       Sesse::pr0n::Common::purge_cache($r, $res, "/$event/");
+       Sesse::pr0n::Common::footer($r, $io);

 
 

-       return Apache2::Const::OK;
+       $io->setpos(0);
+       $res->body($io);
+       return $res;

 }
 
 1;
 }
 
 1;

diff --git a/perl/Sesse/pr0n/Templates.pm b/perl/Sesse/pr0n/Templates.pm
index 8bf0c1f71226ce69d16d38e8e46ebfb7ac75f581..aac4058fc8ab183bef468f9d938f97201013e2e2 100644 (file)
--- a/perl/Sesse/pr0n/Templates.pm
+++ b/perl/Sesse/pr0n/Templates.pm
@@ -18,7 +18,7 @@ our %dirs = ();
 
 sub update_dirs {
        my $r = shift;
 
 sub update_dirs {
        my $r = shift;

-       my $base = $r->dir_config('TemplateBase');
+       my $base = $Sesse::pr0n::Config::template_base;

        
        for my $dir (<$base/*>) {
                next unless -d $dir;
        
        for my $dir (<$base/*>) {
                next unless -d $dir;


@@ -36,7 +36,7 @@ sub r_to_dir {
                update_dirs($r);
        }
        
                update_dirs($r);
        }
        

-       my $site = $r->get_server_name();
+       my $site = Sesse::pr0n::Common::get_server_name($r);

        if (defined($dirs{$site})) {
                return $site;
        } else {
        if (defined($dirs{$site})) {
                return $site;
        } else {


@@ -55,7 +55,7 @@ sub fetch_template {
 
        my $newcache = {};
 
 
        my $newcache = {};
 

-       my $base = $r->dir_config('TemplateBase');
+       my $base = $Sesse::pr0n::Config::template_base;

        open TEMPLATE, "<$base/$dir/$template"
                or ($dir ne 'default' and open TEMPLATE, "<$base/default/$template")
                or Sesse::pr0n::Common::error($r, "Couldn't open $dir/$template: $!");
        open TEMPLATE, "<$base/$dir/$template"
                or ($dir ne 'default' and open TEMPLATE, "<$base/default/$template")
                or Sesse::pr0n::Common::error($r, "Couldn't open $dir/$template: $!");


@@ -84,8 +84,8 @@ sub process_template {
 }
 
 sub print_template {
 }
 
 sub print_template {

-       my ($r, $template, $args) = @_;
-       $r->print(process_template($r, $template, $args));
+       my ($r, $io, $template, $args) = @_;
+       $io->print(process_template($r, $template, $args));

 }
 
 1;
 }
 
 1;

diff --git a/perl/Sesse/pr0n/WebDAV.pm b/perl/Sesse/pr0n/WebDAV.pm
index 3f896453db054d764a526166f483f36abfaf7f4b..84abaca33258cc1287716daa1a78daebf27047d7 100644 (file)
--- a/perl/Sesse/pr0n/WebDAV.pm
+++ b/perl/Sesse/pr0n/WebDAV.pm
@@ -5,53 +5,46 @@ use warnings;
 use Sesse::pr0n::Common qw(error dberror);
 use Digest::SHA;
 use MIME::Base64;
 use Sesse::pr0n::Common qw(error dberror);
 use Digest::SHA;
 use MIME::Base64;

-use Apache2::Request;
-use Apache2::Upload;

 
 sub handler {
        my $r = shift;
        my $dbh = Sesse::pr0n::Common::get_dbh();
 
 sub handler {
        my $r = shift;
        my $dbh = Sesse::pr0n::Common::get_dbh();

-                       
-       $r->headers_out->{'DAV'} = "1,2";
+
+       my $res = Plack::Response->new(200);
+       my $io = IO::String->new;
+       $r->header('DAV' => "1,2");

 
        # We only handle depth=0, depth=1 (cf. the RFC)
 
        # We only handle depth=0, depth=1 (cf. the RFC)

-       my $depth = $r->headers_in->{'depth'};
+       my $depth = $r->header('depth');

        $depth = 0 if (!defined($depth));
        if (defined($depth) && $depth ne "0" && $depth ne "1") {
        $depth = 0 if (!defined($depth));
        if (defined($depth) && $depth ne "0" && $depth ne "1") {

-               $r->content_type('text/plain; charset="utf-8"');
-               $r->status(403);
-               $r->print("Invalid depth setting");
-               return Apache2::Const::OK;
-       }
-
-       my ($user,$takenby) = Sesse::pr0n::Common::check_access($r);
-       if (!defined($user)) {
-               return Apache2::Const::OK;
+               $res->status(403);      
+               $res->content_type('text/plain; charset="utf-8"');
+               $res->body("Invalid depth setting");
+               return $res;

        }
 
        # Just "ping, are you alive and do you speak WebDAV"
        if ($r->method eq "OPTIONS") {
        }
 
        # Just "ping, are you alive and do you speak WebDAV"
        if ($r->method eq "OPTIONS") {

-               $r->content_type('text/plain; charset="utf-8"');
-               $r->status(200);
-               $r->headers_out->{'allow'} = 'OPTIONS,PUT';
-               $r->headers_out->{'ms-author-via'} = 'DAV';
-               return Apache2::Const::OK;
+               $res->content_type('text/plain; charset="utf-8"');
+               $res->header('allow' => 'OPTIONS,PUT');
+               $res->header('ms-author-via' => 'DAV');
+               return $res;

        }
        
        }
        

+       my ($user,$takenby) = Sesse::pr0n::Common::check_access($r);
+       return Sesse::pr0n::Common::generate_401($r) if (!defined($user));
+

        # Directory listings et al
        if ($r->method eq "PROPFIND") {
        # Directory listings et al
        if ($r->method eq "PROPFIND") {

-               # We ignore the body, but we _must_ consume it fully before
-               # we output anything, or Squid will get seriously confused
-               $r->discard_request_body;
-
-               $r->content_type('text/xml; charset="utf-8"');
-               $r->status(207);
+               $res->content_type('text/xml; charset="utf-8"');
+               $res->status(207);

 
 

-               if ($r->uri =~ m#^/webdav/?$#) {
-                       $r->headers_out->{'content-location'} = "/webdav/";
+               if ($r->path_info =~ m#^/webdav/?$#) {
+                       $res->header('content-location' => "/webdav/");

                
                        # Root directory
                
                        # Root directory

-                       $r->print(<<"EOF");
+                       $io->print(<<"EOF");

 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>
 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>


@@ -68,7 +61,7 @@ EOF
 
                        # Optionally list the upload/ dir
                        if ($depth >= 1) {
 
                        # Optionally list the upload/ dir
                        if ($depth >= 1) {

-                               $r->print(<<"EOF");
+                               $io->print(<<"EOF");

   <response>
      <href>/webdav/upload/</href>
      <propstat>
   <response>
      <href>/webdav/upload/</href>
      <propstat>


@@ -81,12 +74,12 @@ EOF
   </response>
 EOF
                        }
   </response>
 EOF
                        }

-                       $r->print("</multistatus>\n");
-                } elsif ($r->uri =~ m#^/webdav/upload/?$#) {
-                       $r->headers_out->{'content-location'} = "/webdav/upload/";
+                       $io->print("</multistatus>\n");
+                } elsif ($r->path_info =~ m#^/webdav/upload/?$#) {
+                       $res->header('content-location' => "/webdav/upload/");

                        
                        # Upload root directory
                        
                        # Upload root directory

-                       $r->print(<<"EOF");
+                       $io->print(<<"EOF");

 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>
 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>


@@ -104,16 +97,16 @@ EOF
                        # Optionally list all events
                        if ($depth >= 1) {
                                my $q = $dbh->prepare('SELECT * FROM events WHERE vhost=?') or
                        # Optionally list all events
                        if ($depth >= 1) {
                                my $q = $dbh->prepare('SELECT * FROM events WHERE vhost=?') or

-                                       dberror($r, "Couldn't list events");
-                               $q->execute($r->get_server_name) or
-                                       dberror($r, "Couldn't get events");
+                                       return dberror($r, "Couldn't list events");
+                               $q->execute(Sesse::pr0n::Common::get_server_name($r)) or
+                                       return dberror($r, "Couldn't get events");

                
                                while (my $ref = $q->fetchrow_hashref()) {
                
                                while (my $ref = $q->fetchrow_hashref()) {

-                                       my $id = $ref->{'event'};
-                                       my $name = $ref->{'name'};
+                                       my $id = Encode::encode_utf8($ref->{'event'});
+                                       my $name = Encode::encode_utf8($ref->{'name'});

                                
                                        $name =~ s/&/\&amp;/g;  # hack :-)
                                
                                        $name =~ s/&/\&amp;/g;  # hack :-)

-                                       $r->print(<<"EOF");
+                                       $io->print(<<"EOF");

   <response>
      <href>/webdav/upload/$id/</href>
      <propstat>
   <response>
      <href>/webdav/upload/$id/</href>
      <propstat>


@@ -130,24 +123,24 @@ EOF
                                $q->finish;
                        }
 
                                $q->finish;
                        }
 

-                       $r->print("</multistatus>\n");
-               } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/?$#) {
+                       $io->print("</multistatus>\n");
+               } elsif ($r->path_info =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/?$#) {

                        my $event = $1;
                        
                        my $event = $1;
                        

-                       $r->headers_out->{'content-location'} = "/webdav/upload/$event/";
+                       $res->header('content-location' => "/webdav/upload/$event/");

                        
                        # Check that we do indeed exist
                        my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numev FROM events WHERE vhost=? AND event=?',
                        
                        # Check that we do indeed exist
                        my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numev FROM events WHERE vhost=? AND event=?',

-                               undef, $r->get_server_name, $event);
+                               undef, Sesse::pr0n::Common::get_server_name($r), $event);

                        if ($ref->{'numev'} != 1) {
                        if ($ref->{'numev'} != 1) {

-                               $r->status(404);
-                               $r->content_type('text/plain; charset=utf-8');
-                               $r->print("Couldn't find event in database");
-                               return Apache2::Const::OK;
+                               $res->status(404);
+                               $res->content_type('text/plain; charset=utf-8');
+                               $res->body("Couldn't find event in database");
+                               return $res;

                        }
                        
                        # OK, list the directory
                        }
                        
                        # OK, list the directory

-                       $r->print(<<"EOF");
+                       $io->print(<<"EOF");

 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>
 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>


@@ -165,9 +158,9 @@ EOF
                        # List all the files within too, of course :-)
                        if ($depth >= 1) {
                                my $q = $dbh->prepare('SELECT * FROM images WHERE vhost=? AND event=?') or
                        # List all the files within too, of course :-)
                        if ($depth >= 1) {
                                my $q = $dbh->prepare('SELECT * FROM images WHERE vhost=? AND event=?') or

-                                       dberror($r, "Couldn't list images");
-                               $q->execute($r->get_server_name, $event) or
-                                       dberror($r, "Couldn't get events");
+                                       return dberror($r, "Couldn't list images");
+                               $q->execute(Sesse::pr0n::Common::get_server_name($r), $event) or
+                                       return dberror($r, "Couldn't get events");

                
                                while (my $ref = $q->fetchrow_hashref()) {
                                        my $id = $ref->{'id'};
                
                                while (my $ref = $q->fetchrow_hashref()) {
                                        my $id = $ref->{'id'};


@@ -178,7 +171,7 @@ EOF
                                        $mtime = POSIX::strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime($mtime));
                                        my $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename);
 
                                        $mtime = POSIX::strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime($mtime));
                                        my $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename);
 

-                                       $r->print(<<"EOF");
+                                       $io->print(<<"EOF");

   <response>
      <href>/webdav/upload/$event/$filename</href>
      <propstat>
   <response>
      <href>/webdav/upload/$event/$filename</href>
      <propstat>


@@ -196,7 +189,7 @@ EOF
                                $q->finish;
 
                                # And the magical autorename folder
                                $q->finish;
 
                                # And the magical autorename folder

-                               $r->print(<<"EOF");
+                               $io->print(<<"EOF");

   <response>
      <href>/webdav/upload/$event/autorename/</href>
      <propstat>
   <response>
      <href>/webdav/upload/$event/autorename/</href>
      <propstat>


@@ -210,27 +203,28 @@ EOF
 EOF
                        }
 
 EOF
                        }
 

-                       $r->print("</multistatus>\n");
-
-                       return Apache2::Const::OK;
-               } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/autorename/?$#) {
+                       $io->print("</multistatus>\n");
+                       $io->setpos(0);
+                       $res->body($io);
+                       return $res;
+               } elsif ($r->path_info =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/autorename/?$#) {

                        # The autorename folder is always empty
                        my $event = $1;
                        
                        # The autorename folder is always empty
                        my $event = $1;
                        

-                       $r->headers_out->{'content-location'} = "/webdav/upload/$event/autorename/";
+                       $res->header('content-location' => "/webdav/upload/$event/autorename/");

                        
                        # Check that we do indeed exist
                        my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numev FROM events WHERE vhost=? AND event=?',
                        
                        # Check that we do indeed exist
                        my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numev FROM events WHERE vhost=? AND event=?',

-                               undef, $r->get_server_name, $event);
+                               undef, Sesse::pr0n::Common::get_server_name($r), $event);

                        if ($ref->{'numev'} != 1) {
                        if ($ref->{'numev'} != 1) {

-                               $r->status(404);
-                               $r->content_type('text/plain; charset=utf-8');
-                               $r->print("Couldn't find event in database");
-                               return Apache2::Const::OK;
+                               $res->status(404);
+                               $res->content_type('text/plain; charset=utf-8');
+                               $res->body("Couldn't find event in database");
+                               return $res;

                        }
                        
                        # OK, list the (empty) directory
                        }
                        
                        # OK, list the (empty) directory

-                       $r->print(<<"EOF");
+                       $res->body(<<"EOF");

 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>
 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>


@@ -246,15 +240,15 @@ EOF
 </multistatus>
 EOF
        
 </multistatus>
 EOF
        

-                       return Apache2::Const::OK;
-               } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/([a-zA-Z0-9._()-]+)$#) {
+                       return $res;
+               } elsif ($r->path_info =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/([a-zA-Z0-9._()-]+)$#) {

                        # stat a single file
                        my ($event, $filename) = ($1, $2);
                        my ($fname, $size, $mtime);
                        
                        # check if we have a pending fake file for this
                        my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numfiles FROM fake_files WHERE event=? AND vhost=? AND filename=? AND expires_at > now()',
                        # stat a single file
                        my ($event, $filename) = ($1, $2);
                        my ($fname, $size, $mtime);
                        
                        # check if we have a pending fake file for this
                        my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numfiles FROM fake_files WHERE event=? AND vhost=? AND filename=? AND expires_at > now()',

-                               undef, $event, $r->get_server_name, $filename);
+                               undef, $event, Sesse::pr0n::Common::get_server_name($r), $filename);

                        if ($ref->{'numfiles'} == 1) {
                                $fname = "/dev/null";
                                $size = 0;
                        if ($ref->{'numfiles'} == 1) {
                                $fname = "/dev/null";
                                $size = 0;


@@ -264,15 +258,15 @@ EOF
                        }
                        
                        if (!defined($fname)) {
                        }
                        
                        if (!defined($fname)) {

-                               $r->status(404);
-                               $r->content_type('text/plain; charset=utf-8');
-                               $r->print("Couldn't find file");
-                               return Apache2::Const::OK;
+                               $res->status(404);
+                               $res->content_type('text/plain; charset=utf-8');
+                               $res->body("Couldn't find file");
+                               return $res;

                        }
                        my $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename);
                        
                        $mtime = POSIX::strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime($mtime));
                        }
                        my $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename);
                        
                        $mtime = POSIX::strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime($mtime));

-                       $r->print(<<"EOF");
+                       $res->body(<<"EOF");

 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>
 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>


@@ -289,15 +283,15 @@ EOF
   </response>
 </multistatus>
 EOF
   </response>
 </multistatus>
 EOF

-                       return Apache2::Const::OK;
-               } elsif ($r->uri =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/autorename/(.{1,250})$#) {
+                       return $res;
+               } elsif ($r->path_info =~ m#^/webdav/upload/([a-zA-Z0-9-]+)/autorename/(.{1,250})$#) {

                        # stat a single file in autorename
                        my ($event, $filename) = ($1, $2);
                        my ($fname, $size, $mtime);
                        
                        # check if we have a pending fake file for this
                        my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numfiles FROM fake_files WHERE event=? AND vhost=? AND filename=? AND expires_at > now()',
                        # stat a single file in autorename
                        my ($event, $filename) = ($1, $2);
                        my ($fname, $size, $mtime);
                        
                        # check if we have a pending fake file for this
                        my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numfiles FROM fake_files WHERE event=? AND vhost=? AND filename=? AND expires_at > now()',

-                               undef, $event, $r->get_server_name, $filename);
+                               undef, $event, Sesse::pr0n::Common::get_server_name($r), $filename);

                        if ($ref->{'numfiles'} == 1) {
                                $fname = "/dev/null";
                                $size = 0;
                        if ($ref->{'numfiles'} == 1) {
                                $fname = "/dev/null";
                                $size = 0;


@@ -305,22 +299,22 @@ EOF
                        } else {
                                # check if we have a "shadow file" for this
                                my $ref = $dbh->selectrow_hashref('SELECT id FROM shadow_files WHERE vhost=? AND event=? AND filename=? AND expires_at > now()',
                        } else {
                                # check if we have a "shadow file" for this
                                my $ref = $dbh->selectrow_hashref('SELECT id FROM shadow_files WHERE vhost=? AND event=? AND filename=? AND expires_at > now()',

-                                       undef, $r->get_server_name, $event, $filename);
+                                       undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename);

                                if (defined($ref)) {
                                        ($fname, $size, $mtime) = Sesse::pr0n::Common::stat_image_from_id($r, $ref->{'id'});
                                }
                        }
                        
                        if (!defined($fname)) {
                                if (defined($ref)) {
                                        ($fname, $size, $mtime) = Sesse::pr0n::Common::stat_image_from_id($r, $ref->{'id'});
                                }
                        }
                        
                        if (!defined($fname)) {

-                               $r->status(404);
-                               $r->content_type('text/plain; charset=utf-8');
-                               $r->print("Couldn't find file");
-                               return Apache2::Const::OK;
+                               $res->status(404);
+                               $res->content_type('text/plain; charset=utf-8');
+                               $res->body("Couldn't find file");
+                               return $res;

                        }
                        my $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename);
                        
                        $mtime = POSIX::strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime($mtime));
                        }
                        my $mime_type = Sesse::pr0n::Common::get_mimetype_from_filename($filename);
                        
                        $mtime = POSIX::strftime("%a, %d %b %Y %H:%M:%S GMT", gmtime($mtime));

-                       $r->print(<<"EOF");
+                       $io->print(<<"EOF");

 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>
 <?xml version="1.0" encoding="utf-8"?>
 <multistatus xmlns="DAV:">
   <response>


@@ -338,19 +332,22 @@ EOF
 </multistatus>
 EOF
                } else {
 </multistatus>
 EOF
                } else {

-                       $r->status(404);
-                       $r->content_type('text/plain; charset=utf-8');
-                       $r->print("Couldn't find file");
+                       $res->status(404);
+                       $res->content_type('text/plain; charset=utf-8');
+                       $res->body("Couldn't find file");
+                       return $res;

                }
                }

-               return Apache2::Const::OK;
+               $io->setpos(0);
+               $res->body($io);
+               return $res;

        }
        
        if ($r->method eq "HEAD" or $r->method eq "GET") {
        }
        
        if ($r->method eq "HEAD" or $r->method eq "GET") {

-               if ($r->uri !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(.{1,250})$#) {
-                       $r->status(404);
-                       $r->content_type('text/xml; charset=utf-8');
-                       $r->print("<?xml version=\"1.0\"?>\n<p>Couldn't find file</p>");
-                       return Apache2::Const::OK;
+               if ($r->path_info !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(.{1,250})$#) {
+                       $res->status(404);
+                       $res->content_type('text/xml; charset=utf-8');
+                       $res->body("<?xml version=\"1.0\"?>\n<p>Couldn't find file</p>");
+                       return $res;

                }
 
                my ($event, $autorename, $filename) = ($1, $2, $3);
                }
 
                my ($event, $autorename, $filename) = ($1, $2, $3);


@@ -360,7 +357,7 @@ EOF
 
                # check if we have a pending fake file for this
                my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numfiles FROM fake_files WHERE event=? AND vhost=? AND filename=? AND expires_at > now()',
 
                # check if we have a pending fake file for this
                my $ref = $dbh->selectrow_hashref('SELECT count(*) AS numfiles FROM fake_files WHERE event=? AND vhost=? AND filename=? AND expires_at > now()',

-                       undef, $event, $r->get_server_name, $filename);
+                       undef, $event, Sesse::pr0n::Common::get_server_name($r), $filename);

                if ($ref->{'numfiles'} == 1) {
                        $fname = "/dev/null";
                        $size = 0;
                if ($ref->{'numfiles'} == 1) {
                        $fname = "/dev/null";
                        $size = 0;


@@ -369,7 +366,7 @@ EOF
                        # check if we have a "shadow file" for this
                        if (defined($autorename) && $autorename eq "autorename/") {
                                my $ref = $dbh->selectrow_hashref('SELECT id FROM shadow_files WHERE vhost=? AND event=? AND filename=? AND expires_at > now()',
                        # check if we have a "shadow file" for this
                        if (defined($autorename) && $autorename eq "autorename/") {
                                my $ref = $dbh->selectrow_hashref('SELECT id FROM shadow_files WHERE vhost=? AND event=? AND filename=? AND expires_at > now()',

-                                       undef, $r->get_server_name, $event, $filename);
+                                       undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename);

                                if (defined($ref)) {
                                        ($fname, $size, $mtime) = Sesse::pr0n::Common::stat_image_from_id($r, $ref->{'id'});
                                }
                                if (defined($ref)) {
                                        ($fname, $size, $mtime) = Sesse::pr0n::Common::stat_image_from_id($r, $ref->{'id'});
                                }


@@ -379,34 +376,34 @@ EOF
                }
                
                if (!defined($fname)) {
                }
                
                if (!defined($fname)) {

-                       $r->status(404);
-                       $r->content_type('text/plain; charset=utf-8');
-                       $r->print("Couldn't find file");
-                       return Apache2::Const::OK;
+                       $res->status(404);
+                       $res->content_type('text/plain; charset=utf-8');
+                       $res->body("Couldn't find file");
+                       return $res;

                }
                
                }
                

-               $r->status(200);
-               $r->set_content_length($size);
-               $r->set_last_modified($mtime);
+               $res->status(200);
+               $res->set_content_length($size);
+               Sesse::pr0n::Common::set_last_modified($res, $mtime);

        
                if ($r->method eq "GET") {
        
                if ($r->method eq "GET") {

-                       $r->sendfile($fname);
+                       $res->content(IO::File::WithPath->new($fname));

                }
                }

-               return Apache2::Const::OK;
+               return $res;

        }
        
        if ($r->method eq "PUT") {
        }
        
        if ($r->method eq "PUT") {

-               if ($r->uri !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(.{1,250})$#) {
-                       $r->status(403);
-                       $r->content_type('text/plain; charset=utf-8');
-                       $r->print("No access");
-                       return Apache2::Const::OK;
+               if ($r->path_info !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(.{1,250})$#) {
+                       $res->status(403);
+                       $res->content_type('text/plain; charset=utf-8');
+                       $res->body("No access");
+                       return $res;

                }
                
                my ($event, $autorename, $filename) = ($1, $2, $3);
                }
                
                my ($event, $autorename, $filename) = ($1, $2, $3);

-               my $size = $r->headers_in->{'content-length'};
+               my $size = $r->header('content-length');

                if (!defined($size)) {
                if (!defined($size)) {

-                       $size = $r->headers_in->{'x-expected-entity-length'};
+                       $size = $r->header('x-expected-entity-length');

                }
                my $orig_filename = $filename;
 
                }
                my $orig_filename = $filename;
 


@@ -415,10 +412,10 @@ EOF
                        if (defined($autorename) && $autorename eq "autorename/") {
                                $filename =~ tr/a-zA-Z0-9.()-/_/c;
                        } else {
                        if (defined($autorename) && $autorename eq "autorename/") {
                                $filename =~ tr/a-zA-Z0-9.()-/_/c;
                        } else {

-                               $r->status(403);
-                               $r->content_type('text/plain; charset=utf-8');
-                               $r->print("Illegal characters in filename");
-                               return Apache2::Const::OK;
+                               $res->status(403);
+                               $res->content_type('text/plain; charset=utf-8');
+                               $res->body("Illegal characters in filename");
+                               return $res;

                        }
                }
                
                        }
                }
                


@@ -428,38 +425,38 @@ EOF
                # 
                if ($size == 0 || $filename =~ /^\.(_|DS_Store)/) {
                        $dbh->do('DELETE FROM fake_files WHERE expires_at <= now() OR (event=? AND vhost=? AND filename=?);',
                # 
                if ($size == 0 || $filename =~ /^\.(_|DS_Store)/) {
                        $dbh->do('DELETE FROM fake_files WHERE expires_at <= now() OR (event=? AND vhost=? AND filename=?);',

-                               undef, $event, $r->get_server_name, $filename)
-                               or dberror($r, "Couldn't prune fake_files");
+                               undef, $event, Sesse::pr0n::Common::get_server_name($r), $filename)
+                               or return dberror($r, "Couldn't prune fake_files");

                        $dbh->do('INSERT INTO fake_files (vhost,event,filename,expires_at) VALUES (?,?,?,now() + interval \'1 day\');',
                        $dbh->do('INSERT INTO fake_files (vhost,event,filename,expires_at) VALUES (?,?,?,now() + interval \'1 day\');',

-                               undef, $r->get_server_name, $event, $filename)
-                               or dberror($r, "Couldn't add file");
-                       $r->content_type('text/plain; charset="utf-8"');
-                       $r->status(201);
-                       $r->print("OK");
-                       $r->log->info("Fake upload of $event/$filename");
-                       return Apache2::Const::OK;
+                               undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename)
+                               or return dberror($r, "Couldn't add file");
+                       $res->content_type('text/plain; charset="utf-8"');
+                       $res->status(201);
+                       $res->body("OK");
+                       Sesse::pr0n::Common::log_info($r, "Fake upload of $event/$filename");
+                       return $res;

                }
                        
                # Get the new ID
                my $ref = $dbh->selectrow_hashref("SELECT NEXTVAL('imageid_seq') AS id;");
                my $newid = $ref->{'id'};
                if (!defined($newid)) {
                }
                        
                # Get the new ID
                my $ref = $dbh->selectrow_hashref("SELECT NEXTVAL('imageid_seq') AS id;");
                my $newid = $ref->{'id'};
                if (!defined($newid)) {

-                       dberror($r, "Couldn't get new ID");
+                       return dberror($r, "Couldn't get new ID");

                }
                
                # Autorename if we need to
                $ref = $dbh->selectrow_hashref("SELECT COUNT(*) AS numfiles FROM images WHERE vhost=? AND event=? AND filename=?",
                }
                
                # Autorename if we need to
                $ref = $dbh->selectrow_hashref("SELECT COUNT(*) AS numfiles FROM images WHERE vhost=? AND event=? AND filename=?",

-                                              undef, $r->get_server_name, $event, $filename)
-                       or dberror($r, "Couldn't check for existing files");
+                                              undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename)
+                       or return dberror($r, "Couldn't check for existing files");

                if ($ref->{'numfiles'} > 0) {
                        if (defined($autorename) && $autorename eq "autorename/") {
                if ($ref->{'numfiles'} > 0) {
                        if (defined($autorename) && $autorename eq "autorename/") {

-                               $r->log->info("Renaming $filename to $newid.jpeg");
+                               Sesse::pr0n::Common::log_info($r, "Renaming $filename to $newid.jpeg");

                                $filename = "$newid.jpeg";
                        } else {
                                $filename = "$newid.jpeg";
                        } else {

-                               $r->status(403);
-                               $r->content_type('text/plain; charset=utf-8');
-                               $r->print("File $filename already exists in event $event, cannot overwrite");
-                               return Apache2::Const::OK;
+                               $res->status(403);
+                               $res->content_type('text/plain; charset=utf-8');
+                               $res->body("File $filename already exists in event $event, cannot overwrite");
+                               return $res;

                        }
                }
                
                        }
                }
                


@@ -472,23 +469,19 @@ EOF
                        # Try to insert this new file
                        eval {
                                $dbh->do('DELETE FROM fake_files WHERE vhost=? AND event=? AND filename=?',
                        # Try to insert this new file
                        eval {
                                $dbh->do('DELETE FROM fake_files WHERE vhost=? AND event=? AND filename=?',

-                                       undef, $r->get_server_name, $event, $filename);
+                                       undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename);

                                        
                                $dbh->do('INSERT INTO images (id,vhost,event,uploadedby,takenby,filename) VALUES (?,?,?,?,?,?)',
                                        
                                $dbh->do('INSERT INTO images (id,vhost,event,uploadedby,takenby,filename) VALUES (?,?,?,?,?,?)',

-                                       undef, $newid, $r->get_server_name, $event, $user, $takenby, $filename);
-                               Sesse::pr0n::Common::purge_cache($r, "/$event/");
+                                       undef, $newid, Sesse::pr0n::Common::get_server_name($r), $event, $user, $takenby, $filename);
+                               Sesse::pr0n::Common::purge_cache($r, $res, "/$event/");

 
                                # Now save the file to disk
                                Sesse::pr0n::Common::ensure_disk_location_exists($r, $newid);   
                                $fname = Sesse::pr0n::Common::get_disk_location($r, $newid);
 
                                # Now save the file to disk
                                Sesse::pr0n::Common::ensure_disk_location_exists($r, $newid);   
                                $fname = Sesse::pr0n::Common::get_disk_location($r, $newid);

-                               open NEWFILE, ">$fname"
-                                       or die "$fname: $!";
-
-                               my $buf;
-                               if ($r->read($buf, $size)) {
-                                       print NEWFILE $buf or die "write($fname): $!";
-                               }

 
 

+                               open NEWFILE, ">", $fname
+                                       or die "$fname: $!";
+                               print NEWFILE $r->content;

                                close NEWFILE or die "close($fname): $!";
                                
                                # Orient stuff correctly
                                close NEWFILE or die "close($fname): $!";
                                
                                # Orient stuff correctly


@@ -506,51 +499,50 @@ EOF
                                # OK, we got this far, commit
                                $dbh->commit;
 
                                # OK, we got this far, commit
                                $dbh->commit;
 

-                               $r->log->notice("Successfully wrote $event/$filename to $fname");
+                               Sesse::pr0n::Common::log_info($r, "Successfully wrote $event/$filename to $fname");

                        };
                        if ($@) {
                                # Some error occurred, rollback and bomb out
                                $dbh->rollback;
                        };
                        if ($@) {
                                # Some error occurred, rollback and bomb out
                                $dbh->rollback;

-                               error($r, "Transaction aborted because $@");

                                unlink($fname);
                                unlink($fname);

+                               return error($r, "Transaction aborted because $@");

                        }
                }
 
                # Insert a `shadow file' we can stat the next day or so
                if (defined($autorename) && $autorename eq "autorename/") {
                        $dbh->do('DELETE FROM shadow_files WHERE expires_at <= now() OR (vhost=? AND event=? AND filename=?);',
                        }
                }
 
                # Insert a `shadow file' we can stat the next day or so
                if (defined($autorename) && $autorename eq "autorename/") {
                        $dbh->do('DELETE FROM shadow_files WHERE expires_at <= now() OR (vhost=? AND event=? AND filename=?);',

-                               undef, $r->get_server_name, $event, $filename)
-                               or dberror($r, "Couldn't prune shadow_files");
+                               undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename)
+                               or return dberror($r, "Couldn't prune shadow_files");

                        $dbh->do('INSERT INTO shadow_files (vhost,event,filename,id,expires_at) VALUES (?,?,?,?,now() + interval \'1 day\');',
                        $dbh->do('INSERT INTO shadow_files (vhost,event,filename,id,expires_at) VALUES (?,?,?,?,now() + interval \'1 day\');',

-                               undef, $r->get_server_name, $event, $orig_filename, $newid)
-                               or dberror($r, "Couldn't add shadow file");
-                       $r->log->info("Added shadow entry for $event/$filename");
+                               undef, Sesse::pr0n::Common::get_server_name($r), $event, $orig_filename, $newid)
+                               or return dberror($r, "Couldn't add shadow file");
+                       Sesse::pr0n::Common::log_info($r, "Added shadow entry for $event/$filename");

                }
 
                }
 

-               $r->content_type('text/plain; charset="utf-8"');
-               $r->status(201);
-               $r->print("OK");
-
-               return Apache2::Const::OK;
+               $res->content_type('text/plain; charset="utf-8"');
+               $res->status(201);
+               $res->body("OK");
+               return $res;

        }
        
        # Yes, we fake locks. :-)
        if ($r->method eq "LOCK") {
        }
        
        # Yes, we fake locks. :-)
        if ($r->method eq "LOCK") {

-               if ($r->uri !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?([a-zA-Z0-9._-]+)$#) {
-                       $r->status(403);
-                       $r->content_type('text/plain; charset=utf-8');
-                       $r->print("No access");
-                       return Apache2::Const::OK;
+               if ($r->path_info !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?([a-zA-Z0-9._-]+)$#) {
+                       $res->status(403);
+                       $res->content_type('text/plain; charset=utf-8');
+                       $res->body("No access");
+                       return $res;

                }
 
                my ($event, $autorename, $filename) = ($1, $2, $3);
                $autorename = '' if (!defined($autorename));
                my $sha1 = Digest::SHA::sha1_base64("/$event/$autorename$filename");
 
                }
 
                my ($event, $autorename, $filename) = ($1, $2, $3);
                $autorename = '' if (!defined($autorename));
                my $sha1 = Digest::SHA::sha1_base64("/$event/$autorename$filename");
 

-               $r->status(200);
-               $r->content_type('text/xml; charset=utf-8');
+               $res->status(200);
+               $res->content_type('text/xml; charset=utf-8');

 
 

-               $r->print(<<"EOF");
+               $io->print(<<"EOF");

 <?xml version="1.0" encoding="utf-8"?>
 <prop xmlns="DAV:">
   <lockdiscovery>
 <?xml version="1.0" encoding="utf-8"?>
 <prop xmlns="DAV:">
   <lockdiscovery>


@@ -569,38 +561,39 @@ EOF
   </lockdiscovery>
 </prop>
 EOF
   </lockdiscovery>
 </prop>
 EOF

-               return Apache2::Const::OK;
+               $io->setpos(0);
+               $res->body($io);
+               return $res;

        }
        
        if ($r->method eq "UNLOCK") {
        }
        
        if ($r->method eq "UNLOCK") {

-               $r->content_type('text/plain; charset="utf-8"');
-               $r->status(200);
-               $r->print("OK");
-
-               return Apache2::Const::OK;
+               $res->content_type('text/plain; charset="utf-8"');
+               $res->status(200);
+               $res->body("OK");
+               return $res;

        }
 
        if ($r->method eq "DELETE") {
        }
 
        if ($r->method eq "DELETE") {

-               if ($r->uri !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(\._[a-zA-Z0-9._-]+)$#) {
-                       $r->status(403);
-                       $r->content_type('text/plain; charset=utf-8');
-                       $r->print("No access");
-                       return Apache2::Const::OK;
+               if ($r->path_info !~ m#^/webdav/upload/([a-zA-Z0-9-]+)/(autorename/)?(\._[a-zA-Z0-9._-]+)$#) {
+                       $res->status(403);
+                       $res->content_type('text/plain; charset=utf-8');
+                       $res->body("No access");
+                       return $res;

                }
                
                my ($event, $autorename, $filename) = ($1, $2, $3);
                $dbh->do('DELETE FROM images WHERE vhost=? AND event=? AND filename=?',
                }
                
                my ($event, $autorename, $filename) = ($1, $2, $3);
                $dbh->do('DELETE FROM images WHERE vhost=? AND event=? AND filename=?',

-                       undef, $r->get_server_name, $event, $filename)
-                       or dberror($r, "Couldn't remove file");
+                       undef, Sesse::pr0n::Common::get_server_name($r), $event, $filename)
+                       or return dberror($r, "Couldn't remove file");

                $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?',
                $dbh->do('UPDATE last_picture_cache SET last_update=CURRENT_TIMESTAMP WHERE vhost=? AND event=?',

-                       undef, $r->get_server_name, $event)
-                       or dberror($r, "Couldn't invalidate cache");
-               $r->status(200);
-               $r->print("OK");
+                       undef, Sesse::pr0n::Common::get_server_name($r), $event)
+                       or return dberror($r, "Couldn't invalidate cache");
+               $res->status(200);
+               $res->body("OK");

 
 

-               $r->log->info("deleted $event/$filename");
+               Sesse::pr0n::Common::log_info($r, "deleted $event/$filename");

                
                

-               return Apache2::Const::OK;
+               return $res;

        }
        
        if ($r->method eq "MOVE" or
        }
        
        if ($r->method eq "MOVE" or


@@ -608,18 +601,17 @@ EOF
            $r->method eq "RMCOL" or
            $r->method eq "RENAME" or
            $r->method eq "COPY") {
            $r->method eq "RMCOL" or
            $r->method eq "RENAME" or
            $r->method eq "COPY") {

-               $r->content_type('text/plain; charset="utf-8"');
-               $r->status(403);
-               $r->print("Sorry, you do not have access to that feature.");
-               return Apache2::Const::OK;
+               $res->content_type('text/plain; charset="utf-8"');
+               $res->status(403);
+               $res->body("Sorry, you do not have access to that feature.");
+               return $res;

        }
 
        }
 

-       $r->content_type('text/plain; charset=utf-8');
-       $r->log->error("unknown method " . $r->method);
-       $r->status(500);
-       $r->print("Unknown method");
-       
-       return Apache2::Const::OK;
+       $res->content_type('text/plain; charset=utf-8');
+       Sesse::pr0n::Common::log_error($r, "unknown method " . $r->method);
+       $res->status(500);
+       $res->body("Unknown method");
+       return $res;

 }
 
 1;
 }
 
 1;

diff --git a/perl/Sesse/pr0n/pr0n.pm b/perl/Sesse/pr0n/pr0n.pm
index 939139808aa6315bd5fb44db07584d095f276b7a..bddfe223e2192e884db28e34392c7ce77c216ebb 100644 (file)
--- a/perl/Sesse/pr0n/pr0n.pm
+++ b/perl/Sesse/pr0n/pr0n.pm
@@ -6,6 +6,7 @@ use Sesse::pr0n::Rotate;
 use Sesse::pr0n::Select;
 use Sesse::pr0n::WebDAV;
 use Sesse::pr0n::NewEvent;
 use Sesse::pr0n::Select;
 use Sesse::pr0n::WebDAV;
 use Sesse::pr0n::NewEvent;

+use IO::File::WithPath;

 
 package Sesse::pr0n::pr0n;
 use strict;    
 
 package Sesse::pr0n::pr0n;
 use strict;    


@@ -14,7 +15,7 @@ use warnings;
 sub handler {
        my $r = shift;
 
 sub handler {
        my $r = shift;
 

-       my $uri = $r->uri;
+       my $uri = $r->path_info;

        if ($uri eq '/' || $uri =~ /^\/\+tags\/?$/) {
                return Sesse::pr0n::Listing::handler($r);
        } elsif ($uri eq '/robots.txt' ||
        if ($uri eq '/' || $uri =~ /^\/\+tags\/?$/) {
                return Sesse::pr0n::Listing::handler($r);
        } elsif ($uri eq '/robots.txt' ||


@@ -33,29 +34,32 @@ sub handler {
                 $uri eq '/pr0n.ico' ||
                 $uri =~ m#^/usage/([a-zA-Z0-9_.]+)$#) {
                $uri =~ s#^/##;
                 $uri eq '/pr0n.ico' ||
                 $uri =~ m#^/usage/([a-zA-Z0-9_.]+)$#) {
                $uri =~ s#^/##;

-               my $fname = Sesse::pr0n::Common::get_base($r) . 'files/' . $uri;
+               my $fname = $Sesse::pr0n::Config::image_base . 'files/' . $uri;

                my (undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime) = stat($fname)
                        or error($r, "stat of $fname: $!");
 
                my (undef, undef, undef, undef, undef, undef, undef, $size, undef, $mtime) = stat($fname)
                        or error($r, "stat of $fname: $!");
 

-               $r->content_type(Sesse::pr0n::Common::get_mimetype_from_filename($uri));
-               $r->set_content_length($size);  
-               $r->set_last_modified($mtime);
+               my $res = Plack::Response->new(200);
+               $res->content_type(Sesse::pr0n::Common::get_mimetype_from_filename($uri));
+               $res->content_length($size);    
+               Sesse::pr0n::Common::set_last_modified($res, $mtime);

 
 

-               if((my $rc = $r->meets_conditions) != Apache2::Const::OK) {
-                       return $rc;
-               }
+               #if((my $rc = $r->meets_conditions) != Apache2::Const::OK) {
+               #       return $rc;
+               #}

 
 

-               $r->sendfile(Sesse::pr0n::Common::get_base($r) . 'files/' . $uri);
-               return Apache2::Const::OK;
+               $res->content(IO::File::WithPath->new($Sesse::pr0n::Config::image_base . 'files/' . $uri));
+               return $res;

        } elsif ($uri eq '/newevent.html') {
        } elsif ($uri eq '/newevent.html') {

-               $r->content_type('text/html; charset=utf-8');
-               $r->sendfile(Sesse::pr0n::Common::get_base($r) . "files/newevent.html");
-               return Apache2::Const::OK;
+               my $res = Plack::Response->new(200);
+               $res->content_type('text/html; charset=utf-8');
+               $res->content(IO::File::WithPath->new($Sesse::pr0n::Config::image_base . 'files/newevent.html'));
+               return $res;

        } elsif ($uri =~ m#^/webdav#) {
                return Sesse::pr0n::WebDAV::handler($r);
        } elsif ($uri =~ m#^/usage/([a-zA-Z0-9.-]+)$#) {
        } elsif ($uri =~ m#^/webdav#) {
                return Sesse::pr0n::WebDAV::handler($r);
        } elsif ($uri =~ m#^/usage/([a-zA-Z0-9.-]+)$#) {

-               $r->sendfile(Sesse::pr0n::Common::get_base($r) . "usage/$1");
-               return Apache2::Const::OK;
+               my $res = Plack::Response->new(200);
+               $res->content(IO::File::WithPath->new($Sesse::pr0n::Config::image_base . "usage/$1"));
+               return $res;

        } elsif ($uri =~ m#^/rotate$#) {
                return Sesse::pr0n::Rotate::handler($r);
        } elsif ($uri =~ m#^/select$#) {
        } elsif ($uri =~ m#^/rotate$#) {
                return Sesse::pr0n::Rotate::handler($r);
        } elsif ($uri =~ m#^/select$#) {


@@ -70,11 +74,14 @@ sub handler {
                return Sesse::pr0n::Image::handler($r);
        }
 
                return Sesse::pr0n::Image::handler($r);
        }
 

-       $r->status(404);
-       Sesse::pr0n::Common::header($r, "404 File Not Found");
-       $r->print("     <p>The file you requested was not found.</p>");
-       Sesse::pr0n::Common::footer($r);
-       return Apache2::Const::OK;
+       my $res = Plack::Response->new(404);
+       my $io = IO::String->new;
+       Sesse::pr0n::Common::header($r, $io, "404 File Not Found");
+       $io->print("     <p>The file you requested was not found.</p>");
+       Sesse::pr0n::Common::footer($r, $io);
+       $io->setpos(0);
+       $res->body($io);
+       return $res;

 }
 
 1;
 }
 
 1;

diff --git a/perl/mkpasswd.pl b/perl/mkpasswd.pl
new file mode 100755 (executable)
index 0000000..5d6aac3
--- /dev/null
+++ b/perl/mkpasswd.pl
@@ -0,0 +1,24 @@
+#! /usr/bin/perl
+
+
+use lib qw(.);
+use Term::ReadKey;
+use strict;
+use warnings;
+
+use Sesse::pr0n::Config;
+eval {
+       require Sesse::pr0n::Config_local;
+};
+use Sesse::pr0n::Common;
+
+Term::ReadKey::ReadMode(2);
+print STDERR "Enter password: ";
+chomp (my $pass = <STDIN>);
+print STDERR "\n";
+Term::ReadKey::ReadMode(0);
+
+my $salt = Sesse::pr0n::Common::get_pseudorandom_bytes(16);  # Doesn't need to be cryptographically secur.
+my $hash = "\$2a\$07\$" . Crypt::Eksblowfish::Bcrypt::en_base64($salt);
+print Crypt::Eksblowfish::Bcrypt::bcrypt($pass, $hash), "\n";
+

diff --git a/perl/pr0n.psgi b/perl/pr0n.psgi
new file mode 100644 (file)
index 0000000..6a015dc
--- /dev/null
+++ b/perl/pr0n.psgi
@@ -0,0 +1,16 @@
+#! /usr/bin/perl
+
+use strict;
+use warnings;
+use lib qw(.);
+
+use Plack::Request;
+use Plack::Response;
+use Sesse::pr0n::pr0n;
+
+sub {
+       my $env = shift;
+       my $req = Plack::Request->new($env);
+       my $res = Sesse::pr0n::pr0n::handler($req);
+       return $res->finalize;
+}

diff --git a/pr0n.service b/pr0n.service
new file mode 100644 (file)
index 0000000..a3f207e
--- /dev/null
+++ b/pr0n.service
@@ -0,0 +1,12 @@
+[Unit]
+Description=pr0n app server
+After=network.target
+
+[Service]
+ExecStart=/usr/bin/start_server --port=127.0.0.1:5015 -- plackup -I/srv/pr0n.sesse.net/perl -s Starlet /srv/pr0n.sesse.net/perl/pr0n.psgi
+Type=simple
+Restart=on-failure
+ExecReload=/bin/kill -HUP $MAINPID
+
+[Install]
+WantedBy=multi-user.target