File Coverage

blib/lib/X11/WM/Sawfish/XProp.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package X11::WM::Sawfish::XProp;

# Copyright (C) 2003 Craig B. Agricola.  All rights reserved.  This library is
# free software; you can redistribute it and/or modify it under the same terms
# as Perl itself.

use 5.005;
use strict;
use warnings;

require Exporter;

use X11::WM::Sawfish;
our @ISA = qw(X11::WM::Sawfish);
our @EXPORT_OK = qw();
our @EXPORT = qw();
our $VERSION = '0.01';

use X11::Protocol;

use constant XA_CARDINAL =>  6;
use constant XA_STRING   => 31;

use constant PROTOCOL_X11_VERSION => 1;

sub new {
  my ($package, $display) = @_;
  $package = ref($package) || $package;
  my ($self) = {};
  bless($self, $package);
  $self->{Display} = X11::WM::Sawfish::canonical_display_name($display);
  $self->get_server_version();
  if (!defined($self->{Display})) {
    $!=111; # Connection refused
    return(undef);
  }
  return($self);
}

sub open_xserver {
  my ($self) = @_;
  if (!defined($self->{X11})) {
    my ($x) = $self->{X11} = new X11::Protocol($self->{Display});
    if (defined($x)) {
      my ($value, $type, $format, $bytes_after) =
          $x->GetProperty($x->root, $x->atom("_SAWFISH_REQUEST_WIN"),
                          XA_CARDINAL, 0, 1, 0);
      if (($type == XA_CARDINAL) && ($format == 32)) {
        $self->{ServerRequestWindow} = unpack("I", $value);
        $x->{event_handler} = "queue";
        my $event_mask = $x->pack_event_mask("PropertyChange");
        my $crwin = $x->new_rsrc();
        $x->CreateWindow($crwin, $x->root, 0, 0, 0, -100, -100, 10, 10, 0,
                         "event_mask" => $event_mask);
        $self->{ClientRequestWindow} = $crwin;
        $self->{RequestProperty}     = $x->atom("_SAWFISH_REQUEST");
      } else { $self->{X11} = undef; }
    }
  }
  return($self->{X11});
}

sub close_xserver {
  my ($self) = @_;
  my $x = $self->{X11};
  $x->DestroyWindow($x->{ClientRequestWindow});
  undef($self->{X11});
}

sub eval_form {
  my ($self, $form) = @_;
  my ($resp, $state);
  my $x = $self->open_xserver();
  $resp = undef;
  if (defined($x)) {
    $x->ChangeProperty($self->{ClientRequestWindow},
                       $self->{RequestProperty},
                       XA_STRING, 8, 'Replace', $form);

    # Gobble up the PropertyChangeEvent that we will get
    $x->next_event();

    my $event = $x->pack_event('name'   => 'ClientMessage',
                               'window' => $x->root,
                               'type'   => $self->{RequestProperty},
                               'format' => 32,
                               'data'   => pack("LLLLL",
                                                  PROTOCOL_X11_VERSION,
                                                  $self->{ClientRequestWindow},
                                                  $self->{RequestProperty},
                                                  1, 0));
    $x->SendEvent($self->{ServerRequestWindow}, 0, 0, $event);

    # Wait for Sawfish to update our request property with the results
    $x->next_event();

    my ($value, $type, $format, $bytes_after);
    my $len = 1024;
    do {
      ($value, $type, $format, $bytes_after) =
        $x->GetProperty($self->{ClientRequestWindow},
                        $self->{RequestProperty},
                        XA_STRING, 0, $bytes_after, 0);
      $len += $bytes_after;
    } while ($bytes_after > 0);
    ($state, $resp) = unpack("Ca*", $value);
    if ($state != 1) { $resp = undef; }
  }
  return($resp);
}

1;
__END__