| 1 | ########################################################################### |
|---|
| 2 | # Palimg plugin that allows Perlbal to serve palette altered images |
|---|
| 3 | ########################################################################### |
|---|
| 4 | |
|---|
| 5 | package Perlbal::Plugin::Palimg; |
|---|
| 6 | |
|---|
| 7 | use strict; |
|---|
| 8 | use warnings; |
|---|
| 9 | no warnings qw(deprecated); |
|---|
| 10 | |
|---|
| 11 | # called when we're being added to a service |
|---|
| 12 | sub register { |
|---|
| 13 | my ($class, $svc) = @_; |
|---|
| 14 | |
|---|
| 15 | # verify that an incoming request is a palimg request |
|---|
| 16 | $svc->register_hook('Palimg', 'start_serve_request', sub { |
|---|
| 17 | my Perlbal::ClientHTTPBase $obj = $_[0]; |
|---|
| 18 | return 0 unless $obj; |
|---|
| 19 | my Perlbal::HTTPHeaders $hd = $obj->{req_headers}; |
|---|
| 20 | my $uriref = $_[1]; |
|---|
| 21 | return 0 unless $uriref; |
|---|
| 22 | |
|---|
| 23 | # if this is palimg, peel off the requested modifications and put in headers |
|---|
| 24 | return 0 unless $$uriref =~ m!^/palimg/(.+)\.(\w+)(.*)$!; |
|---|
| 25 | my ($fn, $ext, $extra) = ($1, $2, $3); |
|---|
| 26 | return 0 unless $extra; |
|---|
| 27 | my ($palspec) = $extra =~ m!^/p(.+)$!; |
|---|
| 28 | return 0 unless $fn && $palspec; |
|---|
| 29 | |
|---|
| 30 | # must be ok, setup for it |
|---|
| 31 | $$uriref = "/palimg/$fn.$ext"; |
|---|
| 32 | $obj->{scratch}->{palimg} = [ $ext, $palspec ]; |
|---|
| 33 | return 0; |
|---|
| 34 | }); |
|---|
| 35 | |
|---|
| 36 | # actually serve a palimg |
|---|
| 37 | $svc->register_hook('Palimg', 'start_send_file', sub { |
|---|
| 38 | my Perlbal::ClientHTTPBase $obj = $_[0]; |
|---|
| 39 | return 0 unless $obj && |
|---|
| 40 | (my $palimginfo = $obj->{scratch}->{palimg}); |
|---|
| 41 | |
|---|
| 42 | # turn off writes |
|---|
| 43 | $obj->watch_write(0); |
|---|
| 44 | |
|---|
| 45 | # create filehandle for reading |
|---|
| 46 | my $data = ''; |
|---|
| 47 | Perlbal::AIO::aio_read($obj->reproxy_fh, 0, 2048, $data, sub { |
|---|
| 48 | # got data? undef is error |
|---|
| 49 | return $obj->_simple_response(500) unless $_[0] > 0; |
|---|
| 50 | |
|---|
| 51 | # pass down to handler |
|---|
| 52 | my Perlbal::HTTPHeaders $hd = $obj->{req_headers}; |
|---|
| 53 | my $res = PalImg::modify_file(\$data, $palimginfo->[0], $palimginfo->[1]); |
|---|
| 54 | return $obj->_simple_response(500) unless defined $res; |
|---|
| 55 | return $obj->_simple_response($res) if $res; |
|---|
| 56 | |
|---|
| 57 | # seek into the file now so sendfile starts further in |
|---|
| 58 | my $ld = length $data; |
|---|
| 59 | sysseek($obj->{reproxy_fh}, $ld, &POSIX::SEEK_SET); |
|---|
| 60 | $obj->{reproxy_file_offset} = $ld; |
|---|
| 61 | |
|---|
| 62 | # re-enable writes after we get data |
|---|
| 63 | $obj->tcp_cork(1); # by setting reproxy_file_offset above, it won't cork, so we cork it |
|---|
| 64 | $obj->write($data); |
|---|
| 65 | $obj->watch_write(1); |
|---|
| 66 | }); |
|---|
| 67 | |
|---|
| 68 | return 1; |
|---|
| 69 | }); |
|---|
| 70 | |
|---|
| 71 | return 1; |
|---|
| 72 | } |
|---|
| 73 | |
|---|
| 74 | # called when we're no longer active on a service |
|---|
| 75 | sub unregister { |
|---|
| 76 | my ($class, $svc) = @_; |
|---|
| 77 | |
|---|
| 78 | # clean up time |
|---|
| 79 | $svc->unregister_hooks('Palimg'); |
|---|
| 80 | return 1; |
|---|
| 81 | } |
|---|
| 82 | |
|---|
| 83 | # called when we are loaded/unloaded ... someday add some stats viewing |
|---|
| 84 | # commands here? |
|---|
| 85 | sub load { return 1; } |
|---|
| 86 | sub unload { return 1; } |
|---|
| 87 | |
|---|
| 88 | ####### PALIMG START ########################################################################### |
|---|
| 89 | package PalImg; |
|---|
| 90 | |
|---|
| 91 | sub parse_hex_color |
|---|
| 92 | { |
|---|
| 93 | my $color = shift; |
|---|
| 94 | return [ map { hex(substr($color, $_, 2)) } (0,2,4) ]; |
|---|
| 95 | } |
|---|
| 96 | |
|---|
| 97 | sub modify_file |
|---|
| 98 | { |
|---|
| 99 | my ($data, $type, $palspec) = @_; |
|---|
| 100 | |
|---|
| 101 | # palette altering |
|---|
| 102 | my %pal_colors; |
|---|
| 103 | if (my $pals = $palspec) { |
|---|
| 104 | my $hx = "[0-9a-f]"; |
|---|
| 105 | if ($pals =~ /^g($hx{2,2})($hx{6,6})($hx{2,2})($hx{6,6})$/) { |
|---|
| 106 | # gradient from index $1, color $2, to index $3, color $4 |
|---|
| 107 | my $from = hex($1); |
|---|
| 108 | my $to = hex($3); |
|---|
| 109 | return 404 if $from == $to; |
|---|
| 110 | my $fcolor = parse_hex_color($2); |
|---|
| 111 | my $tcolor = parse_hex_color($4); |
|---|
| 112 | if ($to < $from) { |
|---|
| 113 | ($from, $to, $fcolor, $tcolor) = |
|---|
| 114 | ($to, $from, $tcolor, $fcolor); |
|---|
| 115 | } |
|---|
| 116 | for (my $i=$from; $i<=$to; $i++) { |
|---|
| 117 | $pal_colors{$i} = [ map { |
|---|
| 118 | int($fcolor->[$_] + |
|---|
| 119 | ($tcolor->[$_] - $fcolor->[$_]) * |
|---|
| 120 | ($i-$from) / ($to-$from)) |
|---|
| 121 | } (0..2) ]; |
|---|
| 122 | } |
|---|
| 123 | } elsif ($pals =~ /^t($hx{6,6})($hx{6,6})?$/) { |
|---|
| 124 | # tint everything towards color |
|---|
| 125 | my ($t, $td) = ($1, $2); |
|---|
| 126 | $pal_colors{'tint'} = parse_hex_color($t); |
|---|
| 127 | $pal_colors{'tint_dark'} = $td ? parse_hex_color($td) : [0,0,0]; |
|---|
| 128 | } elsif (length($pals) > 42 || $pals =~ /[^0-9a-f]/) { |
|---|
| 129 | return 404; |
|---|
| 130 | } else { |
|---|
| 131 | my $len = length($pals); |
|---|
| 132 | return 404 if $len % 7; # must be multiple of 7 chars |
|---|
| 133 | for (my $i = 0; $i < $len/7; $i++) { |
|---|
| 134 | my $palindex = hex(substr($pals, $i*7, 1)); |
|---|
| 135 | $pal_colors{$palindex} = [ |
|---|
| 136 | hex(substr($pals, $i*7+1, 2)), |
|---|
| 137 | hex(substr($pals, $i*7+3, 2)), |
|---|
| 138 | hex(substr($pals, $i*7+5, 2)), |
|---|
| 139 | substr($pals, $i*7+1, 6), |
|---|
| 140 | ]; |
|---|
| 141 | } |
|---|
| 142 | } |
|---|
| 143 | } |
|---|
| 144 | |
|---|
| 145 | if (%pal_colors) { |
|---|
| 146 | if ($type eq 'gif') { |
|---|
| 147 | return 404 unless PaletteModify::new_gif_palette($data, \%pal_colors); |
|---|
| 148 | } elsif ($type eq 'png') { |
|---|
| 149 | return 404 unless PaletteModify::new_png_palette($data, \%pal_colors); |
|---|
| 150 | } |
|---|
| 151 | } |
|---|
| 152 | |
|---|
| 153 | # success |
|---|
| 154 | return 0; |
|---|
| 155 | } |
|---|
| 156 | ####### PALIMG END ############################################################################# |
|---|
| 157 | |
|---|
| 158 | ####### PALETTEMODIFY START #################################################################### |
|---|
| 159 | package PaletteModify; |
|---|
| 160 | |
|---|
| 161 | BEGIN { |
|---|
| 162 | $PaletteModify::HAVE_CRC = eval "use String::CRC32 (); 1;"; |
|---|
| 163 | } |
|---|
| 164 | |
|---|
| 165 | sub common_alter |
|---|
| 166 | { |
|---|
| 167 | my ($palref, $table) = @_; |
|---|
| 168 | my $length = length $table; |
|---|
| 169 | |
|---|
| 170 | my $pal_size = $length / 3; |
|---|
| 171 | |
|---|
| 172 | # tinting image? if so, we're remaking the whole palette |
|---|
| 173 | if (my $tint = $palref->{'tint'}) { |
|---|
| 174 | my $dark = $palref->{'tint_dark'}; |
|---|
| 175 | my $diff = [ map { $tint->[$_] - $dark->[$_] } (0..2) ]; |
|---|
| 176 | $palref = {}; |
|---|
| 177 | for (my $idx=0; $idx<$pal_size; $idx++) { |
|---|
| 178 | for my $c (0..2) { |
|---|
| 179 | my $curr = ord(substr($table, $idx*3+$c)); |
|---|
| 180 | my $p = \$palref->{$idx}->[$c]; |
|---|
| 181 | $$p = int($dark->[$c] + $diff->[$c] * $curr / 255); |
|---|
| 182 | } |
|---|
| 183 | } |
|---|
| 184 | } |
|---|
| 185 | |
|---|
| 186 | while (my ($idx, $c) = each %$palref) { |
|---|
| 187 | next if $idx >= $pal_size; |
|---|
| 188 | substr($table, $idx*3+$_, 1) = chr($c->[$_]) for (0..2); |
|---|
| 189 | } |
|---|
| 190 | |
|---|
| 191 | return $table; |
|---|
| 192 | } |
|---|
| 193 | |
|---|
| 194 | sub new_gif_palette |
|---|
| 195 | { |
|---|
| 196 | my ($data, $palref) = @_; |
|---|
| 197 | |
|---|
| 198 | # make sure we have data to operate on, or the substrs below die |
|---|
| 199 | return unless $$data; |
|---|
| 200 | |
|---|
| 201 | # 13 bytes for magic + image info (size, color depth, etc) |
|---|
| 202 | # and then the global palette table (3*256) |
|---|
| 203 | my $header = substr($$data, 0, 13+3*256); |
|---|
| 204 | |
|---|
| 205 | # figure out how big global color table is (don't want to overwrite it) |
|---|
| 206 | my $pf = ord substr($header, 10, 1); |
|---|
| 207 | my $gct = 2 ** (($pf & 7) + 1); # last 3 bits of packaged fields |
|---|
| 208 | |
|---|
| 209 | # final sanity check for size so the substr below doesn't die |
|---|
| 210 | return unless length $header >= 13 + 3 * $gct; |
|---|
| 211 | |
|---|
| 212 | substr($header, 13, 3*$gct) = common_alter($palref, substr($header, 13, 3*$gct)); |
|---|
| 213 | $$data = $header; |
|---|
| 214 | return 1; |
|---|
| 215 | } |
|---|
| 216 | |
|---|
| 217 | sub new_png_palette |
|---|
| 218 | { |
|---|
| 219 | my ($data, $palref) = @_; |
|---|
| 220 | |
|---|
| 221 | # subroutine for reading data |
|---|
| 222 | my ($curidx, $maxlen) = (0, length $$data); |
|---|
| 223 | my $read = sub { |
|---|
| 224 | # put $_[1] data into scalar reference $_[0] |
|---|
| 225 | return undef if $_[1] + $curidx > $maxlen; |
|---|
| 226 | ${$_[0]} = substr($$data, $curidx, $_[1]); |
|---|
| 227 | $curidx += $_[1]; |
|---|
| 228 | return length ${$_[0]}; |
|---|
| 229 | }; |
|---|
| 230 | |
|---|
| 231 | # without this module, we can't proceed. |
|---|
| 232 | return 0 unless $PaletteModify::HAVE_CRC; |
|---|
| 233 | |
|---|
| 234 | my $imgdata; |
|---|
| 235 | |
|---|
| 236 | # Validate PNG signature |
|---|
| 237 | my $png_sig = pack("H16", "89504E470D0A1A0A"); |
|---|
| 238 | my $sig; |
|---|
| 239 | $read->(\$sig, 8); |
|---|
| 240 | return 0 unless $sig eq $png_sig; |
|---|
| 241 | $imgdata .= $sig; |
|---|
| 242 | |
|---|
| 243 | # Start reading in chunks |
|---|
| 244 | my ($length, $type) = (0, ''); |
|---|
| 245 | while ($read->(\$length, 4)) { |
|---|
| 246 | |
|---|
| 247 | $imgdata .= $length; |
|---|
| 248 | $length = unpack("N", $length); |
|---|
| 249 | return 0 unless $read->(\$type, 4) == 4; |
|---|
| 250 | $imgdata .= $type; |
|---|
| 251 | |
|---|
| 252 | if ($type eq 'IHDR') { |
|---|
| 253 | my $header; |
|---|
| 254 | $read->(\$header, $length+4); |
|---|
| 255 | my ($width,$height,$depth,$color,$compression, |
|---|
| 256 | $filter,$interlace, $CRC) |
|---|
| 257 | = unpack("NNCCCCCN", $header); |
|---|
| 258 | return 0 unless $color == 3; # unpaletted image |
|---|
| 259 | $imgdata .= $header; |
|---|
| 260 | } elsif ($type eq 'PLTE') { |
|---|
| 261 | # Finally, we can go to work |
|---|
| 262 | my $palettedata; |
|---|
| 263 | $read->(\$palettedata, $length); |
|---|
| 264 | $palettedata = common_alter($palref, $palettedata); |
|---|
| 265 | $imgdata .= $palettedata; |
|---|
| 266 | |
|---|
| 267 | # Skip old CRC |
|---|
| 268 | my $skip; |
|---|
| 269 | $read->(\$skip, 4); |
|---|
| 270 | |
|---|
| 271 | # Generate new CRC |
|---|
| 272 | my $crc = String::CRC32::crc32($type . $palettedata); |
|---|
| 273 | $crc = pack("N", $crc); |
|---|
| 274 | |
|---|
| 275 | $imgdata .= $crc; |
|---|
| 276 | $$data = $imgdata; |
|---|
| 277 | return 1; |
|---|
| 278 | } else { |
|---|
| 279 | my $skip; |
|---|
| 280 | # Skip rest of chunk and add to imgdata |
|---|
| 281 | # Number of bytes is +4 because of CRC |
|---|
| 282 | # |
|---|
| 283 | for (my $count=0; $count < $length + 4; $count++) { |
|---|
| 284 | $read->(\$skip, 1); |
|---|
| 285 | $imgdata .= $skip; |
|---|
| 286 | } |
|---|
| 287 | } |
|---|
| 288 | } |
|---|
| 289 | |
|---|
| 290 | return 0; |
|---|
| 291 | } |
|---|
| 292 | ####### PALETTEMODIFY END ###################################################################### |
|---|
| 293 | |
|---|
| 294 | 1; |
|---|
| 295 | |
|---|
| 296 | __END__ |
|---|
| 297 | |
|---|
| 298 | =head1 NAME |
|---|
| 299 | |
|---|
| 300 | Perlbal::Plugin::Palimg - plugin that allows Perlbal to serve palette altered images |
|---|
| 301 | |
|---|
| 302 | =head1 VERSION |
|---|
| 303 | |
|---|
| 304 | This documentation refers to C<Perlbal::Plugin::Palimg> that ships with Perlbal 1.50 |
|---|
| 305 | |
|---|
| 306 | =head1 DESCRIPTION |
|---|
| 307 | |
|---|
| 308 | Palimg is a perlbal plugin that allows you to modify C<GIF> and C<PNG> on the fly. Put the images you want to be able to modify into the C<DOCROOT/palimg/> directory. You modify them by adding C</pSPEC> to the end of the url, where SPEC is one of the below defined commands (gradient, tint, etc). |
|---|
| 309 | |
|---|
| 310 | =head1 CONFIGURING PERLBAL |
|---|
| 311 | |
|---|
| 312 | To configure your Perlbal installation to use Palimg you'll need to C<LOAD> the plugin then add a service parameter to a C<web_server> service to activate it. |
|---|
| 313 | |
|---|
| 314 | Example C<perlbal.conf>: |
|---|
| 315 | |
|---|
| 316 | LOAD palimg |
|---|
| 317 | |
|---|
| 318 | CREATE SERVICE palex |
|---|
| 319 | SET listen = ${ip:eth0}:80 |
|---|
| 320 | SET role = web_server |
|---|
| 321 | SET plugins = palimg |
|---|
| 322 | SET docroot = /usr/share/doc/ |
|---|
| 323 | SET dirindexing = 0 |
|---|
| 324 | ENABLE palex |
|---|
| 325 | |
|---|
| 326 | =head1 GRADIENTS |
|---|
| 327 | |
|---|
| 328 | You can change the gradient of the image by adding C</pg0011111164ffffff> to the end of the url. C<00> is the index where the gradient starts and C<111111> is the color (in hex) of the beginning of the gradient. C<64> is the index of the end of the gradient and C<ffffff> is the color of the end of the gradient. Note that all colors specified in hex should be lowercase. |
|---|
| 329 | |
|---|
| 330 | Example: |
|---|
| 331 | |
|---|
| 332 | http://192.168.0.1/palimg/logo.gif/pg01aaaaaa99cccccc |
|---|
| 333 | |
|---|
| 334 | =head1 TINTING |
|---|
| 335 | |
|---|
| 336 | You can tint the image by adding C</pt000000aaaaaa> to the end of the url. C<000000> should be replaced with the color to tint towards. C<aaaaaa> is optional and defines the "dark" tint color. Both colors should be specified as lowercase hex numbers. |
|---|
| 337 | |
|---|
| 338 | Example: |
|---|
| 339 | |
|---|
| 340 | http://192.168.0.1/palimg/logo.gif/pt1c1c1c22dba1 |
|---|
| 341 | |
|---|
| 342 | =head1 PALETTE REPLACEMENT |
|---|
| 343 | |
|---|
| 344 | You can specify a palette to replace the palette of the image. Do this by adding up to six sets of seven hex lowercase numbers prefixed with C</p> to the end of the URL. |
|---|
| 345 | |
|---|
| 346 | Example: |
|---|
| 347 | |
|---|
| 348 | http://192.168.0.1/palimg/logo.gif/p01234567890abcfffffffcccccccddddddd |
|---|
| 349 | |
|---|
| 350 | =head1 BUGS AND LIMITATIONS |
|---|
| 351 | |
|---|
| 352 | There are no known bugs in this module. |
|---|
| 353 | |
|---|
| 354 | Please report problems to the Perlbal mailing list, http://groups.google.com/group/perlbal |
|---|
| 355 | |
|---|
| 356 | Patches are welcome. |
|---|
| 357 | |
|---|
| 358 | =head1 AUTHORS |
|---|
| 359 | |
|---|
| 360 | Brad Fitzpatrick <brad@danga.com> |
|---|
| 361 | Mark Smith <junior@danga.com> |
|---|
| 362 | |
|---|
| 363 | =head1 LICENSE AND COPYRIGHT |
|---|
| 364 | |
|---|
| 365 | Artistic/GPLv2, at your choosing. |
|---|
| 366 | |
|---|
| 367 | Copyright 2004, Danga Interactive |
|---|
| 368 | Copyright 2005-2007, Six Apart Ltd |
|---|
