root/websites/showa_photo_generator/s.cgi @ 38876

#!/usr/bin/perl
# -*- coding:utf-8 -*-
#
# Author: FUJIWARA Shunichiro <fujiwara.shunichiro at gmail.com>
# License: Same as Perl
#

use strict;
use Imager;
use Imager::Fill;
use Imager::Font;
use URI::Fetch;
use Cache::Memcached;
use CGI::Carp qw / fatalsToBrowser /;
use CGI;
use Digest::SHA qw/ sha1_hex /;
use List::Util qw/ min max /;
use Data::Dumper;

my $q = CGI->new;

my $cache = Cache::Memcached->new({
    servers => ['127.0.0.1:11211'],
});

my $uri;
if ( $q->param('uri') ) {
    $uri = $q->param('uri');
}
else {
    $uri = $q->path_info;
    $uri =~ s{^/}{};
    $uri =~ s{(^https?:/)([^/])}{$1/$2};
}

my $data;
if ( $uri ) {
    $data = data_from_uri($uri, $q);
    $data = convert( $data, $cache, $q );
    if ($cache) {
        $cache->set( cache_key( $uri, $q ) => $data => 3600 );
    }
    output($data);
}
elsif ( $q->param('file') ) {
    $data = data_from_upload( $q->param('file') );
    my $file = store_file( convert( $data, undef, $q ) );
    redirect($file);
}
elsif ( $q->param('files') ) {
    $data = data_from_upload_multi( $q->param('files') );
    my $file = store_file( convert( $data, undef, $q ) );
    output_text( URI->new_abs( $file, $q->url )->as_string );
}
else {
    error("no data");
}
exit;

sub store_file {
    my $data = shift;
    my $file = sprintf "files/%s.jpg", sha1_hex( rand() . $ENV{REMOTE_ADDR} );
    open my $out, '>', $file or die $!;
    print $out $data;
    close $out;
    return $file;
}

sub data_from_upload {
    my $fh = shift;
    local $/ = undef;
    $data = <$fh>;
}

sub data_from_upload_multi {
    my $n = shift;
    local $/ = undef;

    for my $i ( 1 .. $n ) {
        my $info = $q->uploadInfo( $q->param("file_$i") );
        if ( $info->{'Content-Type'} =~ /^image\// ) {
            my $fh = $q->upload("file_$i");
            return <$fh>;
        }
    }
    return;
}

sub cache_key {
    my ( $uri, $q ) = @_;

    return sprintf(
        "result:%s:%s:%s:%s",
        $uri,
        $q->param('date'),
        $q->param('noborder'),
        $q->param('glossy'),
    );
}

sub data_from_uri {
    my ( $uri, $q ) = @_;
    if ( my $data = $cache->get( cache_key( $uri, $q ) ) ) {
        output($data);
        exit;
    }
    else {
    }
    my $res = URI::Fetch->fetch( $uri, Cache => $cache )
        or error( URI::Fetch->errstr );
    return $res->content;
}

sub convert {
    my ( $data, $cache, $q ) = @_;

    my $img = Imager->new;
    $img->read( data => $data )
        or error( $img->errstr );

    $img->filter( type => "contrast", intensity => 0.7 );
    $img->filter( type => "conv", coef => [ 0, 1, 0.2 ] );
    $img = solid_border( $img, "#bbbbbb" ) unless $q->param('noborder');

    my $fill = Imager::Fill->new( solid => random_color('302515'), combine => 'add' );
    $img->box( fill => $fill );
    $fill = Imager::Fill->new( solid => '#111111', combine => 'add' );
    $img->box( fill => $fill );
    $img = add_date( $img, $q->param('date') )
        if $q->param('date');

    my $amount = $q->param('glossy') ? 3 : 10;
    $img->filter(
        type    => 'noise',
        amount  => $amount,
        subtype => 1,
    );

    $img->write( data => \$data, type => 'jpeg' );

    return $data;
}

sub redirect {
    my $path = shift;
    print "Location: $path\n\n";
}

sub error {
    my $msg = shift;
    print "status: 500\n";
    print "Content-Type: text/html\n\n";
    die $msg;
}

sub output {
    print "Content-Type: image/jpeg\n";
    print "Content-Length: ", length($_[0]), "\n";
    print "\n";
    print $_[0];
}

sub output_text {
    my $file = shift;
    print "Content-Type: text/plain; charset=utf-8\n";
    print "\n";
    print "昭和の写真ジェネレータ\n";
    print "変換されました\n$file\n";
}

# solid_border is based on Imager/samples/border.pl
# http://search.cpan.org/~tonyc/Imager/samples/border.pl
sub solid_border {
  my ( $source, $color ) = @_;

  my $w = $source->getwidth();
  my $h = $source->getheight();
  my $border = int ( max( $w * 0.015, $h * 0.015, 5 ) );
  my $out = Imager->new(
      xsize    => $source->getwidth()  + 2 * $border,
      ysize    => $source->getheight() + 2 * $border,
      bits     => $source->bits,
      channels => $source->getchannels,
  );

  $out->box( filled => 1, color => $color )
    or die "Invalid color '$color':", $out->errstr, "\n";

  $out->paste(
      left => $border,
      top  => $border,
      img  => $source,
  );

  return $out;
}

sub random_color {
    my $code = shift;
    my @color = map { hex $_ } ( $code =~ m{(..)}g );

    for my $c ( @color ) {
        $c *= ( 1 + ( rand() > 0.5 ? +1 : -1 ) * rand(0.15) );
        $c = min( $c, 255 );
        $c = max( $c, 0   );
    }
    $code = sprintf('#%02x%02x%02x', @color);
    return $code;
}

sub add_date {
    my $img  = shift;
    my $date = shift;
    $date =~ s/[^ \d\-\.]//g;

    my $color  = Imager::Color->new('#ffaa33');
    my $ttfont = Imager::Font->new(
        file  => '7barPBd.TTF', # http://www.trojanbear.net/omake.htm#sevenbarb
    );
    my $size = int( ($img->getwidth + $img->getheight) * 0.02 );
    $img->align_string(
        font   => $ttfont,
        text   => $date,
        x      => int( $img->getwidth  - $size * 1.5 ),
        y      => int( $img->getheight - $size * 1.5 ),
        halign => 'right',
        valign => 'bottom',
        size   => $size,
        color  => $color,
        aa     => 1,
    );
    return $img;
}