File Coverage

blib/lib/X11/Protocol/Other.pm

Criterion	Covered	Total	%
statement	17	67	25.3
branch	0	14	0.0
condition	0	7	0.0
subroutine	6	17	35.2
pod	11	11	100.0
total	34	116	29.3

# Copyright 2010, 2011, 2012, 2013, 2014, 2017, 2019 Kevin Ryde

# This file is part of X11-Protocol-Other.
#
# X11-Protocol-Other 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.
#
# X11-Protocol-Other 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 X11-Protocol-Other.  If not, see .

package X11::Protocol::Other;
use 5.004;
use strict;
use Carp;
use X11::AtomConstants;

use vars '$VERSION', '@ISA', '@EXPORT_OK';
$VERSION = 31;

use Exporter;
@ISA = ('Exporter');
@EXPORT_OK = qw(root_to_screen
                root_to_screen_info
                default_colormap_to_screen
                default_colormap_to_screen_info
                visual_is_dynamic
                visual_class_is_dynamic
                window_size
                window_visual
                get_property_atoms
                hexstr_to_rgb
              );

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

sub window_size {
  my ($X, $window) = @_;
  ### Other window_size(): "$X $window"
  my $screen_info;
  if ($screen_info = root_to_screen_info($X,$window)) {
    return ($screen_info->{'width_in_pixels'},
            $screen_info->{'height_in_pixels'});
  }
  my %geom = $X->GetGeometry ($window);
  return ($geom{'width'}, $geom{'height'});
}
sub window_visual {
  my ($X, $window) = @_;
  ### Other window_visual(): "$X $window"
  my $screen_info;
  if ($screen_info = root_to_screen_info($X,$window)) {
    return $screen_info->{'root_visual'};
  }
  my %attr = $X->GetWindowAttributes ($window);
  return $attr{'visual'};
}

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

sub root_to_screen {
  my ($X, $root) = @_;
  ### Other root_to_screen(): $root
  return ($X->{__PACKAGE__.'.root_to_screen_number'}
          ||= { map {($X->{'screens'}->[$_]->{'root'} => $_)}
                0 .. $#{$X->{'screens'}} })
    ->{$root};
}
sub root_to_screen_info {
  my ($X, $root) = @_;
  ### Other root_to_screen_info(): $root
  my $ret;
  if (defined ($ret = root_to_screen($X,$root))) {
    $ret = $X->{'screens'}->[$ret];
  }
  return $ret;

  # return ($X->{__PACKAGE__.'.root_to_screen_info'}
  #         ||= { map {($_->{'root'} => $_)} @{$X->{'screens'}} })->{$root}
}

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

sub default_colormap_to_screen {
  my ($X, $colormap) = @_;
  ### default_colormap_to_screen(): $colormap
  return ($X->{__PACKAGE__.'.default_colormap_to_screen_number'}
          ||= { map {($X->{'screens'}->[$_]->{'default_colormap'} => $_)}
                0 .. $#{$X->{'screens'}} })
    ->{$colormap};
}
sub default_colormap_to_screen_info {
  my ($X, $colormap) = @_;
  ### Other colormap_to_screen_info(): $colormap
  my $ret;
  if (defined ($ret = default_colormap_to_screen($X,$colormap))) {
    $ret = $X->{'screens'}->[$ret];
  }
  return $ret;
}

# # return true if $colormap is one of the screen default colormaps
# sub colormap_is_default {
#   my ($X, $colormap) = @_;
#   return defined (default_colormap_to_screen($X,$colormap));
# }


#------------------------------------------------------------------------------
# my %visual_class_is_dynamic = (StaticGray  => 0,  0 => 0,
#                                GrayScale   => 1,  1 => 1,
#                                StaticColor => 0,  2 => 0,
#                                PseudoColor => 1,  3 => 1,
#                                TrueColor   => 0,  4 => 0,
#                                DirectColor => 1,  5 => 1,
#                               );
sub visual_class_is_dynamic {
  my ($X, $visual_class) = @_;
  return $X->num('VisualClass',$visual_class) & 1;
}
sub visual_is_dynamic {
  my ($X, $visual_id) = @_;
  my $visual_info = $X->{'visuals'}->{$visual_id}
    || croak 'Unknown visual ',$visual_id;
  return visual_class_is_dynamic ($X, $visual_info->{'class'});
}

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

# cf XcmsLRGB_RGB_ParseString() in XcmsLRGB.c

sub hexstr_to_rgb {
  my ($str) = @_;
  ### hexstr_to_rgb(): $str
  # Crib: [:xdigit:] is new in 5.6, so only 0-9A-F
  $str =~ /^#(([0-9A-F]{3}){1,4})$/i or return;
  my $len = length($1)/3; # of each group, so 1,2,3 or 4
  return (map {hex(substr($_ x 4, 0, 4))}  # first 4 chars of replicated
          substr ($str, 1, $len),      # full groups
          substr ($str, 1+$len, $len),
          substr ($str, -$len));
}

# my %hex_factor = (1 => 0x1111,
#                   2 => 0x101,
#                   3 => 0x10 + 1/0x100,
#                   4 => 1);
#   my $factor = $hex_factor{$len} || return;
#   ### $len
#   ### $factor


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

sub get_property_atoms {
  my ($X, $window, $property) = @_;
  (my $value,
   undef,            # type
   my $format,
   my $bytes_after)
    = $X->GetProperty ($window, $property,
                       X11::AtomConstants::ATOM(), # type
                       0,          # offset
                       0x7FFFFFFF, # long-length: CARD32, unlimited
                       0);         # delete
  ### $value
  ### $format
  $format == 32 or return;  # not atoms
  if ($bytes_after) {
    croak "oops, extremely long property, has $bytes_after more";
  }
  return unpack('L*', $value);
}

sub set_property_atoms {
  my $X = shift;
  my $window = shift;
  my $property = shift;
  $X->ChangeProperty($window,
                     $property,                   # property
                     X11::AtomConstants::ATOM(),  # type
                     32,                          # format
                     'Replace',
                     pack('L*',@_));
}

# sub set_property_atom_names {
#   my ($X, $window, $property, @atoms) = @_;
#   # ENHANCE-ME: might like to intern all atoms in one round-trip, or perhaps
#   # that's better left to a single big pre-fill of atoms in mainline code
#   set_property_atoms($X,$window,$property,
#                      map {$X->atom($_)} @atoms);
# }


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

# # return true if $pixel is black or white in the default root window colormap
# sub pixel_is_black_or_white {
#   my ($X, $pixel) = @_;
#   return ($pixel == $X->{'black_pixel'} || $pixel == $X->{'white_pixel'});
# }
#

1;
__END__