# strip everything before this # cd to your version of Tk-804.025_beta9 # and feed this file to /bin/sh # # touch t/TkTest.pm chmod 0444 t/TkTest.pm patch -p1 -N <<'__END_OF_PATCH__' Index: Change.log --- Tk-804.025_beta9/Change.log 2003-12-10 22:31:06.000000000 +0000 +++ Tk-804.025_beta10/Change.log 2003-12-14 19:46:51.000000000 +0000 @@ -1,3 +1,43 @@ +Change 3042 on 2003/12/14 by nick@llama + + Switch $VERSION stuff to new style when file + has been touched. + +Change 3040 on 2003/12/14 by nick@llama + + Slaven's Entry more like Tcl patch. Nick is not entierly + convinced by the Selection hackery here is an improvement. + +Change 3039 on 2003/12/13 by nick@llama + + Slaven's ToDo additions and listbox test + +Change 3038 on 2003/12/13 by nick@llama + + MANIFEST cleanup + +Change 3037 on 2003/12/13 by nick@llama + + Heuristics for command line parse - ignore things + after -unknown - and no croaks only warn + +Change 3036 on 2003/12/13 by nick@llama + + Slaven's Listbox patches + +Change 3035 on 2003/12/13 by nick@llama + + Slaven's FBox patches + +Change 3034 on 2003/12/13 by nick@llama + + Avoid a core dump if tkUnixFont cannot find (e.g.) Korean + glyph. + +Change 3033 on 2003/12/13 by nick@llama + + Fixup beta9 MANIFEST issues etc. + Change 3032 on 2003/12/10 by nick@llama Makefile generation tweaks: Index: DragDrop/DragDrop.pm --- Tk-804.025_beta9/DragDrop/DragDrop.pm 2003-08-17 19:54:05.000000000 +0100 +++ Tk-804.025_beta10/DragDrop/DragDrop.pm 2003-12-14 19:44:50.000000000 +0000 @@ -4,7 +4,7 @@ require Tk::Label; use vars qw($VERSION); -$VERSION = '4.012'; # $Id: //depot/Tkutf8/DragDrop/DragDrop.pm#13 $ +$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; use base qw(Tk::DragDrop::Common Tk::Toplevel); Index: DragDrop/DragDrop/Rect.pm --- Tk-804.025_beta9/DragDrop/DragDrop/Rect.pm 2003-08-17 19:54:05.000000000 +0100 +++ Tk-804.025_beta10/DragDrop/DragDrop/Rect.pm 2003-12-14 19:44:50.000000000 +0000 @@ -4,7 +4,7 @@ # Proxy class which represents sites to the dropping side use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/Rect.pm#5 $ +$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/; sub Over { Index: DragDrop/DragDrop/SunSite.pm --- Tk-804.025_beta9/DragDrop/DragDrop/SunSite.pm 2003-08-17 19:54:05.000000000 +0100 +++ Tk-804.025_beta10/DragDrop/DragDrop/SunSite.pm 2003-12-14 19:44:50.000000000 +0000 @@ -2,7 +2,7 @@ require Tk::DropSite; use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/SunSite.pm#5 $ +$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/; use Tk::DragDrop::SunConst; use base qw(Tk::DropSite); Index: DragDrop/DragDrop/XDNDDrop.pm --- Tk-804.025_beta9/DragDrop/DragDrop/XDNDDrop.pm 2003-08-17 19:54:05.000000000 +0100 +++ Tk-804.025_beta10/DragDrop/DragDrop/XDNDDrop.pm 2003-12-14 19:44:50.000000000 +0000 @@ -1,7 +1,7 @@ package Tk::DragDrop::XDNDDrop; use strict; use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/DragDrop/XDNDDrop.pm#5 $ +$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/; use base qw(Tk::DragDrop::Rect); sub XDND_PROTOCOL_VERSION () { 4 } Index: DragDrop/Win32Site/Win32Site.pm --- Tk-804.025_beta9/DragDrop/Win32Site/Win32Site.pm 2003-12-06 14:38:02.000000000 +0000 +++ Tk-804.025_beta10/DragDrop/Win32Site/Win32Site.pm 2003-12-14 19:44:50.000000000 +0000 @@ -1,7 +1,7 @@ package Tk::DragDrop::Win32Site; use vars qw($VERSION); -$VERSION = '4.004'; # $Id: //depot/Tkutf8/DragDrop/Win32Site/Win32Site.pm#5 $ +$VERSION = sprintf '4.%03d', q$Revision: #6 $ =~ /\D(\d+)\s*$/; use Tk qw($XS_VERSION); require DynaLoader; Index: Entry/Entry.pm --- Tk-804.025_beta9/Entry/Entry.pm 2003-10-20 18:40:42.000000000 +0100 +++ Tk-804.025_beta10/Entry/Entry.pm 2003-12-14 18:27:52.000000000 +0000 @@ -12,7 +12,8 @@ # This program is free software; you can redistribute it and/or use vars qw($VERSION); -$VERSION = sprintf '4.%03d',q$Revision: #16 $ =~ /#(\d+)/; +use strict; +$VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/; # modify it under the same terms as Perl itself, subject # to additional disclaimer in license.terms due to partial @@ -79,7 +80,21 @@ $class->SUPER::ClassInit($mw); + # <>, <> and <> defined in Tk::Clipboard + $mw->bind($class,'<>' => sub { + my $w = shift; + $w->delete("sel.first", "sel.last"); + }); + $mw->bind($class,'<>' => [sub { + my($w, $x) = @_; + # XXX logic in Tcl/Tk version screwed up? + if (!$Tk::strictMotif && !$Tk::mouseMoved) { + $w->Paste($x); + } + }, Ev('x')]); + # Standard Motif bindings: + # The binding is different from the Tcl/Tk version: $mw->bind($class,'','selectionClear'); $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]); @@ -136,8 +151,18 @@ $mw->bind($class,'' ,'NoOp'); $mw->bind($class,'' ,'NoOp'); $mw->bind($class,'' ,'NoOp'); + if ($mw->windowingsystem =~ /^(?:classic|aqua)$/) + { + $mw->bind($class,'', 'NoOp'); + } + + # On Windows, paste is done using Shift-Insert. Shift-Insert already + # generates the <> event, so we don't need to do anything here. + if ($Tk::platform ne 'MSWin32') + { + $mw->bind($class,'','InsertSelection'); + } - $mw->bind($class,'','InsertSelection'); if (!$Tk::strictMotif) { # Additional emacs-like bindings: @@ -151,20 +176,23 @@ $mw->bind($class,'','Transpose'); + # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead $mw->bind($class,'',['SetCursor',Ev(['wordstart'])]); $mw->bind($class,'',['delete','insert',Ev(['wordend'])]); $mw->bind($class,'',['SetCursor',Ev(['wordend'])]); $mw->bind($class,'',['delete',Ev(['wordstart']),'insert']); + $mw->bind($class,'',['delete',Ev(['wordstart']),'insert']); # A few additional bindings from John Ousterhout. - $mw->bind($class,'',['delete',Ev(['wordstart']),'insert']); +# XXX conflicts with <>: $mw->bind($class,'',['delete',Ev(['wordstart']),'insert']); $mw->bind($class,'<2>','Button_2'); $mw->bind($class,'','B2_Motion'); - $mw->bind($class,'','ButtonRelease_2'); +# XXX superseded by <>: $mw->bind($class,'','ButtonRelease_2'); } return $class; } + sub Shift_1 { my $w = shift; @@ -199,10 +227,11 @@ sub InsertSelection { my $w = shift; - eval {local $SIG{__DIE__}; $w->Insert($w->SelectionGet)} + eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)} } +# Original is ::tk::EntryScanMark sub Button_2 { my $w = shift; @@ -214,10 +243,14 @@ } +# Original is ::tk::EntryScanDrag sub B2_Motion { my $w = shift; my $Ev = $w->XEvent; + # Make sure these exist, as some weird situations can trigger the + # motion binding without the initial press. [Tcl/Tk Bug #220269] + if (!defined $Tk::x) { $Tk::x = $Ev->x } if (abs(($Ev->x-$Tk::x)) > 2) { $Tk::mouseMoved = 1 @@ -226,6 +259,7 @@ } +# XXX Not needed anymore sub ButtonRelease_2 { my $w = shift; @@ -245,6 +279,26 @@ shift->CancelRepeat; } +# ::tk::EntryClosestGap -- +# Given x and y coordinates, this procedure finds the closest boundary +# between characters to the given coordinates and returns the index +# of the character just after the boundary. +# +# Arguments: +# w - The entry window. +# x - X-coordinate within the window. +sub ClosestGap +{ + my($w, $x) = @_; + my $pos = $w->index('@'.$x); + my @bbox = $w->bbox($pos); + if ($x - $bbox[0] < $bbox[2] / 2) + { + return $pos; + } + $pos + 1; +} + # Button1 -- # This procedure is invoked to handle button-1 presses in entry # widgets. It moves the insertion cursor, sets the selection anchor, @@ -257,14 +311,13 @@ { my $w = shift; my $x = shift; - my $y = shift; $Tk::selectMode = 'char'; $Tk::mouseMoved = 0; $Tk::pressX = $x; - $w->icursor('@' . $x); - $w->selectionFrom('@' . $x); + $w->icursor($w->ClosestGap($x)); + $w->selectionFrom('insert'); $w->selectionClear; - if ($w->cget('-state') eq 'normal') + if ($w->cget('-state') ne 'disabled') { $w->focus() } @@ -273,6 +326,7 @@ sub Motion { my ($w,$x,$y) = @_; + $Tk::x = $x; # XXX ? $w->MouseSelect($x); } @@ -291,13 +345,13 @@ my $w = shift; my $x = shift; - return if ref($w) eq 'Tk::Spinbox' and $w->{_element} ne 'entry'; + return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry'; $Tk::selectMode = shift if (@_); - my $cur = $w->index('@' . $x); + my $cur = $w->index($w->ClosestGap($x)); return unless defined $cur; my $anchor = $w->index('anchor'); return unless defined $anchor; - $Tk::pressX ||= $x; + $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"? if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3)) { $Tk::mouseMoved = 1 @@ -306,6 +360,7 @@ return unless $mode; if ($mode eq 'char') { + # The Tcl version uses selectionRange here XXX if ($Tk::mouseMoved) { if ($cur < $anchor) @@ -320,6 +375,7 @@ } elsif ($mode eq 'word') { + # The Tcl version uses tcl_wordBreakBefore/After here XXX if ($cur < $w->index('anchor')) { $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1)) @@ -340,6 +396,26 @@ } $w->idletasks; } +# ::tk::EntryPaste -- +# This procedure sets the insertion cursor to the current mouse position, +# pastes the selection there, and sets the focus to the window. +# +# Arguments: +# w - The entry window. +# x - X position of the mouse. +sub Paste +{ + my($w, $x) = @_; + $w->icursor($w->ClosestGap($x)); + eval { local $SIG{__DIE__}; + $w->insert("insert", $w->GetSelection); + $w->SeeInsert; # Perl/Tk extension + }; + if ($w->cget(-state) ne 'disabled') + { + $w->focus; + } +} # AutoScan -- # This procedure is invoked when the mouse leaves an entry window # with button 1 down. It scrolls the window left or right, @@ -354,6 +430,7 @@ { my $w = shift; my $x = shift; + return if !Tk::Exists($w); if ($x >= $w->width) { $w->xview('scroll',2,'units') @@ -434,6 +511,7 @@ { my $x = $w->index('insert')-1; $w->delete($x) if ($x >= 0); + # XXX Missing repositioning part from Tcl/Tk source } } # SeeInsert @@ -513,6 +591,12 @@ $w->SUPER::tabFocus; } +# ::tk::EntryGetSelection -- +# +# Returns the selected text of the entry with respect to the -show option. +# +# Arguments: +# w - The entry window from which the text to get sub getSelected { my $w = shift; @@ -525,8 +609,7 @@ return substr($str,$s,$e-$s); } + 1; __END__ - - Index: Listbox/Listbox.pm --- Tk-804.025_beta9/Listbox/Listbox.pm 2003-12-06 13:38:23.000000000 +0000 +++ Tk-804.025_beta10/Listbox/Listbox.pm 2003-12-14 19:44:50.000000000 +0000 @@ -37,7 +37,7 @@ use vars qw($VERSION @Selection $Prev); use strict; -$VERSION = '4.012'; # $Id: //depot/Tkutf8/Listbox/Listbox.pm#13 $ +$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; use Tk qw(Ev $XS_VERSION); use Tk::Clipboard (); Index: MANIFEST --- Tk-804.025_beta9/MANIFEST 2003-12-10 20:37:29.000000000 +0000 +++ Tk-804.025_beta10/MANIFEST 2003-12-11 09:42:41.000000000 +0000 @@ -1858,6 +1858,7 @@ t/regexp.t t/Require.t t/Trace.t +t/TkTest.pm t/trace1.t t/slaves.t t/widget.t Index: MANIFEST.SKIP --- Tk-804.025_beta9/MANIFEST.SKIP 2003-11-16 20:39:50.000000000 +0000 +++ Tk-804.025_beta10/MANIFEST.SKIP 2003-12-13 18:13:25.000000000 +0000 @@ -31,6 +31,9 @@ doc/MANFILES$ doc/.*\.htm$ myConfig\.out +JPEG/jpeg/testout* +JPEG/jpeg/config\.(log|status) +JPEG/jpeg/([cd]jpeg|jpegtran|(rd|wr)jpgcom) \.todo$ \bswapm$ bin/patchls$ Index: MANIFEST.SKIP.PL --- Tk-804.025_beta9/MANIFEST.SKIP.PL 2003-11-16 20:39:44.000000000 +0000 +++ Tk-804.025_beta10/MANIFEST.SKIP.PL 2003-12-13 18:13:12.000000000 +0000 @@ -93,6 +93,9 @@ doc/MANFILES$ doc/.*\.htm$ myConfig\.out +JPEG/jpeg/testout* +JPEG/jpeg/config\.(log|status) +JPEG/jpeg/([cd]jpeg|jpegtran|(rd|wr)jpgcom) \.todo$ \bswapm$ bin/patchls$ Index: TixGrid/TixGrid.pm --- Tk-804.025_beta9/TixGrid/TixGrid.pm 2003-09-15 14:06:39.000000000 +0100 +++ Tk-804.025_beta10/TixGrid/TixGrid.pm 2003-12-14 19:44:50.000000000 +0000 @@ -20,7 +20,7 @@ use strict; use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/TixGrid/TixGrid.pm#8 $ +$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/; use Tk qw(Ev $XS_VERSION); use Tk::Widget; Index: Tixish/DirTree.pm --- Tk-804.025_beta9/Tixish/DirTree.pm 2003-12-06 13:38:23.000000000 +0000 +++ Tk-804.025_beta10/Tixish/DirTree.pm 2003-12-14 19:44:50.000000000 +0000 @@ -6,7 +6,7 @@ # Chris Dean use vars qw($VERSION); -$VERSION = '4.009'; # $Id: //depot/Tkutf8/Tixish/DirTree.pm#10 $ +$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; use Tk; use Tk::Derived; @@ -233,6 +233,8 @@ } } +1; + __END__ # Copyright (c) 1996, Expert Interface Technologies Index: Tixish/NoteBook.pm --- Tk-804.025_beta9/Tixish/NoteBook.pm 2003-12-06 13:23:23.000000000 +0000 +++ Tk-804.025_beta10/Tixish/NoteBook.pm 2003-12-14 19:44:50.000000000 +0000 @@ -9,7 +9,7 @@ use vars qw($VERSION); -$VERSION = '4.007'; # $Id: //depot/Tkutf8/Tixish/NoteBook.pm#8 $ +$VERSION = sprintf '4.%03d', q$Revision: #9 $ =~ /\D(\d+)\s*$/; require Tk::NBFrame; use base qw(Tk::Derived Tk::NBFrame); Index: Tk/Clipboard.pm --- Tk-804.025_beta9/Tk/Clipboard.pm 2003-07-20 18:43:28.000000000 +0100 +++ Tk-804.025_beta10/Tk/Clipboard.pm 2003-12-14 19:44:50.000000000 +0000 @@ -5,7 +5,7 @@ use strict; use vars qw($VERSION); -$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Clipboard.pm#6 $ +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; use AutoLoader qw(AUTOLOAD); use Tk qw(catch); @@ -64,7 +64,19 @@ { my $w = shift; local $@; - catch { $w->insert('insert',$w->clipboardGet)}; + catch + { +## Different from Tcl/Tk version: +# if ($w->windowingsystem eq 'x11') +# { +# catch +# { +# $w->deleteSelected; +# }; +# } + $w->insert("insert", $w->clipboardGet); + $w->SeeInsert if $w->can('SeeInsert'); + }; } sub clipboardOperations Index: Tk/ErrorDialog.pm --- Tk-804.025_beta9/Tk/ErrorDialog.pm 2003-08-24 09:50:05.000000000 +0100 +++ Tk-804.025_beta10/Tk/ErrorDialog.pm 2003-12-14 19:44:50.000000000 +0000 @@ -1,7 +1,7 @@ package Tk::ErrorDialog; use vars qw($VERSION); -$VERSION = '4.005'; # $Id: //depot/Tkutf8/Tk/ErrorDialog.pm#6 $ +$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; use Tk (); require Tk::Dialog; Index: Tk/FBox.pm --- Tk-804.025_beta9/Tk/FBox.pm 2003-12-10 20:07:07.000000000 +0000 +++ Tk-804.025_beta10/Tk/FBox.pm 2003-12-13 12:15:48.000000000 +0000 @@ -39,7 +39,7 @@ use strict; use vars qw($VERSION $updirImage $folderImage $fileImage); -$VERSION = sprintf '4.%03d', q$Revision: #17 $ =~ /\D(\d+)\s*$/; +$VERSION = sprintf '4.%03d', q$Revision: #18 $ =~ /\D(\d+)\s*$/; use base qw(Tk::Toplevel); @@ -795,11 +795,12 @@ push @$filenames, $w->{'icons'}->Get($item); } + my $filename = $filenames->[0]; if ($w->cget('-type') eq 'dir' && $from ne "iconlist") { - $w->Done($w->{'selectPath'}); + my $file = $filename eq '' ? $w->{'selectPath'} : JoinFile($w->{'selectPath'}, $filename); + $w->Done($file); } elsif ((@$filenames && !$w->cget('-multiple')) || ($w->cget('-multiple') && @$filenames == 1)) { - my $filename = $filenames->[0]; my $file = JoinFile($w->{'selectPath'}, $filename); if (-d $file) { $w->ListInvoke($filename); Index: Tk/FileSelect.pm --- Tk-804.025_beta9/Tk/FileSelect.pm 2003-08-26 17:48:00.000000000 +0100 +++ Tk-804.025_beta10/Tk/FileSelect.pm 2003-12-14 19:44:50.000000000 +0000 @@ -1,7 +1,7 @@ package Tk::FileSelect; use vars qw($VERSION @EXPORT_OK); -$VERSION = '4.013'; # $Id: //depot/Tkutf8/Tk/FileSelect.pm#14 $ +$VERSION = sprintf '4.%03d', q$Revision: #15 $ =~ /\D(\d+)\s*$/; @EXPORT_OK = qw(glob_to_re); use Tk qw(Ev); Index: Tk/MainWindow.pm --- Tk-804.025_beta9/Tk/MainWindow.pm 2003-08-24 09:50:05.000000000 +0100 +++ Tk-804.025_beta10/Tk/MainWindow.pm 2003-12-14 19:44:50.000000000 +0000 @@ -8,7 +8,7 @@ use strict; use vars qw($VERSION); -$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/MainWindow.pm#8 $ +$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; use Tk::CmdLine; use Tk qw(catch); @@ -81,19 +81,24 @@ { my $mw = shift; $mw->bind('all','','focusNext'); + # <> is named <> in Tcl/Tk $mw->eventAdd(qw[<> ]); - catch { $mw->eventAdd(qw[<> ]) }; + # This is needed for XFree86 systems + catch { $mw->eventAdd(qw[<> ]) }; + # This seems to be correct on *some* HP systems. + catch { $mw->eventAdd(qw[<> ]) }; $mw->bind('all','<>','focusPrev'); - if ($Tk::platform eq 'unix') + if ($mw->windowingsystem eq 'x11') { $mw->eventAdd(qw[<> ]); $mw->eventAdd(qw[<> ]); $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); $mw->eventAdd(qw[<> ]); $mw->eventAdd(qw[<> ]); } - else + elsif ($mw->windowingsystem eq 'win32') { $mw->eventAdd(qw[<> ]); $mw->eventAdd(qw[<> ]); @@ -101,6 +106,26 @@ $mw->eventAdd(qw[<> ]); $mw->eventAdd(qw[<> ]); } + elsif ($mw->windowingsystem eq 'aqua') + { + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + } + elsif ($mw->windowingsystem eq 'classic') + { + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> ]); + } # FIXME - Should these move to Menubutton ? my $c = ($Tk::platform eq 'unix') ? 'all' : 'Tk::Menubutton'; Index: Tk/MakeDepend.pm --- Tk-804.025_beta9/Tk/MakeDepend.pm 2003-12-10 22:14:20.000000000 +0000 +++ Tk-804.025_beta10/Tk/MakeDepend.pm 2003-12-13 12:28:22.000000000 +0000 @@ -11,7 +11,7 @@ use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; +$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/; sub scan_file; @@ -213,8 +213,10 @@ } my $flags = $Config{ccflags}; $flags =~ s/^\s+|\s+$//g; - foreach (@_, split(/\s+/,$flags)) + my @opt = (@_, split(/\s+/,$flags)); + while (@opt) { + local $_ = shift(@opt); if (/^-I(.*)$/) { push @include,$1; @@ -227,17 +229,20 @@ { delete $define{$1}; } - elsif (/^-[fm][\w-]*$/) - { - # GCC-ish - } elsif (/^(-.*)$/) { - warn "Ignoring $1\n"; + # Some option + if ($opt[0] !~ /^-/) + { + # next arg does not start with '-' assume it + # belongs to this option and discard it silently + shift(@opt); + } } else { - croak "Unexpected arg $_\n"; + # We got confused + warn "Ignoring $1\n"; } } # force /usr/include to be last element of @include @@ -246,7 +251,7 @@ # warn "Include:@include\n"; while (@files) { - $_ = shift(@files); + local $_ = shift(@files); unless (/^(.*)\.[^\.]+$/) { warn "Skip $_"; Index: Tk/Menu.pm --- Tk-804.025_beta9/Tk/Menu.pm 2003-08-04 19:50:31.000000000 +0100 +++ Tk-804.025_beta10/Tk/Menu.pm 2003-12-13 20:17:25.000000000 +0000 @@ -21,7 +21,7 @@ use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #19 $ =~ /\D(\d+)\s*$/; +$VERSION = sprintf '4.%03d', q$Revision: #20 $ =~ /\D(\d+)\s*$/; use strict; @@ -1002,7 +1002,6 @@ # path - Name to use for topmost menu in duplicate # hierarchy. -use Data::Dumper; sub tkMenuDup { my ($src,$path,$type) = @_; Index: Tk/ROText.pm --- Tk-804.025_beta9/Tk/ROText.pm 2003-08-24 09:50:05.000000000 +0100 +++ Tk-804.025_beta10/Tk/ROText.pm 2003-12-14 19:44:50.000000000 +0000 @@ -4,7 +4,7 @@ package Tk::ROText; use vars qw($VERSION); -$VERSION = '4.008'; # $Id: //depot/Tkutf8/Tk/ROText.pm#9 $ +$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; use Tk::Text; use base qw(Tk::Derived Tk::Text); Index: Tk/Widget.pm --- Tk-804.025_beta9/Tk/Widget.pm 2003-10-06 20:15:38.000000000 +0100 +++ Tk-804.025_beta10/Tk/Widget.pm 2003-12-14 18:27:52.000000000 +0000 @@ -3,7 +3,7 @@ # modify it under the same terms as Perl itself. package Tk::Widget; use vars qw($VERSION @DefaultMenuLabels); -$VERSION = sprintf '4.%03d', q$Revision: #27 $ =~ /\D(\d+)\s*$/; +$VERSION = sprintf '4.%03d', q$Revision: #28 $ =~ /\D(\d+)\s*$/; require Tk; use AutoLoader; @@ -1306,6 +1306,83 @@ } } +sub ConfigSpecs { + + my $w = shift; + + return map { ( $_->[0], [ $w, @$_[ 1 .. 4 ] ] ) } $w->configure; + +} + +*GetSelection = + ($Tk::platform eq 'unix' + ? sub + { + my $w = shift; + my $sel = @_ ? shift : "PRIMARY"; + my $txt = eval { local $SIG{__DIE__}; + $w->SelectionGet(-selection => $sel, -type => "UTF8_STRING") + }; + if ($@) + { + $txt = eval { local $SIG{__DIE__}; + $w->SelectionGet(-selection => $sel) + }; + if ($@) + { + die "could not find default selection"; + } + } + $txt; + } + : sub + { + my $w = shift; + my $sel = @_ ? shift : "PRIMARY"; + my $txt = eval { local $SIG{__DIE__}; + $w->SelectionGet(-selection => $sel) + }; + if ($@) + { + die "could not find default selection"; + } + $txt; + } + ); + +1; +__END__ + +=head1 NAME + +Tk::bindDump - dump detailed binding information for a widget. + +=head1 SYNOPSIS + + use Tk::bindDump; + + $splash->bindDump; + +=head1 DESCRIPTION + +This subroutine prints a widget's bindtags. For each binding tag it +prints all the bindings, comprised of the event descriptor and the +callback. Callback arguments are printed, and Tk::Ev objects are +expanded. + +=head1 COPYRIGHT + +Copyright (C) 2000 - 2001 Stephen O. Lidie. All rights reserved. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + + +1; +__END__ + sub bindDump { # Dump lots of good binding information. This pretty-print subroutine @@ -1383,46 +1460,6 @@ } # end bindDump -sub ConfigSpecs { - - my $w = shift; - - return map { ( $_->[0], [ $w, @$_[ 1 .. 4 ] ] ) } $w->configure; - -} - -1; -__END__ - -=head1 NAME - -Tk::bindDump - dump detailed binding information for a widget. - -=head1 SYNOPSIS - - use Tk::bindDump; - - $splash->bindDump; - -=head1 DESCRIPTION - -This subroutine prints a widget's bindtags. For each binding tag it -prints all the bindings, comprised of the event descriptor and the -callback. Callback arguments are printed, and Tk::Ev objects are -expanded. - -=head1 COPYRIGHT - -Copyright (C) 2000 - 2001 Stephen O. Lidie. All rights reserved. - -This program is free software; you can redistribute it and/or modify it under -the same terms as Perl itself. - -=cut - - -1; -__END__ sub ASkludge { Index: Tk/Wm.pm --- Tk-804.025_beta9/Tk/Wm.pm 2003-12-08 21:02:31.000000000 +0000 +++ Tk-804.025_beta10/Tk/Wm.pm 2003-12-14 19:44:50.000000000 +0000 @@ -14,7 +14,7 @@ use vars qw($VERSION); -$VERSION = '4.012'; # $Id: //depot/Tkutf8/Tk/Wm.pm#13 $ +$VERSION = sprintf '4.%03d', q$Revision: #14 $ =~ /\D(\d+)\s*$/; use Tk::Submethods; Index: ToDo --- Tk-804.025_beta9/ToDo 2003-07-19 09:39:02.000000000 +0100 +++ Tk-804.025_beta10/ToDo 2003-12-13 18:21:41.000000000 +0000 @@ -23,4 +23,31 @@ Now 5.005_5X has utf8 how do we display it? +Tk::Photo::data dumps core with beta9 and perl5.8.2: + $photo = $mw->Photo(-file => "some.gif"); + $string = $photo->data(-format => "gif"); +Stipple bug, see Message-ID: <2uwCb.683348$pl3.76050@pd7tw3no> (should +be fixed with Tk 8.4.5). + +One can't use filenames with high-bit characters in the Photo constructor: + $photo = $mw->Photo(-file => "high-bit-chars"); + +Add 'as_default_dir' support for chooseDirectory (similar to +'as_default' for get(Open|Save)File). Documentation missing. + +Widget review (Listbox.pm and Canvas.pm done) + +Pod review (Listbox.pod done, options.pod and Canvas.pod in the works, +others pending) + +Port all of Tcl/Tk test suite to Perl/Tk. t/listbox.t and t/entry.t +was a beginning. + +Port message catalogs from Tcl/Tk to Perl/Tk. + +Write a new Tk/804delta.pod. + +Build and test with older perl releases. + +Move bindDump documentation from Widget.pm to pod/Widget.pod. Index: add_version --- Tk-804.025_beta9/add_version 2003-07-26 12:23:13.000000000 +0100 +++ Tk-804.025_beta10/add_version 2003-12-14 19:36:35.000000000 +0000 @@ -4,7 +4,7 @@ use Getopt::Std; use Cwd; my %opt = ('p' => '4'); -getopts('oeap:',\%opt); +getopts('oqeap:',\%opt); my $path = getcwd(); chdir($path); $path = getcwd(); @@ -64,7 +64,7 @@ my $have = `p4 have $ARGV`; my ($path,$need) = $have =~ /^(.*#(\d+))\s+-/; $need++ if (-w $ARGV); - return sprintf "\$VERSION = sprintf '%d.%%03d', q\$Revision: #%d\$ =~ /\\D(\\d+)\\s*\$/;\n",$opt{'p'},$need; + return ($need,sprintf "\$VERSION = sprintf '%d.%%03d', q\$Revision: #%d\$ =~ /\\D(\\d+)\\s*\$/;\n",$opt{'p'},$need); } @@ -75,22 +75,29 @@ { $edit |= s/\r//g; s/ +$//; - if (/^\s*\$VERSION\s*=\s*'(\d+)\.(\d+)'\s*;\s*#\s*\$Id[:\s]+(.*)\$\s*(?:\+(\d+))?.*$/) + if (/^\s*\$VERSION\s*=\s*'(\d+)\.0*(\d+)'\s*;\s*#\s*\$Id[:\s]+(.*)\$\s*(?:\+(\d+))?.*$/) { $seen = 1; - warn "-$ARGV:_"; - $_ = VERSION(); - warn "+$ARGV:$_"; - $edit = 1; + my $have = $2; + my ($want,$str) = VERSION(); + if ($opt{q} && $have ne $want) + { + warn "!$ARGV:$have ne $want\n"; + warn "-$ARGV:$_"; + $_ = $str; + warn "+$ARGV:$_"; + $edit = 1; + } } - elsif (/^\s*(our\s+)?\$VERSION\s*=[^#]*\$Revision[:\s]+(.*)\$/) + elsif (/^\s*(our\s+)?\$VERSION\s*=[^#]*\$Revision[:\s]+#(\d+)\s*\$/) { $seen = 1; - my $want = VERSION(); - if ($_ ne $want) + my $have = $2; + my ($want,$str) = VERSION(); + if ($have ne $want) { warn "-$ARGV:$_"; - $_ = $want; + $_ = $str; warn "+$ARGV:$_"; $edit = 1; } @@ -110,7 +117,8 @@ { warn "$ARGV:$.:insert before\n$_\n"; print "\nuse vars qw(\$VERSION);\n"; - print VERSION(); + my ($want,$str) = VERSION(); + print $str; $seen = $edit = 1; } print if $opt{'e'};; Index: demos/demos/widget_lib/Plot.pm --- Tk-804.025_beta9/demos/demos/widget_lib/Plot.pm 2003-08-26 19:17:23.000000000 +0100 +++ Tk-804.025_beta10/demos/demos/widget_lib/Plot.pm 2003-12-14 19:44:50.000000000 +0000 @@ -12,7 +12,7 @@ require 5.005_03; use vars qw/$VERSION @ISA/; -$VERSION = '4.005'; # $Id: //depot/Tkutf8/demos/demos/widget_lib/Plot.pm#6 $ +$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; use Tk::Frame; use base qw/Tk::Frame/; Index: demos/demos/widget_lib/filebox.pl --- Tk-804.025_beta9/demos/demos/widget_lib/filebox.pl 2003-07-19 09:39:04.000000000 +0100 +++ Tk-804.025_beta10/demos/demos/widget_lib/filebox.pl 2003-12-13 12:08:32.000000000 +0000 @@ -38,10 +38,7 @@ -command => sub { local($^W) = 0; require Tk::FileSelect; Tk::FileSelect->import('as_default'); - # XXX remove cached dialogs - my $mw = $TOP->MainWindow; - delete $mw->{'tk_getOpenFile'}; - delete $mw->{'tk_getSaveFile'}; + _removeCachedFileDialogs(); })->pack(-side => 'left'); my $fdb = $cbf->Radiobutton (-text => 'FBox', @@ -50,10 +47,7 @@ -command => sub { local($^W) = 0; require Tk::FBox; Tk::FBox->import('as_default'); - # XXX remove cached dialogs - my $mw = $TOP->MainWindow; - delete $mw->{'tk_getOpenFile'}; - delete $mw->{'tk_getSaveFile'}; + _removeCachedFileDialogs(); })->pack(-side => 'left'); $fdb->invoke; @@ -98,3 +92,15 @@ $ent->xview('end'); } } + +sub _removeCachedFileDialogs { + my $mw = $TOP->MainWindow; + my $remove = sub { + my $t = shift; + return if (!UNIVERSAL::isa($t, "Tk::Toplevel")); + delete $t->{'tk_getOpenFile'}; + delete $t->{'tk_getSaveFile'}; + }; + $remove->($mw); + $mw->Walk($remove); +} Index: pTk/mTk/generic/tkFont.c --- Tk-804.025_beta9/pTk/mTk/generic/tkFont.c 2003-12-10 20:25:29.000000000 +0000 +++ Tk-804.025_beta10/pTk/mTk/generic/tkFont.c 2003-12-13 11:39:15.000000000 +0000 @@ -3340,7 +3340,9 @@ memset(field, '\0', sizeof(field)); - str = string; + if (!(str = string)) { + return TCL_ERROR; + } if (*str == '-') { str++; } Index: pTk/mTk/generic/tkListbox.c --- Tk-804.025_beta9/pTk/mTk/generic/tkListbox.c 2003-07-27 17:44:09.000000000 +0100 +++ Tk-804.025_beta10/pTk/mTk/generic/tkListbox.c 2003-12-13 12:10:29.000000000 +0000 @@ -2255,6 +2255,9 @@ int result; char *stringRep; int length; +#ifdef _LANG + int refFlag = 0; +#endif oldMaxWidth = listPtr->maxWidth; for (i = 0; i < objc; i++) { @@ -2278,16 +2281,30 @@ /* If the object is shared, duplicate it before writing to it */ if (Tcl_IsShared(listPtr->listObj)) { newListObj = Tcl_DuplicateObj(listPtr->listObj); +#ifdef _LANG + refFlag = 1; +#endif } else { newListObj = listPtr->listObj; } result = Tcl_ListObjReplace(listPtr->interp, newListObj, index, 0, objc, objv); if (result != TCL_OK) { +#ifdef _LANG + if (refFlag) { + Tcl_DecrRefCount(newListObj); + } +#endif return result; } - Tcl_IncrRefCount(newListObj); +#ifdef _LANG + if (!refFlag) { +#endif + Tcl_IncrRefCount(newListObj); +#ifdef _LANG + } +#endif /* Clean up the old reference */ Tcl_DecrRefCount(listPtr->listObj); Index: pTk/mTk/unix/tkUnixFont.c --- Tk-804.025_beta9/pTk/mTk/unix/tkUnixFont.c 2003-12-10 20:26:58.000000000 +0000 +++ Tk-804.025_beta10/pTk/mTk/unix/tkUnixFont.c 2003-12-13 11:46:58.000000000 +0000 @@ -2496,7 +2496,7 @@ Tcl_DStringFree(&dsEncodings); numEncodings = 0; - if (fontStructPtr == NULL) { + if (fontStructPtr == NULL || nameList[nameIdx] == NULL) { if (nameList != nameListOrig) { ckfree((char *) nameList); } Index: pod/Listbox.pod --- Tk-804.025_beta9/pod/Listbox.pod 2003-07-19 09:39:41.000000000 +0100 +++ Tk-804.025_beta10/pod/Listbox.pod 2003-12-13 12:01:08.000000000 +0000 @@ -17,11 +17,13 @@ =head1 STANDARD OPTIONS -B<-background> B<-foreground> B<-relief> B<-takefocus> -B<-borderwidth> B<-height> B<-selectbackground> B<-width> -B<-cursor> B<-highlightbackground> B<-selectborderwidth> B<-xscrollcommand> -B<-exportselection> B<-highlightcolor> B<-selectforeground> B<-yscrollcommand> -B<-font> B<-highlightthickness> B<-setgrid> +B<-background> B<-borderwidth> B<-cursor> B<-disabledforeground> +B<-exportselection> B<-font> B<-foreground> B<-height> +B<-highlightbackground> B<-highlightcolor> B<-highlightthickness> +B<-offset> B<-relief> B<-selectbackground> B<-selectborderwidth> +B<-selectforeground> B<-setgrid> B<-state> B<-takefocus> B<-tile> +B<-width> B<-xscrollcommand> B<-yscrollcommand> + See L for details of the standard options. @@ -29,6 +31,17 @@ =over 4 +=item Name: B + +=item Class: B + +=item Switch: B<-activestyle> + +Specifies the style in which to draw the active element. This must be +one of B (show a focus ring around the active element), B +(no special indication of active element) or B (underline the +active element). The default is B. + =item Name: B =item Class: B @@ -39,6 +52,21 @@ If zero or less, then the desired height for the window is made just large enough to hold all the elements in the listbox. +=item Name: B + +=item Class: B + +=item Switch: B<-listvariable> + +I + +Specifies the reference of a variable. The value of the variable is an array +to be displayed inside the widget; if the variable value changes +then the widget will automatically update itself to reflect the new +value. Attempts to assign a variable with an invalid list value to +B<-listvariable> will cause an error. Attempts to unset a variable in use +as a B<-listvariable> will fail but will not generate an error. + =item Name: B =item Class: B @@ -50,6 +78,18 @@ expect it to be either B, B, B, or B; the default value is B. +=item Name: B + +=item Class: B + +=item Switch: B<-state> + +Specifies one of two states for the listbox: B or B. +If the listbox is disabled then items may not be inserted or deleted, +items are drawn in the B<-disabledforeground> color, and selection +cannot be modified and is not shown (though selection information is +retained). + =item Name: B =item Class: B @@ -218,6 +258,52 @@ B then the new elements are added to the end of the list. Returns an empty string. +=item I<$listbox>-EB(I, I