samples/gifscale.pl

   1 #!perl -w
   2 use strict;
   3 use Imager;
   4 use POSIX qw(ceil);
   5
   6 $Imager::formats{gif} || $Imager::formats{ungif}
   7   or die "Your build of Imager doesn't support gif\n";
   8
   9 $Imager::formats{gif}
  10   or warn "Your build of Imager output's uncompressed GIFs, install libgif instead of libungif (the patents have expired)";
  11
  12 my $factor = shift;
  13 my $in_name = shift;
  14 my $out_name = shift
  15   or die "Usage: $0 scalefactor input.gif output.gif\n";
  16
  17 $factor > 0
  18   or die "scalefactor must be positive\n";
  19
  20 my @in = Imager->read_multi(file => $in_name)
  21   or die "Cannot read image file: ", Imager->errstr, "\n";
  22
  23 # the sizes need to be based on the screen size of the image, but
  24 # that's only present in GIF, make sure the image was read as gif
  25
  26 $in[0]->tags(name => 'i_format') eq 'gif'
  27   or die "File $in_name is not a GIF image\n";
  28
  29 my $src_screen_width = $in[0]->tags(name => 'gif_screen_width');
  30 my $src_screen_height = $in[0]->tags(name => 'gif_screen_height');
  31
  32 my $out_screen_width = ceil($src_screen_width * $factor);
  33 my $out_screen_height = ceil($src_screen_height * $factor);
  34
  35 my @out;
  36 for my $in (@in) {
  37   my $scaled = $in->scale(scalefactor => $factor, qtype=>'mixing');
  38
  39   # roughly preserve the relative position
  40   $scaled->settag(name => 'gif_left',
  41                   value => $factor * $in->tags(name => 'gif_left'));
  42   $scaled->settag(name => 'gif_top',
  43                   value => $factor * $in->tags(name => 'gif_top'));
  44
  45   $scaled->settag(name => 'gif_screen_width', value => $out_screen_width);
  46   $scaled->settag(name => 'gif_screen_height', value => $out_screen_height);
  47
  48   # set some other tags from the source
  49   for my $tag (qw/gif_delay gif_user_input gif_loop gif_disposal/) {
  50     $scaled->settag(name => $tag, value => $in->tags(name => $tag));
  51   }
  52   if ($in->tags(name => 'gif_local_map')) {
  53     $scaled->settag(name => 'gif_local_map', value => 1);
  54   }
  55
  56   push @out, $scaled;
  57 }
  58
  59 Imager->write_multi({ file => $out_name }, @out)
  60   or die "Cannot save $out_name: ", Imager->errstr, "\n";
  61
  62 =head1 NAME
  63
  64 =for stopwords gifscale.pl
  65
  66 gifscale.pl - demonstrates adjusting tags when scaling a GIF image
  67
  68 =head1 SYNOPSIS
  69
  70   perl gifscale.pl scalefactor input.gif output.gif
  71
  72 =head1 DESCRIPTION
  73
  74 Scales an input multiple-image GIF file.  Unlike a simple scale each file
  75 solution this:
  76
  77 =over
  78
  79 =item *
  80
  81 preserves GIF animation attributes
  82
  83 =item *
  84
  85 adjusts the sub-images positions on the background accounting for the
  86 scale factor.
  87
  88 =back
  89
  90 =head1 AUTHOR
  91
  92 Tony Cook <tonyc@cpan.org>
  93
  94 =cut