Skip Menu |

This queue is for tickets about the Tk-Contrib CPAN distribution.

Report information
The Basics
Id: 74831
Status: new
Priority: 0/
Queue: Tk-Contrib

People
Owner: Nobody in particular
Requestors: user42 [...] zip.com.au
Cc:
AdminCc:

Bug Information
Severity: (no value)
Broken in: (no value)
Fixed in: (no value)



Subject: Tk::OlWm on wrapper window
Date: Fri, 10 Feb 2012 09:16:37 +1100
To: bug-Tk-Contrib [...] rt.cpan.org
From: Kevin Ryde <user42 [...] zip.com.au>
With Tk::OlWm 1.3 and the debian packaged olwm, the program foo.pl displays a window with resize handles, where I expected it would not have handles. Nosing around with xprop etc I believe Tk::OlWm is applying the relevant properties to the main window which is only an application child, not the actual toplevel window, in the Tk 8.x wrapper window scheme. The diff below works for me to have the properties on the wrapper window. That change fixes foo.pl to now have resize handles. Did Tk::OlWm pre-date the wrapper window thing? I had a suspicion at one time that Tk::Mwm might be suffering similarly. At any rate the check with can() can let it work on both older and newer tk.
#!/usr/bin/perl -w use strict; use Tk; use Tk::OlWm; my $mw = MainWindow->new; $mw->OL_DECOR(RESIZE => 0); MainLoop; exit 0;
--- OlWm.pm.orig 1998-09-22 07:02:17.000000000 +1000 +++ OlWm.pm 2012-02-10 09:09:59.000000000 +1100 @@ -10,6 +10,19 @@ # # CLOSE FOOTER HEADER RESIZE PIN ICON_NAME +# Return an XID integer, or no values if not applicable. +# The wrapper window of toplevels is new in Tk 8.x, allow for past versions +# without it.. +sub _xid { + my ($mw) = @_; + if ($mw->can('wrapper')) { + my ($xid, $menuheight) = $mw->wrapper; + return $xid; + } else { + return; + } +} + sub ADDDEL { my ($mw,$atom,$to,$from) = @_; @@ -23,16 +36,18 @@ { my $mw = shift; my $data = $mw->privateData; + my @xid = _xid($mw); foreach my $kind (keys %$data) { - $mw->property('set',"_OL_DECOR_$kind",'ATOM',32,[keys %{$data->{$kind}}]); + $mw->property('set',"_OL_DECOR_$kind",'ATOM',32,[keys %{$data->{$kind}}], + @xid); } } sub Flag { my ($name,$mw,$state) = @_; - $mw->property('set',"_OL_$name",'INTEGER',32,$state); + $mw->property('set',"_OL_$name",'INTEGER',32,$state,_xid($mw)); $mw->update if ($mw->IsMapped); }