git.oblomov.eu Git - svg-meme/blob - src/meme.fcgi

   1 #!/usr/bin/perl -w
   2
   3 # SVG meme generator
   4 # Copyright (C) 2013 Giuseppe Bilotta
   5 # Distributed under the terms of the Artistic License,
   6 # see 'Artistic' in the repository root.
   7
   8 use strict;
   9
  10 use CGI::Fast;
  11
  12 use HTML::Entities;
  13
  14 use File::Basename;
  15
  16 use Scalar::Util qw(looks_like_number);
  17
  18 my %sizes; # meme base image sizes
  19 my %acros; # meme base acronyms (BLB => bad-luck-brian.jpg)
  20
  21 # Are we running as CGI or from the command-line?
  22 # TODO better detection
  23 my $is_cgi = $ENV{'SCRIPT_FILENAME'};
  24
  25 my $script_path =  $is_cgi ? dirname($ENV{'SCRIPT_FILENAME'}) : dirname($0);
  26
  27 my $sz_fname = $script_path . '/meme-sizes.lst';
  28
  29 open FILE, $sz_fname or die $!;
  30
  31 while (my $line = <FILE>) {
  32         chomp($line);
  33         next unless $line;
  34         my ($width, $height, $fname) = split(/ /, $line, 3);
  35         $sizes{$fname} = [$width, $height];
  36
  37         # Find a potential short form (acronym for multiword, no extension otherwise)
  38         my $acro = '';
  39
  40         # remove article for the purpose of the shortening; we don't care if it's
  41         # in the middle of a word because we only care about initials anyway
  42         # FIXME this actually fails in the case of XXXthe-XXX, let's care about that
  43         # when we actually come across it
  44         my $the = $fname;
  45         $the =~ s/the-//g;
  46         if ($the =~ /-/) {
  47                 $acro = join('', map { uc(substr($_, 0, 1)) } split(/-/, $the ));
  48         } else {
  49                 $acro = (split(/\./, $the))[0]
  50         }
  51         if (!defined $acros{$acro}) {
  52                 $acros{$acro} = $fname;
  53         } else {
  54                 print STDERR "Trying to redefined acronym $acro from $acros{$acro} to ${fname}\n";
  55         }
  56 }
  57
  58 my %revacros = reverse %acros;
  59
  60 close FILE;
  61
  62
  63 # params: img, width, height, font-size, text
  64
  65 my $svg_template=<<SVG;
  66 <?xml version='1.0' encoding='UTF-8'?>
  67 <svg
  68  xmlns='http://www.w3.org/2000/svg'
  69  xmlns:xlink='http://www.w3.org/1999/xlink' version='1.1'
  70  viewBox='0 0 %2\$d %3\$d'>
  71 <style type="text/css">text{font-family:'Impact';font-size:%4\$dpx;fill:white;stroke:black;stroke-width:2px;text-anchor:middle}</style>
  72 <image xlink:href='%1\$s' x='0' y='0'
  73 width='%2\$d' height='%3\$d'/>
  74 %5\$s</svg>
  75 SVG
  76
  77 sub fill_svg(%) {
  78         my %p = @_;
  79         return sprintf($svg_template,
  80                 $p{img}, $p{width}, $p{height}, $p{fs}, $p{text});
  81 }
  82
  83 # params: text, y-pos, font-size
  84 # the font-size presented here is optional, and should only be
  85 # present when this text line has a different font-size than
  86 # the default one
  87
  88 my $txt_template=<<TXT;
  89 <text x='50%%' y='%2\$d%%'%3\$s
  90 >%1\$s</text>
  91 TXT
  92
  93 sub fill_txt($%) {
  94         my $text = shift;
  95         my %p = @_;
  96         return sprintf($txt_template, $text, $p{y}, $p{linefs});
  97 }
  98
  99 # routine to actually prepare the SVG.
 100 # params: img, sep, text
 101 sub make_svg(%) {
 102         my %p = @_;
 103
 104         unless (defined $sizes{$p{img}}) {
 105                 return undef unless defined $acros{$p{img}};
 106                 $p{img} = $acros{$p{img}};
 107         }
 108
 109         ($p{width}, $p{height}) = @{$sizes{$p{img}}};
 110
 111         $p{sep} = qr/\Q$p{sep}\E/;
 112
 113         # font size specification is default:line/per/line/override
 114         # Non-numeric values are skipped
 115         my $fs_override;
 116         my @fss; # array of font-size overrides
 117
 118         ($p{fs}, $fs_override) = split(/:/, $p{fs},2);
 119         if (defined $p{fs} and $p{fs} =~ $p{sep}) {
 120                 # there's a / in the default part. is this because there is no override part?
 121                 if (!defined $fs_override) {
 122                         $fs_override = $p{fs};
 123                 }
 124                 $p{fs} = undef;
 125         }
 126
 127         if (defined $fs_override) {
 128                 foreach (split($p{sep}, $fs_override, -1)) {
 129                         push @fss, looks_like_number($_) ? $_ : '';
 130                 }
 131         }
 132
 133         my @lines; # text lines
 134         foreach (split($p{sep}, $p{text}, -1)) {
 135                 push @lines, $_;
 136         }
 137
 138         my $divisions = 7;
 139         $divisions = @lines if @lines > $divisions;
 140
 141         # if the user specified a single font-size, use that, otherwise
 142         # compute a default one based on the number of divisions
 143         if (defined $p{fs} and $p{fs}) {
 144                 $divisions = int($p{height}/$p{fs} + 0.5);
 145         } else {
 146                 $p{fs} = int($p{height}/$divisions + 0.5);
 147                 if ($p{fs} > $p{width}/10) {
 148                         $p{fs} = int($p{width}/10 + 0.5) if $p{fs} > $p{width}/10;
 149                         $divisions = int($p{height}/$p{fs} + 0.5);
 150                 }
 151         }
 152
 153         # formatted lines: each element is a ref to an array with the following elements:
 154         #  * line text (undef for empty line),
 155         #  * font size (undef for empty line or default font),
 156         #  * y increment (always defined)
 157
 158         my @fmt_lines;
 159         my $total_height = 0; # total height of real lines
 160         my $fillers = 0; # number of fillers
 161         for (my $i = 0; $i < @lines; ++$i) {
 162                 my $line = $lines[$i];
 163                 my $fs = $fss[$i];
 164                 my $lh = undef;
 165                 if (defined $line and $line eq '') {
 166                         $line = undef;
 167                         ++$fillers;
 168                 }
 169                 # let's have an actually defined font-size for purposes of height
 170                 # computation
 171                 if (!defined $fs or $fs eq '') {
 172                         $fs = $p{fs};
 173                 }
 174                 if (defined $line) {
 175                         $lh = int(100*$fs/$p{height} + 0.5);
 176                         $total_height += $lh;
 177                 }
 178                 # undefine $fs if not needed
 179                 if (!defined $line or $fs == $p{fs}) {
 180                         $fs = undef;
 181                 }
 182                 push @fmt_lines, [$line, $fs, $lh];
 183         }
 184         my $filler_size = $fillers? int((98 - $total_height)/$fillers) : 0;
 185
 186         if ($filler_size) {
 187                 foreach (@fmt_lines) {
 188                         $_->[2] = $filler_size unless defined $_->[2];
 189                 }
 190         }
 191
 192         $p{y} = 0;
 193         $p{text} = '';
 194         # iterate over both @lines and @fss. I'm sure there's a more perlish
 195         # way to do it
 196         foreach (@fmt_lines) {
 197                 my $line = $_->[0];
 198                 my $fs = $_->[1];
 199                 my $lh = $_->[2];
 200
 201                 $p{y} += $lh;
 202                 next unless defined $line; #fillers just increment y
 203
 204                 if (not defined $fs) {
 205                         $p{linefs} = '';
 206                 } else {
 207                         # Damn, apparently attribute font-size does not ovverride style
 208                         # $p{linefs} = " font-size='$fs'";
 209                         $p{linefs} = " style='font-size:${fs}px'";
 210                 }
 211
 212                 $p{text} .= fill_txt($line, %p);
 213         }
 214
 215         return fill_svg(%p);
 216 }
 217
 218 my %p;
 219
 220 while (my $q = new CGI::Fast) {
 221
 222         my (@t, @fs);
 223
 224         if ($is_cgi) {
 225                 $p{img} = $q->param('m');
 226                 $p{sep} = $q->param('s');
 227                 @fs = $q->param('fs');
 228                 @t = $q->param('t');
 229         } else {
 230                 # TODO specify font-size from CLI
 231                 ($p{img}, $p{sep}, @t) = @ARGV;
 232         }
 233
 234         $p{sep} ||= '/';
 235         $p{fs} = join($p{sep}, @fs);
 236         $p{text} = join($p{sep}, @t);
 237
 238         $p{img} ||= (keys %sizes)[0];
 239         $p{text}||= 'TOP TEST//BOTTOM TEST';
 240
 241         my $svg = make_svg(%p);
 242
 243         if (defined $svg) {
 244                 print $q->header(
 245                         -type => 'image/svg+xml',
 246                         -charset => 'UTF-8'
 247                 ) if $is_cgi;
 248
 249                 print $svg;
 250
 251                 next if $is_cgi;
 252                 exit 0;
 253         }
 254
 255         # missing meme
 256         if ($is_cgi) {
 257                 print $q->header(-status=>404),
 258                 $q->start_html("Unknown meme base"),
 259                 $q->h1("Unknown meme base!");
 260                 print   "<p>Sorry, <tt>'" . encode_entities($p{img}) . "'</tt> is not a known meme base. ".
 261                 "You want one of the following instead:</p><ul>";
 262                 foreach (keys %sizes) {
 263                         print "<li><tt>" . encode_entities($_) . "</tt>";
 264                         print " (<tt>" . encode_entities($revacros{$_}) . "</tt>)" if defined $revacros{$_};
 265                         print "</tt></li>";
 266                 }
 267                 print "</ul>";
 268                 # foreach (keys %ENV) {
 269                 #       print "<p>$_=$ENV{$_}</p>"
 270                 # }
 271                 print $q->end_html();
 272                 next;
 273         } else {
 274                 foreach (keys %sizes) {
 275                         print STDERR "* $_";
 276                         print STDERR " ($revacros{$_})" if defined $revacros{$_};
 277                         print STDERR "\n";
 278                 }
 279                 exit -1;
 280         }
 281 }