From 90825e2392b2d70e43c7a25b8a3752299a933894 Mon Sep 17 00:00:00 2001 From: toma Date: Wed, 25 Nov 2009 17:56:58 +0000 Subject: Copy the KDE 3.5 branch to branches/trinity for new KDE 3.5 features. BUG:215923 git-svn-id: svn://anonsvn.kde.org/home/kde/branches/trinity/kdebindings@1054174 283d02a7-25f6-0310-bc7c-ecb5cbfe19da --- dcopperl/AUTHORS | 1 + dcopperl/Changes | 5 + dcopperl/DCOP.pm | 303 +++++++++++++++++++++++++++++ dcopperl/DCOP.xs | 492 +++++++++++++++++++++++++++++++++++++++++++++++ dcopperl/DCOP/Object.pm | 41 ++++ dcopperl/MANIFEST | 8 + dcopperl/Makefile.PL | 42 ++++ dcopperl/Makefile.PL.in | 28 +++ dcopperl/README | 13 ++ dcopperl/TODO | 4 + dcopperl/configure.in.in | 7 + dcopperl/test.pl | 123 ++++++++++++ dcopperl/typemap | 23 +++ 13 files changed, 1090 insertions(+) create mode 100644 dcopperl/AUTHORS create mode 100644 dcopperl/Changes create mode 100644 dcopperl/DCOP.pm create mode 100644 dcopperl/DCOP.xs create mode 100644 dcopperl/DCOP/Object.pm create mode 100644 dcopperl/MANIFEST create mode 100644 dcopperl/Makefile.PL create mode 100644 dcopperl/Makefile.PL.in create mode 100644 dcopperl/README create mode 100644 dcopperl/TODO create mode 100644 dcopperl/configure.in.in create mode 100644 dcopperl/test.pl create mode 100644 dcopperl/typemap (limited to 'dcopperl') 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 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 +#include +#include +#include +#include + +#include +#include +#include +#include + +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 <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", \®ister], + ["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)); -- cgit v1.2.1