# strip everything before this and feed to /bin/sh # # rm -f PNG/libpng/example.c.diff rm -f PNG/libpng/makefile.vc rm -f PNG/libpng/msvc/README.txt rm -f PNG/libpng/msvc/libpng.dsp rm -f PNG/libpng/msvc/libpng.dsw rm -f PNG/libpng/msvc/png.rc rm -f PNG/libpng/msvc/png32ms.def rm -f PNG/libpng/msvc/zlib.def rm -f PNG/libpng/msvc/zlib.dsp touch t/magic.t chmod 0444 t/magic.t patch -p1 -N <<'__END_OF_PATCH__' Index: Change.log --- Tk-804.025_beta4/Change.log 2003-10-20 21:08:21.000000000 +0100 +++ Tk-804.025_beta5/Change.log 2003-11-02 20:33:41.000000000 +0000 @@ -1,3 +1,139 @@ +Change 2983 on 2003/11/02 by nick@llama + + HList's ->header('size',0) command is unreliable as measure of height + of header window. Add new sub-command ->header('height') which + uses computed geometry based height of _all_ column headers. + Use that to compute nearest info. + Fixes snag reported by Petr Pajas + +Change 2982 on 2003/11/02 by nick@llama + + Create common dialogs as child of toplevel not MainWindow + which avoids spurious raise of MainWindow. + Try using ->Popup in FBox's ->Show rather than centred. + +Change 2981 on 2003/11/02 by nick@llama + + Add -lm if perl's Configure has found it. + +Change 2980 on 2003/11/02 by nick@llama + + Steve's browseentry.t patch + +Change 2979 on 2003/11/02 by nick@llama + + Enable transparency + +Change 2978 on 2003/11/02 by nick@llama + + If site gets event (size change etc.) need + to update site info. Thanks to Scott Smedley + +Change 2977 on 2003/11/02 by nick@llama + + Tweaks for Ballon and DialogBox from "Michael Krause" + +Change 2976 on 2003/11/02 by nick@llama + + Jack's Ballon pod too + +Change 2975 on 2003/11/02 by nick@llama + + Improved Balloon.pm from "Jack" + +Change 2974 on 2003/11/01 by nick@camel + + MANIFEST stuff + +Change 2973 on 2003/11/01 by nick@camel + + Tweak icon stuff (still not working on XP?) + Now entry selection range bug is fixed test needs to reflect + that. + +Change 2972 on 2003/11/01 by nick@llama + + Naive copy/paste of old iconimage code + +Change 2971 on 2003/11/01 by nick@llama + + Slaven's patch for Gedi.pl + +Change 2970 on 2003/11/01 by nick@llama + + Fix -foreground on widgets which use Tk::Derived but + inherit from a widget which has the option (e.g. ROText from Text) + +Change 2969 on 2003/11/01 by nick@llama + + Tab focus fix - something is returning '' rather than undef now. + +Change 2966 on 2003/10/28 by nick@llama + + Update change log + +Change 2965 on 2003/10/28 by nick@llama + + Fix for spaces in HList entry name + +Change 2964 on 2003/10/28 by nick@llama + + More Slaven/Steve patches + +Change 2963 on 2003/10/28 by nick@llama + + Something almost quite unlike Dan Rawson's + patch for BrowseEntry button packing which should have same effect. + +Change 2962 on 2003/10/28 by nick@llama + + Slaven's dialog box binding (Tk800 -like) + +Change 2961 on 2003/10/28 by nick@llama + + Slaven's hlist with spaces test. + +Change 2960 on 2003/10/28 by nick@llama + + Slaven's tied SV test and fix + +Change 2959 on 2003/10/26 by nick@llama + + Steve's PNG Makefile.PL patch (RANLIB with spaces). + +Change 2958 on 2003/10/26 by nick@llama + + Try some tuning from CPANPLUS fail reports + +Change 2957 on 2003/10/26 by nick@llama + + When we are using real Xrm calls we need extra + check these days that mainwindow still exists. + +Change 2956 on 2003/10/26 by nick@llama + + LangDoCallback() as used by Entry's -validatecmd etc. was + not assuming UTF-8 (Thanks to Petr Pajas + once again for finding this.) + +Change 2954 on 2003/10/26 by nick@llama + + More panic avoidance + +Change 2953 on 2003/10/26 by nick@llama + + Avoid using unqualified 'panic' + +Change 2952 on 2003/10/26 by nick@llama + + Add some sort-s so that 5.8.1's randomized hashes + don't keep changing generated .t/.m files. + +Change 2951 on 2003/10/20 by nick@llama + + Update changes + Dist name Tk-804... rather than Tk804... + Change 2950 on 2003/10/20 by nick@llama Avoid poking our noses in the internals of objects. Index: DragDrop/DropSite.pm --- Tk-804.025_beta4/DragDrop/DropSite.pm 2003-08-17 19:54:05.000000000 +0100 +++ Tk-804.025_beta5/DragDrop/DropSite.pm 2003-11-02 20:43:27.000000000 +0000 @@ -3,7 +3,7 @@ require Tk::DragDrop::Rect; use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DropSite.pm#5 $ +$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; use base qw(Tk::DragDrop::Common Tk::DragDrop::Rect); @@ -245,6 +245,7 @@ $w->bindtags([$w->bindtags,$obj]); $w->Tk::bind($obj,'',[$obj,'DropSiteUpdate']); $w->Tk::bind($obj,'',[$obj,'DropSiteUpdate']); + $w->Tk::bind($obj,'',[$obj,'DropSiteUpdate']); $t->Tk::bind($class,'',[\&TopSiteUpdate,$t]); unless (grep($_ eq $class,$t->bindtags)) { Index: HList/HList.pm --- Tk-804.025_beta4/HList/HList.pm 2003-07-20 18:43:27.000000000 +0100 +++ Tk-804.025_beta5/HList/HList.pm 2003-11-02 20:36:32.000000000 +0000 @@ -1,7 +1,7 @@ package Tk::HList; use vars qw($VERSION); -$VERSION = '4.011'; # $Id: //depot/Tkutf8/HList/HList.pm#11 $ +$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/; use Tk qw(Ev $XS_VERSION); @@ -232,8 +232,15 @@ my $highlightthickness = $w->cget('-highlightthickness'); my $bottomy = ($w->infoBbox($ent))[3]; $bottomy += $borderwidth + $highlightthickness; - if ($w->header('exist', 0)){ $bottomy += ($w->header('size', 0))[1]; }; - if ($y > $bottomy){ return undef; } + if ($w->header('exist', 0)) + { + $bottomy += $w->header('height'); + } + if ($y > $bottomy) + { + print "$y > $bottomy\n"; + return undef; + } } my $state = $w->entrycget($ent, '-state'); return $ent if (!defined($state) || $state ne 'disabled'); Index: MANIFEST --- Tk-804.025_beta4/MANIFEST 2003-10-10 18:37:04.000000000 +0100 +++ Tk-804.025_beta5/MANIFEST 2003-11-02 09:36:58.000000000 +0000 @@ -563,7 +563,6 @@ PNG/libpng/contrib/visupng/VisualPng.png PNG/libpng/contrib/visupng/VisualPng.rc PNG/libpng/example.c -PNG/libpng/example.c.diff PNG/libpng/INSTALL PNG/libpng/KNOWNBUG PNG/libpng/libpng.3 @@ -571,14 +570,6 @@ PNG/libpng/libpngpf.3 PNG/libpng/LICENSE PNG/libpng/Makefile.maybe -PNG/libpng/makefile.vc -PNG/libpng/msvc/libpng.dsp -PNG/libpng/msvc/libpng.dsw -PNG/libpng/msvc/png.rc -PNG/libpng/msvc/png32ms.def -PNG/libpng/msvc/README.txt -PNG/libpng/msvc/zlib.def -PNG/libpng/msvc/zlib.dsp PNG/libpng/png.5 PNG/libpng/png.c PNG/libpng/png.h @@ -1851,6 +1842,7 @@ t/leak.t t/list.t t/listbox.t +t/magic.t t/mega.t t/mwm.t t/optmenu.t Index: README.darwin --- Tk-804.025_beta4/README.darwin 2003-08-04 19:56:42.000000000 +0100 +++ Tk-804.025_beta5/README.darwin 2003-10-28 21:56:16.000000000 +0000 @@ -1,14 +1,9 @@ +For Tk804.025 to build properly on Mac OS X 10.2 (Jaguar) or 10.3 +(Panther), Perl must be built dynamic, rather that the default of +static. Use a Configure incantation similar to this: -For Tk804.025 to build properly on Mac OS X 10.2.6 (Darwin), Perl must -be built dynamic, rather that the default of static. Use a Configure -incantation similar to this: - -sh Configure -des useshrplib=true [-Dprefix=/path/to/your/private/perl] - -S. Lidie, 2003/07/31 +sh Configure -des -Duseshrplib [-Dprefix=/path/to/your/private/perl] -Another style (knowing nothing of Darwin) might be: +S. Lidie, 2003/10/27 -sh Configure -des -Duseshrplib [-Dprefix=/path/to/your/private/perl] -NI-S, 2002/08/04 Index: Text/Text.pm --- Tk-804.025_beta4/Text/Text.pm 2003-07-27 16:31:19.000000000 +0100 +++ Tk-804.025_beta5/Text/Text.pm 2003-11-02 20:43:27.000000000 +0000 @@ -20,7 +20,7 @@ use Text::Tabs; use vars qw($VERSION); -$VERSION = '4.017'; # $Id: //depot/Tkutf8/Text/Text.pm#18 $ +$VERSION = sprintf '4.%03d', q$Revision: #20 $ =~ /\D(\d+)\s*$/; use Tk qw(Ev $XS_VERSION); use base qw(Tk::Clipboard Tk::Widget); @@ -1000,7 +1000,7 @@ my ($w,$find_only)=@_; my $pop = $w->Toplevel; - $pop->transient($w->MainWindow); + $pop->transient($w->toplevel); if ($find_only) { $pop->title("Find"); } else Index: Tixish/Balloon.pm --- Tk-804.025_beta4/Tixish/Balloon.pm 2003-10-06 20:15:38.000000000 +0100 +++ Tk-804.025_beta5/Tixish/Balloon.pm 2003-11-02 12:19:43.000000000 +0000 @@ -7,11 +7,15 @@ # on wether there's enough space for it. The little arrow now # should always point directly to the client. # Added by Gerhard Petrowitsch (gerhard.petrowitsch@philips.com) +# +# Nov 1, 2003 - Jack Dunnigan +# Added support for more than one screen in single logical +# screen mode (i.e. xinerama, dual monitors) package Tk::Balloon; use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; +$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/; use Tk qw(Ev Exists); use Carp; @@ -53,54 +57,35 @@ # Only the container frame's background should be black... makes it # look better. $w->configure(-background => 'black'); - my $a = $w->Frame; - my $m = $w->Frame; - my $d = $w->Frame; + # the balloon arrows - $w->{img_tl} = $w->Photo(-data => $arrows{TL}, '-format' => 'gif'); - $w->{img_tr} = $w->Photo(-data => $arrows{TR}, '-format' => 'gif'); - $w->{img_bl} = $w->Photo(-data => $arrows{BL}, '-format' => 'gif'); - $w->{img_br} = $w->Photo(-data => $arrows{BR}, '-format' => 'gif'); - $w->{img_no} = $w->Photo(-data => $arrows{NO}, '-format' => 'gif'); + $w->{img_tl} = $w->Photo(-data => $arrows{TL}, -format => 'gif'); + $w->{img_tr} = $w->Photo(-data => $arrows{TR}, -format => 'gif'); + $w->{img_bl} = $w->Photo(-data => $arrows{BL}, -format => 'gif'); + $w->{img_br} = $w->Photo(-data => $arrows{BR}, -format => 'gif'); + $w->{img_no} = $w->Photo(-data => $arrows{NO}, -format => 'gif'); $w->OnDestroy([$w, '_destroyed']); - $a->configure(-bd => 0); - $d->configure(-bd => 0); - my $atl = $a->Label(-bd => 0, - -relief => 'flat', - -image => $w->{img_no}); - $atl->pack(-side => 'top', -padx => 1, -pady => 1, -anchor => 'nw'); - my $abl = $a->Label(-bd => 0, - -relief => 'flat', - -image => $w->{img_no}); - $abl->pack(-side => 'bottom', -padx => 1, -pady => 1, -anchor => 'sw'); - my $dtr = $d->Label(-bd => 0, - -relief => 'flat', - -image => $w->{img_no}); - $dtr->pack(-side => 'top', -padx => 1, -pady => 1, -anchor => 'ne'); - my $dbr = $d->Label(-bd => 0, - -relief => 'flat', - -image => $w->{img_no}); - $dbr->pack(-side => 'bottom', -padx => 1, -pady => 1, -anchor => 'se'); + + $w->{'pointer'} = $w->Label(-bd=>0, -relief=>'flat',-image=>$w->{img_no}); + # the balloon message - $m->configure(-bd => 0); - my $ml = $m->Label(-bd => 0, - -padx => 0, - -pady => 0, - -text => $args->{-message}); + # We give the Label a big borderwidth + # ..enough to slide a 6x6 gif image along the border including some space + + my $ml = $w->Label(-bd => 10, + -padx => 0, + -pady => 0, + -justify => 'left', + -relief=>'flat'); $w->Advertise('message' => $ml); - $w->Advertise('TLarrow' => $atl); - $w->Advertise('TRarrow' => $dtr); - $w->Advertise('BLarrow' => $abl); - $w->Advertise('BRarrow' => $dbr); - $ml->pack(-side => 'left', - -anchor => 'w', - -expand => 1, - -fill => 'both', - -padx => 10, - -pady => 3); - $a->pack(-fill => 'both', -side => 'left'); - $m->pack(-fill => 'both', -side => 'left'); - $d->pack(-fill => 'both', -side => 'left'); + + $ml->pack( + -side => 'top', + -anchor => 'nw', + -expand => 1, + -fill => 'both', + -padx => 0, + -pady => 0); # append to global list of balloons push(@balloons, $w); @@ -110,6 +95,7 @@ $w->{'menu_index_over'} = 'none'; $w->{'canvas_tag'} = ''; $w->{'canvas_tag_over'} = ''; + $w->{'current_screen'} = 0; $w->ConfigSpecs(-installcolormap => ['PASSIVE', 'installColormap', 'InstallColormap', 0], -initwait => ['PASSIVE', 'initWait', 'InitWait', 350], @@ -118,14 +104,14 @@ -statusmsg => ['PASSIVE', 'statusMsg', 'StatusMsg', ''], -balloonmsg => ['PASSIVE', 'balloonMsg', 'BalloonMsg', ''], -balloonposition => ['PASSIVE', 'balloonPosition', 'BalloonPosition', 'widget'], -# -balloonanchor => ['PASSIVE', 'balloonAnchor', 'BalloonAnchor', 'nw'], -postcommand => ['CALLBACK', 'postCommand', 'PostCommand', undef], -cancelcommand => ['CALLBACK', 'cancelCommand', 'CancelCommand', undef], -motioncommand => ['CALLBACK', 'motionCommand', 'MotionCommand', undef], -background => ['DESCENDANTS', 'background', 'Background', '#C0C080'], - -foreground => ['DESCENDANTS', 'foreground', 'Foreground', undef], + -foreground => ['DESCENDANTS', 'foreground', 'Foreground', undef], -font => [$ml, 'font', 'Font', '-*-helvetica-medium-r-normal--*-120-*-*-*-*-*-*'], - -borderwidth => ['SELF', 'borderWidth', 'BorderWidth', 1] + -borderwidth => ['SELF', 'borderWidth', 'BorderWidth', 1], + -numscreens=>['PASSIVE', 'numScreens','NumScreens',1], ); } @@ -173,8 +159,6 @@ # Find which window we are over my $over = $ewin->Containing($x, $y); - #return if not defined $ewin or ((($s & 0x1f00) or $ewin->grabCurrent()) and not $ewin->isa('Tk::Menu')); -# return if $ewin->grabBad($over); return if &grabBad($ewin, $over); foreach my $w (@balloons) { @@ -198,26 +182,26 @@ $button_up = 0; } # Deactivate it if the motioncommand says to: - my $command = $w->GetOption(-motioncommand => $client); + my $command = $w->GetOption(-motioncommand => $client); $deactivate = $command->Call($client, $x, $y) if defined $command; - if ($deactivate) - { - $w->Deactivate; - } - else - { - # warn "deact: $client $w->{'client'}"; - $w->Deactivate unless $client->IS($w->{'client'}); - my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg'); - if (defined($msg)) - { - my $delay = delete $w->{'delay'}; - $delay->cancel if defined $delay; - my $initwait = $w->GetOption(-initwait => $client); - $w->{'delay'} = $client->after($initwait, sub {$w->SwitchToClient($client);}); - $w->{'client'} = $client; - } - } + if ($deactivate) + { + $w->Deactivate; + } + else + { + # warn "deact: $client $w->{'client'}"; + $w->Deactivate unless $client->IS($w->{'client'}); + my $msg = $client->BalloonInfo($w,$x,$y,'-statusmsg','-balloonmsg'); + if (defined($msg)) + { + my $delay = delete $w->{'delay'}; + $delay->cancel if defined $delay; + my $initwait = $w->GetOption(-initwait => $client); + $w->{'delay'} = $client->after($initwait, sub {$w->SwitchToClient($client);}); + $w->{'client'} = $client; + } + } } else { # cursor is at a position covered by a non client # pop down the balloon if it is up or scheduled. @@ -230,7 +214,7 @@ my ($ewin) = @_; foreach my $w (@balloons) { - $w->Deactivate; + $w->Deactivate; } } @@ -244,18 +228,16 @@ return unless Exists($w); return unless Exists($client); return unless $client->IS($w->{'client'}); - #return if $w->grabCurrent and not $client->isa('Tk::Menu'); - #return if $w->grabBad($client); return if &grabBad($w, $client); my $command = $w->GetOption(-postcommand => $client); if (defined $command) { - # Execute the user's command and return if it returns false: - my $pos = $command->Call($client); - return if not $pos; - if ($pos =~ /^(\d+),(\d+)$/) { - # Save the returned position so the Popup method can use it: - $w->{'clients'}{$client}{'postposition'} = [$1, $2]; - } + # Execute the user's command and return if it returns false: + my $pos = $command->Call($client); + return if not $pos; + if ($pos =~ /^(\d+),(\d+)$/) { + # Save the returned position so the Popup method can use it: + $w->{'clients'}{$client}{'postposition'} = [$1, $2]; + } } my $state = $w->GetOption(-state => $client); $w->Popup if ($state =~ /both|balloon/); @@ -285,6 +267,7 @@ } # end grabBad + sub Subclient { my ($w,$data) = @_; @@ -322,26 +305,27 @@ my $delay = delete $w->{'delay'}; $delay->cancel if defined $delay; if ($w->{'popped'}) { - my $client = $w->{'client'}; - my $command = $w->GetOption(-cancelcommand => $client); - if (defined $command) { - # Execute the user's command and return if it returns false: - return if not $command->Call($client); - } - $w->withdraw; - $w->ClearStatus; - $w->{'popped'} = 0; - $w->{'menu_index'} = 'none'; - $w->{'canvas_tag'} = ''; + my $client = $w->{'client'}; + my $command = $w->GetOption(-cancelcommand => $client); + if (defined $command) { + # Execute the user's command and return if it returns false: + return if not $command->Call($client); + } + $w->withdraw; + $w->ClearStatus; + $w->{'popped'} = 0; + $w->{'menu_index'} = 'none'; + $w->{'canvas_tag'} = ''; } $w->{'client'} = undef; $w->{'subclient'} = undef; + $w->{'location'} = undef; } sub Popup { my ($w) = @_; if ($w->cget(-installcolormap)) { - $w->colormapwindows($w->winfo('toplevel')) + $w->colormapwindows($w->winfo('toplevel')) } my $client = $w->{'client'}; return if not defined $client or not exists $w->{'clients'}{$client}; @@ -358,69 +342,217 @@ my ($x, $y); my $pos = $w->GetOption(-balloonposition => $client); -# my $anc = $w->GetOption(-balloonanchor => $client); my $postpos = delete $w->{'clients'}{$client}{'postposition'}; if (defined $postpos) { - # The postcommand must have returned a position for the balloon - I will use that: - ($x, $y) = @{$postpos}; + # The postcommand must have returned a position for the balloon - I will use that: + ($x,$y) = @{$postpos}; } elsif ($pos eq 'mouse') { - $x = int($client->pointerx + 10); - $y = int($client->pointery + 10); + ($x,$y)=$client->pointerxy; # We adjust the position later } elsif ($pos eq 'widget') { - $x = int($client->rootx + $client->width/2); - $y = int($client->rooty + int ($client->height/1.3)); + $x = int($client->rootx + $client->width/2); + $y = int($client->rooty + int ($client->height/1.3)); } else { - croak "'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'."; + croak "'$pos' is not a valid position for the balloon - it must be one of: 'widget', 'mouse'."; } $w->idletasks; - my($width, $height) = ($w->reqwidth, $w->reqheight); - my($xx, $yy) = ($x,$y); - my $ex = 0; - if ($x + $width > $w->screenwidth) { - $ex |= 1; - } - if ($y + $height > $w->screenheight) { - $ex |= 2; - } - if ($ex == 0) { - $w->Subwidget('TLarrow')->configure(-image => $w->{img_tl}); - $w->Subwidget('TRarrow')->configure(-image => $w->{img_no}); - $w->Subwidget('BLarrow')->configure(-image => $w->{img_no}); - $w->Subwidget('BRarrow')->configure(-image => $w->{img_no}); - ($xx,$yy) = ($x,$y); - } elsif ($ex == 1) { - $w->Subwidget('TLarrow')->configure(-image => $w->{img_no}); - $w->Subwidget('TRarrow')->configure(-image => $w->{img_tr}); - $w->Subwidget('BLarrow')->configure(-image => $w->{img_no}); - $w->Subwidget('BRarrow')->configure(-image => $w->{img_no}); - $x = int($client->pointerx - 2) if ($pos eq 'mouse'); - ($xx,$yy) = ($x-$width,$y); - } elsif ($ex == 2) { - $w->Subwidget('TLarrow')->configure(-image => $w->{img_no}); - $w->Subwidget('TRarrow')->configure(-image => $w->{img_no}); - $w->Subwidget('BLarrow')->configure(-image => $w->{img_bl}); - $w->Subwidget('BRarrow')->configure(-image => $w->{img_no}); - $x = int($client->pointerx + 2) if ($pos eq 'mouse'); - $y = int($client->pointery - 2) if ($pos eq 'mouse'); - $y = int($client->rooty + int ($client->height/4.3)) if ($pos eq 'widget'); - ($xx,$yy) = ($x,$y-$height); - } else { - $w->Subwidget('TLarrow')->configure(-image => $w->{img_no}); - $w->Subwidget('TRarrow')->configure(-image => $w->{img_no}); - $w->Subwidget('BLarrow')->configure(-image => $w->{img_no}); - $w->Subwidget('BRarrow')->configure(-image => $w->{img_br}); - $x = int($client->pointerx - 2) if ($pos eq 'mouse'); - $y = int($client->pointery - 2) if ($pos eq 'mouse'); - $y = int($client->rooty + int ($client->height/4.3)) if ($pos eq 'widget'); - ($xx,$yy) = ($x-$width,$y-$height); + + # Explanation of following code. [JD] + # PREMISE: We want to ensure that the balloon is always "on screen". + # To do this we use calculate the size of the + # toplevel before it is mapped. Then we adjust it's position with respect to the + # mouse cursor or widget. Balloons are usually shown below and to the right of the target. + # From extensive KDE experience using Xinerama, and from using dual monitors on WinXP.. + # the balloon will extend across two monitors in single logical screen mode (SLS). + # This is an undesirable characteristic indeed. Trying to read a disjointed balloon + # across monitors is not fun. + # + # The intent of the following code is to fix this problem. We do this by avoiding + # placement of any part of the balloon over,say, the "half screenwidth" mark (for two + # monitors in SLS mode) or "thirds of screenwidth" mark (for 3 monitors) and so on... + # i.e. In SLS mode these *WILL BE* separate screens and as such, should be considered hard + # boundaries to be avoided. + # + # The only drawback of this code, is I know of no way to actually determine this on a + # user by user basis. This means that the developer or administrator will have to know + # the hardware (monitor) setup for which the application is designed. + # + # This code uses Gerhard's GIF images but changes *how* the image gets shown. Instead + # of creating four separate labels, we configure only ONE label with the proper image. + # Then using the place geometry manager, this image/label can be "slid" along the + # appropriate side of the toplevel so that it always points directly at the target widget. + # + # Here we go.. + + my ($width, $height) = ($w->reqwidth, $w->reqheight); + my ($sw, $sh) = ($w->screenwidth, $w->screenheight); + my $numscreen = $w->cget(-numscreens); + my $deltax = $sw/$numscreen; + my $leftedge; + my $rightedge; + my $count = 0; + for (my $i=0; $i<$sw; $i+=$deltax){ + $leftedge = $i; + $rightedge = $i + $deltax; + if ($x >= $leftedge && $x < $rightedge ){ + last; + } + $count++; } + # Force another look at balloon location because mouse has switched + # virtual screens. + $w->{'location'} = undef unless ( $count == $w->{'current_screen'} ); + $w->{'current_screen'} = $count; + + my $xx=undef; + my $yy=undef; # to hold final toplevel placement + my $slideOffsetX = 0; + my $slideOffsetY = 0; + my $testtop = $y - $height; + my $testbottom = $y + $height; + my $testright = $x + $width; + my $testleft = $x - $width; + my $vert='bottom'; #default + my $horiz='right'; #default + + if ( defined $w->{'location'} ){ + # Once balloon is activated, **don't** change the location of the balloon. + # It is annoying to have it jump from one location to another. + ( $w->{'location'}=~/top/ ) ? ( $vert = 'top' ) : ( $vert = 'bottom' ); + ( $w->{'location'}=~/left/ ) ? ( $horiz = 'left' ) : ( $horiz = 'right' ); + + if ($vert eq 'top' && $testtop < 0) { + $yy = 0; + $slideOffsetY = $testtop; + } + elsif ($vert eq 'bottom' && $testbottom > $sh) { + $slideOffsetY = $testbottom - $sh; + } + + if ($horiz eq 'left' && $testleft < $leftedge) { + $xx = $leftedge; + } + elsif ($horiz eq 'right' && $testright > $rightedge) { + $slideOffsetX = $testright - $rightedge; + } + } + else { + #Test balloon positions in the vertical + if ($testbottom > $sh) { + #Then offscreen to bottom, check top + if ($testtop >= 0) { + $vert = 'top'; + } + elsif ($y > $sh/2) { + #still offscreen to top but there is more room above then below + $vert = 'top'; + $yy=0; + $slideOffsetY = $testtop; + } + if ($vert eq 'bottom'){ + #Calculate Yoffset to fit entire balloon onto screen + $slideOffsetY = $testbottom - $sh; + } + } + #Test balloon positions in the horizontal + + if ($testright > $rightedge) { + #The offscreen, check left + if ($testleft >= $leftedge) { + $horiz = 'left'; + } + elsif ($x > ($leftedge+$deltax) ) { + #still offscreen to left but there is more room to left than right + $horiz = 'left'; + $xx=0; + $slideOffsetX = $testleft; + } + if ($horiz eq 'right'){ + #Calculate Xoffset to fit entire balloon onto screen + $slideOffsetX = $testright - $rightedge; + } + } + } + + $w->{'location'} = $vert.$horiz unless (defined $w->{'location'}); + + if ($w->{'location'} eq 'bottomright') { + if ($slideOffsetX and $slideOffsetY) { + $w->{'pointer'}->configure(-image => $w->{img_no}); + } + else { + $w->{'pointer'}->configure(-image => $w->{img_tl}); + } + + $w->{'pointer'}->place( + -in=>$w, + -relx=>0, -x=>$slideOffsetX + 2, + -rely=>0, -y=>$slideOffsetY + 2, + -bordermode=>'outside', + -anchor=>'nw'); + # Keep corner away from pointer. + # It is okay if it goes offscreen a little, because of our 10 pixel borderwidth + $xx=$x-$slideOffsetX+10 unless (defined $xx); + $yy=$y-$slideOffsetY+10 unless (defined $yy); + + } + elsif ($w->{'location'} eq 'bottomleft') { + if ($slideOffsetX and $slideOffsetY) { + $w->{'pointer'}->configure(-image => $w->{img_no}); + } + else { + $w->{'pointer'}->configure(-image => $w->{img_tr}); + } + + $w->{'pointer'}->place(-in=>$w, + -relx=>1, -x=>$slideOffsetX - 2, + -rely=>0, -y=>$slideOffsetY + 2, + -bordermode=>'outside', + -anchor=>'ne'); + $xx=$x-$width-$slideOffsetX-5 unless (defined $xx); + $yy=$y-$slideOffsetY+10 unless (defined $yy); + + } + elsif ($w->{'location'} eq 'topright') { + if ($slideOffsetX and $slideOffsetY) { + $w->{'pointer'}->configure(-image => $w->{img_no}); + } + else { + $w->{'pointer'}->configure(-image => $w->{img_bl}); + } + + $w->{'pointer'}->place(-in=>$w, + -relx=>0, -x=>$slideOffsetX + 2, + -rely=>1, -y=>$slideOffsetY - 2, + -bordermode=>'outside', + -anchor=>'sw'); + $xx=$x-$slideOffsetX+5 unless (defined $xx); + $yy=$y-$height-$slideOffsetY-5 unless (defined $yy); + } + elsif ($w->{'location'} eq 'topleft') { + if ($slideOffsetX and $slideOffsetY) { + $w->{'pointer'}->configure(-image => $w->{img_no}); + } + else { + $w->{'pointer'}->configure(-image => $w->{img_br}); + } + + $w->{'pointer'}->place(-in=>$w, + -relx=>1, -x=>$slideOffsetX - 2, + -rely=>1, -y=>$slideOffsetY - 2, + -bordermode=>'outside', + -anchor=>'se'); + $xx=$x-$width-$slideOffsetX-5 unless (defined $xx); + $yy=$y-$height-$slideOffsetY-5 unless (defined $yy); + } + + $w->{'pointer'}->raise; + $xx = int($xx); + $yy = int($yy); $w->geometry("+$xx+$yy"); - #$w->MoveToplevelWindow($x,$y); $w->deiconify(); $w->raise; - #$w->update; # This can cause confusion by processing more Motion events before this one has finished. } sub SetStatus { @@ -428,16 +560,16 @@ my $client = $w->{'client'}; my $s = $w->GetOption(-statusbar => $client); if (defined $s and $s->winfo('exists')) { - my $vref = $s->cget(-textvariable); - return if not defined $client or not exists $w->{'clients'}{$client}; - my $msg = $client->BalloonInfo($w, $w->pointerxy,'-statusmsg'); - # Dereference it if it looks like a scalar reference: - $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR'); - if (not defined $vref) { - eval { $s->configure(-text => $msg); }; - } else { - $$vref = $msg; - } + my $vref = $s->cget(-textvariable); + return if not defined $client or not exists $w->{'clients'}{$client}; + my $msg = $client->BalloonInfo($w, $w->pointerxy,'-statusmsg'); + # Dereference it if it looks like a scalar reference: + $msg = $$msg if UNIVERSAL::isa($msg, 'SCALAR'); + if (not defined $vref) { + eval { $s->configure(-text => $msg); }; + } else { + $$vref = $msg; + } } } @@ -455,8 +587,7 @@ } } -sub _destroyed -{ +sub _destroyed { my ($w) = @_; # This is called when widget is destroyed (no matter how!) # via the ->OnDestroy hook set in Populate. @@ -469,9 +600,10 @@ # Delete the images for (qw(no tl tr bl br)) { my $img = delete $w->{"img_$_"}; - $img->delete if defined $img; + $img->delete if defined $img; } } 1; + Index: Tixish/BrowseEntry.pm --- Tk-804.025_beta4/Tixish/BrowseEntry.pm 2003-07-24 22:32:18.000000000 +0100 +++ Tk-804.025_beta5/Tixish/BrowseEntry.pm 2003-10-28 21:48:50.000000000 +0000 @@ -8,7 +8,7 @@ package Tk::BrowseEntry; use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /#(\d+)/; +$VERSION = sprintf '4.%03d', q$Revision: #11 $ =~ /#(\d+)/; use Tk qw(Ev); use Carp; @@ -56,7 +56,14 @@ my $b = $w->$Button(-bitmap => '@' . Tk->findINC($w->{_BE_Style} eq 'MSWin32' ? 'arrowdownwin.xbm' : 'cbxarrow.xbm')); $w->Advertise('entry' => $e); $w->Advertise('arrow' => $b); - $b->pack(-side => 'right', -padx => 1); + + # Pack the button to align vertically with the entry widget + my @anch; + my $edge = {@$lpack}->{-side}; + push(@anch,-anchor => 's') if ($edge && $edge eq 'top'); + push(@anch,-anchor => 'n') if ($edge && $edge eq 'bottom'); + $b->pack(-side => 'right', -padx => 1, @anch); + $e->pack(-side => 'right', -fill => 'x', -expand => 1); #XXX, -padx => 1); # popup shell for listbox with values. Index: Tixish/DialogBox.pm --- Tk-804.025_beta4/Tixish/DialogBox.pm 2003-07-20 18:43:28.000000000 +0100 +++ Tk-804.025_beta5/Tixish/DialogBox.pm 2003-11-02 20:43:27.000000000 +0000 @@ -9,7 +9,7 @@ use Carp; use vars qw($VERSION); -$VERSION = '4.009'; # $Id: //depot/Tkutf8/Tixish/DialogBox.pm#9 $ +$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; use base qw(Tk::Toplevel); @@ -62,6 +62,7 @@ $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); } $cw->{'default_button'} = $b; + $cw->bind('' => [ $b, 'Invoke']); } else { $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); } @@ -119,4 +120,11 @@ return $cw->{'selected_button'}; } +sub Exit +{ + my $cw = shift; + #kill the dialogbox, by faking a 'DONE' + $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text); +} + 1; Index: Tk.pm --- Tk-804.025_beta4/Tk.pm 2003-09-13 11:28:04.000000000 +0100 +++ Tk-804.025_beta5/Tk.pm 2003-11-02 19:12:22.000000000 +0000 @@ -61,7 +61,7 @@ use Carp; # Record author's perforce depot record -$Tk::CHANGE = q$Change: 2901 $; +$Tk::CHANGE = q$Change: 2982 $; # $tk_version and $tk_patchLevel are reset by pTk when a mainwindow # is created, $VERSION is checked by bootstrap @@ -346,7 +346,7 @@ $w->withdraw; $created = 1; } - my $mw = $w->MainWindow; + my $mw = $w->toplevel; my $fs = $mw->{$kind}; unless (defined $fs) { @@ -624,8 +624,11 @@ { return 0 if ($value eq '0'); return $w->viewable if ($value eq '1'); - $value = $w->$value(); - return $value if (defined $value); + if ($value) + { + $value = $w->$value(); + return $value if (defined $value); + } } if (!$w->viewable) { Index: Tk/Derived.pm --- Tk-804.025_beta4/Tk/Derived.pm 2003-07-20 18:43:28.000000000 +0100 +++ Tk-804.025_beta5/Tk/Derived.pm 2003-11-01 20:32:45.000000000 +0000 @@ -8,7 +8,7 @@ use Carp; use vars qw($VERSION); -$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/Derived.pm#8 $ +$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/; $Tk::Derived::Debug = 0; @@ -336,14 +336,16 @@ unless (exists($specs->{'-background'})) { - my (@bg) = ('SELF'); + Tk::catch { $cw->Tk::cget('-foreground') }; + my (@bg) = $@ ? ('PASSIVE') : ('SELF'); push(@bg,'CHILDREN') if $child; $specs->{'-background'} = [\@bg,'background','Background',NORMAL_BG]; } unless (exists($specs->{'-foreground'})) { - my (@fg) = ('PASSIVE'); - unshift(@fg,'CHILDREN') if $child; + Tk::catch { $cw->Tk::cget('-foreground') }; + my (@fg) = $@ ? ('PASSIVE') : ('SELF'); + push(@fg,'CHILDREN') if $child; $specs->{'-foreground'} = [\@fg,'foreground','Foreground',BLACK]; } $cw->ConfigAlias(-fg => '-foreground', -bg => '-background'); Index: Tk/FBox.pm --- Tk-804.025_beta4/Tk/FBox.pm 2003-09-13 11:28:04.000000000 +0100 +++ Tk-804.025_beta5/Tk/FBox.pm 2003-11-02 20:43:27.000000000 +0000 @@ -39,7 +39,7 @@ use strict; use vars qw($VERSION $updirImage $folderImage $fileImage); -$VERSION = '4.012'; # $Id: //depot/Tkutf8/Tk/FBox.pm#14 $ +$VERSION = sprintf '4.%03d', q$Revision: #16 $ =~ /\D(\d+)\s*$/; use base qw(Tk::Toplevel); @@ -295,16 +295,6 @@ } $w->UpdateWhenIdle; - # Withdraw the window, then update all the geometry information - # so we know how big it wants to be, then center the window in the - # display and de-iconify it. -#XXX use Tk::Wm::Popup? or Tk::PlaceWindow? - $w->withdraw; - $w->idletasks; - my $x = int($w->screenwidth / 2 - $w->reqwidth / 2 - $w->parent->vrootx); - my $y = int($w->screenheight / 2 - $w->reqheight / 2 - $w->parent->vrooty); - $w->geometry("+$x+$y"); - { my $title = $w->cget(-title); if (!defined $title) { @@ -315,7 +305,24 @@ $w->title($title); } - $w->deiconify; + # Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display and de-iconify it. + $w->withdraw; + $w->idletasks; + if (0) + { + #XXX use Tk::Wm::Popup? or Tk::PlaceWindow? + my $x = int($w->screenwidth / 2 - $w->reqwidth / 2 - $w->parent->vrootx); + my $y = int($w->screenheight / 2 - $w->reqheight / 2 - $w->parent->vrooty); + $w->geometry("+$x+$y"); + $w->deiconify; + } + else + { + $w->Popup; + } + # Set a grab and claim the focus too. #XXX use Tk::setFocusGrab when it's available my $oldFocus = $w->focusCurrent; Index: Tk/MMutil.pm --- Tk-804.025_beta4/Tk/MMutil.pm 2003-09-07 11:15:37.000000000 +0100 +++ Tk-804.025_beta5/Tk/MMutil.pm 2003-11-02 20:43:27.000000000 +0000 @@ -9,7 +9,7 @@ use File::Basename; use vars qw($VERSION); -$VERSION = '4.017'; # $Id: //depot/Tkutf8/Tk/MMutil.pm#17 $ +$VERSION = sprintf '4.%03d', q$Revision: #19 $ =~ /\D(\d+)\s*$/; # warn __FILE__." $VERSION\n"; @@ -526,6 +526,13 @@ # 'dynamic_lib' => { INST_DYNAMIC_DEP => "$ptk/libpTk\$(LIB_EXT)" } ); } + # Several loadable widgets use things from -lm + # if platform does not have a shared -lm need to link against it + if ($Config{libs} =~/-lm\b/) + { + my $libs = $att{'LIBS'}->[0]; + $att{'LIBS'}->[0] = "$libs -lm" unless $libs =~ /-lm\b/; + } if ($IsWin32 && $Config{'cc'} =~ /^bcc/) { # Borland compiler is very dumb at finding files Index: Tk/Photo.pm --- Tk-804.025_beta4/Tk/Photo.pm 2003-09-27 21:19:44.000000000 +0100 +++ Tk-804.025_beta5/Tk/Photo.pm 2003-11-02 17:42:41.000000000 +0000 @@ -1,7 +1,7 @@ package Tk::Photo; use vars qw($VERSION); -$VERSION = sprintf '4.%03d', 4+q$Revision: #2 $ =~ /\D(\d+)\s*$/; +$VERSION = sprintf '4.%03d', 4+q$Revision: #3 $ =~ /\D(\d+)\s*$/; use Tk qw($XS_VERSION); @@ -11,7 +11,8 @@ sub Tk_image { 'photo' } -Tk::Methods('blank','copy','data','formats','get','put','read','redither','write'); +Tk::Methods('blank','copy','data','formats','get','put','read', + 'redither','transparency','write'); 1; __END__ Index: demos/demos/widget_lib/WidgetDemo.pm --- Tk-804.025_beta4/demos/demos/widget_lib/WidgetDemo.pm 2003-08-07 20:11:14.000000000 +0100 +++ Tk-804.025_beta5/demos/demos/widget_lib/WidgetDemo.pm 2003-11-02 20:43:27.000000000 +0000 @@ -3,7 +3,7 @@ use 5.005_03; use vars qw($VERSION); -$VERSION = '4.007'; # $Id: //depot/Tkutf8/demos/demos/widget_lib/WidgetDemo.pm#9 $ +$VERSION = sprintf '4.%03d', q$Revision: #11 $ =~ /\D(\d+)\s*$/; use Tk 800.000; use Carp; @@ -78,10 +78,14 @@ $dismiss->pack(qw/-side left -expand 1/); $see->pack(qw/-side left -expand 1/); $msg->pack; - $demo_frame->pack(qw/-fill both/); + $demo_frame->pack(qw/-fill both -expand 1 -anchor n/); } elsif ($gm eq 'grid') { $msg->grid; - $demo_frame->grid; + $demo_frame->grid(-sticky => "news"); + $demo_frame->gridColumnconfigure(0,-weight=>1); + $demo_frame->gridRowconfigure(0,-weight=>1); + $self->gridColumnconfigure(qw/0 -weight 1/); + $self->gridRowconfigure(qw/1 -weight 1/); $buttons->grid(qw/-pady 2m -sticky ew/); $buttons->gridColumnconfigure(qw/0 -weight 1/); $buttons->gridColumnconfigure(qw/1 -weight 1/); @@ -115,7 +119,7 @@ @label_attributes = @$text[1 .. $#{$text}]; $text = $text->[0]; } - + $self->{msg}->configure( -text => $text, @label_attributes, Index: demos/demos/widtrib/Gedi.pl --- Tk-804.025_beta4/demos/demos/widtrib/Gedi.pl 2003-07-27 10:27:21.000000000 +0100 +++ Tk-804.025_beta5/demos/demos/widtrib/Gedi.pl 2003-11-01 20:34:59.000000000 +0000 @@ -29,20 +29,20 @@ my $pop = $TOP->Toplevel(); $pop->title("About"); - $pop->Label(text=>"Gedi (Gregs EDItor)")->pack(); - $pop->Label(text=>"Ver. 1.0")->pack(); - $pop->Label(text=>"Copyright 1999")->pack(); - $pop->Label(text=>"Greg London")->pack(); - $pop->Label(text=>"All Rights Reserved.")->pack(); - $pop->Label(text=>"This program is free software.")->pack(); - $pop->Label(text=>"You can redistribute it and/or")->pack(); - $pop->Label(text=>"modify it under the same terms")->pack(); - $pop->Label(text=>"as Perl itself.")->pack(); - $pop->Label(text=>"Special Thanks to")->pack(); - $pop->Label(text=>"Nick Ing-Simmons.")->pack(); + $pop->Label(-text=>"Gedi (Gregs EDItor)")->pack(); + $pop->Label(-text=>"Ver. 1.0")->pack(); + $pop->Label(-text=>"Copyright 1999")->pack(); + $pop->Label(-text=>"Greg London")->pack(); + $pop->Label(-text=>"All Rights Reserved.")->pack(); + $pop->Label(-text=>"This program is free software.")->pack(); + $pop->Label(-text=>"You can redistribute it and/or")->pack(); + $pop->Label(-text=>"modify it under the same terms")->pack(); + $pop->Label(-text=>"as Perl itself.")->pack(); + $pop->Label(-text=>"Special Thanks to")->pack(); + $pop->Label(-text=>"Nick Ing-Simmons.")->pack(); - my $button_ok = $pop->Button(text=>'OK', - command => sub {$pop->destroy(); + my $button_ok = $pop->Button(-text=>'OK', + -command => sub {$pop->destroy(); $about_pop_up_reference = undef; } ) ->pack(); Index: myConfig --- Tk-804.025_beta4/myConfig 2003-08-31 22:45:13.000000000 +0100 +++ Tk-804.025_beta5/myConfig 2003-11-01 11:06:00.000000000 +0000 @@ -28,7 +28,7 @@ { # This is the author - catch as many bugs as possible $gccopt .= " -MMD -Werror -Wno-format"; - @macro = ( macro => { INSTALLDIRS => 'perl' }); +# @macro = ( macro => { INSTALLDIRS => 'perl' }); } } } Index: objGlue.c --- Tk-804.025_beta4/objGlue.c 2003-10-20 20:14:11.000000000 +0100 +++ Tk-804.025_beta5/objGlue.c 2003-10-28 21:24:26.000000000 +0000 @@ -478,6 +478,14 @@ { if (SvROK(sv) && SvPOK(SvRV(sv)) && !SvUTF8(SvRV(sv))) sv_utf8_upgrade(SvRV(sv)); + /* FIXME: Slaven's quick fix for magical (tied) SVs with only SvPOKp */ + else if (SvPOKp(sv) && !SvPOK(sv)) + { + SvPOK_on(sv); + sv_utf8_upgrade(sv); + SvPOK_off(sv); + SvPOKp_on(sv); + } else if (!SvUTF8(sv)) sv_utf8_upgrade(sv); return SvPV_nolen(sv); Index: pTk/mTk/tixGeneric/tixHLHdr.c --- Tk-804.025_beta4/pTk/mTk/tixGeneric/tixHLHdr.c 2003-07-27 17:45:25.000000000 +0100 +++ Tk-804.025_beta5/pTk/mTk/tixGeneric/tixHLHdr.c 2003-11-02 20:24:52.000000000 +0000 @@ -25,6 +25,7 @@ static TIX_DECLARE_SUBCMD(Tix_HLHdrDelete); static TIX_DECLARE_SUBCMD(Tix_HLHdrExist); static TIX_DECLARE_SUBCMD(Tix_HLHdrSize); +static TIX_DECLARE_SUBCMD(Tix_HLHdrHeight); static void FreeWindowItem _ANSI_ARGS_((Tcl_Interp *interp, WidgetPtr wPtr, HListHeader *hPtr)); @@ -348,6 +349,8 @@ "column"}, {TIX_DEFAULT_LEN, "size", 1, 1, Tix_HLHdrSize, "column"}, + {TIX_DEFAULT_LEN, "height", 0, 0, Tix_HLHdrHeight, + ""}, }; static Tix_CmdInfo cmdInfo = { Tix_ArraySize(subCmdInfo), 1, TIX_VAR_ARGS, "?option? ?arg ...?", @@ -577,3 +580,25 @@ Tix_DItemHeight(hPtr->iPtr)); return TCL_OK; } + +/*---------------------------------------------------------------------- + * "header height" sub command + *---------------------------------------------------------------------- + */ +static int +Tix_HLHdrHeight(clientData, interp, argc, argv) + ClientData clientData; + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + WidgetPtr wPtr = (WidgetPtr) clientData; + + if (wPtr->headerDirty) { + Tix_HLComputeHeaderGeometry(wPtr); + } + + Tcl_SetObjResult(interp,Tcl_NewIntObj(wPtr->headerHeight)); + return TCL_OK; +} + Index: pTk/mTk/tixGeneric/tixHList.c --- Tk-804.025_beta4/pTk/mTk/tixGeneric/tixHList.c 2003-09-04 19:45:18.000000000 +0100 +++ Tk-804.025_beta5/pTk/mTk/tixGeneric/tixHList.c 2003-10-28 22:30:46.000000000 +0000 @@ -1203,6 +1203,10 @@ int i, m, n; char column[20]; + /* A hack to make result a list */ + Tcl_Obj *result = Tcl_NewListObj(0,NULL); + Tcl_SetObjResult(interp,result); + if (argc != 2) { return Tix_ArgcError(interp, argc+3, argv-3, 3, "x y"); } Index: pTk/mTk/win/tkWinWm.c --- Tk-804.025_beta4/pTk/mTk/win/tkWinWm.c 2003-07-28 19:48:04.000000000 +0100 +++ Tk-804.025_beta5/pTk/mTk/win/tkWinWm.c 2003-11-02 09:36:58.000000000 +0000 @@ -7331,6 +7331,48 @@ int objc; Tcl_Obj *CONST objv[]; { + register WmInfo *wmPtr = winPtr->wmInfoPtr; + Pixmap pixmap; + + if ((objc != 3) && (objc != 4)) { + Tcl_AppendResult(interp, "wrong # arguments: must be \"", + argv[0], " iconimage window ?image?\"", + (char *) NULL); + return TCL_ERROR; + } + if (objc == 3) { + if (wmPtr->hints.flags & IconPixmapHint && wmPtr->iconImage) { + interp->result = Tk_NameOfBitmap(winPtr->display, + wmPtr->hints.icon_pixmap); + } + return TCL_OK; + } + /* clear any existing pixmap hints and free associated resources */ + if (wmPtr->hints.icon_pixmap != None) { + if (wmPtr->iconImage) { + Tk_FreePixmap(winPtr->display, wmPtr->hints.icon_pixmap); + } else { + Tk_FreeBitmap(winPtr->display, wmPtr->hints.icon_pixmap); + } + wmPtr->hints.icon_pixmap = None; + } + if (wmPtr->iconImage) { + Tk_FreeImage(wmPtr->iconImage); + wmPtr->iconImage = NULL; + } + wmPtr->hints.flags &= ~IconPixmapHint; + wmPtr->iconImage = Tk_GetImage(interp, tkwin, argv[3], + ImageChangedProc, (ClientData) winPtr); + if (wmPtr->iconImage != NULL) { + int width = 0; + int height = 0; + Tk_SizeOfImage(wmPtr->iconImage, &width, &height); + ImageChangedProc((ClientData) winPtr, 0, 0, width, height, width, height); + } else { + UpdateIcon(winPtr); + return TCL_ERROR; + } + return TCL_OK; } Index: pod/Balloon.pod --- Tk-804.025_beta4/pod/Balloon.pod 2003-07-19 15:29:41.000000000 +0100 +++ Tk-804.025_beta5/pod/Balloon.pod 2003-11-02 11:51:45.000000000 +0000 @@ -149,6 +149,14 @@ response will appear slow and consume a lot of CPU time (it is executed every time the mouse moves over the widgets the balloon is attached to). +=item B<-numscreens> + +This option accepts an integer 1 or greater. This option should be used +to avoid disjointed balloons across multiple screens in single logical +sceen (SLS) mode. This only currently works in the horizontal direction. +Example: If you are running dual screens in SLS mode then you would set +this value to 2. Default value is 1. + =back =head1 METHODS @@ -260,6 +268,9 @@ B added intelligent positioning +B Made positioning I intelligent and +added support for multiple monitors under single logical screen. + =head1 HISTORY The code and documentation was derived from Balloon.tcl from the @@ -268,3 +279,4 @@ =cut + Index: t/browseentry.t --- Tk-804.025_beta4/t/browseentry.t 2003-08-17 19:57:14.000000000 +0100 +++ Tk-804.025_beta5/t/browseentry.t 2003-11-02 17:56:46.000000000 +0000 @@ -24,11 +24,11 @@ my $listcmd = sub { @listcmd = @_ }; my $browsecmd = sub { @browsecmd = @_ }; -my $bla; -my $be = $mw->BrowseEntry(-listcmd => $listcmd, +my( $bla, $be ); +eval { $be = $mw->BrowseEntry(-listcmd => $listcmd, -browsecmd => $browsecmd, -textvariable => \$bla, - )->pack; + )->pack; }; ok("$@", "", "can't create BrowseEntry"); ok(Tk::Exists($be), 1, "BrowseEntry creation failed"); @@ -56,10 +56,11 @@ "wrong 1st argument in -browsecmd"); ok($browsecmd[1], 1, "wrong 2nd argument in -browsecmd"); -my $be2 = $mw->BrowseEntry(-choices => [qw/a b c d e/], +my $be2; +eval { $be2 = $mw->BrowseEntry(-choices => [qw/a b c d e/], -textvariable => \$bla, -state => "normal", - )->pack; + )->pack; }; ok("$@", "", "can't create BrowseEntry"); ok(Tk::Exists($be2), 1, "BrowseEntry creation failed"); Index: t/entry.t --- Tk-804.025_beta4/t/entry.t 2003-10-26 17:49:21.000000000 +0000 +++ Tk-804.025_beta5/t/entry.t 2003-11-02 09:36:58.000000000 +0000 @@ -1141,7 +1141,7 @@ # last selected range. When selection ownership is restored to # entry, the old range will be rehighlighted. - ok($e->getSelected, '123456'); + ok($e->getSelected, '12345'); ok($e->index("sel.first"), 1); } Index: t/magic.t --- /dev/null 2003-03-14 13:07:09.000000000 +0000 +++ Tk-804.025_beta5/t/magic.t 2003-10-28 21:16:16.000000000 +0000 @@ -0,0 +1,13 @@ +#!/usr/bin/perl +# -*- perl -*- +use strict; +use Test; +use Tk; + +plan tests => 1; + +my $mw = MainWindow->new; +my $foo = "\260"; +$mw->Label(-textvariable => \$foo); +ok($foo, "\260"); + Index: t/zzHList.t --- Tk-804.025_beta4/t/zzHList.t 2003-07-19 09:39:42.000000000 +0100 +++ Tk-804.025_beta5/t/zzHList.t 2003-10-28 21:26:05.000000000 +0000 @@ -5,7 +5,7 @@ use Test; use Tk; -BEGIN { plan tests => 22 }; +BEGIN { plan tests => 23 }; my $mw = Tk::MainWindow->new; eval { $mw->geometry('+10+10'); }; # This works for mwm and interactivePlacement @@ -21,6 +21,12 @@ ok($@, "", '$hlist->grid problem'); eval { $hlist->update; }; ok($@, "", '$hlist->update problem.'); + + $hlist->delete("all"); + $hlist->add("entry with spaces"); + my @bbox = $hlist->info('bbox', 'entry with spaces'); + my @info = $hlist->info('item', @bbox[0, 1]); + ok($info[0], 'entry with spaces', 'Problems with spaces in entry path'); } ## ## With Tk800.004: __END_OF_PATCH__