libx11-protocol-other-perl 28-1 / usr / share / perl5 / X11 / Protocol / Other.pm

# Copyright 2010, 2011, 2012, 2013 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 <http://www.gnu.org/licenses/>.

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

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

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
                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


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

# # 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__

=for stopwords Ryde XID colormap colormaps ie PseudoColor VisualClass RGB rgb 0xFFFF FFF FFFF Xcms recognised unrecognised recognising

=head1 NAME

X11::Protocol::Other -- miscellaneous X11::Protocol helpers

=head1 SYNOPSIS

 use X11::Protocol::Other;

=head1 DESCRIPTION

This is some helper functions for C<X11::Protocol>.

=head1 EXPORTS

Nothing is exported by default, but the functions can be requested in usual
C<Exporter> style,

    use X11::Protocol::Other 'visual_is_dynamic';
    if (visual_is_dynamic ($X, $visual_id)) {
      ...
    }

Or just called with full package name

    use X11::Protocol::Other;
    if (X11::Protocol::Other::visual_is_dynamic ($X, $visual_id)) {
      ...
    }

There's no C<:all> tag since this module is meant as a grab-bag of functions
and to import as-yet unknown things would be asking for name clashes.

=head1 FUNCTIONS

=head2 Screen Finding

=over 4

=item C<$number = root_to_screen ($X, $root)>

=item C<$hashref = root_to_screen_info ($X, $root)>

Return the screen number or screen info hash for a given root window.
C<$root> can be any XID integer on C<$X>.  If it's not one of the root
windows then the return is C<undef>.

=item C<$number = default_colormap_to_screen ($X, $colormap)>

=item C<$hashref = default_colormap_to_screen_info ($X, $colormap)>

Return the screen number or screen info hash for a given default colormap.
C<$colormap> can be any XID integer on C<$X>.  If it's not one of the screen
default colormaps then the return is C<undef>.

=back

=head2 Visuals

=over

=item C<$bool = visual_is_dynamic ($X, $visual_id)>

=item C<$bool = visual_class_is_dynamic ($X, $visual_class)>

Return true if the given visual is dynamic, meaning colormap entries on it
can be changed to change the colour of a given pixel value.

C<$visual_id> is one of the visual ID numbers, ie. one of the keys in
C<$X-E<gt>{'visuals'}>.  Or C<$visual_class> is a VisualClass string like
"PseudoColor" or corresponding integer such as 3.

=back

=head2 Window Info

=over

=item C<($width, $height) = window_size ($X, $window)>

=item C<$visual_id = window_visual ($X, $window)>

Return the size or visual ID of a given window.

C<$window> is an integer XID on C<$X>.  If it's one of the root windows then
the return values are from the screen info hash in C<$X>, otherwise the
server is queried with C<GetGeometry()> (for the size) or
C<GetWindowAttributes()> (for the visual).

These functions are handy when there's a good chance C<$window> might be a
root window and therefore not need a server round trip.

=back

=head2 Colour Parsing

=over

=item C<($red16, $green16, $blue16) = hexstr_to_rgb($str)>

Parse a given RGB colour string like "#FF00FF" into 16-bit red, green, blue
components.  The return values are always in the range 0 to 65535.  The
strings recognised are 1, 2, 3 or 4 digit hex.

    #RGB
    #RRGGBB
    #RRRGGGBBB
    #RRRRGGGGBBBB

If C<$str> is unrecognised then the return is an empty list, so for instance

    my @rgb = hexstr_to_rgb($str)
      or die "Unrecognised colour: $str";

The digits of the 1, 2 and 3 forms are replicated as necessary to give a
16-bit range.  For example 3-digit style "#321FFF000" gives return values
0x3213, 0xFFFF, 0.  Or 1-digit "#F0F" is 0xFFFF, 0, 0xFFFF.  Notice "F"
expands to 0xFFFF so an "F", "FF" or "FFF" all mean full saturation the same
as a 4-digit "FFFF".

Would it be worth recognising the Xcms style "rgb:RR/GG/BB"?  Perhaps that's
best left to full Xcms, or general colour conversion modules.  The X11R6
X(7) man page describes the "rgb:" form, but just "#" is much more common.

=back

=head1 SEE ALSO

L<X11::Protocol>,
L<X11::Protocol::GrabServer>

L<Color::Library> (many named colours), L<Convert::Color>,
L<Graphics::Color> (Moose based) for more colour parsing

L<X11::AtomConstants>,
L<X11::CursorFont>

=head1 HOME PAGE

L<http://user42.tuxfamily.org/x11-protocol-other/index.html>

=head1 LICENSE

Copyright 2010, 2011, 2012, 2013 Kevin Ryde

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 <http://www.gnu.org/licenses/>.

=cut