summaryrefslogtreecommitdiffstats
path: root/dcopperl
diff options
context:
space:
mode:
Diffstat (limited to 'dcopperl')
-rw-r--r--dcopperl/AUTHORS1
-rw-r--r--dcopperl/Changes5
-rw-r--r--dcopperl/DCOP.pm303
-rw-r--r--dcopperl/DCOP.xs492
-rw-r--r--dcopperl/DCOP/Object.pm41
-rw-r--r--dcopperl/MANIFEST8
-rw-r--r--dcopperl/Makefile.PL42
-rw-r--r--dcopperl/Makefile.PL.in28
-rw-r--r--dcopperl/README13
-rw-r--r--dcopperl/TODO4
-rw-r--r--dcopperl/configure.in.in7
-rw-r--r--dcopperl/test.pl123
-rw-r--r--dcopperl/typemap23
13 files changed, 1090 insertions, 0 deletions
diff --git a/dcopperl/AUTHORS b/dcopperl/AUTHORS
new file mode 100644
index 00000000..9f0ed935
--- /dev/null
+++ b/dcopperl/AUTHORS
@@ -0,0 +1 @@
+Malte Starostik <malte@kde.org>
diff --git a/dcopperl/Changes b/dcopperl/Changes
new file mode 100644
index 00000000..1d84f77e
--- /dev/null
+++ b/dcopperl/Changes
@@ -0,0 +1,5 @@
+Revision history for Perl extension DCOP.
+
+0.01 Thu Aug 24 15:46:42 2000
+ - original version; created by h2xs 1.19
+
diff --git a/dcopperl/DCOP.pm b/dcopperl/DCOP.pm
new file mode 100644
index 00000000..ff463362
--- /dev/null
+++ b/dcopperl/DCOP.pm
@@ -0,0 +1,303 @@
+package DCOP;
+
+use strict;
+use vars qw($VERSION @ISA);
+
+use DynaLoader;
+use DCOP::Object;
+
+@ISA = qw(DynaLoader);
+
+$VERSION = '0.01';
+
+bootstrap DCOP $VERSION;
+
+# Returns a DCOP::Object that is logically bound to a specific object of a specific app
+sub createObject
+{
+ my ($self, $app, $obj) = @_;
+ $obj = "default" unless defined $obj;
+ $self = {
+ CLIENT => $self,
+ APP => $app,
+ OBJ => $obj,
+ };
+ bless $self, "DCOP::Object";
+}
+
+# That's it :)
+
+1;
+__END__
+
+=head1 NAME
+
+DCOP - Perl extension for communcation with KDE's DCOP server
+
+=head1 SYNOPSIS
+
+use DCOP;
+
+my $client = new DCOP;
+$client->attach();
+$running_apps = $client->registeredApplications();
+$client->send("kmail", "KMailIface", "checkMail()");
+
+my $kmail = $client->createObject("kmail", "KMailIface");
+$kmail->openComposer("fred@outer.space",
+ undef,
+ undef,
+ "This is a mail initiated by DCOP.pm",
+ 0,
+ "file:/home/joe/file/with/mail/to/send");
+
+=head1 DESCRIPTION
+
+The Desktop COmmunication Protocol is used by almost every KDE application
+and is a lightweight but powerful IPC mechanism. For more information look at
+
+http://developer.kde.org/documentation/library/2.0-api/dcop/HOWTO.html
+
+This Perl extension can be used to send commands to any currently registered
+DCOP application, as well as query which apps are registered and what
+interfaces with what functions they offer. Additionally you can use DCOP::Object
+to trigger DCOP sends or calls as native methods of DCOP::Object
+(see the secion on Autoload Magic below).
+
+=head2 Creation, Attachment and Registration
+
+Creating a DCOP client is as simple as it gets:
+
+ use DCOP;
+
+ $client = new DCOP;
+
+That's it. Some arguments to new are planned for future releases.
+After creation the client is not attached to the server. The easiest way to
+establish a connection is
+
+ $client->attach();
+
+which registers your DCOP client anonymously.
+To register with a well known name use:
+
+ $client->registerAs("fred");
+NOTE: registerAs is currently disabled
+
+To close the connection, simply call
+
+ $client->detach();
+
+=head2 Hello World!
+
+Now that you have your client registered with the server, either anonymously
+or by name, you can use it to query information about other registered applications.
+To get a list with names of all clients, use:
+
+ $client->registeredApplications();
+
+To retrieve the Qt object hierarchy of an application, call
+
+ $client->remoteObjects($appname);
+
+Similarly you can get a list of supported interfaces with
+
+ $client->remoteIterfaces($appname, $objectname);
+
+And to know what you can do with all these nice interfaces, learn about their functions:
+
+ $client->remoteFunctions($appname, $objectname);
+
+=head2 Let them do something
+
+To simply dispatch a command neglecting its return value, use
+
+ $client->send($appname, $objectname, $function, ...);
+
+If you're interested in the return value, consider call:
+
+ $client->call($appname, $objectname, $function, ...);
+
+=head2 Autoload Magic
+
+A much more intuitive way to use send and call is via DCOP::Object. This class
+is not intended for explicit instantiation and is merely a very small autoload stub.
+To get a DCOP::Object, simply call
+
+ $obj = $client->createObject($appname [, $objectname]);
+
+The returned $obj is a DCOP::Object "bound" to the specified application and object
+(or the app's default object if $objectname is omitted or undef). This DCOP::Object
+has only two known methods, _app() and _object() which return the application and object
+name respectively and are merely for internal use. Any other method you call will be
+looked up in the functions() list of the target object. So, if you created it e.g. with
+
+ $obj = $client->createObject("kmail", "KMailIface");
+
+You can simply invoke
+
+ $obj->checkMail();
+
+instead of
+
+ $client->send("kmail", "KMailIface", "checkMail()");
+
+=head2 Detailed Reference
+
+sub new(); [ class method ]
+
+takes no arguments by now and returns a blessed reference to a new DCOP client.
+
+sub attach();
+
+returns a true value if the attachment succeeded or undef on error.
+
+sub detach();
+
+returns a true value if the client was successfully detached or undef on error.
+
+sub isAttached();
+
+returns true or undef whether the client is attached or not.
+
+sub registerAs($appId [, $addPID]);
+CURRENTLY DISABLED
+
+registers the client with the name $appId or $appId with a number appended if a
+client by that name already exists. If $addPID is true, the PID of the client is
+appended to the appId, seperated by a hyphen. If addPID is ommited, it defaults to
+true. To not add a PID, specify undef or zero.
+registerAs returns the actual appId after the PID or possibly a sequence number has
+been added.
+If you call this method on an already attached or registered client, the old appId will
+be replaced with the new one.
+
+sub isRegistered();
+CURRENTLY DISABLED
+
+like isAttached but returns true only if the client used registerAs.
+
+sub appId();
+
+returns the appId the client is known as or undef if it's not registered or only
+attached anonymously.
+
+sub send($app, $object, $function [, ...])
+
+dispatches a function call without waiting for completion and thus without retrieving
+a return value. Returns true if a matching object has been found or undef otherwise.
+$app is the name of a registered application,
+$object the name of an object implemented by $app or undef for the default object,
+$function is the signature of the function to be called.
+Any following arguments are passed as parameters to the called function.
+Make sure that they match the function's signature in count and types (see Datatypes below)
+or your program will die. (This will be configurable in later versions)
+
+sub call($app, $object, $function [, ...])
+
+like send, but blocks until the called function returns and supplies the return value of that
+function (see Datatypes below). In scalar context, the value returned is the function's return
+value, in list context call returns a two element list with the first item set to the function's
+repturn value and the second set to true or undef according to success or failure of the DCOP call.
+
+
+sub findObject
+
+not really implemented, yet.
+
+sub emitDCOPSignal
+
+dito.
+
+sub isApplicationRegistered($app)
+
+returns true if an application with the given name is known to the DCOP server or otherwise undef.
+
+sub registeredApplications()
+
+returns a reference to an array with the names of all currently registered applications.
+On error it returns undef.
+
+sub remoteObjects($app)
+
+returns a reference to an array with the names of the objects supported by the named application.
+On error it returns undef.
+
+sub remoteInterfaces($app, $object)
+
+returns a reference to an array with the names of the interfaces supported by the given application
+and object. On error it returns undef.
+
+sub remoteFunctions($app, $object)
+
+returns a reference to an array with the names of the functions the specified interface supports.
+The functions are returned as their signatures with parameter names and return type like
+
+ QCStringList functions()
+
+sub normalizeSignature($signature)
+
+removes extraneous whitespace from a function signature.
+
+sub canonicalizeSignature($signature)
+
+mostly for internal use. Calls normalizeSignature and then strips parameter names and
+return type from it.
+
+=head2 Datatypes
+
+The following datatypes are currently supported in arguments to send and call and as
+return values:
+
+=over 4
+
+=item * int
+mapped to scalar
+
+=item * QCString
+mapped to scalar
+
+=item * QString (no Unicode support yet, just latin 1)
+mapped to scalar
+
+=item * QCStringList
+mapped to a reference to an array of scalars.
+
+=item * QStringList
+mapped to a reference to an array of scalars.
+
+=item * QPoint (untested)
+mapped to a reference to a two elemtent array [$x, $y]
+named value support via hash planned.
+
+=item * QSize (untested)
+mapped to a reference to a two elemtent array [$width, $height]
+named value support via hash planned.
+
+=item * QRect (untested)
+mapped to a reference to a four elemtent array [$left, $top, $width, $height]
+named value support via hash planned (including alternative right and bottom / width height)
+
+=item * KURL (only QString url() now)
+mapped to scalar
+
+=item * DCOPRef (partially)
+mapped to DCOP::Object, methods like isNull() missing.
+
+=back
+
+=head1 BUGS
+Most probably many. A lot of memory leaks I fear, but that has to be proven.
+There are many important features missing also. By now, it is not possible to
+use DCOP.pm to receive DCOP messages. That is planned.
+
+=head1 AUTHOR
+
+Malte Starostik, malte@kde.org
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
+
diff --git a/dcopperl/DCOP.xs b/dcopperl/DCOP.xs
new file mode 100644
index 00000000..509366af
--- /dev/null
+++ b/dcopperl/DCOP.xs
@@ -0,0 +1,492 @@
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef METHOD
+#undef METHOD
+#endif
+
+#ifdef ref
+#undef ref
+#endif
+#ifdef list
+#undef list
+#endif
+#ifdef do_open
+#undef do_open
+#endif
+#ifdef do_close
+#undef do_close
+#endif
+#ifdef assert
+#undef assert
+#endif
+#ifdef vform
+#undef vform
+#endif
+
+#include <qpoint.h>
+#include <qrect.h>
+#include <qregexp.h>
+#include <qsize.h>
+#include <qstringlist.h>
+
+#include <dcopclient.h>
+#include <dcopref.h>
+#include <kdatastream.h>
+#include <kurl.h>
+
+int intFromSV(SV *data)
+{
+ if (!SvOK(data))
+ return 0;
+ if (!SvIOK(data))
+ croak("DCOP: Cannot convert to integer");
+ return SvIV(data);
+}
+
+SV *intToSV(int data, SV * self = 0)
+{
+ return newSViv(data);
+}
+
+uint uintFromSV(SV *data)
+{
+ if (!SvOK(data))
+ return 0;
+ if (!SvIOK(data))
+ croak("DCOP: Cannot convert to integer");
+ return SvIV(data);
+}
+
+SV *uintToSV(uint data, SV * self = 0)
+{
+ return newSViv(data);
+}
+
+
+bool boolFromSV(SV *data)
+{
+ if (!SvOK(data))
+ return false;
+ if (SvIOK(data))
+ return SvIV(data);
+ if (SvPOK(data))
+ return QCString(SvPV(data, PL_na)).lower() == "true";
+ croak("DCOP: Cannot convert to bool");
+}
+
+SV *boolToSV(bool data, SV *self = 0)
+{
+ return newSViv(data ? 1 : 0);
+}
+
+QCString QCStringFromSV(SV *data)
+{
+ if (!SvOK(data))
+ return QCString();
+ if (!SvPOK(data))
+ croak("DCOP: Cannot convert to QCString");
+ return SvPV(data, PL_na);
+}
+
+SV *QCStringToSV(const QCString &data, SV * self = 0)
+{
+ return data.isNull() ? &PL_sv_undef : newSVpv(data.data(), 0);
+}
+
+QString QStringFromSV(SV *data)
+{
+ if (!SvOK(data))
+ return QString::null;
+ if (!SvPOK(data))
+ croak("DCOP: Cannot convert to QString");
+ return SvPV(data, PL_na);
+}
+
+SV *QStringToSV(const QString &data, SV * self = 0)
+{
+ return data.isNull() ? &PL_sv_undef : newSVpv((char *)data.latin1(), 0);
+}
+
+QCStringList QCStringListFromSV(SV *data)
+{
+ if (!SvROK(data))
+ croak("DCOP: Not reference");
+ if (SvTYPE(SvRV(data)) != SVt_PVAV)
+ croak("DCOP: Not an array reference");
+ QCStringList result;
+ for (int i = 0; i <= av_len((AV*)SvRV(data)); i++)
+ result.append(QCStringFromSV(av_fetch((AV*)SvRV(data), i, 0)[0]));
+ return result;
+}
+
+SV *QCStringListToSV(const QCStringList &data, SV * self = 0)
+{
+ AV *result = newAV();
+ for (QCStringList::ConstIterator i = data.begin(); i != data.end(); i++)
+ av_push(result, QCStringToSV(*i));
+ return newRV((SV*)result);
+}
+
+QStringList QStringListFromSV(SV *data)
+{
+ if (!SvROK(data))
+ croak("DCOP: Not reference");
+ if (SvTYPE(SvRV(data)) != SVt_PVAV)
+ croak("DCOP: Not an array reference");
+ QStringList result;
+ for (int i = 0; i <= av_len((AV*)SvRV(data)); i++)
+ result.append(QCStringFromSV(av_fetch((AV*)SvRV(data), i, 0)[0]));
+ return result;
+}
+
+SV *QStringListToSV(const QStringList &data, SV * self = 0)
+{
+ AV *result = newAV();
+ for (QStringList::ConstIterator i = data.begin(); i != data.end(); i++)
+ av_push(result, QStringToSV(*i));
+ return newRV((SV*)result);
+}
+
+QPoint QPointFromSV(SV *data)
+{
+ if (!SvROK(data))
+ croak("DCOP: Not reference");
+ if (SvTYPE(SvRV(data)) != SVt_PVAV)
+ croak("DCOP: Not an array reference");
+ if (av_len((AV*)SvRV(data)) != 1)
+ croak("DCOP: A QPoint must have exactly 2 components");
+ SV **pts = av_fetch((AV*)SvRV(data), 0, 0);
+ return QPoint(intFromSV(pts[0]), intFromSV(pts[1]));
+}
+
+SV *QPointToSV(const QPoint &data, SV * self = 0)
+{
+ SV *pts[2] = {
+ intToSV(data.x()),
+ intToSV(data.y())
+ };
+ return newRV((SV*)av_make(2, pts));
+}
+
+QSize QSizeFromSV(SV *data)
+{
+ if (!SvROK(data))
+ croak("DCOP: Not reference");
+ if (SvTYPE(SvRV(data)) != SVt_PVAV)
+ croak("DCOP: Not an array reference");
+ if (av_len((AV*)SvRV(data)) != 1)
+ croak("DCOP: A QSize must have exactly 2 components");
+ SV **ext = av_fetch((AV*)SvRV(data), 0, 0);
+ return QSize(intFromSV(ext[0]), intFromSV(ext[1]));
+}
+
+SV *QSizeToSV(const QSize &data, SV * self = 0)
+{
+ SV *ext[2] = {
+ intToSV(data.width()),
+ intToSV(data.height())
+ };
+ return newRV((SV*)av_make(2, ext));
+}
+
+QRect QRectFromSV(SV *data)
+{
+ if (!SvROK(data))
+ croak("DCOP: Not a reference");
+ if (SvTYPE(SvRV(data)) != SVt_PVAV)
+ croak("DCOP: Not an array reference");
+ if (av_len((AV*)SvRV(data)) != 1)
+ croak("DCOP: A QRect must have exactly 4 components");
+ SV **rc = av_fetch((AV*)SvRV(data), 0, 0);
+ return QRect(intFromSV(rc[0]), intFromSV(rc[1]), intFromSV(rc[2]), intFromSV(rc[3]));
+}
+
+SV *QRectToSV(const QRect &data, SV * self = 0)
+{
+ SV *rc[4] = {
+ intToSV(data.left()),
+ intToSV(data.top()),
+ intToSV(data.width()),
+ intToSV(data.height())
+ };
+ return newRV((SV*)av_make(4, rc));
+}
+
+KURL KURLFromSV(SV *data)
+{
+ return KURL(QStringFromSV(data));
+}
+
+SV *KURLToSV(const KURL &data, SV * self = 0)
+{
+ return QStringToSV(data.url());
+}
+
+DCOPRef DCOPRefFromSV(SV *data)
+{
+ if (!sv_isa(data, "DCOP::Object"))
+ croak("DCOP: Not a DCOP::Object");
+ SV **app = hv_fetch((HV*)SvRV(data), "APP", 3, 0);
+ SV **obj = hv_fetch((HV*)SvRV(data), "OBJ", 3, 0);
+ return DCOPRef(QCStringFromSV(app[0]), QCStringFromSV(obj[0]));
+}
+
+SV *DCOPRefToSV(const DCOPRef &data, SV * self)
+{
+ SV *ref = newRV((SV*)newHV());
+ hv_store((HV*)SvRV(ref), "CLIENT", 6, SvREFCNT_inc(self), 0);
+ hv_store((HV*)SvRV(ref), "APP", 3, QCStringToSV(data.app()), 0);
+ hv_store((HV*)SvRV(ref), "OBJ", 3, QCStringToSV(data.object()), 0);
+ return sv_bless(ref, gv_stashpv("DCOP::Object", 0));
+}
+
+# // Yes, defines *are* ugly...
+#define CHECK_ARG(t) \
+ if ((*it) == #t) \
+ s << t##FromSV(data[i]);
+
+#define CHECK_REPLY(t) \
+ if (replyType == #t) \
+ { \
+ t r; \
+ s >> r; \
+ return t##ToSV(r, self); \
+ }
+
+#define DATA(func, argn) mapArgs(func, &ST(argn), items - argn)
+
+QByteArray mapArgs(const QCString &func, SV **data, int n)
+{
+ int p = func.find('('),
+ q = func.find(')');
+ if (p == -1 || q == -1 || q < p)
+ croak("DCOP: Invalid function signature \"%s\"", func.data());
+ QStringList types = QStringList::split(',', func.mid(p + 1, q - p - 1));
+ QByteArray result;
+ QDataStream s(result, IO_WriteOnly);
+ QStringList::ConstIterator it = types.begin();
+ for (int i = 0; i < n; ++i, ++it)
+ {
+ if (it == types.end())
+ croak("DCOP: Too many (%d) arguments to function \"%s\"", n, func.data());
+ CHECK_ARG(int)
+ else CHECK_ARG(uint)
+ else CHECK_ARG(bool)
+ else CHECK_ARG(QCString)
+ else CHECK_ARG(QString)
+ else CHECK_ARG(QCStringList)
+ else CHECK_ARG(QStringList)
+ else CHECK_ARG(QPoint)
+ else CHECK_ARG(QSize)
+ else CHECK_ARG(QRect)
+ else CHECK_ARG(KURL)
+ else CHECK_ARG(DCOPRef)
+ else
+ croak("DCOP: Sorry, passing a %s is not implemented", (*it).latin1());
+ }
+ if (it != types.end())
+ croak("DCOP: Too few (%d) arguments to function \"%s\"", n, func.data());
+ return result;
+}
+
+SV* mapReply(const QCString &replyType, const QByteArray &replyData, SV *self)
+{
+ if (replyType == "void")
+ return sv_newmortal();
+ QDataStream s(replyData, IO_ReadOnly);
+ CHECK_REPLY(int)
+ else CHECK_REPLY(uint)
+ else CHECK_REPLY(bool)
+ else CHECK_REPLY(QCString)
+ else CHECK_REPLY(QString)
+ else CHECK_REPLY(QCStringList)
+ else CHECK_REPLY(QStringList)
+ else CHECK_REPLY(QPoint)
+ else CHECK_REPLY(QSize)
+ else CHECK_REPLY(QRect)
+ else CHECK_REPLY(KURL)
+ else CHECK_REPLY(DCOPRef)
+ else croak("Sorry, receiving a %s is not implemented", replyType.data());
+}
+
+bool isMultiWordType(const QString &type)
+{
+ return type == "unsigned" || type == "signed" || type == "long";
+}
+
+QCString canonicalizeSignature(const QCString &sig)
+{
+ QCString normal = DCOPClient::normalizeFunctionSignature(sig);
+ int p = normal.find('('), q = normal.find(')');
+ QCString result = normal.left(p + 1);
+ result.remove(0, result.findRev(' ') + 1);
+
+ QStringList params = QStringList::split(',', normal.mid(p + 1, q - p - 1));
+ for (QStringList::ConstIterator it = params.begin(); it != params.end(); ++it)
+ {
+ QStringList words = QStringList::split(' ', (*it).simplifyWhiteSpace());
+ for (QStringList::ConstIterator wi = words.begin(); wi != words.end(); ++wi)
+ if (!isMultiWordType(*wi))
+ {
+ result += *wi;
+ break;
+ }
+ if (it != params.fromLast())
+ result += ',';
+ }
+ result += ')';
+
+ return result;
+}
+
+MODULE = DCOP PACKAGE = DCOP
+
+PROTOTYPES: ENABLE
+
+DCOPClient *
+DCOPClient::new()
+ OUTPUT:
+ RETVAL
+
+void
+DCOPClient::DESTROY()
+
+bool
+DCOPClient::attach()
+ OUTPUT:
+ RETVAL
+
+bool
+DCOPClient::detach()
+ OUTPUT:
+ RETVAL
+
+bool
+DCOPClient::isAttached()
+ OUTPUT:
+ RETVAL
+
+#if 0
+QCString
+DCOPClient::registerAs(appId, ...)
+ QCString appId
+ PREINIT:
+ bool addPID = true;
+ CODE:
+ if (items > 3)
+ croak("Usage: DCOP::registerAs(THIS, appId [, addPID])");
+ if (items == 3)
+ addPID = SvIV(ST(2));
+ RETVAL = THIS->registerAs(appId, addPID);
+ OUTPUT:
+ RETVAL
+
+bool
+DCOPClient::isRegistered()
+ OUTPUT:
+ RETVAL
+
+#endif
+
+QCString
+DCOPClient::appId()
+ OUTPUT:
+ RETVAL
+
+bool
+DCOPClient::send(app, obj, func, ...)
+ QCString app
+ QCString obj
+ QCString func
+ CODE:
+ func = canonicalizeSignature(func);
+ RETVAL = THIS->send(app, obj, func, DATA(func, 4));
+ OUTPUT:
+ RETVAL
+
+SV*
+DCOPClient::call(app, obj, func, ...)
+ QCString app
+ QCString obj
+ QCString func
+ PPCODE:
+ func = canonicalizeSignature(func);
+ QCString replyType;
+ QByteArray replyData;
+ bool success;
+ if ((success = THIS->call(app, obj, func, DATA(func, 4), replyType, replyData)))
+ PUSHs(mapReply(replyType, replyData, ST(0)));
+ else
+ PUSHs(&PL_sv_undef);
+ if (GIMME_V == G_ARRAY)
+ PUSHs(success ? &PL_sv_yes : &PL_sv_no);
+
+SV*
+DCOPClient::findObject(app, obj, func, ...)
+ QCString app
+ QCString obj
+ QCString func
+ PPCODE:
+ func = canonicalizeSignature(func);
+ QCString foundApp;
+ QCString foundObj;
+ if (!THIS->findObject(app, obj, func, DATA(func, 4), foundApp, foundObj))
+ XSRETURN_UNDEF;
+ PUSHs(QCStringToSV(foundApp));
+ PUSHs(QCStringToSV(foundObj));
+
+void
+DCOPClient::emitDCOPSignal(obj, signal, ...)
+ QCString obj
+ QCString signal
+ CODE:
+ signal = canonicalizeSignature(signal);
+ THIS->emitDCOPSignal(obj, signal, DATA(signal, 3));
+
+bool
+DCOPClient::isApplicationRegistered(app)
+ QCString app
+ OUTPUT:
+ RETVAL
+
+QCStringList
+DCOPClient::registeredApplications()
+ OUTPUT:
+ RETVAL
+
+QCStringList
+DCOPClient::remoteObjects(app)
+ QCString app
+ OUTPUT:
+ RETVAL
+
+QCStringList
+DCOPClient::remoteInterfaces(app, obj)
+ QCString app
+ QCString obj
+ OUTPUT:
+ RETVAL
+
+QCStringList
+DCOPClient::remoteFunctions(app, obj)
+ QCString app
+ QCString obj
+ OUTPUT:
+ RETVAL
+
+static QCString
+DCOPClient::normalizeFunctionSignature(sig)
+ QCString sig
+ OUTPUT:
+ RETVAL
+
+QCString
+canonicalizeSignature(sig)
+ QCString sig
+ CODE:
+ RETVAL = canonicalizeSignature(sig);
+ OUTPUT:
+ RETVAL
diff --git a/dcopperl/DCOP/Object.pm b/dcopperl/DCOP/Object.pm
new file mode 100644
index 00000000..e98f65b5
--- /dev/null
+++ b/dcopperl/DCOP/Object.pm
@@ -0,0 +1,41 @@
+package DCOP::Object;
+
+use strict;
+use vars qw($VERSION $AUTOLOAD);
+
+$VERSION = '0.01';
+
+sub AUTOLOAD()
+{
+ my $funcname;
+ ($funcname = $AUTOLOAD) =~ s/.*:://;
+ return if $funcname eq 'DESTROY';
+ my $self = shift;
+ foreach my $func (map {DCOP::canonicalizeSignature $_}
+ @{DCOP::remoteFunctions($self->{CLIENT}, $self->{APP}, $self->{OBJ})})
+ {
+ my $argstr = $func;
+ $argstr =~ s/.*\((.*)\)/$1/;
+ my @args = split /,/, $argstr;
+ next unless $func =~ /^$funcname\(/ && scalar(@args) == scalar(@_);
+ unshift @_, $self->{CLIENT}, $self->{APP}, $self->{OBJ}, "$func";
+ defined wantarray ? goto &DCOP::call : goto &DCOP::send;
+ }
+ die 'Function "', $self->{APP}, '.', $self->{OBJ}, ".$funcname()\" doesn't exist.";
+}
+
+sub _app()
+{
+ my $self = shift;
+ $self->{APP};
+}
+
+sub _object()
+{
+ my $self = shift;
+ $self->{OBJ};
+}
+
+1;
+__END__
+
diff --git a/dcopperl/MANIFEST b/dcopperl/MANIFEST
new file mode 100644
index 00000000..27522a5d
--- /dev/null
+++ b/dcopperl/MANIFEST
@@ -0,0 +1,8 @@
+Changes
+DCOP.pm
+DCOP.xs
+DCOP/Object.pm
+Makefile.PL
+MANIFEST
+test.pl
+typemap
diff --git a/dcopperl/Makefile.PL b/dcopperl/Makefile.PL
new file mode 100644
index 00000000..c22ff234
--- /dev/null
+++ b/dcopperl/Makefile.PL
@@ -0,0 +1,42 @@
+use ExtUtils::MakeMaker;
+use Config;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+
+print "Trying to find some configuration information...\n";
+my $kde_dirs = $ENV{KDEDIRS} || '/usr/local/kde';
+my $qt_dir = $ENV{QTDIR} || '/usr/lib/qt';
+my $kde_inc = "$kde_dirs/include";
+my $kde_lib = "$kde_dirs/lib";
+my $qt_inc = "$qt_dir/include";
+my $qt_lib = "$qt_dir/lib";
+$kde_inc = undef unless -f "$kde_inc/dcopclient.h";
+$kde_lib = undef unless -f "$kde_lib/libDCOP.$Config{dlext}";
+$qt_dir = undef unless -f "$qt_inc/qglobal.h";
+
+print "Path to Qt headers? [$qt_inc]: ";
+chomp $input, $qt_inc = $input if (($input = <>) =~ /\S/);
+print "Path to Qt libraries? [$qt_lib]: ";
+chomp $input, $qt_lib = $input if (($input = <>) =~ /\S/);
+print "Path to KDE headers? [$kde_inc]: ";
+chomp $input, $kde_inc = $input if (($input = <>) =~ /\S/);
+print "Path to KDE libraries? [$kde_lib]: ";
+chomp $input, $kde_lib = $input if (($input = <>) =~ /\S/);
+
+WriteMakefile(
+ NAME => 'DCOP',
+ VERSION_FROM => 'DCOP.pm',
+ INC => "-I$qt_inc -I$kde_inc",
+ LIBS => "-L$qt_lib -lqt-mt -L$kde_lib -lkdecore -lDCOP",
+ XS => {'DCOP.xs' => 'DCOP.cpp'},
+ XSOPT => '-C++',
+ CCFLAGS => '-x c++',
+);
+
+sub MY::xs_c {
+ package MY;
+ my $hack = shift->SUPER::xs_c(@_);
+ $hack =~ s/\.c/.cpp/g;
+ $hack;
+}
+
diff --git a/dcopperl/Makefile.PL.in b/dcopperl/Makefile.PL.in
new file mode 100644
index 00000000..2a8e355b
--- /dev/null
+++ b/dcopperl/Makefile.PL.in
@@ -0,0 +1,28 @@
+use ExtUtils::MakeMaker;
+use Config;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+
+print "Trying to find some configuration information...\n";
+my $kde_inc = "@kde_includes@";
+my $kde_lib = "@kde_libraries@";
+my $qt_inc = "@qt_includes@";
+my $qt_lib = "@qt_libraries@";
+
+WriteMakefile(
+ NAME => 'DCOP',
+ VERSION_FROM => '@srcdir@/DCOP.pm',
+ INC => "-I$qt_inc -I$kde_inc",
+ LIBS => "-L$qt_lib -lqt-mt -L$kde_lib -lkdecore -lDCOP",
+ XS => {'DCOP.xs' => 'DCOP.cpp'},
+ XSOPT => '-C++',
+ CCFLAGS => '-x c++',
+);
+
+sub MY::xs_c {
+ package MY;
+ my $hack = shift->SUPER::xs_c(@_);
+ $hack =~ s/\.c/.cpp/g;
+ $hack;
+}
+
diff --git a/dcopperl/README b/dcopperl/README
new file mode 100644
index 00000000..c2432e8f
--- /dev/null
+++ b/dcopperl/README
@@ -0,0 +1,13 @@
+DCOP Bindings for Perl
+
+This does need some updating, basic functionality already works quite well
+
+To install, follow the usual Perl-Module-Installation-Procedure:
+perl Makefile.PL
+make
+make test
+make install
+
+Documentation is available in perldoc format embedded into DCOP.pm and
+after installation it should be accessible via
+man DCOP
diff --git a/dcopperl/TODO b/dcopperl/TODO
new file mode 100644
index 00000000..9846ee5f
--- /dev/null
+++ b/dcopperl/TODO
@@ -0,0 +1,4 @@
+* Lots of cleanup
+* More data types
+* signals/slots
+* UTF8-safe QString <=> scalar conversions
diff --git a/dcopperl/configure.in.in b/dcopperl/configure.in.in
new file mode 100644
index 00000000..1775534b
--- /dev/null
+++ b/dcopperl/configure.in.in
@@ -0,0 +1,7 @@
+KDE_CHECK_PERL(5.005, dcopperl)
+AC_CONFIG_FILES([ dcopperl/Makefile.PL ], [
+ cd dcopperl
+ perl -I$srcdir Makefile.PL
+ cd ..
+])
+
diff --git a/dcopperl/test.pl b/dcopperl/test.pl
new file mode 100644
index 00000000..0402395e
--- /dev/null
+++ b/dcopperl/test.pl
@@ -0,0 +1,123 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+BEGIN {
+ print <<EOT;
+Now that you've built the DCOP extension, it's time to run some tests on it.
+The first of them will just run by themselves, after that, there will be
+some interactive ones.
+
+EOT
+print "Loading...";
+}
+
+END {print "failed\n" unless $loaded;}
+use DCOP;
+$loaded = 1;
+print "done\n";
+
+######################### End of black magic.
+
+my $ok;
+
+sub check {
+ my $res = shift;
+ print $res ? "." : "!";
+ $ok = undef unless $res;
+}
+
+my ($client, $desk);
+
+sub attach {
+ $client = new DCOP;
+ check (ref $client) eq "DCOP";
+ check !$client->isAttached();
+ check $client->attach();
+ check $client->isAttached();
+ check $client->detach();
+ check !$client->isAttached();
+# For now, as register is disabled
+ $client->attach();
+}
+
+sub register {
+ check (my $appid = $client->registerAs("perltests"));
+ print "[$appid]";
+ check $client->isRegistered();
+ check $client->appId() eq $appid;
+ check ($appid = $client->registerAs("perltests", undef));
+ print "[$appid]";
+ check $client->isRegistered();
+ check $client->appId() eq $appid;
+}
+
+sub query {
+ check (my $list = $client->registeredApplications());
+ print "[$#$list]";
+ check ($list = $client->remoteObjects("kdesktop"));
+ print "[$#$list]";
+ check ($list = $client->remoteInterfaces("kdesktop", "qt"));
+ print "[$#$list]";
+ check ($list = $client->remoteFunctions("kdesktop", "qt"));
+ print "[$#$list]";
+ check grep /^QCStringList functions\(\)$/, @$list;
+}
+
+sub calls {
+ check (my $list = $client->call("kdesktop", "qt", "objects()"));
+ print "[$#$list]";
+ check grep m#^qt/kdesktop$#, @$list;
+}
+
+sub magic {
+ check ($desk = $client->createObject("kdesktop"));
+ check (ref $desk) eq "DCOP::Object";
+ check (my ($list) = $desk->interfaces());
+ print "[$#$list]";
+ check grep /^KDesktopIface$/, @$list;
+}
+
+sub icons {
+ check scalar $desk->selectAll();
+ sleep 1;
+ check scalar $desk->unselectAll();
+}
+
+sub saver {
+ check ($desk = $client->createObject("kdesktop")) unless defined $desk;
+ check (my ($saver) = $desk->screenSaver());
+ check (ref $saver) eq "DCOP::Object";
+ check scalar $saver->save();
+}
+
+@tests = (
+ ["simple attachments", \&attach],
+# ["full registration", \&register],
+ ["tree queries", \&query],
+ ["calls", \&calls],
+ ["autoload magic", \&magic],
+ ["more autoload magic", \&icons,
+ "The next test should cause all icons on your desktop to be selected\nand deselected again."],
+ ["DCOPRefs", \&saver,
+ "The next test should activate your screen saver."],
+ );
+
+foreach (@tests) {
+ my ($msg, $test, $confirm) = @{$_};
+ if ($confirm) {
+ print "$confirm\nDo you want this test to be performed? [Y/n]";
+ my $answer = <>;
+ next unless ($answer =~ /^\s*$/ || $answer =~ /^[yY]/);
+ }
+ printf "%-25s", $msg;
+ $ok = 1;
+ &$test();
+ unless ($ok) {
+ print "failed\n";
+ exit 1;
+ }
+ print "passed\n";
+}
+
diff --git a/dcopperl/typemap b/dcopperl/typemap
new file mode 100644
index 00000000..cb7f2420
--- /dev/null
+++ b/dcopperl/typemap
@@ -0,0 +1,23 @@
+TYPEMAP
+DCOPClient * O_OBJECT
+QCString T_QCSTRING
+QCStringList T_QCSTRINGLIST
+
+INPUT
+O_OBJECT
+ if(sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG))
+ $var = ($type)SvIV((SV*)SvRV($arg));
+ else {
+ warn(\"${Package}::$func_name() -- $var is not a blessed SV reference\");
+ XSRETURN_UNDEF;
+ }
+T_QCSTRING
+ $var = QCStringFromSV($arg);
+
+OUTPUT
+O_OBJECT
+ sv_setref_pv( $arg, CLASS, (void*)$var );
+T_QCSTRING
+ sv_setsv($arg, QCStringToSV($var));
+T_QCSTRINGLIST
+ sv_setsv($arg, QCStringListToSV($var));
generated by cgit v1.2.1 (git 2.18.0) at 2024-12-22 20:31:46 +0000