Sawfish.pm

package Sawfish;
# (C) 2001 Paris Sinclair <pariss@efn.org>
require 5.006;
use strict;
use warnings;
use IPC::Open3;

our $VERSION = v0.0.1;
our $DEBUG   = 99;
our $AUTOLOAD;
our $SAWFISH_CLIENT = '/usr/bin/sawfish-client';
our @MODULE = qw/ maximize /;

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;
    my $self = {};
    bless( $self, $class );

    $self->connect or die "failed connecting to sawfish-client '$SAWFISH_CLIENT'";
    $self->getline; # toss out banner (ahh, the joys of programming by co-inky-dink...)

    return $self;
}

sub AUTOLOAD {
    my $self = shift;
    ref $self or return undef;
    dp( "Autoloaded $AUTOLOAD \@_=@_" );
    my $lispfunc = $AUTOLOAD;
    $lispfunc =~ s/.*://;
    $lispfunc =~ s/_/-/g;
    if ( wantarray ) {
	return( $self->generic_window_command( $lispfunc, @_ ) );
    }
    return scalar $self->generic_window_command( $lispfunc, @_ );
}

sub generic_window_command {
  my $self = shift;
  my $command = shift;
  my $id = shift;
  $id = sprintf( "%#x", 0+$id) if defined $id; # convert to decorated hex
  my $lisp = "$command";
  $lisp .= " (get-window-by-id $id)" if defined $id;
  $lisp .= " @_" if @_;
  my $res = $self->eval( "($lisp)" );
  return undef if $res =~ /^\007\*{3}/;
  if ( wantarray ) {
      $res =~ s/^\((.*)\)$/$1/;
      my (@res) = split( ' . ', $res );
      return @res;
  }
  return $res;
}

sub fullscreen {
    my $self = shift;
    my $win = shift;
    $self->make_window_ignored( $win );
    $self->move_resize_window_to( $win, 0, 0, $self->screen_width, $self->screen_height );
}

sub managed_windows {
    my $self = shift;
    my $raw = $self->eval( '(managed-windows)' );
    my ( @windows ) = map { hex } ($raw =~ /\#<window\s(\w+?)>/g);
    return @windows;
}

sub eval {
    my $self = shift;
    my @responses = ();
    foreach my $lisp ( @_ ) {
	dp( "sending '$lisp'" );
	$self->send( $lisp );
	my $res = $self->getline;
	push @responses, $res;
	dp( "got reply '$res'" );
    }
    return @responses if wantarray;
    return pop(@responses);
}

sub send {
    my $self = shift;
    my $lisp = join( '', @_ );
    $lisp =~ s/[\n\r]/ /g;
    my $fh = $self->{wfh};
    print $fh $lisp,"\n";
}

sub getline {
    my $self = shift;
    my $fh = $self->{rfh};
    <$fh>; # toss echoed input (can this fail? what if input contains a newline?
    local $/ = "\nuser> ";
#    local $/ = "user> ";
    chomp( my $res = <$fh> );
    $res =~ tr/\r//d;
    return $res;
}

sub connect {
    my $self = shift;
    my @args = ('-'); # meow
    foreach my $module ( @MODULE ) {
	unshift( @args, '-r', $module);
    }
    dp( "@args" );
    $self->{pid} = open3( $self->{wfh}, $self->{rfh}, $self->{efh}, $SAWFISH_CLIENT, @args );
    return $self->{pid};
}

sub disconnect {
    my $self = shift;
    kill 9, $self->{pid};
    waitpid( $self->{pid}, 0 ) if exists $self->{pid};
}

sub reconnect {
    my $self = shift;
    $self->disconnect;
    $self->connect;
}

sub DESTROY {
    my $self = shift;
    $self->disconnect;
}

###
sub dp {
    return undef unless $DEBUG;
    my $mess = join( '', @_ );
    #$mess =~ s/\n/\\n/g;
    $mess =~ s/\r/\\r/g;
    print "DEBUG: >>> $mess <<<\n";
}


1;
__END__

=head1 NAME

Sawfish - Perl interface to sawfish-client

=head1 SYNOPSIS

  use Sawfish;
  blah blah blah

=head1 DESCRIPTION

Stub documentation for Sawfish.

Oops, did I really forget to do this?!

=head2 EXPORT

None.

=head1 AUTHOR

Paris Sinclair E<lt>pariss@efn.orgE<gt>

=head1 SEE ALSO

L<perl>.

=cut

test.pl

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

#########################

# change 'tests => 1' to 'tests => last_test_to_print';

use Test;
BEGIN { plan tests => 1 };
use Sawfish;
ok(1); # If we made it this far, we're ok.

#########################

# Insert your test code below, the Test module is use()ed here so read
# its man page ( perldoc Test ) for help writing this test script.