#!/usr/bin/perl -w

# Copyright 2011 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/>.


# Usage: perl xfixes-selection.pl
#
# This is an example of using XFixesSelectSelectionInput() to listen for
# changes to selection ownership.
#
# With just the core protocol this sort of thing has to be done by polling
# GetSelectionOwner() periodically.  If you're the selection owner you're
# notified of its loss with an event, but third parties like a cut-buffer
# display have to poll.
#
# The key part is merely $X->XFixesSelectSelectionInput() and the
# XFixesSelectionNotify events.  The window creation and GetProperty()
# nonsense are only to retrieve the selection contents.  If you're
# interested in selection changes then you probably want to fetch the
# selection contents at some point.
#
# The window supplied to XFixesSelectSelectionInput() doesn't have to be a
# client window.  It seems to work to give $X->root.  Is it's purpose in the
# protocol to let clients dispatch events to a widget?  Or have multiple
# independent parts of a program listening or some such?
#
# The only selection data type supported here is "STRING".  A real program
# might ask for "TEXT" to read either STRING or COMPOUND_TEXT.  The ICCCM
# spec lists a lot of possible types, but how many are usefully generated by
# programs is another matter.
#

use strict;
use X11::Protocol;
use X11::AtomConstants;

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

my $X = X11::Protocol->new;
if (! $X->init_extension('XFIXES')) {
  print "XFIXES extension not available on the server\n";
  exit 1;
}

my $receiver_window = $X->new_rsrc;
$X->CreateWindow ($receiver_window,
                  $X->root,         # parent
                  'InputOutput',    # class
                  0,                # depth, from parent
                  'CopyFromParent', # visual
                  0,0,              # x,y
                  1,1,              # width,height
                  0,                # border
                  event_mask => $X->pack_event_mask('PropertyChange'));

$X->XFixesSelectSelectionInput ($receiver_window, $X->atom('PRIMARY'), 0x07);

my %converts_in_progress;

$X->{'event_handler'} = sub {
  my (%h) = @_;
  ### event_handler: \%h

  if ($h{'name'} eq 'XFixesSelectionNotify') {
    my $subtype = $h{'subtype'};
    my $owner = $h{'owner'};
    my $selection_atom = $h{'selection'};  # eg. "PRIMARY"
    if ($owner ne 'None') { $owner = sprintf('0x%X',$owner); }
    printf("%s %s, owner now %s\n",
           $X->atom_name($selection_atom),
           $subtype,
           $owner);

    # ask for selection value
    if ($subtype eq 'SetSelectionOwner') {
      $X->ConvertSelection ($selection_atom,       # atom
                            $X->atom('STRING'),    # type
                            $selection_atom,       # destination
                            $receiver_window,      # destination
                            $h{'time'});
      $converts_in_progress{$selection_atom} = 1;
    }

  } elsif ($h{'name'} eq 'PropertyNotify'
           && $h{'state'} eq 'NewValue'
           # only the selection property receives, not other property changes
           && $converts_in_progress{$h{'atom'}}) {
    # selection value received
    my ($value, $type, $format, $bytes_after)
      = $X->GetProperty ($receiver_window,
                         $h{'atom'},         # property
                         'AnyPropertyType',  # type
                         0,      # offset
                         60/4,   # length limit, in 4-byte chunks
                         1);     # delete, now have received
    ### $value
    print "  value: \"",
      $value,
        ($bytes_after ? " ..." : ""),  # if longer than requested size
          "\"\n";
  }
};

for (;;) {
  $X->handle_input;
}

exit 0;