r36413 - in /branches/upstream/libgtk2-unique-perl: ./ current/ current/examples/ current/lib/ current/lib/Gtk2/ current/t/ current/xs/
ryan52-guest at users.alioth.debian.org
ryan52-guest at users.alioth.debian.org
Tue May 26 04:38:30 UTC 2009
Author: ryan52-guest
Date: Tue May 26 04:38:22 2009
New Revision: 36413
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=36413
Log:
[svn-inject] Installing original source of libgtk2-unique-perl
Added:
branches/upstream/libgtk2-unique-perl/
branches/upstream/libgtk2-unique-perl/current/
branches/upstream/libgtk2-unique-perl/current/Changes
branches/upstream/libgtk2-unique-perl/current/MANIFEST
branches/upstream/libgtk2-unique-perl/current/MANIFEST.SKIP
branches/upstream/libgtk2-unique-perl/current/META.yml
branches/upstream/libgtk2-unique-perl/current/Makefile.PL
branches/upstream/libgtk2-unique-perl/current/README
branches/upstream/libgtk2-unique-perl/current/examples/
branches/upstream/libgtk2-unique-perl/current/examples/sample.pl
branches/upstream/libgtk2-unique-perl/current/lib/
branches/upstream/libgtk2-unique-perl/current/lib/Gtk2/
branches/upstream/libgtk2-unique-perl/current/lib/Gtk2/Unique.pm
branches/upstream/libgtk2-unique-perl/current/maps
branches/upstream/libgtk2-unique-perl/current/t/
branches/upstream/libgtk2-unique-perl/current/t/Unique.t
branches/upstream/libgtk2-unique-perl/current/t/UniqueApp.t
branches/upstream/libgtk2-unique-perl/current/t/UniqueBackend.t
branches/upstream/libgtk2-unique-perl/current/t/unit-tests.pl
branches/upstream/libgtk2-unique-perl/current/unique-perl.h
branches/upstream/libgtk2-unique-perl/current/xs/
branches/upstream/libgtk2-unique-perl/current/xs/Unique.xs
branches/upstream/libgtk2-unique-perl/current/xs/UniqueApp.xs
branches/upstream/libgtk2-unique-perl/current/xs/UniqueBackend.xs
branches/upstream/libgtk2-unique-perl/current/xs/UniqueMessageData.xs
Added: branches/upstream/libgtk2-unique-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/Changes?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/Changes (added)
+++ branches/upstream/libgtk2-unique-perl/current/Changes Tue May 26 04:38:22 2009
@@ -1,0 +1,6 @@
+Revision history for Gtk2::Unique
+
+
+0.01 Thu Apr 2 15:44:36 CEST 2009
+ First version, released on an unsuspecting world.
+
Added: branches/upstream/libgtk2-unique-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/MANIFEST?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/MANIFEST (added)
+++ branches/upstream/libgtk2-unique-perl/current/MANIFEST Tue May 26 04:38:22 2009
@@ -1,0 +1,18 @@
+Changes
+MANIFEST
+MANIFEST.SKIP
+Makefile.PL
+README
+lib/Gtk2/Unique.pm
+maps
+unique-perl.h
+xs/UniqueApp.xs
+xs/UniqueBackend.xs
+xs/UniqueMessageData.xs
+xs/Unique.xs
+t/Unique.t
+t/UniqueApp.t
+t/UniqueBackend.t
+t/unit-tests.pl
+examples/sample.pl
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libgtk2-unique-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/MANIFEST.SKIP?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/MANIFEST.SKIP (added)
+++ branches/upstream/libgtk2-unique-perl/current/MANIFEST.SKIP Tue May 26 04:38:22 2009
@@ -1,0 +1,9 @@
+^build/
+^Makefile$
+^Makefile[.]old$
+^xs/.*[.][co]$
+^blib/
+^pm_to_blib$
+^[.]git
+^Unique[.]bs$
+^Gtk2-Unique-.+\.tar\.gz$
Added: branches/upstream/libgtk2-unique-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/META.yml?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/META.yml (added)
+++ branches/upstream/libgtk2-unique-perl/current/META.yml Tue May 26 04:38:22 2009
@@ -1,0 +1,14 @@
+--- #YAML:1.0
+name: Gtk2-Unique
+version: 0.01
+abstract: Use single instance applications
+license: perl, lgpl
+author:
+ - Emmanuel Rodriguez <potyl at cpan.org>
+generated_by: ExtUtils::MakeMaker version 6.42
+distribution_type: module
+requires:
+ Gtk2: 1.161
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
Added: branches/upstream/libgtk2-unique-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/Makefile.PL?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/Makefile.PL (added)
+++ branches/upstream/libgtk2-unique-perl/current/Makefile.PL Tue May 26 04:38:22 2009
@@ -1,0 +1,112 @@
+use strict;
+use warnings;
+
+use ExtUtils::MakeMaker;
+
+use Cwd;
+use File::Spec;
+
+use Gtk2::CodeGen;
+use Glib::MakeHelper;
+use ExtUtils::Depends;
+use ExtUtils::PkgConfig;
+
+my $DEPENDS;
+my @XS_FILES = ();
+
+exit main();
+
+sub main {
+
+ # Create the build folder used by the code generation utilities
+ mkdir 'build', 0777;
+
+ # Find libunique
+ my @typemaps = ();
+ my @deps = ('Glib');
+ my %pkgconfig;
+
+ eval {
+ %pkgconfig = ExtUtils::PkgConfig->find("unique-1.0");
+ push @XS_FILES, <xs/*.xs>;
+ push @typemaps, 'maps';
+ push @deps, 'Gtk2';
+ };
+ if (my $error = $@) {
+ warn "FAIL: ", $error;
+ return;
+ }
+
+ $DEPENDS = ExtUtils::Depends->new('Gtk2::Unique', @deps);
+
+ $DEPENDS->add_pm(
+ File::Spec->catfile('lib', 'Gtk2', 'Unique.pm'),
+ File::Spec->catfile('$(INST_LIBDIR)', 'Unique.pm'),
+ );
+
+ # Code generation
+ Gtk2::CodeGen->parse_maps('unique', input => [ @typemaps ]);
+ Gtk2::CodeGen->write_boot(
+ ignore => qr/^Gtk2::Unique$/,
+ xs_files => [ @XS_FILES ],
+ );
+
+
+ $DEPENDS->set_inc($pkgconfig{cflags} . ' -I./build');
+ $DEPENDS->set_libs($pkgconfig{libs});
+ $DEPENDS->add_xs(@XS_FILES);
+ $DEPENDS->add_typemaps(
+ File::Spec->catfile(cwd(), 'build', 'unique.typemap'),
+ );
+ $DEPENDS->install(
+ File::Spec->catfile('build', 'unique-autogen.h'),
+ 'unique-perl.h',
+ );
+ $DEPENDS->save_config(File::Spec->catfile('build', 'IFiles.pm'));
+
+
+ # Create the Makefile
+ WriteMakefile(
+ AUTHOR => 'Emmanuel Rodriguez <potyl at cpan.org>',
+ NAME => 'Gtk2::Unique',
+ VERSION_FROM => File::Spec->catfile('lib', 'Gtk2', 'Unique.pm'),
+ ABSTRACT_FROM => File::Spec->catfile('lib', 'Gtk2', 'Unique.pm'),
+ LICENSE => 'perl, lgpl',
+
+ PREREQ_PM => {
+ 'Gtk2' => '1.161', # Other verions might work too (Ubuntu 8.04 has this version)
+ },
+ PREREQ_FATAL => 1,
+
+ XSPROTOARG => '-noprototypes ',
+ MAN3PODS => {
+ Glib::MakeHelper->do_pod_files(@XS_FILES),
+ },
+
+ META_MERGE => {
+ repository => 'http://github.com/potyl/gtk2-unique/tree/master',
+ },
+
+ $DEPENDS->get_makefile_vars(),
+
+ # Remove the build folder when doing "make clean"
+ clean => {
+ FILES => 'build',
+ },
+ );
+
+ return 0;
+}
+
+
+sub MY::postamble {
+
+ my $postamble = Glib::MakeHelper->postamble_clean();
+ $postamble .= Glib::MakeHelper->postamble_docs_full(
+ DEPENDS => $DEPENDS,
+ XS_FILES => [ @XS_FILES ],
+ COPYRIGHT => 'Copyright (C) 2009 by Emmanuel Rodriguez'
+ );
+
+ return $postamble;
+}
Added: branches/upstream/libgtk2-unique-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/README?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/README (added)
+++ branches/upstream/libgtk2-unique-perl/current/README Tue May 26 04:38:22 2009
@@ -1,0 +1,47 @@
+Gtk2::Unique
+=========
+
+Perl bindings for the C library "libunique" that provides a mechanism for
+writing single instance applications. If you launch a single instance
+application twice, the second instance will either just quit or will send a
+message to the running instance.
+
+Unique makes it easy to write this kind of applications, by providing a base
+class, taking care of all the IPC machinery needed to send messages to a running
+instance, and also handling the startup notification side.
+
+For more information about libunique refer to the library's web site:
+
+ http://live.gnome.org/LibUnique
+
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the
+perldoc command.
+
+ perldoc Gtk2::Unique
+
+Also feel free to take a look at the examples in the folder "examples/" and to
+play around with them.
+
+For any kind of help or support simply report a bug or join us in the IRC
+channel #gtk2-perl on freenode.
+
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2009 Emmanuel Rodriguez
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
Added: branches/upstream/libgtk2-unique-perl/current/examples/sample.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/examples/sample.pl?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/examples/sample.pl (added)
+++ branches/upstream/libgtk2-unique-perl/current/examples/sample.pl Tue May 26 04:38:22 2009
@@ -1,0 +1,91 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Glib qw(TRUE FALSE);
+use Gtk2 '-init';
+use Gtk2::Unique;
+use Encode;
+use Data::Dumper;
+
+my $COMMAND_WRITE = 1;
+
+
+exit main();
+
+
+sub main {
+ die "Usage: message\n" unless @ARGV;
+ my ($text) = @ARGV;
+ # If we want to pass UTF-8 text in the command line arguments
+ $text = decode('UTF-8', $text);
+
+ # As soon as we create the UniqueApp instance we either have the name we
+ # requested ("org.mydomain.MyApplication", in the example) or we don't because
+ # there already is an application using the same name.
+ my $app = Gtk2::UniqueApp->new(
+ "org.example.Sample", undef,
+ write => $COMMAND_WRITE,
+ );
+
+
+ # If there already is an instance running, this will return TRUE; there's no
+ # race condition because the check is already performed at construction time.
+ if ($app->is_running) {
+ my $data = [$text, '/etc/passwd'];
+ my $response = $app->send_message($COMMAND_WRITE, data => '/etc/passwd');
+ return 0;
+ }
+
+
+ # Create the single application instance and wait for other requests
+ my $window = create_application($app, $text);
+ Gtk2->main();
+
+ return 0;
+}
+
+
+#
+# Called when the application needs to be created. This happens when there's no
+# other instance running.
+#
+sub create_application {
+ my ($app, $text) = @_;
+
+ # Standard window and windgets
+ my $window = Gtk2::Window->new();
+ $window->set_title("Unique - Example");
+ $window->set_size_request(480, 240);
+ my $textview = Gtk2::TextView->new();
+ my $scroll = Gtk2::ScrolledWindow->new();
+ my $buffer = $textview->get_buffer;
+
+ $buffer->insert($buffer->get_end_iter, "$text\n");
+
+ # Widget packing
+ $scroll->add($textview);
+ $window->add($scroll);
+ $window->show_all();
+
+ # Widget signals
+ $window->signal_connect(delete_event => sub {
+ Gtk2->main_quit();
+ return TRUE;
+ });
+
+ # Listen for new commands
+ $app->watch_window($window);
+ $app->signal_connect('message-received' => sub {
+ my ($app, $command, $message, $time) = @_;
+
+ my $text = Dumper($message->get);
+ $buffer->insert($buffer->get_end_iter, "$text\n");
+
+ # Must return a "Gtk2::UniqueResponse"
+ return 'ok';
+ });
+
+ return $window;
+}
Added: branches/upstream/libgtk2-unique-perl/current/lib/Gtk2/Unique.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/lib/Gtk2/Unique.pm?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/lib/Gtk2/Unique.pm (added)
+++ branches/upstream/libgtk2-unique-perl/current/lib/Gtk2/Unique.pm Tue May 26 04:38:22 2009
@@ -1,0 +1,101 @@
+package Gtk2::Unique;
+
+=head1 NAME
+
+Gtk2::Unique - Use single instance applications
+
+=head1 SYNOPSIS
+
+ use Gtk2 '-init';
+ use Gtk2::Unique;
+
+ my $COMMAND_FOO = 1;
+ my $COMMAND_BAR = 2;
+
+ my $app = Gtk2::UniqueApp->new(
+ "org.example.UnitTets", undef,
+ foo => $COMMAND_FOO,
+ bar => $COMMAND_BAR,
+ );
+
+
+ if ($app->is_running) {
+ # The application is already running, send it a message
+ my ($text) = @ARGV ? @ARGV : ("Foo text here");
+ $app->send_message($COMMAND_FOO, text => $text);
+ }
+ else {
+ # Create the single application instance and wait for other requests
+ my $window = create_application_window($app);
+ Gtk2->main();
+ }
+
+
+ sub create_application_window {
+ my ($app) = @_;
+
+ my $window = Gtk2::Window->new();
+ my $label = Gtk2::Label->new("Waiting for a message");
+ $window->add($label);
+ $window->set_size_request(480, 120);
+ $window->show_all();
+
+ $window->signal_connect(delete_event => sub {
+ Gtk2->main_quit();
+ return TRUE;
+ });
+
+ # Watch the main window and register a handler that will be called each time
+ # that there's a new message.
+ $app->watch_window($window);
+ $app->signal_connect('message-received' => sub {
+ my ($app, $command, $message, $time) = @_;
+ $label->set_text($message->get_text);
+ return 'ok';
+ });
+ }
+
+=head1 DESCRIPTION
+
+Gtk2::Unique is a Perl binding for the C library libunique which provides a
+way for writing single instance application. If you launch a single instance
+application twice, the second instance will either just quit or will send a
+message to the running instance.
+
+For more information about libunique see:
+L<http://live.gnome.org/LibUnique>.
+
+=head1 BUGS & API
+
+This is the first release of the module, some bugs can be expected to be found.
+Furthermore, the Perl API is not yet frozen, if you would like to suggest some
+changes please do so as fast as possible.
+
+=head1 AUTHORS
+
+Emmanuel Rodriguez E<lt>potyl at cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2009 by Emmanuel Rodriguez.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.8 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
+
+use warnings;
+use strict;
+use base 'DynaLoader';
+
+use Gtk2;
+
+our $VERSION = '0.01';
+
+sub dl_load_flags { $^O eq 'darwin' ? 0x00 : 0x01 }
+
+__PACKAGE__->bootstrap($VERSION);
+
+1;
+
Added: branches/upstream/libgtk2-unique-perl/current/maps
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/maps?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/maps (added)
+++ branches/upstream/libgtk2-unique-perl/current/maps Tue May 26 04:38:22 2009
@@ -1,0 +1,5 @@
+UNIQUE_TYPE_APP UniqueApp GObject Gtk2::UniqueApp
+UNIQUE_TYPE_BACKEND UniqueBackend GObject Gtk2::UniqueBackend
+UNIQUE_TYPE_COMMAND UniqueCommand GEnum Gtk2::UniqueCommand
+UNIQUE_TYPE_RESPONSE UniqueResponse GEnum Gtk2::UniqueResponse
+UNIQUE_TYPE_MESSAGE_DATA UniqueMessageData GBoxed Gtk2::UniqueMessageData
Added: branches/upstream/libgtk2-unique-perl/current/t/Unique.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/t/Unique.t?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/t/Unique.t (added)
+++ branches/upstream/libgtk2-unique-perl/current/t/Unique.t Tue May 26 04:38:22 2009
@@ -1,0 +1,15 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Gtk2::TestHelper tests => 1;
+
+use Gtk2::Unique;
+
+exit tests();
+
+sub tests {
+ ok($Gtk2::Unique::VERSION, "Library loaded");
+ return 0;
+}
Added: branches/upstream/libgtk2-unique-perl/current/t/UniqueApp.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/t/UniqueApp.t?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/t/UniqueApp.t (added)
+++ branches/upstream/libgtk2-unique-perl/current/t/UniqueApp.t Tue May 26 04:38:22 2009
@@ -1,0 +1,104 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Gtk2::TestHelper tests => 10;
+
+use Gtk2::Unique;
+
+my $COMMAND_FOO = 1;
+my $COMMAND_BAR = 2;
+my $APP_NAME = 'org.example.UnitTets';
+
+exit tests();
+
+
+sub tests {
+ tests_new();
+ tests_new_with_commands();
+ return 0;
+}
+
+
+sub tests_new {
+ my $app = Gtk2::UniqueApp->new($APP_NAME, undef);
+ isa_ok($app, 'Gtk2::UniqueApp');
+
+ $app->add_command(foo => $COMMAND_FOO);
+ $app->add_command(bar => $COMMAND_BAR);
+
+ generic_test($app);
+}
+
+
+sub tests_new_with_commands {
+
+ my @commands = (
+ foo => $COMMAND_FOO,
+ bar => $COMMAND_BAR,
+ );
+
+ my $app = Gtk2::UniqueApp->new_with_commands($APP_NAME, undef, @commands);
+ isa_ok($app, 'Gtk2::UniqueApp');
+
+ generic_test($app);
+
+ my $pass;
+
+ # Check that the constructor enforces ints for the command ID
+ $app = undef;
+ $pass = 1;
+ eval {
+ $app = Gtk2::UniqueApp->new_with_commands($APP_NAME, undef, foo => 'not-an-int');
+ $pass = 0;
+ };
+ if (my $error = $@) {
+ $pass = 1;
+ }
+ ok($pass, "new_with_command() checks for IDs as int");
+
+
+ # Check that the constructor enforces the argument count
+ $app = undef;
+ $pass = 1;
+ eval {
+ $app = Gtk2::UniqueApp->new_with_commands($APP_NAME, undef, foo => 1, 'bar');
+ $pass = 0;
+ };
+ if (my $error = $@) {
+ $pass = 1;
+ }
+ ok($pass, "new_with_command() checks for argument count");
+
+}
+
+
+sub generic_test {
+ my ($app) = @_;
+
+ if (! $app->is_running()) {
+ SKIP: {
+ skip "No app is running; execute perl -Mblib t/unit-tests.pl", 3;
+ }
+ return;
+ }
+ my $response;
+
+ $response = $app->send_message($COMMAND_FOO, text => "hello");
+ is($response, 'ok', "send_message(text)");
+
+ $response = $app->send_message($COMMAND_BAR, filename => __FILE__);
+ is($response, 'invalid', "send_message(filename)");
+
+ $response = $app->send_message($COMMAND_FOO, uris => [
+ 'http://live.gnome.org/LibUnique',
+ 'http://gtk2-perl.sourceforge.net/',
+ ]);
+ is($response, 'ok', "send_message(uris)");
+
+
+ my $window = Gtk2::Window->new();
+ $app->watch_window($window);
+}
+
Added: branches/upstream/libgtk2-unique-perl/current/t/UniqueBackend.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/t/UniqueBackend.t?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/t/UniqueBackend.t (added)
+++ branches/upstream/libgtk2-unique-perl/current/t/UniqueBackend.t Tue May 26 04:38:22 2009
@@ -1,0 +1,35 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Gtk2::TestHelper tests => 9;
+
+use Gtk2::Unique;
+
+exit tests();
+
+sub tests {
+ my $backend = Gtk2::UniqueBackend->create();
+ isa_ok($backend, 'Gtk2::UniqueBackend');
+
+ is($backend->get_name, undef, "get_name()");
+ $backend->set_name("perl-testing");
+ is($backend->get_name, "perl-testing", "set_name()");
+
+ is($backend->get_startup_id, undef, "get_startup_id()");
+ $backend->set_startup_id("staring");
+ is($backend->get_startup_id, "staring", "set_startup_id()");
+
+ isa_ok($backend->get_screen, 'Gtk2::Gdk::Screen', "get_screen()");
+ $backend->set_screen(Gtk2::Gdk::Screen->get_default);
+ is($backend->get_screen, Gtk2::Gdk::Screen->get_default, "set_screen()");
+
+ ok($backend->get_workspace >= 0, "get_workspace()");
+ ok($backend->request_name(), "request_name()");
+
+# my $response = $backend->send_message(1, undef, 0);
+# is ($response, '', "send_message()");
+
+ return 0;
+}
Added: branches/upstream/libgtk2-unique-perl/current/t/unit-tests.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/t/unit-tests.pl?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/t/unit-tests.pl (added)
+++ branches/upstream/libgtk2-unique-perl/current/t/unit-tests.pl Tue May 26 04:38:22 2009
@@ -1,0 +1,79 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Glib qw(TRUE FALSE);
+use Gtk2 '-init';
+use Gtk2::Unique;
+use Data::Dumper;
+
+my $COMMAND_FOO = 1;
+my $COMMAND_BAR = 2;
+
+
+exit main();
+
+
+sub main {
+
+ my $app = Gtk2::UniqueApp->new(
+ "org.example.UnitTets", undef,
+ foo => $COMMAND_FOO,
+ bar => $COMMAND_BAR,
+ );
+
+
+ if ($app->is_running) {
+ die "Application is already running";
+ }
+
+
+ # Create the single application instance and wait for other requests
+ my $window = create_application($app);
+ Gtk2->main();
+
+ return 0;
+}
+
+
+#
+# Called when the application needs to be created. This happens when there's no
+# other instance running.
+#
+sub create_application {
+ my ($app) = @_;
+
+ # Standard window and windgets
+ my $window = Gtk2::Window->new();
+ $window->set_title("Gtk2::Unique - Unit Tests");
+ $window->set_size_request(480, 240);
+ my $textview = Gtk2::TextView->new();
+ my $scroll = Gtk2::ScrolledWindow->new();
+ my $buffer = $textview->get_buffer;
+
+ # Widget packing
+ $scroll->add($textview);
+ $window->add($scroll);
+ $window->show_all();
+
+ # Widget signals
+ $window->signal_connect(delete_event => sub {
+ Gtk2->main_quit();
+ return TRUE;
+ });
+
+ # Listen for new commands
+ $app->watch_window($window);
+ $app->signal_connect('message-received' => sub {
+ my ($app, $command, $message, $time) = @_;
+
+ my $text = Dumper($message->get);
+ $buffer->insert($buffer->get_end_iter, "$command: $text\n");
+
+ # The command FOO will succeed while the command BAR will fail
+ return $command == $COMMAND_FOO ? 'ok' : 'invalid';
+ });
+
+ return $window;
+}
Added: branches/upstream/libgtk2-unique-perl/current/unique-perl.h
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/unique-perl.h?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/unique-perl.h (added)
+++ branches/upstream/libgtk2-unique-perl/current/unique-perl.h Tue May 26 04:38:22 2009
@@ -1,0 +1,9 @@
+#ifndef _UNIQUE_PERL_H_
+
+#include <gtk2perl.h>
+
+#include <unique/unique.h>
+
+#include "unique-autogen.h"
+
+#endif /* _UNIQUE_PERL_H_ */
Added: branches/upstream/libgtk2-unique-perl/current/xs/Unique.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/xs/Unique.xs?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/xs/Unique.xs (added)
+++ branches/upstream/libgtk2-unique-perl/current/xs/Unique.xs Tue May 26 04:38:22 2009
@@ -1,0 +1,11 @@
+#include "unique-perl.h"
+
+
+MODULE = Gtk2::Unique PACKAGE = Gtk2::Unique PREFIX = unique_
+
+PROTOTYPES: DISABLE
+
+
+BOOT:
+#include "register.xsh"
+#include "boot.xsh"
Added: branches/upstream/libgtk2-unique-perl/current/xs/UniqueApp.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/xs/UniqueApp.xs?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/xs/UniqueApp.xs (added)
+++ branches/upstream/libgtk2-unique-perl/current/xs/UniqueApp.xs Tue May 26 04:38:22 2009
@@ -1,0 +1,166 @@
+#include "unique-perl.h"
+
+
+MODULE = Gtk2::UniqueApp PACKAGE = Gtk2::UniqueApp PREFIX = unique_app_
+
+
+UniqueApp_noinc*
+unique_app_new (class, const gchar *name, const gchar_ornull *startup_id, ...)
+ ALIAS:
+ Gtk2::UniqueApp::new_with_commands = 1
+
+ PREINIT:
+ UniqueApp *app = NULL;
+
+ CODE:
+ PERL_UNUSED_VAR(ix);
+
+ if (items == 3) {
+ app = unique_app_new(name, startup_id);
+ }
+ else if (items > 3 && (items % 2 == 1)) {
+ /* Calling unique_app_new_with_command(), First create a new app with
+ unique_app_new() and the populate the commands one by one with
+ unique_app_add_command().
+ */
+ int i;
+ app = unique_app_new(name, startup_id);
+
+ for (i = 3; i < items; i += 2) {
+ SV *command_name_sv = ST(i);
+ SV *command_id_sv = ST(i + 1);
+ gchar *command_name = NULL;
+ gint command_id;
+
+ if (! looks_like_number(command_id_sv)) {
+ g_object_unref(G_OBJECT(app));
+ croak(
+ "Invalid command_id at position %d, expected a number but got '%s'",
+ i,
+ SvGChar(command_id_sv)
+ );
+ }
+ command_name = SvGChar(command_name_sv);
+ command_id = SvIV(command_id_sv);
+ unique_app_add_command(app, command_name, command_id);
+ }
+ }
+ else {
+ croak(
+ "Usage: Gtk2::UniqueApp->new(name, startup_id)"
+ "or Gtk2::UniqueApp->new_with_commands(name, startup_id, @commands)"
+ );
+ }
+
+ RETVAL = app;
+
+ OUTPUT:
+ RETVAL
+
+
+void
+unique_app_add_command (UniqueApp *app, const gchar *command_name, gint command_id)
+
+
+void
+unique_app_watch_window (UniqueApp *app, GtkWindow *window)
+
+
+gboolean
+unique_app_is_running (UniqueApp *app)
+
+
+# $app->send_message($ID) -> unique_app_send_message(app, command_id, NULL);
+# $app->send_message($ID, text => $text) -> set_text() unique_app_send_message(app, command_id, message);
+# $app->send_message($ID, data => $data) -> set() unique_app_send_message(app, command_id, message);
+# $app->send_message($ID, uris => @uri) -> set_uris() unique_app_send_message(app, command_id, message);
+#
+#
+UniqueResponse
+unique_app_send_message (UniqueApp *app, gint command_id, ...)
+ PREINIT:
+ UniqueMessageData *message = NULL;
+ SV **s = NULL;
+
+ CODE:
+ if (items == 4) {
+ SV *sv_data;
+ gchar *type;
+
+ message = unique_message_data_new();
+ type = SvGChar(ST(2));
+ sv_data = ST(3);
+
+ if (g_strcmp0(type, "data") == 0) {
+ SV *sv;
+ STRLEN length;
+ char *data;
+
+ length = sv_len(sv_data);
+ data = SvPV(sv_data, length);
+ unique_message_data_set(message, data, length);
+ }
+ else if (g_strcmp0(type, "text") == 0) {
+ STRLEN length;
+ char *text;
+
+ length = sv_len(sv_data);
+ text = SvGChar(sv_data);
+ unique_message_data_set_text(message, text, length);
+ }
+ else if (g_strcmp0(type, "filename") == 0) {
+ SV *sv;
+ char *filename;
+
+ filename = SvGChar(sv_data);
+ unique_message_data_set_filename(message, filename);
+ }
+ else if (g_strcmp0(type, "uris") == 0) {
+ gchar **uris = NULL;
+ gsize length;
+ AV *av = NULL;
+ int i;
+
+ if (SvTYPE(SvRV(sv_data)) != SVt_PVAV) {
+ unique_message_data_free(message);
+ croak("Value for the type 'uris' must be an array ref");
+ }
+
+ /* Convert the Perl array into a C array of strings */
+ av = (AV*) SvRV(sv_data);
+ length = av_len(av) + 2; /* last index + extra NULL padding */
+
+ uris = g_new0(gchar *, length);
+ for (i = 0; i < length - 1; ++i) {
+ SV **uri_sv = av_fetch(av, i, FALSE);
+ uris[i] = SvGChar(*uri_sv);
+ }
+ uris[length - 1] = NULL;
+
+ unique_message_data_set_uris(message, uris);
+ g_free(uris);
+ }
+ else {
+ unique_message_data_free(message);
+ croak("Parameter 'type' must be: 'data', 'text', 'filename' or 'uris'; got %s", type);
+ }
+ }
+ else if (items == 2) {
+ message = NULL;
+ }
+ else {
+ croak(
+ "Usage: $app->send_message($id, $type => $data)"
+ " or $app->send_message($id, uris => [])"
+ " or $app->send_message($id)"
+ );
+ }
+
+ RETVAL = unique_app_send_message(app, command_id, message);
+
+ if (message) {
+ unique_message_data_free(message);
+ }
+
+ OUTPUT:
+ RETVAL
Added: branches/upstream/libgtk2-unique-perl/current/xs/UniqueBackend.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/xs/UniqueBackend.xs?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/xs/UniqueBackend.xs (added)
+++ branches/upstream/libgtk2-unique-perl/current/xs/UniqueBackend.xs Tue May 26 04:38:22 2009
@@ -1,0 +1,46 @@
+#include "unique-perl.h"
+
+
+MODULE = Gtk2::UniqueBackend PACKAGE = Gtk2::UniqueBackend PREFIX = unique_backend_
+
+
+UniqueBackend*
+unique_backend_create (class)
+ C_ARGS: /* No args */
+
+
+const gchar*
+unique_backend_get_name (UniqueBackend *backend)
+
+
+void
+unique_backend_set_name (UniqueBackend *backend, const gchar *name)
+
+
+const gchar*
+unique_backend_get_startup_id (UniqueBackend *backend)
+
+
+void
+unique_backend_set_startup_id (UniqueBackend *backend, const gchar *startup_id)
+
+
+GdkScreen*
+unique_backend_get_screen (UniqueBackend *backend)
+
+
+void
+unique_backend_set_screen (UniqueBackend *backend, GdkScreen *screen)
+
+
+guint
+unique_backend_get_workspace (UniqueBackend *backend)
+
+
+gboolean
+unique_backend_request_name (UniqueBackend *backend)
+
+
+UniqueResponse
+unique_backend_send_message (UniqueBackend *backend, gint command_id, UniqueMessageData_ornull *message_data, guint time_)
+
Added: branches/upstream/libgtk2-unique-perl/current/xs/UniqueMessageData.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgtk2-unique-perl/current/xs/UniqueMessageData.xs?rev=36413&op=file
==============================================================================
--- branches/upstream/libgtk2-unique-perl/current/xs/UniqueMessageData.xs (added)
+++ branches/upstream/libgtk2-unique-perl/current/xs/UniqueMessageData.xs Tue May 26 04:38:22 2009
@@ -1,0 +1,58 @@
+#include "unique-perl.h"
+
+
+MODULE = Gtk2::UniqueMessageData PACKAGE = Gtk2::UniqueMessageData PREFIX = unique_message_data_
+
+SV*
+unique_message_data_get (UniqueMessageData *message_data)
+ PREINIT:
+ const guchar *string = NULL;
+ gint length = 0;
+
+ CODE:
+ string = unique_message_data_get(message_data, &length);
+ if (string == NULL) {XSRETURN_UNDEF;}
+
+ RETVAL = newSVpvn(string, length);
+
+ OUTPUT:
+ RETVAL
+
+gchar*
+unique_message_data_get_text (UniqueMessageData *message_data)
+
+
+gchar*
+unique_message_data_get_filename (UniqueMessageData *message_data)
+
+
+void
+unique_message_data_get_uris (UniqueMessageData *message_data)
+ PREINIT:
+ gchar **uris = NULL;
+ gchar *uri = NULL;
+ gint i = 0;
+
+ PPCODE:
+ uris = unique_message_data_get_uris(message_data);
+ if (uris == NULL) {XSRETURN_EMPTY;}
+
+ for (i = 0; TRUE; ++i) {
+ uri = uris[i];
+ if (uri == NULL) {break;}
+
+ XPUSHs(sv_2mortal(newSVGChar(uri)));
+ }
+ g_strfreev(uris);
+
+
+GdkScreen*
+unique_message_data_get_screen (UniqueMessageData *message_data)
+
+
+const gchar*
+unique_message_data_get_startup_id (UniqueMessageData *message_data)
+
+
+guint
+unique_message_data_get_workspace (UniqueMessageData *message_data)
More information about the Pkg-perl-cvs-commits
mailing list