site/cgi-bin/modules/BSE/Thumb/Imager.pm

   1 package BSE::Thumb::Imager;
   2 use strict;
   3 #use blib '/home/tony/dev/imager/maint/Imager/';
   4
   5 sub new {
   6   my ($class, $cfg) = @_;
   7
   8   return bless { cfg => $cfg }, $class;
   9 }
  10
  11 sub _parse_scale {
  12   my ($geometry, $error) = @_;
  13
  14   my %geo = ( action => 'scale' );
  15   if ($geometry =~ s/^(\d+)x(\d+)//) {
  16     @geo{qw(width height)} = ( $1, $2 );
  17   }
  18   elsif ($geometry =~ s/^x(\d+)//) {
  19     $geo{height} = $1;
  20   }
  21   elsif ($geometry =~ s/^(\d+)x//) {
  22     $geo{width} = $1;
  23   }
  24   elsif ($geometry =~ s/^(\d+)//) {
  25     $geo{width} = $geo{height} = $1;
  26   }
  27   else {
  28     $$error = "No leading dimension";
  29     return;
  30   }
  31
  32   if ($geometry =~ s/^,?c//) {
  33     $geo{crop} = 1;
  34     if (!$geo{width} || !$geo{height}) {
  35       $$error = "Both dimensions much be supplied for crop";
  36       return;
  37     }
  38   }
  39   if ($geometry =~ s/^,fill:([^,]+)//) {
  40     $geo{fill} = $1;
  41     if (!$geo{width} || !$geo{height}) {
  42       $$error = "scale:Both dimensions must be supplied for fill";
  43       return;
  44     }
  45   }
  46
  47   return \%geo;
  48 }
  49
  50 sub _parse_roundcorners {
  51   my ($text, $error) = @_;
  52
  53   my %geo =
  54     (
  55      action => 'roundcorners',
  56      tl => 10,
  57      tr => 10,
  58      bl => 10,
  59      br => 10,
  60      bg => 'FFFFFF',
  61      bgalpha => '255'
  62     );
  63
  64   if ($text =~ s/^radi(?:us|i):([\d ]+),?//) {
  65     my @radii = split ' ', $1;
  66     if (@radii == 1) {
  67       $geo{tl} = $geo{tr} = $geo{br} = $geo{bl} = $radii[0];
  68     }
  69     elsif (@radii == 2) {
  70       $geo{tl} = $geo{tr} = $radii[0];
  71       $geo{bl} = $geo{br} = $radii[1];
  72     }
  73     elsif (@radii == 4) {
  74       @geo{qw/tl tr bl br/} = @radii;
  75     }
  76     else {
  77       $$error = 'roundcorners(radius:...) only accepts 1,2,4 radii';
  78       return;
  79     }
  80   }
  81   if ($text =~ s/^bg:([^,]+),?//) {
  82     $geo{bg} = $1;
  83   }
  84   if ($text =~ s/^bgalpha:(\d+)//) {
  85     $geo{bgalpha} = $1;
  86   }
  87   if (length $text) {
  88     $$error = "unexpected junk in roundcorners: $text";
  89     return;
  90   }
  91
  92   \%geo;
  93 }
  94
  95 sub _parse_mirror {
  96   my ($text, $error) = @_;
  97
  98   my %mirror =
  99     (
 100      action => 'mirror',
 101      height => '30%',
 102      bg => '000000',
 103      bgalpha => 255,
 104      opacity => '40%',
 105      srcx => 'x',
 106      srcy => 'y',
 107      horizon => '0',
 108      perspective => 0,
 109      perspectiveangle => '0',
 110     );
 111
 112   while ($text =~ s/^(\w+):([^,]+),?//) {
 113     unless (exists $mirror{$1}) {
 114       $$error = "Unknown mirror parameter $1";
 115       return;
 116     }
 117
 118     $mirror{$1} = $2;
 119   }
 120
 121   if (length $text) {
 122     $$error = "unexpected junk in mirror: $text";
 123     return;
 124   }
 125
 126   \%mirror;
 127 }
 128
 129 sub _parse_sepia {
 130   my ($text, $error) = @_;
 131
 132   my %sepia =
 133     (
 134      action => 'sepia',
 135      color => '000000',
 136     );
 137   if ($text =~ s/^([^,]+),?//) {
 138     $sepia{color} = $1;
 139   }
 140   if (length $text) {
 141     $$error = "unexpected junk in mirror: $text";
 142     return;
 143   }
 144   \%sepia;
 145 }
 146
 147 sub _parse_filter {
 148   my ($text, $error) = @_;
 149
 150   unless ($text =~ s/^(\w+),?//) {
 151     $$error = "filter: no filter name";
 152     return;
 153   }
 154   my %filter =
 155     (
 156      action => 'filter',
 157      type => $1
 158     );
 159   while ($text =~ s/^(\w+):([^,]+),?//) {
 160     $filter{$1} = $2;
 161   }
 162
 163   \%filter;
 164 }
 165
 166 sub _parse_geometry {
 167   my ($geometry, $error) = @_;
 168
 169   my @geo;
 170   while (length $geometry) {
 171     if ($geometry =~ s/^scale\(([^\)]+)\)//) {
 172       my $scale = _parse_scale($1, $error)
 173         or return;
 174       push @geo, $scale;
 175     }
 176     elsif ($geometry =~ s/^roundcorners\(([^\)]*)\)//) {
 177       my $round = _parse_roundcorners($1, $error)
 178         or return;
 179       push @geo, $round;
 180     }
 181     elsif ($geometry =~ s/^mirror\(([^\)]*)\)//) {
 182       my $mirror = _parse_mirror($1, $error)
 183         or return;
 184       push @geo, $mirror;
 185     }
 186     elsif ($geometry =~ s/^grey\(\)//) {
 187       push @geo, { action => 'grey' };
 188     }
 189     elsif ($geometry =~ s/^sepia\(([^\)]*)\)//) {
 190       my $sepia = _parse_sepia($1, $error)
 191         or return;
 192       push @geo, $sepia;
 193     }
 194     elsif ($geometry =~ s/^filter\(([^\)]*)\)//) {
 195       my $filter = _parse_filter($1, $error)
 196         or return;
 197       push @geo, $filter;
 198     }
 199     else {
 200       $$error = "Unexpected junk at the end of the geometry $geometry";
 201       return;
 202     }
 203     $geometry =~ s/^,//;
 204   }
 205
 206   return \@geo;
 207 }
 208
 209 sub validate_geometry {
 210   my ($self, $geometry, $rerror) = @_;
 211
 212   _parse_geometry($geometry, $rerror)
 213     or return;
 214
 215   return 1;
 216 }
 217
 218 sub thumb_dimensions_sized {
 219   my ($self, $geometry, $width, $height) = @_;
 220
 221   my $error;
 222   my $geolist = _parse_geometry($geometry, \$error)
 223     or return;
 224
 225   my $req_alpha = 0;
 226
 227   for my $geo (@$geolist) {
 228     if ($geo->{action} eq 'scale') {
 229       if ($geo->{fill}) {
 230         # fill always produces an image the right size
 231         ($width, $height) = @$geo{qw/width height/};
 232         next;
 233       }
 234
 235       if ($geo->{crop}) {
 236         my $width_scale = $geo->{width} / $width;
 237         my $height_scale = $geo->{height} / $height;
 238         my $scale = $width_scale < $height_scale ? $height_scale : $width_scale;
 239
 240         $width *= $scale;
 241         $height *= $scale;
 242         $width > $geo->{width} and $width = $geo->{width};
 243         $height > $geo->{height} and $height = $geo->{height};
 244       }
 245       else {
 246         if ($geo->{width} && $width > $geo->{width}) {
 247           $height = $height * $geo->{width} / $width;
 248           $width = $geo->{width};
 249         }
 250         if ($geo->{height} && $height > $geo->{height}) {
 251           $width = $width * $geo->{height} / $height;
 252           $height = $geo->{height};
 253         }
 254       }
 255       $width = int($width);
 256       $height = int($height);
 257     }
 258     elsif ($geo->{action} eq 'roundcorners') {
 259       if ($geo->{bgalpha} != 255) {
 260         $req_alpha = 1;
 261       }
 262     }
 263     elsif ($geo->{action} eq 'mirror') {
 264       $height += _percent_of($geo->{height}, $height)
 265         + _percent_of($geo->{horizon}, $height);
 266       $height = int($height);
 267
 268       if ($geo->{bgalpha} != 255) {
 269         $req_alpha = 1;
 270       }
 271     }
 272   }
 273
 274   return ($width, $height, $req_alpha);
 275 }
 276
 277 sub _min {
 278   $_[0] < $_[1] ? $_[0] : $_[1];
 279 }
 280
 281 sub _max {
 282   $_[0] > $_[1] ? $_[0] : $_[1];
 283 }
 284
 285 sub _do_roundcorners {
 286   my ($src, $geo) = @_;
 287
 288   if ($src->getchannels == 1 || $src->getchannels == 2) {
 289     $src = $src->convert(preset => 'rgb');
 290   }
 291
 292   my $bg = _bgcolor($geo);
 293   my $channels = $src->getchannels;
 294   if ($geo->{bgalpha} != 255 && $channels != 4) {
 295     $channels = 4;
 296     $src = $src->convert(preset => 'addalpha');
 297   }
 298   my $width = $src->getwidth;
 299   my $height = $src->getheight;
 300   my $out = Imager->new(xsize => $width, ysize => $height,
 301                         channels => $channels);
 302
 303   require Imager::Fill;
 304   my $fill = Imager::Fill->new(image => $src);
 305
 306   $out = $src->copy;
 307   if ($geo->{tl}) {
 308     $out->box(filled => 1, color => $bg, xmax => $geo->{tl}-1, ymax => $geo->{tl}-1);
 309     $out->arc(aa => 1, fill => $fill, r => $geo->{tl},
 310               x => $geo->{tl}, y => $geo->{tl},
 311               d1 => 175, d2 => 275);
 312   }
 313   if ($geo->{tr}) {
 314     $out->box(filled => 1, color => $bg, xmin => $width - $geo->{tr}, ymax => $geo->{tr}-1);
 315     $out->arc(aa => 1, fill => $fill, r => $geo->{tr},
 316               x => $width - $geo->{tr}, y => $geo->{tr},
 317               d1 => 265, d2 => 365);
 318   }
 319   if ($geo->{bl}) {
 320     $out->box(filled => 1, color => $bg, xmax => $geo->{bl}-1,
 321               ymin => $height - $geo->{bl});
 322     $out->arc(aa => 1, fill => $fill, r => $geo->{bl},
 323               x => $geo->{bl}, y => $height - $geo->{bl},
 324               d1 => 85, d2 => 185);
 325   }
 326   if ($geo->{br}) {
 327     $out->box(filled => 1, color => $bg, xmin => $width - $geo->{br},
 328               ymin => $height - $geo->{br});
 329     $out->arc(aa => 1, fill => $fill, r => $geo->{br},
 330               x => $width - $geo->{br}, y => $height - $geo->{br},
 331               d1 => 355, d2 => 455);
 332   }
 333
 334   return $out;
 335 }
 336
 337 sub _do_mirror {
 338   my ($work, $mirror) = @_;
 339
 340   if ($work->getchannels < 3) {
 341     $work = $work->convert(preset => 'rgb');
 342   }
 343   if ($mirror->{bgalpha} != 255) {
 344     $work = $work->convert(preset => 'addalpha');
 345   }
 346
 347   my $bg = _bgcolor($mirror);
 348
 349   my $oldheight = $work->getheight();
 350   my $height = $oldheight;
 351   my $gap = int(_percent_of($mirror->{horizon}, $oldheight));
 352   my $add_height = int(_percent_of($mirror->{height}, $oldheight));
 353   $height += $gap + $add_height;
 354
 355   my $out = Imager->new(xsize => $work->getwidth, ysize => $height,
 356                         channels => $work->getchannels);
 357   $out->box(filled => 1, color => $bg);
 358
 359   if ($work->getchannels == 4) {
 360     $out->rubthrough(src => $work)
 361       or print STDERR $out->errstr, "\n";
 362   }
 363   else {
 364     $out->paste(src => $work)
 365       or print STDERR $out->errstr, "\n";
 366   }
 367
 368   $work->flip(dir => 'v');
 369
 370   $work = $work->crop(bottom => $add_height);
 371
 372   $work = Imager::transform2
 373     (
 374      {
 375       channels => 4,
 376       constants =>
 377       {
 378        opacity => _percent($mirror->{opacity})
 379       },
 380       rpnexpr => <<EOS,
 381 $mirror->{srcx} !srcx
 382 $mirror->{srcy} !srcy
 383 \@srcx \@srcy getp1 !p
 384 \@p red \@p green \@p blue
 385 \@p alpha opacity h y - h / * * rgba
 386 EOS
 387      },
 388      $work
 389     ) or die Imager->errstr;
 390   $out->rubthrough(src => $work, ty => $oldheight + $gap);
 391
 392   if ($mirror->{perspective}) {
 393     require Imager::Matrix2d;
 394     my $old_width = $out->getwidth;
 395     my $p = abs($mirror->{perspective});
 396     my $new_width = $old_width / (1 + $p * $old_width) + 1;
 397     my $angle = sin($mirror->{perspectiveangle} * 3.1415926 / 180);
 398     my $persp = bless [ 1, 0, 0,
 399                         -$angle, 1, 0,
 400                         -abs($p), 0, 1 ], 'Imager::Matrix2d';
 401     $out->flip(dir => 'v');
 402     $mirror->{perspective} < 0 and $out->flip(dir => 'h');
 403     my $temp = $out->matrix_transform(matrix=> $persp, back=>$bg, xsize => $new_width)
 404       or print STDERR "failed", $work->errstr, "\n";
 405     $out = $temp;
 406     $mirror->{perspective} < 0 and $out->flip(dir => 'h');
 407     $out->flip(dir => 'v');
 408   }
 409
 410
 411   $out;
 412 }
 413
 414 sub _do_sepia {
 415   my ($work, $sepia) = @_;
 416
 417   require Imager::Filter::Sepia;
 418   $work = $work->convert(preset => 'rgb')
 419     if $work->getchannels < 3;
 420   my $color = Imager::Color->new($sepia->{color});
 421   $work->filter(type => 'sepia', tone => $color);
 422
 423   $work;
 424 }
 425
 426 sub _do_filter {
 427   my ($work, $filter) = @_;
 428
 429   $work = $work->convert(preset => 'rgb')
 430     if $work->getchannels < 3;
 431
 432   $work->filter(%$filter)
 433     or die $work->errstr;
 434
 435   $work;
 436 }
 437
 438 sub thumb_data {
 439   my ($self, $filename, $geometry, $error) = @_;
 440
 441   my $geolist = _parse_geometry($geometry, $error)
 442     or return;
 443
 444   require Imager;
 445   my $src = Imager->new;
 446   unless ($src->read(file => $filename)) {
 447     $$error = "Cannot read image $filename: ".$src->errstr;
 448     return;
 449   }
 450
 451   my $work = $src;
 452   for my $geo (@$geolist) {
 453     if ($geo->{action} eq 'scale') {
 454       my $scaled = $work;
 455       if ($geo->{crop}) {
 456         my $width_scale = $geo->{width} / $work->getwidth;
 457         my $height_scale = $geo->{height} / $work->getheight;
 458         my $scale = $width_scale < $height_scale ? $height_scale : $width_scale;
 459         if ($scale < 1.0) {
 460           $scaled = $work->scale(scalefactor => $scale, qtype=>'mixing');
 461         }
 462         my $width = $scaled->getwidth;
 463         if ($width > $geo->{width}) {
 464           $scaled = $scaled->crop(left => ($width-$geo->{width})/2, width => $geo->{width});
 465         }
 466         my $height = $scaled->getheight;
 467         if ($height > $geo->{height}) {
 468           $scaled = $scaled->crop(top => ($height - $geo->{height}) / 2,
 469                                   height => $geo->{height});
 470         }
 471       }
 472       else {
 473         my $width = $work->getwidth;
 474         my $height = $work->getheight;
 475         if ($geo->{width} && $width > $geo->{width}) {
 476           $height = $height * $geo->{width} / $width;
 477           $width = $geo->{width};
 478         }
 479         if ($geo->{height} && $height > $geo->{height}) {
 480           $width = $width * $geo->{height} / $height;
 481           $height = $geo->{height};
 482         }
 483         $width = int($width);
 484         $height = int($height);
 485         $scaled = $work->scale(xpixels => $width, ypixels => $height,
 486                                qtype => 'mixing');
 487       }
 488
 489       my $result = $scaled;
 490       if ($geo->{fill} &&
 491           ($scaled->getwidth < $geo->{width} || $scaled->getheight < $geo->{height})) {
 492         $result = Imager->new(xsize => $geo->{width}, ysize => $geo->{height});
 493         $result->box(color => $geo->{fill}, filled => 1);
 494         $result->paste(left => ($geo->{width} - $scaled->getwidth) / 2,
 495                        top => ($geo->{height} - $scaled->getheight) / 2 ,
 496                        img => $scaled);
 497       }
 498       $work = $result;
 499     }
 500     elsif ($geo->{action} eq 'roundcorners') {
 501       $work = _do_roundcorners($work, $geo);
 502     }
 503     elsif ($geo->{action} eq 'mirror') {
 504       $work = _do_mirror($work, $geo);
 505     }
 506     elsif ($geo->{action} eq 'grey') {
 507       $work = $work->convert(preset => 'grey');
 508       print STDERR "channels ", $work->getchannels, "\n";
 509     }
 510     elsif ($geo->{action} eq 'sepia') {
 511       $work = _do_sepia($work, $geo);
 512     }
 513     elsif ($geo->{action} eq 'filter') {
 514       $work = _do_filter($work, $geo);
 515     }
 516   }
 517
 518   my $data;
 519   my $type = $src->tags(name => 'i_format');
 520
 521   if ($work->getchannels == 4 || $work->getchannels == 2) {
 522     $type = 'png';
 523   }
 524
 525   unless ($work->write(data => \$data, type => $type)) {
 526     $$error = "cannot write image ".$work->errstr;
 527     return;
 528   }
 529
 530   return ( $data, "image/$type" );
 531 }
 532
 533 sub _percent {
 534   my ($num) = @_;
 535
 536   if ($num =~ s/%$//) {
 537     $num /= 100.0;
 538   }
 539   $num;
 540 }
 541
 542 sub _percent_of {
 543   my ($num, $base) = @_;
 544
 545   if ($num =~ s/%$//) {
 546     return $base * $num / 100.0;
 547   }
 548   else {
 549     return $num;
 550   }
 551 }
 552
 553 sub _bgcolor {
 554   my ($spec) = @_;
 555
 556   my $bg = Imager::Color->new($spec->{bg});
 557   $bg->set(($bg->rgba)[0..2], $spec->{bgalpha});
 558
 559   $bg;
 560 }
 561
 562 1;