File Coverage

blib/lib/Gtk2/Ex/PixbufBits.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

# Copyright 2007, 2008, 2009, 2010, 2011, 2012 Kevin Ryde

# This file is part of Gtk2-Ex-WidgetBits.
#
# Gtk2-Ex-WidgetBits is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# Gtk2-Ex-WidgetBits is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Gtk2-Ex-WidgetBits.  If not, see .

package Gtk2::Ex::PixbufBits;
use 5.008;
use strict;
use warnings;
use Carp;
use Gtk2;
use List::Util;

use Exporter;
our @ISA = ('Exporter');
our @EXPORT_OK = qw(type_to_format
                    save_adapt
                    save_adapt_options
                    sampled_majority_color);

our $VERSION = 48;

# uncomment this to run the ### lines
#use Smart::Comments;

#------------------------------------------------------------------------------

sub type_to_format {
  my ($type) = @_;
  return List::Util::first {$_->{'name'} eq $type}
    Gtk2::Gdk::Pixbuf->get_formats;
}

# Not absolutely sure of the BMP limit, but io-bmp.c reads and writes it as
# a signed 32-bit, hence 2^31-1.
#
# PNG spec requires width>=1 and height>=1.
#
my %type_max_size = (ico  => 255,
                     jpeg => 65500,
                     png  => 0x7FFF_FFFF,
                     bmp  => 0x7FFF_FFFF,
                     tiff => 0xFFFF_FFFF,
                    );
sub type_max_size {
  my ($type) = @_;
  if (my $size = $type_max_size{$type}) {
    return ($size, $size);
  } else {
    return;
  }
}
sub type_supports_size {
  my ($type, $width, $height) = @_;
  if (my $size = $type_max_size{$type}) {
    if ($width > $size || $height > $size) {
      return 0;
    }
  }
  return 1;
}

#------------------------------------------------------------------------------

# Could extract the tEXts from get_option() as defaults to save back.  But
# can't list what's in there, so maybe only the png specified ones.

sub save_adapt {
  my $pixbuf = shift;   # ($pixbuf, $filename, $type, key=>value, ...)
  $pixbuf->save (save_adapt_options($pixbuf, @_));
}

my %tiff_compression_types = (none    => 1,
                              huffman => 2,
                              lzw     => 5,
                              jpeg    => 7,
                              deflate => 8);

sub save_adapt_options {
  my $pixbuf = shift;
  my $filename = shift;
  my $type = shift;
  if (@_ & 1) {
    croak 'PixbufBits save_adapt(): option key without value (odd number of arguments)';
  }
  my @first = ($filename, $type);
  my @rest;
  my %seen;

  while (@_) {
    my $key = shift;
    my $value = shift;
    if ($key eq 'zlib_compression') {
      next unless $type eq 'png';
      # png saving always available, but compression option only in 2.8 up
      next if Gtk2->check_version(2,8,0);
      $key = 'compression';

    } elsif ($key eq 'tiff_compression_type') {
      next unless $type eq 'tiff';
      next if Gtk2->check_version(2,20,0);  # new in 2.20
      $key = 'compression';
      $value = $tiff_compression_types{$value} || $value;

    } elsif ($key =~ /^tEXt:/) {
      next unless $type eq 'png';
      # Gtk2-Perl 1.221 doesn't upgrade byte values to utf8 the way it does
      # in other wrappers, ensure utf8 for output
      utf8::upgrade($value);
      # text before "compression" or Gtk 2.20.1 botches the file output
      push @first, $key, $value;
      next;

    } elsif ($key eq 'quality_percent') {
      next unless $type eq 'jpeg';
      $key = 'quality';

    } elsif ($key eq 'x_hot' || $key eq 'y_hot') {
      # no xpm saving as of 2.20, but maybe it would use x_hot/y_hot
      # if/when available ... || $type eq 'xpm';
      next unless $type eq 'ico';
      $seen{$key} = 1;
      next if ! defined $value; # undef means no hotspot

      # } elsif ($key eq 'depth') {
      #   next unless $type eq 'ico';
      #
      # } elsif ($key eq 'icc-profile') {
      #   # this mangling not yet documented ....
      #   next unless $type eq 'png' ||  $type eq 'tiff';
      #   next if Gtk2->check_version(2,20,0);
    }
    push @rest, $key, $value;
  }

  if ($pixbuf && $type eq 'ico') {
    foreach my $key ('x_hot', 'y_hot') {
      unless ($seen{$key}) {
        if (defined (my $default = $pixbuf->get_option($key))) {
          push @rest, $key, $default;
        }
      }
    }
  }

  return @first, @rest;
}

#------------------------------------------------------------------------------
# Currently all pixels if <= 1800, or 900 pixels at random otherwise, with
# transparents skipped but only up to an absolute limit of 3600 attempts.
#
# The worst case is every pixel different and a hash entry for each.  If
# that was done for every pixel of a big image then it might use a lot of
# memory.  An in-place sort could put same pixels adjacent to find the
# biggest count, but a sort of a big image might be a bit slow.
#
use constant _SAMPLES => 900;

sub sampled_majority_color {
  my ($pixbuf) = @_;

  my $bytes_per_sample = $pixbuf->get_bits_per_sample / 8;
  my $n_channels = $pixbuf->get_n_channels;

  if ($pixbuf->get_colorspace ne 'rgb'
      || $bytes_per_sample != 1) {
    croak "sampled_majority_color() can only read 8-bit RGB or RGBA";
    #
    # || $bytes_per_sample != int($bytes_per_sample)
  }

  my $width = $pixbuf->get_width;
  my $height = $pixbuf->get_height;
  my $row_stride = $pixbuf->get_rowstride;
  my $pixel_bytes = $bytes_per_sample * 3;
  my $pixel_stride = $bytes_per_sample * $n_channels;
  my $zero = "\0" x $bytes_per_sample;
  my $data = $pixbuf->get_pixels;

  my %hash;
  # return true if accumulated, false if skip a transparent pixel
  my $acc = sub {
    my ($offset) = @_;
    return (substr ($data, $offset+$pixel_bytes, $bytes_per_sample) ne $zero
            && ++$hash{substr ($data, $offset, $pixel_bytes)});
  };

  if ($width * $height < 2 * _SAMPLES) {
    foreach my $y (0 .. $width-1) {
      my $offset = $y * $row_stride;
      foreach my $x (0 .. $width-1) {
        $acc->($offset);
        $offset += $pixel_stride;
      }
    }
  } else {
    for (my $i = 0; $i < _SAMPLES; $i++) {
      unless ($acc->($pixel_stride * int(rand($width))        # x
                     + $row_stride * int(rand($height)))) {   # y
        $i -= .75;
      }
    }
  }

  if (! %hash) {
    ### oops, only saw transparent pixels, what to do?
    return '#000000';
  }

  return sprintf '#%02X%02X%02X', unpack ('C*', _hash_key_with_max_value (\%hash));
}

# sub _pixel_bytes_to_color_string {
#   my ($pixbuf, $bytes) = @_;
#   if ($pixbuf->get_colorspace eq 'rgb') {
#     if ($pixbuf->get_bits_per_sample == 8) {
#       return sprintf '#%02X%02X%02X', unpack ('C*', $bytes);
#     }
#     # if ($pixbuf->get_bits_per_sample == 16) {
#     #   return sprintf '#%04X%04X%04X', unpack ('S*', $bytes);
#     # }
#   }
#   croak "sampled_majority_color() can only read 8-bit RGB or RGBA";
# }

# $hash is a hashref, return the key from it with the biggest value,
# comparing values as numbers with ">"
sub _hash_key_with_max_value {
  my ($hashref) = @_;
  my ($max_key, $max_value) = each %$hashref;
  while (my ($key, $value) = each %$hashref) {
    if ($value > $max_value) {
      $max_key = $key;
      $max_value = $value;
    }
  }
  return $max_key;
}

1;
__END__