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