package IPC::GimpFu;
use 5.006;
use strict;
use Carp;
use Cwd;
=head1 NAME
IPC::GimpFu - interface to Gimp's script-fu server
=head1 VERSION
Version 0.02
=cut
our $VERSION = '0.02';
=head1 SYNOPSIS
This module makes it possible to communicate with Gimp's script-fu
server, and also to start/stop it on the local machine.
use IPC::GimpFu;
# Fine control on a local instance:
my $gimp = IPC::GimpFu->new();
$gimp->local_start();
$gimp->run("some command");
$gimp->local_stop();
# Start locally if needed, keep running once we're done:
my $gimp = IPC::GimpFu->new({ autostart => 1 });
$gimp->run({ file => "gimp-source.scm" });
$gimp->run("some command");
# Use a remote server:
my $gimp = IPC::GimpFu->new({ server => "other-server", port => "other-port" });
$gimp->run("something else");
=cut
=head1 SUBROUTINES/METHODS
=head2 new
Create a new object, using an anonymous hash. The following can be set
this way: autostart, server, and port; autostart is only valid if
server is localhost; default settings are:
* autostart => 0
* server => 'localhost'
* port => '10008'
=cut
sub new {
my $class = shift;
my $params = shift;
# Default params:
my $self = {
autostart => 0,
server => 'localhost',
port => '10008',
};
# Override if needed:
foreach my $key (keys %$self) {
$self->{$key} = $params->{$key}
if $params->{$key};
}
# Can only autostart on localhost:
if (not _is_localhost($self->{server}) and $self->{autostart}) {
carp "autostart and non-localhost server (" . $self->{server} . ") are incompatible";
return undef;
}
bless($self, $class);
return $self;
}
=head2 start
Start the server...
=cut
sub start {
my $self = shift;
# Make sure it makes sense to try starting the server:
if (not _is_localhost($self->{server})) {
carp "attempting to start on a non-localhost server (" . $self->{server} . ")";
return 0;
}
# FIXME: Implement checking whether there's already somebody on this port?
# FIXME: Implement some checks on port's validity?
my $port = $self->{port};
# Original command-line:
# gimp --verbose -i -b '(plug-in-script-fu-server RUN-NONINTERACTIVE 10008 "some file")'
my $cmd = "gimp --verbose -i -b '(plug-in-script-fu-server RUN-NONINTERACTIVE $port \"/dev/null\")'";
my $daemon = Proc::Daemon->new(
work_dir => getcwd,
exec_command => $cmd,
);
if (not $daemon) {
carp "Proc::Daemon->new failed: $!";
return 0;
}
my $pid = $daemon->Init()
or carp "Proc::Daemon->Init failed: $!";
return $pid;
}
=head2 stop
Stop the server...
=cut
sub stop {
my $self = shift;
# Make sure it makes sense to try starting the server:
if (not _is_localhost($self->{server})) {
carp "attempting to stop on a non-localhost server (" . $self->{server} . ")";
return 0;
}
# Forget about the connection previously opened:
$self->{sock} = undef;
# Hopefully there shouldn't be anyone left after that:
my $gimp = killall('KILL', 'gimp');
my $scriptfu = killall('KILL', 'script-fu');
return $gimp+$scriptfu;
}
=head2 run
Run a given command on the specified server, connecting on the fly if
needed. Can be passed a command, or a hash with a file key:
$gimp->run("some command");
$gimp->run({ file => 'foo.scm' });
=cut
sub run {
my $self = shift;
my $params = shift;
if (ref($params) eq 'HASH' && $params->{file}) {
my $file = $params->{file};
#print STDERR "file: $file\n";
if (! -f $file) {
carp "unable to find $file";
return 0;
}
## Slurp and strip comments/newlines:
open my $source_fh, '<', $file
or die "Unable to open source file $file";
my $source_code;
while (<$source_fh>) {
# Kill comments:
s{^\s*;.*}{};
$source_code .= ' ' . $_;
}
# Kill newlines, and minimize spaces:
$source_code =~ s/\n/ /msg;
$source_code =~ s/\s+/ /msg;
close $source_fh
or die "Unable to close source file $file";
# Finally run:
return $self->_run_cmd($source_code);
}
elsif (not ref($params)) {
my $source = $params;
if (not $source) {
carp "no command was passed, returning";
return 0;
}
#print STDERR "source: $source\n";
return $self->_run_cmd($source);
}
else {
carp "run(): unexpected parameter, check documentation";
return 0;
}
}
=head2 _run_cmd
Helper called from run(), dealing with a command passed as a string.
=cut
sub _run_cmd {
my $self = shift;
my $cmd = shift;
# Only open a socket if there's none open already:
if (! $self->{sock}) {
# FIXME: 10 and '1 second' shouldn't be hardcoded below:
my $max_attempts = $self->{autostart} ? 10 : 1;
my $sleep = 1;
my $sock;
my $ready = 0;
for my $attempt (0..$max_attempts-1) {
# Regular connection attempt first:
#print STDERR "trying connection to: " . $self->{server} . ':' . $self->{port} . "\n";
if ($sock = IO::Socket::IP->new(
PeerHost => $self->{server},
PeerPort => $self->{port},
Type => SOCK_STREAM,
)) {
#print STDERR "connection ok on attempt #$attempt\n";
$self->{sock} = $sock;
last;
}
else {
if ($self->{autostart} && $attempt == 0) {
#print STDERR "attempting start\n";
$self->start();
}
# Wait in all non-last-attempt cases:
#print STDERR "maybe sleeping\n";
sleep $sleep
if $attempt < $max_attempts-1;
}
}
}
# By now there's hopefully a socket open:
if ($self->{sock}) {
return _gimp_send_command($self->{sock}, $cmd);
}
else {
die sprintf "Failed to connect to %s:%d\n", $self->{server}, $self->{port};
}
}
sub _gimp_ensure_proper_connection {
my ($sock) = @_;
# Connection-level:
$sock->connected
or die "No proper connection on the socket";
# This should be quick and free from side-effects
# Other ideas include:
# - gimp-image-list
# - gimp-getpid
_gimp_send_command($sock, '(gimp-version)');
}
sub _gimp_send_command {
my ($sock, $command) = @_;
# print "Sending command: $command\n";
# Upstream doc about the format:
#
# Query of length L:
# 0 0x47 Magic byte ('G')
# 1 L div 256 High byte of L
# 2 L mod 256 Low byte of L
#
# Response of length L:
# 0 0x47 Magic byte ('G')
# 1 error code 0 on success, 1 on error
# 2 L div 256 High byte of L
# 3 L mod 256 Low byte of L
#
# Beware of the response!
# Prepare query and send:
# FIXME: Should error out if $command is too long
my $magic1 = 'G';
my $len1 = length($command) & 0xffff;
my $high1 = ($len1 & 0xff00) >> 8;
my $low1 = ($len1 & 0x00ff);
my $header = pack('A1C1C1', $magic1, $high1, $low1);
$sock->send($header);
$sock->send($command);
# Read 4 bytes to get error code and response's length, then the response itself:
# FIXME: Check the second magic is right?
$sock->read($header, 4);
my ($magic2, $error, $high2, $low2) = unpack('A1C1C1C1', $header);
my $len2 = $high2 << 8 | $low2;
$sock->read(my $response, $len2);
return $response;
}
=head2 _is_localhost($server)
Tiny helper helping decide whether the specified server is localhost.
=cut
sub _is_localhost {
my $server = shift;
return scalar(grep { $_ eq $server } qw(localhost 127.0.0.1));
}
=head1 AUTHOR
Cyril Brulebois, C<< <kibi at debian.org> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-app-gimpfu at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-GimpFu>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc IPC::GimpFu
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker (report bugs here)
=item * AnnoCPAN: Annotated CPAN documentation
=item * CPAN Ratings
=item * Search CPAN
=back
=head1 LICENSE AND COPYRIGHT
Copyright 2012-2013 Cyril Brulebois.
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.
See http://dev.perl.org/licenses/ for more information.
=cut
1; # End of IPC::GimpFu