File Coverage

blib/lib/X11/Protocol/ChooseWindow.pm

Criterion	Covered	Total	%
statement	13	114	11.4
branch	0	44	0.0
condition	0	28	0.0
subroutine	5	17	29.4
pod	1	8	12.5
total	19	211	9.0

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


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

use vars '$VERSION', '$_instance';
$VERSION = 31;

use X11::Protocol::WM;

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


# undocumented yet ...
sub new {
  my $class = shift;
  return bless { want_client => 1,
                 @_ }, $class;
}

sub _X {
  my ($self) = @_;
  return ($self->{'X'} ||= do {
    require X11::Protocol;
    my $display = $self->{'display'};
    ### $display
    X11::Protocol->new (defined $display ? ($display) : ());
  });
}

sub choose {
  my ($self, %options) = @_;
  unless (ref $self) {
    $self = $self->new;  # X11::Protocol::ChooseWindow->choose()
  }
  local @{$self}{keys %options} = values %options;  # hash slice
  local $_instance = $self;

  my $X = _X($self);
  {
    my $old_event_handler = $X->{'event_handler'};
    local $X->{'event_handler'} = sub {
      $self->handle_event (@_);
      goto $old_event_handler;
    };

    $self->start;
    do {
      $X->handle_input;
    } until ($self->is_done);
  }

  return $self->chosen_window;
}

sub chosen_window {
  my ($self) = @_;
  if ($self->{'want_client'}) {
    return $self->client_window;
  } else {
    return $self->{'frame_window'};
  }
}
sub client_window {
  my ($self) = @_;
  if (! exists $self->{'client_window'}) {
    my $frame_window = $self->{'frame_window'};
    ### frame_window: $frame_window.sprintf('  0x%X',$frame_window)
    $self->{'client_window'}
      = (defined $frame_window && _num_none($frame_window) != 0
         ? X11::Protocol::WM::frame_window_to_client(_X($self),$frame_window)
         : undef);
    ### client_window: $self->{'client_window'}
  }
  return $self->{'client_window'};
}

# undocumented yet ...
sub start {
  my ($self) = @_;

  $self->abort;
  $self->{'frame_window'} = undef;
  delete $self->{'client_window'};
  $self->{'button_released'} = 0;
  my $X = _X($self);

  my $want_free_cursor;
  my $cursor = $self->{'cursor'};
  if (! defined $cursor) {
    my $cursor_glyph = $self->{'cursor_glyph'};
    if (! defined $cursor_glyph) {
      require X11::CursorFont;
      my $cursor_name = $self->{'cursor_name'};
      if (! defined $cursor_name) {
        $cursor_name = 'crosshair';  # default
      }
      $cursor_glyph = $X11::CursorFont::CURSOR_GLYPH{$cursor_name};
      if (! defined $cursor_glyph) {
        croak "Unrecognised cursor_name: ",$cursor_name;
      }
    }

    my $cursor_font = $X->new_rsrc;
    $X->OpenFont ($cursor_font, 'cursor');

    $cursor = $X->new_rsrc;
    $X->CreateGlyphCursor ($cursor,
                           $cursor_font,  # font
                           $cursor_font,  # mask font
                           $cursor_glyph,    # glyph number
                           $cursor_glyph+1,  # and its mask
                           0,0,0,                    # foreground, black
                           0xFFFF, 0xFFFF, 0xFFFF);  # background, white
    $want_free_cursor = 1;
    $X->CloseFont ($cursor_font);
  }
  ### cursor: sprintf '%d %#X', $cursor, $cursor

  my $root = $self->{'root'};
  if (! defined $root) {
    if (defined (my $screen_number = $self->{'screen'})) {
      $root = $X->{'screens'}->[$screen_number]->{'root'};
    } else {
      $root = $X->{'root'};
    }
  }
  ### $root

  # follow any __SWM_VROOT
  $root = (X11::Protocol::WM::root_to_virtual_root($X,$root) || $root);

  my $time = $self->{'time'} || $self->{'event'}->{'time'} || 'CurrentTime';
  ### $time

  my $status = $X->GrabPointer
    ($root,          # window
     0,              # owner events
     $X->pack_event_mask('ButtonPress','ButtonRelease'),
     'Synchronous',  # pointer mode
     'Asynchronous', # keyboard mode
     $root,          # confine window
     $cursor,        # crosshair cursor
     $time);
  if ($status eq 'Success') {
    $self->{'ungrab_time'} = $time;
  }
  if ($want_free_cursor) {
    $X->FreeCursor ($cursor);
  }
  if ($status ne 'Success') {
    croak "Cannot grab mouse pointer to choose a window: ",$status;
  }
  $X->AllowEvents ('SyncPointer', 'CurrentTime');
}

# undocumented yet ...
sub handle_event {
  my ($self, %h) = @_;
  ### ChooseWindow handle_event: %h
  return if $self->is_done;

  my $name = $h{'name'};
  my $X = _X($self);

  if ($name eq 'ButtonPress') {
    ### ButtonPress
    $self->{'frame_window'} = $h{'child'};
    $self->{'choose_time'} = $h{'time'};
    $X->AllowEvents ('SyncPointer', 'CurrentTime');

  } elsif ($name eq 'ButtonRelease') {
    ### ButtonRelease
    # wait for button pressed to choose window, and then released so the
    # release event doesn't go to the chosen window
    if ($self->{'frame_window'}) {
      # button press seen, and now release seen
      $self->{'button_released'} = 1;
      $self->{'ungrab_time'} = $h{'time'};
      $self->abort;  # ungrab
    } else {
      $X->AllowEvents ('SyncPointer', 'CurrentTime');
    }
  }
}

# undocumented yet ...
sub is_done {
  my ($self) = @_;
  return (! defined $self->{'ungrab_time'} # aborted or never started
          || ($self->{'frame_window'} && $self->{'button_released'}));
}

sub DESTROY {
  my ($self) = @_;
  my ($X, $ungrab_time);
  if (defined ($X = $self->{'X'})
      && defined ($ungrab_time = delete $self->{'ungrab_time'})) {
    # no errors if connection gone
    eval { $X->UngrabPointer ($ungrab_time) };
  }
}

# undocumented yet ...
sub abort {
  my ($self, $time) = @_;
  if (! ref $self) {
    # class method X11::Protocol::ChooseWindow->abort()
    $self = $_instance || return;  # if not in a ->choose()
  }
  my ($X, $ungrab_time);
  if (defined ($X = $self->{'X'})
      && defined ($ungrab_time = delete $self->{'ungrab_time'})) {
    $X->UngrabPointer ($time || $ungrab_time);
  }
}

sub _num_none {
  my ($xid) = @_;
  if (defined $xid && $xid eq "None") {
    return 0;
  } else {
    return $xid;
  }
}

1;
__END__