1# -*- perl -*-
2
3#
4# $Id: KDEUtil.pm,v 2.28 2008/10/03 07:01:38 eserte Exp $
5# Author: Slaven Rezic
6#
7# Copyright (C) 1999,2004,2008 Slaven Rezic. All rights reserved.
8# This package is free software; you can redistribute it and/or
9# modify it under the same terms as Perl itself.
10#
11# Mail: srezic@cpan.org
12# WWW:  http://www.rezic.de/eserte
13#
14
15=head1 NAME
16
17KDEUtil - provide standard KDE functions for perl
18
19=cut
20
21package KDEUtil;
22use strict;
23
24=head1 CONSTRUCTOR
25
26=head2 KDEUtil->new(...)
27
28Create a new object. Possible options are:
29
30=over 4
31
32=item -checkrunning
33
34If set to true, then undef will be returned instead of a KDEUtil
35object if KDE is not running.
36
37=item -tk
38
39=item -top
40
41A reference to a Tk MainWindow. The C<-tk> option is an alias for C<-top>.
42
43=back
44
45=cut
46
47sub new {
48    my($class, %args) = @_;
49    my $self = \%args;
50    bless $self, $_[0];
51    if (exists $args{-tk}) {
52	$args{-top} = delete $args{-tk};
53    }
54    if ($args{-checkrunning} && !$self->is_running) {
55	undef;
56    } else {
57	$self;
58    }
59}
60
61=head1 METHODS
62
63=head2 is_running
64
65Check if KDE is running (ie. kwm is running). Set the KDE_VERSION member to
66either 1 (version 1) or 2 (version 2 and 3).
67
68=cut
69
70sub is_running {
71    my $self = shift;
72    if ($self->get_property("KWM_RUNNING")) { # KDE 1
73	$self->{KDE_VERSION} = 1;
74	1;
75    } elsif ($self->get_property("KWIN_RUNNING")) { # KDE 2
76	$self->{KDE_VERSION} = 2; # or 3
77	1;
78    } else {
79	0;
80    }
81}
82
83=head2 current_desktop
84
85Return the active KDE desktop.
86
87=cut
88
89sub current_desktop {
90    my $self = shift;
91    if ($self->{KDE_VERSION} == 1) {
92	$self->get_property("KWM_CURRENT_DESKTOP");
93    } else {
94	$self->get_property("_NET_CURRENT_DESKTOP");
95    }
96}
97
98=head2 window_region
99
100Return array with current window region bounds (for maximizing)
101Output is (top, left, width, height).
102
103=cut
104
105sub window_region {
106    my $self = shift;
107    my $desktop = shift || $self->current_desktop;
108    if ($self->{KDE_VERSION} == 1) {
109	$self->get_property("KWM_WINDOW_REGION_$desktop");
110    } else {
111	for my $prop ("_NET_WORKAREA") { # does "_WIN_AREA" work, too?
112	    my(@vals) = ($self->get_property($prop))[$desktop*4 .. $desktop*4+3];
113	    if (@vals && defined $vals[0]) {
114		return @vals;
115	    }
116	}
117	if ($self->{-top} && defined &Tk::Exists && Tk::Exists $self->{-top}) {
118	    (0, 0, $self->{-top}->screenwidth, $self->{-top}->screenheight);
119	} else {
120	    (0, 0, 800, 600); # provide reasonable values as fallback
121	}
122    }
123}
124
125=head2 client_window_region
126
127Return array with current windoe region bound without approximate size for
128borders and titlebar.
129
130=cut
131
132sub client_window_region {
133    my $self = shift;
134    my(@extends) = $self->window_region;
135    $extends[2] -= (4+4); # XXX wie kann man die Gr��e des Rahmens ansonsten rauskriegen?
136    $extends[3] -= (22+4);
137    @extends;
138}
139
140sub maximize {
141    my $self = shift;
142    my $w = shift;
143    my(@extends) = $self->client_window_region;
144    $w->geometry("$extends[2]x$extends[3]+$extends[0]+$extends[0]");
145}
146
147=head2 get_property
148
149Get property with name C<$prop>.
150If possible, use Tk methods, otherwise use the standard X11 program C<xprop>.
151
152=cut
153
154sub get_property {
155    my $self = shift;
156    my $prop = shift;
157    my @ret;
158    if (exists $self->{'-top'} and Tk::Exists($self->{'-top'})) {
159	my $top = $self->{'-top'};
160	if ($top->property('exists', $prop, 'root')) {
161	    # XXX split?
162	    @ret = $top->property('get', $prop, 'root');
163	    shift @ret; # get rid of property name
164	}
165    } else {
166	local(%ENV) = %ENV;
167	delete $ENV{XPROPFORMATS};
168	open(XPROP, "xprop -notype -root $prop|");
169	my $line = scalar <XPROP>;
170	if ($line =~ /=\s*(.*)/) {
171	    @ret = map { hex($_) } split /\s*,\s*/, $1;
172	}
173	close XPROP;
174    }
175    @ret;
176}
177
178=head2 keep_on_top($tkwin)
179
180Arrange the Tk window $tkwin to stay on top. This works best with Tk
181804.028, otherwise you need X11::Protocol, otherwise it will only work
182with older KDE window managers (version 2 or so).
183
184Return true on success. You cannot trust the success value, as KDE 3.5
185(for example) defines the old _NET_WM_STATE_STAYS_ON_TOP property, but
186does not handle it anymore.
187
188Note that this method might actually overwrite a <Map> binding on
189$tkwin's toplevel. This actually happens if
190
191=over
192
193=item * the Tk version is too old and X11::Protocol must be used and
194
195=item * $tkwin is withdrawn when calling this method
196
197=back
198
199Alias method name: stays_on_top.
200
201=cut
202
203sub keep_on_top {
204    shift;
205    my $w = shift;
206    my $toplevel = $w->toplevel;
207
208    if ($Tk::VERSION >= 804.027501 && $w->toplevel->can('attributes')) {
209	$toplevel->attributes(-topmost => 1);
210	# this was easy
211	return 3;
212    }
213
214    my($wrapper) = $toplevel->wrapper;
215
216    if (eval {
217	require X11::Protocol;
218	my $x = X11::Protocol->new($toplevel->screen);
219	my $_NET_WM_STATE_ADD = 1;
220	my $data = pack("LLLLL", $_NET_WM_STATE_ADD, $w->InternAtom('_NET_WM_STATE_ABOVE'), 0, 0, 0);
221	my $send_event = sub {
222	    $x->SendEvent($x->{'root'}, 0,
223			  $x->pack_event_mask('SubstructureNotify', 'SubstructureRedirect'),
224			  $x->pack_event(name   => 'ClientMessage',
225					 window => $wrapper,
226					 type   => $w->InternAtom('_NET_WM_STATE'),
227					 format => 32,
228					 data   => $data));
229	};
230	if ($toplevel->state eq 'withdrawn') {
231	    $toplevel->bind('<Map>' => sub { $send_event->(); $toplevel->bind('<Map>', undef) });
232	} else {
233	    $send_event->();
234	}
235	1;
236    }) {
237	return 2;
238    }
239    warn $@ if $@;
240
241    eval {
242	if (!grep { $_ eq '_NET_WM_STATE_STAYS_ON_TOP' } $w->property('get', '_NET_SUPPORTED', 'root')) {
243	    die "_NET_WM_STATE_STAYS_ON_TOP not supported";
244	}
245	$w->property('set', '_NET_WM_STATE', "ATOM", 32,
246		     ["_NET_WM_STATE_STAYS_ON_TOP"], $wrapper);
247    };
248    if ($@) {
249	warn $@;
250	0;
251    } else {
252	1;
253    }
254}
255*stays_on_top = \&keep_on_top;
256
257sub panel {
258    bless {Parent => $_[0]}, 'KDEUtil::Panel';
259}
260
261sub wm {
262    bless {Parent => $_[0]}, 'KDEUtil::WM';
263}
264
265sub fm {
266    bless {Parent => $_[0]}, 'KDEUtil::FM';
267}
268
269# XXX Probably wrong for KDE 3
270sub kde_dirs {
271    my $self = shift;
272    my(%args) = @_;
273    my $given_prefix = $args{-prefix};
274    my $writable     = $args{-writable};
275    my $all          = $args{-all};
276    if (defined $given_prefix) {
277	my %kdedirs;
278	%kdedirs = $self->_find_kde_dirs($given_prefix, $writable);
279	return %kdedirs;
280    } else {
281	require Config;
282	require File::Basename;
283	my $sep = $Config::Config{'path_sep'} || ':';
284
285	my %kdedirs = $self->_find_kde_dirs_with_kde_config(-writable => $writable, -all => $all);
286	return %kdedirs if %kdedirs;
287
288	my @path = map { File::Basename::dirname($_) } split(/$sep/o, $ENV{PATH});
289	foreach my $prefix (qw(/usr/local/kde /usr/local /opt/kde),
290			    @path) {
291#	    warn "Try $prefix...\n";
292	    %kdedirs = $self->_find_kde_dirs($prefix, $writable);
293	    return %kdedirs if %kdedirs;
294	}
295    }
296    return ();
297}
298
299sub _find_kde_dirs_with_kde_config {
300    shift;
301    my(%args) = @_;
302    my $writable = $args{-writable} || 0;
303    my $all      = $args{-all}      || 0;
304    my %ret;
305
306    # PATH fallback
307    require Config;
308    my $sep = $Config::Config{'path_sep'} || ':';
309    local $ENV{PATH} = $ENV{PATH} . join $sep, map { "/opt/kde$_/bin" } (3, 2, "");
310
311 TYPE:
312    for my $def ([apps => "applnk"],
313		 [icon => "icons"],
314		 [mime => "mimelnk"],
315		 [exe  => "bin"],
316		 [html => "doc"],
317		 [config => "config"],
318		) {
319	my($new_name, $old_name) = @$def;
320	my $cfg = `kde-config --expandvars --path $new_name`;
321	chomp $cfg;
322	my(@path) = split /:/, $cfg;
323	for my $path (@path) {
324	    next if (!-e $path || !-d $path);
325	    next if $writable && !-w $path;
326	    if ($all) {
327		push @{ $ret{"-$old_name"} }, $path;
328	    } else {
329		$ret{"-$old_name"} = $path;
330		next TYPE;
331	    }
332	}
333    }
334    %ret;
335}
336
337sub _find_kde_dirs {
338    shift;
339    my($prefix, $writable) = @_;
340    my $applnk  = "$prefix/share/applnk";
341    my $icons   = "$prefix/share/icons";
342    my $mimelnk = "$prefix/share/mimelnk";
343    my $bin     = "$prefix/bin";
344    my $doc     = "$prefix/share/doc/HTML";
345    my $config  = "$prefix/share/config";
346
347    if (-d $applnk && (!$writable || -w $applnk) &&
348	-d $icons  && (!$writable || -w $icons)) {
349	my %ret = (-applnk => $applnk,
350		   -icons  => $icons,
351		  );
352	if (-d $mimelnk && (!$writable || -w $mimelnk)) {
353	    $ret{-mimelnk} = $mimelnk;
354	}
355	if (-d $bin && (!$writable || -w $bin)) {
356	    $ret{-bin} = $bin;
357	}
358	if (-d $doc && (!$writable || -w $doc)) {
359	    $ret{-doc} = $doc;
360	}
361	if (-d $config && (!$writable || -w $config)) {
362	    $ret{-config} = $config;
363	}
364	%ret;
365    } else {
366	();
367    }
368}
369
370# Modern KDE paths
371# References:
372#   http://docs.kde.org/userguide/kde-menu.html
373#   http://standards.freedesktop.org/basedir-spec/basedir-spec-0.6.html
374#   http://standards.freedesktop.org/menu-spec/menu-spec-1.0.html
375sub get_kde_path_types {
376    my($self) = @_;
377    if (!$self->{PATH_TYPES}) {
378	my @path_types;
379	for (split /\n/, `kde-config --types`) {
380	    chomp;
381	    my($path_type) = $_ =~ m{^(\S+)};
382	    push @path_types, $path_type;
383	}
384	$self->{PATH_TYPES} = \@path_types;
385    }
386    @{ $self->{PATH_TYPES} };
387}
388
389# Returns array of paths
390sub get_kde_path {
391    my($self, $path_type) = @_;
392    if (!$self->{PATH}->{$path_type}) {
393	my $paths;
394	if (_is_in_path("kde-config")) {
395	    ($paths) = `kde-config --expandvars --path $path_type`;
396	    chomp $paths;
397	} else {
398	    # Fallback only works for xdg paths
399	    my $xdg_data_home   = $ENV{XDG_DATA_HOME} || "$ENV{HOME}/.local/share";
400	    my $xdg_config_home = $ENV{XDG_CONFIG_HOME} || "$ENV{HOME}/.config";
401	    $paths = {'xdgconf-menu' => "$xdg_config_home/menus/:" . _default_prefix("etc") . "/xdg/menus/",
402		      'xdgdata-apps' => "$xdg_data_home/applications/:" . _default_prefix("share") . "/applications/",
403		      'xdgdata-dirs' => "$xdg_data_home/desktop-directories/:" . _default_prefix("share") . "/desktop-directories/",
404		     }->{$path_type};
405	}
406	$self->{PATH}->{$path_type} = [ split /:/, $paths ];
407    }
408    @{ $self->{PATH}->{$path_type} };
409}
410
411# Returns default installation path
412sub get_kde_install_path {
413    my($self, $path_type) = @_;
414    if (!$self->{INSTALL_PATH}->{$path_type}) {
415	my $paths;
416	if (_is_in_path("kde-config")) {
417	    ($paths) = `kde-config --expandvars --install $path_type`;
418	    chomp $paths;
419	} else {
420	    $paths = {'xdgconf-menu' => _default_prefix("etc")   . "/xdg/menus/",
421		      'xdgdata-apps' => _default_prefix("share") . "/applications/",
422		      'xdgdata-dirs' => _default_prefix("share") . "/desktop-directories/",
423		      'exe'          => _default_prefix("usr")   . "/bin/",
424		     }->{$path_type};
425	}
426	$self->{INSTALL_PATH}->{$path_type} = $paths;
427    }
428    $self->{INSTALL_PATH}->{$path_type};
429}
430
431sub get_kde_user_path {
432    my($self, $path_type) = @_;
433    if (!$self->{USER_PATH}->{$path_type}) {
434	my $paths;
435	if (_is_in_path("kde-config")) {
436	    # Cease kde-config's "KLocale: trying to look up "" in catalog. Fix the program"
437	    # warnings by redirecting STDERR.
438	    # Seen with KDE: 3.5.1, kde-config: 1.0
439	    ($paths) = `kde-config --expandvars --userpath $path_type 2>/dev/null`;
440	    chomp $paths;
441	} else {
442	    $paths = {'desktop'  => "$ENV{HOME}/Desktop",
443		      'document' => "$ENV{HOME}",
444		     }->{$path_type};
445	}
446	$self->{USER_PATH}->{$path_type} = $paths;
447    }
448    $self->{USER_PATH}->{$path_type};
449}
450
451# KDE configuration, probably outdated
452sub get_kde_config {
453    my $self = shift;
454    my $rc = shift;
455
456    my %commondirs = $self->kde_dirs(-all => 1);
457    my %homedirs   = $self->kde_dirs(-prefix => "$ENV{HOME}/.kde");
458
459    my @dirs;
460    foreach my $cfgdir (\%commondirs, \%homedirs) {
461	if (exists $cfgdir->{-config}) {
462	    if (ref $cfgdir->{-config} eq "ARRAY") {
463		push @dirs, reverse @{ $cfgdir->{-config} };
464	    } else {
465		push @dirs, $cfgdir->{-config};
466	    }
467	}
468    }
469
470    my $cfg = {};
471    foreach my $dir (@dirs) {
472	my $rcfile = "$dir/$rc";
473	if (open(F, $rcfile)) {
474	    my $curr_section;
475	    while(<F>) {
476		/^#/ && next;
477		chomp;
478		if (/^\[(.*)\]/) {
479		    $curr_section = $1;
480		} elsif (/^([^=]+)=(.*)/) {
481		    if (defined $curr_section) {
482			$cfg->{$curr_section}{$1} = $2;
483		    }
484		}
485	    }
486	    close F;
487	}
488    }
489    $cfg;
490}
491
492=head2 kde_config_for_tk
493
494Set the appearance of Tk windows as close as possible to that of the
495current KDE defintions.
496
497Seems to work again with KDE 3 (but is there always a .kderc?)
498
499XXX It's better to use get_kde_config on config > kdeglobals
500
501=cut
502
503sub kde_config_for_tk {
504    my $self = shift;
505    my $top = $self->{'-top'};
506    return if (!open(KDERC, "$ENV{HOME}/.kderc"));
507
508    my $general;
509    while(<KDERC>) {
510	if (!$general && /^\[General\]/) {
511	    $general++;
512	} elsif ($general) {
513	    chomp;
514	    my($key,$val) = split /=/, $_, 2;
515	    if (grep { $key eq $_} qw(foreground
516				      background
517				      selectForeground
518				      selectBackground)) {
519		my $rgbcol = sprintf "#%02x%02x%02x", split /,/, $val;
520		$top->optionAdd("*$key", $rgbcol, "userDefault");
521		eval { $top->configure("-$key" => $rgbcol) };
522		if ($key eq 'background') {
523		    my $dark_rgbcol = $top->Darken($rgbcol, 80);
524		    $top->optionAdd("*highlightBackground", $rgbcol,
525				    "userDefault");
526		    $top->optionAdd("*troughColor", $dark_rgbcol,
527				    "userDefault");
528		    foreach (qw(Check Radio)) {
529			$top->optionAdd("*${_}button.selectColor",
530					$dark_rgbcol, "userDefault");
531		    }
532		    $top->optionAdd("*NoteBook.backPageColor", $rgbcol,
533				    "userDefault");
534		    # XXX This is a hack:
535		    $top->afterIdle
536			(sub {
537			     my $m = $top->cget(-menu);
538			     $m->configure(-background => $rgbcol) if $m;
539			 });
540		    foreach (qw(Menu Menubutton Optionmenu)) {
541			$top->optionAdd("*$_*activeBackground", $rgbcol,
542					"userDefault");
543		    }
544		} elsif ($key eq 'foreground') {
545		    foreach (qw(Menu Menubutton Optionmenu)) {
546			$top->optionAdd("*$_*activeForeground", $rgbcol,
547					"userDefault");
548		    }
549		}
550	    } elsif ($key eq 'windowBackground') {
551		my $rgbcol = sprintf "#%02x%02x%02x", split /,/, $val;
552		for (qw(Entry NumEntry BrowseEntry.Entry
553			Listbox KListbox K2Listbox TixHList HList
554			Text ROText
555		       )) {
556		    $top->optionAdd("*$_.background", $rgbcol, "userDefault");
557		}
558	    } elsif ($key =~ /^(font|fixedFont)$/) {
559		my @font = split /,/, $val;
560		my $font = "$font[0] -$font[1]";
561		$top->optionAdd("*$key", $font, "userDefault");
562	    }
563	}
564    }
565    close KDERC;
566
567    $top->optionAdd("*Scrollbar*Width", 11, "userDefault");
568
569    foreach (qw(Menu Menubutton Optionmenu)) {
570	$top->optionAdd("*$_*tearOff", 0, "userDefault");
571	$top->optionAdd("*$_*activeBorderWidth", 2, "userDefault");
572	$top->optionAdd("*$_*relief", "raised", "userDefault");
573    }
574
575}
576
577=head2 remove_kde_decoration($tkwin)
578
579Remove the window decoration for the Tk window $tkwin. This is
580different from overrideredirect, because window manager operations
581like lowering, raising etc. still work. This method works for KDE 2
582and 3.
583
584=cut
585
586sub remove_kde_decoration {
587    my $self = shift;
588    my $toplevel = shift || $self->{-top};
589    return if $Tk::platform ne 'unix';
590
591    my($wrapper) = $toplevel->wrapper;
592
593    if (eval {
594	scalar grep { $_ eq '_KDE_NET_WM_WINDOW_TYPE_OVERRIDE' } $toplevel->property('get', '_NET_SUPPORTED', 'root')
595    }) {
596	eval {
597	    $toplevel->property('set','_NET_WM_WINDOW_TYPE','ATOM',
598				32,['_KDE_NET_WM_WINDOW_TYPE_OVERRIDE'],$wrapper);
599	}; warn $@ if $@;
600    } else {
601	eval {
602	    my($wrapper) = $toplevel->wrapper;
603	    $toplevel->property('set','KWM_WIN_DECORATION','KWM_WIN_DECORATION',
604				32,[0],$wrapper);
605	}; warn $@ if $@;
606    }
607}
608
609#XXX tobedone
610# sub append_magic {
611#     my($self, $magicfile,
612# }
613
614sub _is_in_path {
615    my($prog) = @_;
616    my $sep = ':';
617    foreach (split(/$sep/o, $ENV{PATH})) {
618	return "$_/$prog" if (-x "$_/$prog" && !-d "$_/$prog");
619    }
620    undef;
621}
622
623sub _default_prefix {
624    my($path) = @_;
625    if ($^O =~ m{linux}) {
626	if ($path eq 'etc') {
627	    '/etc';
628	} elsif ($path eq 'usr') {
629	    '/usr';
630	} elsif ($path eq 'share') {
631	    '/usr/share';
632	} else {
633	    die "Unhandled path <$path>";
634	}
635    } else { # e.g. BSD
636	if ($path eq 'etc') {
637	    '/usr/local/etc';
638	} elsif ($path eq 'usr') {
639	    '/usr/local';
640	} elsif ($path eq 'share') {
641	    '/usr/local/share';
642	} else {
643	    die "Unhandled path <$path>";
644	}
645    }
646}
647
648{
649package KDEUtil::WM;
650@KDEUtil::WM::ISA = qw(KDEUtil);
651
652my @cmd = qw(refreshScreen darkenScreen logout commandLine taskManager
653	     configure
654	     winMove winResize winRestore winIconify winClose winShade
655	     winSticky winOperations
656	     deskUnclutter deskCascade
657	     desktop);
658foreach (@cmd) {
659    eval 'sub ' . $_ . ' { shift->command("' . $_ . '", @_) } ';
660}
661
662use vars qw($config);
663
664sub command {
665    shift;
666    my(@cmd) = @_;
667    my $cmd = join("", @cmd);
668    system("kwmcom", $cmd);
669}
670
671sub get_config {
672    my($self, $section, $key) = @_;
673    if (!defined $config) {
674	$config = KDEUtil->get_kde_config("kwmrc", 0);
675    }
676    if (exists $config->{$section}) {
677	return $config->{$section}{$key};
678    }
679    undef;
680}
681
682}
683
684{
685package KDEUtil::Panel;
686@KDEUtil::Panel::ISA = qw(KDEUtil);
687
688my @cmd = qw(restart hide show system);
689foreach (@cmd) {
690    eval 'sub ' . $_ . ' { shift->command("' . $_ . '", @_) } ';
691}
692
693sub command {
694    shift;
695    my(@cmd) = @_;
696    my $cmd = join("", @cmd);
697    system("kwmcom", "kpanel:$cmd");
698}
699
700}
701
702{
703package KDEUtil::FM;
704@KDEUtil::FM::ISA = qw(KDEUtil);
705
706my @cmd = qw(openURL refreshDesktop refreshDirectory openProperties
707	     exec move folder sortDesktop configure);
708foreach (@cmd) {
709    eval 'sub ' . $_ . ' { shift->command("' . $_ . '", @_) } ';
710}
711
712sub command {
713    shift;
714    my(@cmd) = @_;
715    system("kfmclient", @cmd);
716}
717
718}
719
720=head1 SEE ALSO
721
722Extended Window Manager Hints - L<http://standards.freedesktop.org/wm-spec/1.3/>
723
724=head1 AUTHOR
725
726Slaven Rezic
727
728=cut
729
730# peacify -w
731$Tk::platform = $Tk::platform if 0;
732*KDEUtil::stays_on_top = *KDEUtil::stays_on_top if 0;
733
7341;
735
736__END__
737