File Coverage

blib/lib/X11/Protocol/WM.pm

Criterion	Covered	Total	%
statement	20	352	5.6
branch	1	134	0.7
condition	2	91	2.2
subroutine	8	62	12.9
pod	32	34	94.1
total	63	673	9.3

# Copyright 2011, 2012, 2013, 2014, 2016 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 .


# /usr/share/doc/xorg-docs/icccm/icccm.txt.gz
# /usr/share/doc/xorg-docs/ctext/ctext.txt.gz
#
# /usr/include/X11/Xutil.h
#    Xlib structs.
#
# http://www.pps.univ-paris-diderot.fr/%7Ejch/software/UTF8_STRING/
# http://www.pps.univ-paris-diderot.fr/%7Ejch/software/UTF8_STRING/UTF8_STRING.text
# /so/netwm/UTF8_STRING.text

BEGIN { require 5 }
package X11::Protocol::WM;
use strict;
use Carp;
use X11::AtomConstants;

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

use Exporter;
@ISA = ('Exporter');
@EXPORT_OK = qw(
                 frame_window_to_client
                 root_to_virtual_root

                 change_wm_hints
                 change_net_wm_state

                 get_wm_icon_size
                 get_wm_hints
                 get_wm_state
                 get_net_frame_extents
                 get_net_wm_state
                 set_text_property

                 set_wm_class
                 set_wm_client_machine
                 set_wm_client_machine_from_syshostname
                 set_wm_command
                 set_wm_hints
                 set_wm_name
                 set_wm_normal_hints
                 set_wm_icon_name
                 set_wm_protocols
                 set_wm_transient_for

                 set_motif_wm_hints

                 set_net_wm_pid
                 set_net_wm_state
                 set_net_wm_user_time
                 set_net_wm_window_type

                 pack_wm_hints
                 pack_wm_size_hints
                 pack_motif_wm_hints
                 unpack_wm_hints
                 unpack_wm_state
                 aspect_to_num_den

                 iconify
                 withdraw
              );

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


#------------------------------------------------------------------------------
# shared bits

BEGIN {
  eval 'utf8->can("is_utf8") && *is_utf8 = \&utf8::is_utf8'   # 5.8.1
    || eval 'use Encode "is_utf8"; 1'                         # 5.8.0
      || eval 'sub is_utf8 { 0 }; 1'                          # 5.6 fallback
        || die 'Oops, cannot create is_utf8() subr: ',$@;
}
### \&is_utf8

sub set_text_property {
  my ($X, $window, $prop, $str) = @_;
  if (defined $str) {
    my $type;
    ($type, $str) = _to_TEXT ($X, $str);
    $X->ChangeProperty ($window,
                        $prop,  # prop name
                        $type,  # type
                        8,      # format
                        'Replace',
                        $str);
  } else {
    $X->DeleteProperty ($window, $prop);
  }
}

# Maybe ...
#
# =item C<$str = _to_STRING ($str)>
#
# Convert C<$str> to latin-1 bytes for use in a STRING property.  If C<$str>
# is already bytes then they're presumed to be latin-1.  If C<$str> is Perl
# 5.8 wide chars then it's converted with the Encode module, and C
# if cannot be represented as a STRING.
#
sub _to_STRING {
  my ($str) = @_;
  if (is_utf8($str)) {
    require Encode;
    # croak in the interests of not letting bad values go through unnoticed,
    # nor letting a mangled name be stored
    return Encode::encode ('iso-8859-1', $str, Encode::FB_CROAK());
  } else {
    return $str;
  }
}

# Maybe ...
#
# =item C<($atom, $bytes) = _to_TEXT ($X, $str)>
#
# Convert C<$str> to either C or C per L
# Properties> above.  The returned C<$atom> (an integer) is the either
# C or C and C<$bytes> are bytes of that type.
#
sub _to_TEXT {
  my ($X, $str) = @_;
  if (! is_utf8($str)) {
    # bytes or pre-5.8 taken to be latin-1
    return (X11::AtomConstants::STRING(), $str);
  }
  require Encode;
  {
    my $input = $str; # don't clobber $str
    my $bytes = Encode::encode ('iso-8859-1', $input, Encode::FB_QUIET());
    if (length($input) == 0) {
      # latin-1 suffices
      return (X11::AtomConstants::STRING(), $bytes);
    }
  }
  require Encode::X11;
  return ($X->atom('COMPOUND_TEXT'),
          Encode::encode ('x11-compound-text', $str, Encode::FB_WARN()));
}

# Set a property on $window (integer XID) to a single CARD32 integer value.
# $prop is the property (integer atom ID).
# $type is the property type (integer atom ID).
# $value is a 32-bit integer to store, or undef to delete the property.
#
# The ICCCM or similar specification will say what C<$type> should be in a
# property.  Often there's only one type, but in any case C<$type> indicates
# what has been stored.  This might be for example the atom for "PIXMAP" if
# $value is a pixmap XID.  Things which are counts or numbers are usually
# the atom "CARDINAL".
#
sub _set_card32_property {
  my ($X, $window, $prop, $type, $value) = @_;
  if (defined $value) {
    $X->ChangeProperty ($window,
                        $prop,  # prop name
                        $type,  # type
                        32,     # format
                        'Replace',
                        pack ('L', $value));
  } else {
    $X->DeleteProperty ($window, $prop);
  }
}

# or maybe $X->num('IDorNone',$xid)
#          $X->num('XID',$xid)
sub _num_none {
  my ($xid) = @_;
  if (defined $xid && $xid eq "None") {
    return 0;
  } else {
    return $xid;
  }
}

# or maybe $X->interp('IDorNone',$xid) or 'XIDorNone'
sub _none_interp {
  my ($X, $xid) = @_;
  if ($X->{'do_interp'} && $xid == 0) {
    return 'None';
  } else {
    return $xid;
  }
}

# return $root or if that's undef then lookup root of $window
sub _root_for_window {
  my ($X, $window, $root) = @_;
  if (! defined $root) {
    ($root) = $X->QueryTree($window);
  }
  return $root;
}

#------------------------------------------------------------------------------
# frame_window_to_client()

# /usr/share/doc/libxmu-headers/Xmu.txt.gz for XmuClientWindow()
# https://bugs.freedesktop.org/show_bug.cgi?id=7474
#     XmuClientWindow() bottom-up was hurting fluxbox and probably ion, pekwm
#
sub frame_window_to_client {
  my ($X, $frame) = @_;

  my @search = ($frame);
  my $property = $X->atom('WM_STATE');

  # ENHANCE-ME: do three reqs in parallel, better yet all reqs for an
  # @search depth level in parallel

  my $count = 0;
 OUTER: foreach (1 .. 5) {   # limit search depth for safety
    my $child;
    foreach $child (splice @search) {   # breadth-first search
      ### look at: sprintf '0x%X', $child

      if ($count++ > 50) {
        ### abandon search at count: $count
        return undef;
      }

      {
        my $ret = $X->robust_req ('GetWindowAttributes', $child);
        if (! ref $ret) {
          ### some error, skip this child
          next;
        }
        my %attr = @$ret;
        ### map_state: $attr{'map_state'}
        if ($attr{'map_state'} ne 'Viewable') {
          ### not viewable, skip
          next;
        }
      }
      {
        my $ret = $X->robust_req ('GetProperty',
                                  $child, $property, 'AnyPropertyType',
                                  0,  # offset
                                  0,  # length
                                  0); # delete;
        if (! ref $ret) {
          ### some error, skip this child
          next;
        }
        my ($value, $type, $format, $bytes_after) = @$ret;
        if ($type) {
          ### found
          return $child;
        }
      }
      {
        my $ret = $X->robust_req ('QueryTree', $child);
        if (ref $ret) {
          my ($root, $parent, @children) = @$ret;
          ### push children: @children
          # @children are in bottom up order, prefer the topmost
          push @search, reverse @children;
        }
      }
    }
  }
  ### not found
  return undef;
}


#------------------------------------------------------------------------------
# root_to_virtual_root()

# ENHANCE-ME: Could do all the GetProperty checks in parallel.
# Could intern the VROOT atom during the QueryTree too.
#
sub root_to_virtual_root {
  my ($X, $root) = @_;
  ### root_to_virtual_root(): $root

  my ($root_root, $root_parent, @toplevels) = $X->QueryTree($root);
  my $toplevel;
  foreach $toplevel (@toplevels) {
    ### $toplevel
    my @ret = $X->robust_req ('GetProperty',
                              $toplevel,
                              $X->atom('__SWM_VROOT'),
                              X11::AtomConstants::WINDOW(),  # type
                              0,  # offset
                              1,  # length x 32bits
                              0); # delete;
    ### @ret
    next unless ref $ret[0]; # ignore errors from toplevels destroyed etc

    my ($value, $type, $format, $bytes_after) = @{$ret[0]};
    if (my $vroot = unpack 'L', $value) {
      ### found: $vroot
      return $vroot;
    }
  }
  return $root;
}


#------------------------------------------------------------------------------
# WM_CLASS

sub set_wm_class {
  my ($X, $window, $instance, $class) = @_;
  if (defined $instance) {
    my $str = _to_STRING($instance)."\0"._to_STRING($class)."\0";
    $X->ChangeProperty($window,
                       X11::AtomConstants::WM_CLASS(), # prop
                       X11::AtomConstants::STRING(),   # type
                       8,                              # byte format
                       'Replace',
                       $str);
  } else {
    $X->DeleteProperty ($window, X11::AtomConstants::WM_CLASS());
  }
}


#------------------------------------------------------------------------------
# WM_CLIENT_MACHINE

sub set_wm_client_machine {
  my ($X, $window, $hostname) = @_;
  set_text_property ($X, $window,
                     X11::AtomConstants::WM_CLIENT_MACHINE(), $hostname);
}

sub set_wm_client_machine_from_syshostname {
  my ($X, $window) = @_;
  require Sys::Hostname;
  set_wm_client_machine ($X, $window, eval { Sys::Hostname::hostname() });
}


#------------------------------------------------------------------------------
# WM_COMMAND

sub set_wm_command {
  my $X = shift;
  my $window = shift;

  if (@_ && ! defined $_[0]) {
    # this not documented ...
    $X->DeleteProperty ($window, X11::AtomConstants::WM_COMMAND());
    return;
  }

  # cf join() gives a wide-char result if any parts wide, upgrading byte
  # strings as if they were latin-1
  my $value = '';
  my $type = X11::AtomConstants::STRING();
  my $str;
  foreach $str (@_) {
    my ($atom, $bytes) = _to_TEXT($X,$str);
    if ($atom != X11::AtomConstants::STRING()) {
      $type = $atom;  # COMPOUND_TEXT if any part needs COMPOUND_TEXT
    }
    $value .= "$bytes\0";
  }
  if ($value eq "\0") {
    $value = "";  # this not documented ...
    # C<$command> can be an empty string "" to mean no known command as a
    # reply to C ... maybe
  }
  $X->ChangeProperty ($window,
                      X11::AtomConstants::WM_COMMAND(), # prop name
                      $type,  # type
                      8,      # format
                      'Replace',
                      $value);
}


#------------------------------------------------------------------------------
# WM_ICON_SIZE

sub get_wm_icon_size {
  my ($X, $root) = @_;
  if (! defined $root) {
    $root = $X->root;
  }
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($root,
                       X11::AtomConstants::WM_ICON_SIZE(),  # property
                       X11::AtomConstants::WM_ICON_SIZE(),  # type
                       0,   # offset
                       6,   # length CARD32s
                       0);  # delete;
  if ($format == 32) {
    return unpack 'L6', $value;
  } else {
    return;
  }
}


#------------------------------------------------------------------------------
# WM_HINTS

sub set_wm_hints {
  my $X = shift;
  my $window = shift;
  ### set_wm_hints(): @_
  ### set cards: map {sprintf '%#x',$_} unpack 'L*', pack_wm_hints($X,@_)
  $X->ChangeProperty($window,
                     X11::AtomConstants::WM_HINTS(), # prop name
                     X11::AtomConstants::WM_HINTS(), # type
                     32,           # format
                     'Replace',
                     pack_wm_hints($X, @_));
}

sub get_wm_hints {
  my ($X, $window) = @_;
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window,
                       X11::AtomConstants::WM_HINTS(), # prop name
                       X11::AtomConstants::WM_HINTS(), # type
                       0,             # offset
                       9,             # length($format), of CARD32
                       0);            # no delete
  if ($format == 32) {
    ### got cards: map {sprintf '%#x',$_} unpack 'L*', $value
    return unpack_wm_hints ($X, $value);
  } else {
    return;
  }
}

sub change_wm_hints {
  my $X = shift;
  my $window = shift;
  set_wm_hints ($X, $window, get_wm_hints($X,$window), @_);
}

{
  my $format = 'LLLLLllLL';
  # The C hint was called "visible" in X11R5.  The name "urgency"
  # is used here per X11R6.  The actual field sent and received is the same.
  #
  my %key_to_flag = (input         => 1,
                     initial_state => 2,
                     icon_pixmap   => 4,
                     icon_window   => 8,
                     icon_x        => 16,
                     icon_y        => 16,
                     icon_mask     => 32,
                     window_group  => 64,
                     # message     => 128, # in the code, obsolete
                     # urgency     => 256, # in the code
                    );

  sub pack_wm_hints {
    my ($X, %hint) = @_;
    ### pack_wm_hints(): %hint
    my $flags = 0;
    if (delete $hint{'message'}) {
      $flags = 128;
    }
    if (delete $hint{'urgency'}) {
      $flags |= 256;
    }
    my $key;
    foreach $key (keys %hint) {
      my $flag_bit = $key_to_flag{$key}
        || croak "Unknown WM_HINT field: ",$key;
      if (defined $hint{$key}) {
        $flags |= $flag_bit;
      }
    }
    return pack ($format,
                 $flags,
                 $hint{'input'} || 0,                       # CARD32 bool
                 _wmstate_num($hint{'initial_state'}) || 0, # CARD32 enum
                 _num_none($hint{'icon_pixmap'}) || 0,      # PIXMAP
                 _num_none($hint{'icon_window'}) || 0,      # WINDOW
                 $hint{'icon_x'} || 0,                      # INT32
                 $hint{'icon_y'} || 0,                      # INT32
                 _num_none($hint{'icon_mask'}) || 0,        # PIXMAP
                 _num_none($hint{'window_group'}) || 0);    # WINDOW
  }

  # X11R2 Xlib had a bug where XSetWMHints() set a WM_HINTS property to only
  # 8 CARD32s, chopping off the window_group field.  This was due to
  # Xatomtype.h NumPropWMHintsElements being 8 instead of 9.  If the length
  # of $bytes here is only 8 then ignore any window_group bit in the flags
  # and don't return a window_group field.  X11R2 source available at
  # http://ftp.x.org/pub/X11R2/X.V11R2.tar.gz
  #
  my @keys = ('input',
              'initial_state',
              'icon_pixmap',
              'icon_window',
              'icon_x',
              'icon_y',
              'icon_mask',
              'window_group',
              # 'message',      # in the code, and obsolete ...
              # 'urgency',      # in the code
             );
  my @interp = (\&_unchanged,                          # input
                \&_wmstate_interp,   # initial_state
                \&_none_interp,      # icon_pixmap
                \&_none_interp,      # icon_window
                \&_unchanged,                           # icon_x
                \&_unchanged,                           # icon_y
                \&_none_interp,      # icon_mask
                \&_none_interp,      # window_group
               );
  sub unpack_wm_hints {
    my ($X, $bytes) = @_;
    ### unpack_wm_hints(): unpack 'L*', $bytes
    my ($flags, @values) = unpack ($format, $bytes);
    my $bit = 1;
    my @ret;
    my $i;
    foreach $i (0 .. $#keys) {
      my $value = $values[$i];
      if (! defined $value) {
        # if $bytes is only 8 CARD32s as from X11R2 then omit window_group
        # from the return
        next;
      }
      if ($flags & $bit) {
        push @ret, $keys[$i], &{$interp[$i]}($X, $value);
      }
      $bit <<= ($i!=4);  # icon_x,icon_y both at $bit==16
    }
    if ($flags & 128) {
      push @ret, message => 1;
    }
    if ($flags & 256) {
      push @ret, urgency => 1;
    }
    return @ret;
  }
}

sub _unchanged {
  my ($X, $value) = @_;
  return $value;
}


#------------------------------------------------------------------------------
# WM_ICON_NAME

sub set_wm_icon_name {
  my ($X, $window, $name) = @_;
  set_text_property ($X, $window, X11::AtomConstants::WM_ICON_NAME(), $name);
}


#------------------------------------------------------------------------------
# WM_NAME

sub set_wm_name {
  my ($X, $window, $name) = @_;
  set_text_property ($X, $window, X11::AtomConstants::WM_NAME(), $name);
}

#------------------------------------------------------------------------------
# WM_PROTOCOLS

sub set_wm_protocols {
  my $X = shift;
  my $window = shift;

  # ENHANCE-ME: intern all atoms in one round-trip
  my $prop = $X->atom('WM_PROTOCOLS');
  if (@_) {
    $X->ChangeProperty($window,
                       $prop,                       # property
                       X11::AtomConstants::ATOM(),  # type
                       32,                          # format
                       'Replace',
                       pack('L*',_to_atom_nums($X,@_)));
  } else {
    $X->DeleteProperty ($window, $prop);
  }
}
sub _to_atom_nums {
  my $X = shift;
  return map { ($_ =~ /^\d+$/ ? $_ : $X->atom($_)) } @_;
}


#------------------------------------------------------------------------------
# WM_STATE enum
# For internal use yet ...

{
  my %wmstate = (WithdrawnState => 0,
                 DontCareState  => 0, # no longer in ICCCM
                 NormalState    => 1,
                 ZoomState      => 2, # no longer in ICCCM
                 IconicState    => 3,
                 InactiveState  => 4, # no longer in ICCCM
                );
  sub _wmstate_num {
    my ($wmstate) = @_;
    if (defined $wmstate && defined (my $num = $wmstate{$wmstate})) {
      return $num;
    }
    return $wmstate;
  }
}

{
  # DontCareState==0 no longer ICCCM
  my @wmstate = ('WithdrawnState', # 0
                 'NormalState',    # 1
                 'ZoomState',      # 2, no longer ICCCM
                 'IconicState',    # 3
                 'InactiveState',  # 4, no longer in ICCCM
                );
  sub _wmstate_interp {
    my ($X, $num) = @_;
    if ($X->{'do_interp'} && defined (my $str = $wmstate[$num])) {
      return $str;
    }
    return $num;
  }
}

# Maybe through $X->interp() with ...
#
# {
#   # $X->interp('WmState',$num);
#   # $X->num('WmState',$str);
#   my %const_arrays
#     = (
#        WmState => ['WithdrawnState', # 0
#                    'NormalState',    # 1
#                    'ZoomState',      # 2, no longer ICCCM
#                    'IconicState',    # 3
#                    'InactiveState',  # 4, no longer in ICCCM
#                   ],
#       );
#
#   my %const_hashes
#     = (map { $_ => { X11::Protocol::make_num_hash($const_arrays{$_}) } }
#        keys %const_arrays);
#
#
#   sub ext_const_init {
#     my ($X) = @_;
#     unless ($X->{'ext_const'}->{'WmState'}) {
#       %{$X->{'ext_const'}} = (%{$X->{'ext_const'}}, %const_arrays);
#       $X->{'ext_const_num'} ||= {};
#       %{$X->{'ext_const_num'}} = (%{$X->{'ext_const_num'}}, %const_hashes);
#     }
#   }
# }


#------------------------------------------------------------------------------
# WM_STATE

sub get_wm_state {
  my ($X, $window) = @_;
  my $xa_wm_state = $X->atom('WM_STATE');
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window,
                       $xa_wm_state,  # property
                       $xa_wm_state,  # type
                       0,             # offset
                       2,             # length, 2 x CARD32
                       0);            # delete
  if ($format == 32) {
    return unpack_wm_state($X,$value);
  } else {
    return;
  }
}

sub unpack_wm_state {
  my ($X, $data) = @_;
  my ($state, $icon_window) = unpack 'LL', $data;
  return (_wmstate_interp($X,$state), _none_interp($X,$icon_window));
}


#------------------------------------------------------------------------------
# WM_STATE transitions

# cf /so/xorg/libX11-1.4.0/src/Iconify.c
#
sub iconify {
  my ($X, $window, $root) = @_;
  ### iconify(): $window

  # The icccm spec doesn't seem to say any particular event mask for this
  # ClientMessage, but follow Xlib Iconify.c and send
  # SubstructureRedirect+SubstructureNotify.
  #
  _send_event_to_wm ($X, _root_for_window($X,$window,$root),
                     name   => 'ClientMessage',
                     window => $window,
                     type   => $X->atom('WM_CHANGE_STATE'),
                     format => 32,
                     data   => pack('L5', 3)); # 3=IconicState
}

# cf /so/xorg/libX11-1.4.0/src/Withdraw.c
#
sub withdraw {
  my ($X, $window, $root) = @_;
  ### withdraw(): $window, $root
  $root = _root_for_window($X,$window,$root); # QueryTree before unmap
  $X->UnmapWindow ($window);
  _send_event_to_wm ($X, $root,
                     name   => 'UnmapNotify',
                     event  => $root,
                     window => $window,
                     from_configure => 0);
}

# =item C<_send_event_to_wm ($X, $root, name=E$str,...)>
#
# Send an event to the window manager by C<$X-ESendEvent()> to the given
# C<$root> (integer XID of a root window).
#
# The key/value parameters specify an event packet as per
# C<$X-Epack_event()>.  Often this is a C event, but any
# type can be sent.  (For example C sends a synthetic
# C.)
#
# But: event-mask=ColormapChange for own colormap install setups ...
# But: event-mask=StructureNotify for "manager" acquiring resource ...
#
sub _send_event_to_wm {
  my $X = shift;
  my $root = shift;
  $X->SendEvent ($root,
                 0,  # all clients
                 $X->pack_event_mask('SubstructureRedirect',
                                     'SubstructureNotify'),
                 $X->pack_event(@_));
}


#------------------------------------------------------------------------------
# WM_TRANSIENT

# $transient_for eq 'None' supported for generality, but not yet documented
# since not sure such a property value would be ICCCM compliant
#
sub set_wm_transient_for {
  my ($X, $window, $transient_for) = @_;
  _set_card32_property ($X, $window,
                        X11::AtomConstants::WM_TRANSIENT_FOR(),  # prop name
                        X11::AtomConstants::WINDOW(),            # type
                        _num_none ($transient_for));
}

# not sure about this, might be only used by window manager, not a client
# =item C<$transient_for = X11::Protocol::WM::get_wm_transient_for ($X, $window)>
# sub get_wm_transient_for {
#   my ($X, $window) = @_;
#   _get_card32_property ($X, $window,
#                         X11::AtomConstants::WM_TRANSIENT_FOR(),
#                         X11::AtomConstants::WINDOW());
# }


#------------------------------------------------------------------------------
# _MOTIF_WM_HINTS

sub set_motif_wm_hints {
  my $X = shift;
  my $window = shift;
  $X->ChangeProperty($window,
                     $X->atom('_MOTIF_WM_HINTS'), # property
                     $X->atom('_MOTIF_WM_HINTS'), # type
                     32,                          # format
                     'Replace',
                     pack_motif_wm_hints ($X, @_));
}

{
  # per /usr/include/Xm/MwmUtil.h
  my %key_to_flag = (functions   => 1,
                     decorations => 2,
                     input_mode  => 4,
                     status      => 8,
                    );
  sub pack_motif_wm_hints {
    my ($X, %hint) = @_;

    my $flags = 0;
    my $key;
    foreach $key (keys %hint) {
      if (defined $hint{$key}) {
        $flags |= $key_to_flag{$key};
      } else {
        croak "Unrecognised _MOTIF_WM_HINTS field: ",$key;
      }
    }
    pack ('L5',
          $flags,
          $hint{'functions'} || 0,
          $hint{'decorations'} || 0,
          _motif_input_mode_num($X, $hint{'input_mode'} || 0),
          $hint{'status'} || 0);
  }
}
{
  my %input_mode_num = (modeless                  => 0,
                        primary_application_modal => 1,
                        system_modal              => 2,
                        full_application_modal    => 3,

                        # application_modal         => 1,
                       );
  sub _motif_input_mode_num {
    my ($X, $input_mode) = @_;
    if (exists $input_mode_num{$input_mode}) {
      return $input_mode_num{$input_mode};
    } else {
      return $input_mode;
    }
  }
}



#------------------------------------------------------------------------------
# _NET_FRAME_EXTENTS

sub get_net_frame_extents {
  my ($X, $window) = @_;
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window,
                       $X->atom('_NET_FRAME_EXTENTS'),  # property
                       X11::AtomConstants::CARDINAL(),  # type
                       0,    # offset
                       4,    # length, 4 x CARD32
                       0);   # delete
  if ($format == 32) {
    return unpack 'L4', $value;
  } else {
    return;
  }
}

#------------------------------------------------------------------------------
# _NET_WM_PID

sub set_net_wm_pid {
  my ($X, $window, $pid) = @_;
  if (@_ < 3) { $pid = $$; }
  _set_card32_property ($X,
                        $window,
                        $X->atom('_NET_WM_PID'),
                        X11::AtomConstants::CARDINAL(),
                        $pid);
}

#------------------------------------------------------------------------------
# _NET_WM_STATE

sub get_net_wm_state {
  my ($X, $window) = @_;
  # ENHANCE-ME: maybe atom_names() for parallel name fetch
  return map {_net_wm_state_interp($X,$_)} get_net_wm_state_atoms($X,$window);
}
# $atom is an atom integer, return a string like "FULLSCREEN".
sub _net_wm_state_interp {
  my ($X, $atom) = @_;
  my $state = $X->atom_name($atom);
  $state =~ s/^_NET_WM_STATE_//;
  return $state;
}
sub get_net_wm_state_atoms {
  my ($X, $window) = @_;
  my ($value, $type, $format, $bytes_after)
    = $X->GetProperty ($window,
                       $X->atom('_NET_WM_STATE'),   # property
                       X11::AtomConstants::ATOM(),  # type
                       0,    # offset
                       999,  # length limit
                       0);   # delete
  if ($format == 32) {
    return unpack('L*', $value);
  } else {
    return;
  }
}

# $state is a string "_NET_WM_STATE_FULLSCREEN" etc, or an integer atom
# number.  Return an integer atom number.
sub _net_wm_state_num {
  my ($X, $state) = @_;
  if (! defined $state) {
    return 0;
  }
  if ($state =~ /^\d+$/) {
    return $state;  # a number already
  }
  if ($state !~ /^_NET_WM_STATE_/) {
    $state = '_NET_WM_STATE_' . $state;
  }
  return $X->atom($state);
}

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

{
  my %_net_wm_state_action_num = (remove => 0,
                                  add    => 1,
                                  toggle => 2);
  # $action is a string "add" etc, or a number 0,1,2.
  # Return a number 0,1,2.
  sub _net_wm_state_action_num {
    my ($X, $action) = @_;
    ### _net_wm_state_action_num(): $action
    if ($action =~ /^\d+$/) {
      return $action;  # a number already
    }
    my $num = $_net_wm_state_action_num{$action};
    if (defined $num) {
      return $num;
    }
    croak 'Unrecognized _NET_WM_STATE action: ',$action;
  }
}

{
  my %_net_wm_source_num = (none   => 0,
                            normal => 1,
                            user   => 2);
  # $source is a string "normal" etc, or a number 0,1,2.
  # Return a number 0,1,2.
  sub _net_wm_source_num {
    my ($X, $source) = @_;
    if (! defined $source) {
      return 1;  # default "normal"
    }
    if ($source =~ /^\d+$/) {
      return $source;  # a number already
    }
    my $num = $_net_wm_source_num{$source};
    if (defined $num) {
      return $num;
    }
    croak 'Unrecognized _NET_WM source: ',$source;
  }
}

sub change_net_wm_state {
  my ($X, $window, $action, $state, %h) = @_;
  ### change_net_wm_state() ...
  ### $state
  ### %h

  my $root = X11::Protocol::WM::_root_for_window($X,$window,
                                                 delete $h{'root'});
  my $state2 = _net_wm_state_num($X, delete $h{'state2'});
  my $source = _net_wm_source_num($X, delete $h{'source'});
  if (%h) {
    croak "change_net_wm_state() unrecognised parameter(s): ",
      join(',',keys %h);
  }
  X11::Protocol::WM::_send_event_to_wm ($X, $root,
                     name   => 'ClientMessage',
                     window => $window,
                     type   => $X->atom('_NET_WM_STATE'),
                     format => 32,
                     data   => pack('L5',
                                    _net_wm_state_action_num($X, $action),
                                    _net_wm_state_num($X, $state),
                                    $state2,
                                    $source));
}

#------------------------------------------------------------------------------
# _NET_WM_WINDOW_TYPE

sub set_net_wm_window_type {
  my ($X, $window, $window_type) = @_;
  _set_card32_property ($X,
                        $window,
                        $X->atom('_NET_WM_WINDOW_TYPE'),
                        X11::AtomConstants::ATOM(),
                        _net_wm_window_type_to_atom ($X, $window_type));
}

# not documented yet ...
sub _net_wm_window_type_to_atom {
  my ($X, $window_type) = @_;
  if (! defined $window_type || $window_type =~ /^\d+$/) {
    return $window_type;
  } else {
    return $X->atom ("_NET_WM_WINDOW_TYPE_$window_type");
  }
}

# unless ($window_type =~ /^_NET_WM/) {
# }
# my ($akey, $atype) = _atoms ($X,
#                              '_NET_WM_WINDOW_TYPE',
#                              "_NET_WM_WINDOW_TYPE_$window_type");
#  a type stringcan be an atom integer, a full atom name like
# "_NET_WM_WINDOW_TYPE_NORMAL", or just the type part "NORMAL".  The types in
# the EWMH spec are


#------------------------------------------------------------------------------
# _NET_WM_USER_TIME

sub set_net_wm_user_time {
  my ($X, $window, $time) = @_;
  _set_card32_property ($X,
                        $window,
                        $X->atom('_NET_WM_USER_TIME'),
                        X11::AtomConstants::CARDINAL(),
                        $time);
}

#------------------------------------------------------------------------------
# WM_NORMAL_HINTS

sub set_wm_normal_hints {
  my $X = shift;
  my $window = shift;
  $X->ChangeProperty($window,
                     X11::AtomConstants::WM_NORMAL_HINTS(),  # property
                     X11::AtomConstants::WM_SIZE_HINTS(),    # type
                     32,                                     # format
                     'Replace',
                     pack_wm_size_hints ($X, @_));
}

{
  my %key_to_flag =
    (user_position    => 1,   # user-specified window x,y
     user_size        => 2,   # user-specified win width,height
     program_position => 4,   # program-specified window x,y
     program_size     => 8,   # program-specified win width,height
     min_width        => 16,
     min_height       => 16,
     max_width        => 32,
     max_height       => 32,
     width_inc        => 64,
     height_inc       => 64,
     min_aspect       => 128,
     min_aspect_num   => 128,
     min_aspect_den   => 128,
     max_aspect       => 128,
     max_aspect_num   => 128,
     max_aspect_den   => 128,
     base_width       => 256,
     base_height      => 256,
     win_gravity      => 512,
    );
  sub pack_wm_size_hints {
    my ($X, %hint) = @_;
    ### pack_wm_size_hints(): %hint

    my $flags = 0;
    my $key;
    foreach $key (keys %hint) {
      if (defined $hint{$key}) {
        $flags |= $key_to_flag{$key};
      } else {
        croak "Unrecognised WM_NORMAL_HINTS field: ",$key;
      }
    }
    pack ('Lx16L13',
          $flags,
          $hint{'min_width'} || 0,        # 1
          $hint{'min_height'} || 0,       # 2
          $hint{'max_width'} || 0,        # 3
          $hint{'max_height'} || 0,       # 4
          $hint{'width_inc'} || 0,        # 5
          $hint{'height_inc'} || 0,       # 6
          _aspect (\%hint, 'min'),        # 7,8
          _aspect (\%hint, 'max'),        # 9,10
          $hint{'base_width'} || 0,       # 11
          $hint{'base_height'} || 0,      # 12
          $X->num('WinGravity',$hint{'win_gravity'} || 0),  # 13
         );
  }
}
sub _aspect {
  my ($hint, $which) = @_;
  if (defined (my $aspect = $hint->{"${which}_aspect"})) {
    return aspect_to_num_den($aspect);
  } else {
    return ($hint->{"${which}_aspect_num"} || 0,
            $hint->{"${which}_aspect_den"} || 0);
  }
}
sub aspect_to_num_den {
  my ($aspect) = @_;
  ### $aspect

  my ($num, $den);

  if ($aspect =~ /^\d+$/) {
    ### integer
    $num = $aspect;
    $den = 1;
  } elsif (($num,$den) = ($aspect =~ m{(.*)/(.*)})) {
    ### slash fraction
  } else {
    $num = $aspect;
    $den = 1;
  }

  my $den_zeros = 0;
  if ($num =~ /^0*(\d*)\.(\d*?)0*$/) {
    ### decimal
    $num = "$1$2";
    $den_zeros = length($2);
  }
  if ($den =~ /^0*(\d*)\.(\d*?)0*$/) {
    ### decimal
    $den = "$1$2";
    $den_zeros -= length($2);
  }
  if ($den_zeros > 0) {
    $den .= '0' x $den_zeros;
  }
  if ($den_zeros < 0) {
    $num .= '0' x -$den_zeros;
  }

  if ($num == $num-1) {  # infinity
    return (0x7FFF_FFFF, ($den == $den-1  # infinity too
                          ? 0x7FFF_FFFF : 1));
  }
  if ($den == $den-1) {  # infinity
    return (1, 0x7FFF_FFFF);
  }

  # cap anything bigger than 0x7FFFFFFF
  if ($num >= $den && $num > 0x7FFF_FFFF) {
    ### reduce big numerator
    ($num,$den) = _aspect_reduce($num,$den);
  }
  if ($den > 0x7FFF_FFFF) {
    ### reduce big denominator
    ($den,$num) = _aspect_reduce($den,$num);
  }

  # increase non-integers in binary
  while ((int($num) != $num || int($den) != $den)
         && $num < 0x4000_0000
         && $den < 0x4000_0000) {
    $num *= 2;
    $den *= 2;
    ### up to: $num,$den
  }

  return (_round_nz($num), _round_nz($den));
}

# Return $x rounded to the nearest integer.
# If $x is not zero then the return is not zero too, ie. $x<0.5 is rounded
# up to return 1.
sub _round_nz {
  my ($x) = @_;
  my $nz = ($x != 0);
  $x = int ($x + 0.5);
  if ($nz && $x == 0) {
    return 1;
  } else {
    return $x;
  }
}

# $x is > 0x7FFF_FFFF.  Reduce it to 0x7FFF_FFFF and reduce $y in proportion.
# If $y!=0 then it's reduced to a minimum 1, not to 0.
sub _aspect_reduce {
  my ($x,$y) = @_;
  my $nz = ($y != 0);
  $y = int (0.5 + $y / $x * 0x7FFF_FFFF);
  if ($nz && $y == 0) { $y = 1; }
  elsif ($y > 0x7FFF_FFFF) { $y = 0x7FFF_FFFF; }
  return (0x7FFF_FFFF, $y);
}
# printf "%d %d", _aspect_frac('.123456789');



1;
__END__