# strip everything before this # cd to your version of Tk-804.025_beta11 # and feed this file to /bin/sh # # rm -f demos/demos/widtrib/HList.pl rm -f demos/demos/widtrib/HList2.pl rm -f demos/demos/widtrib/balloon.pl rm -f demos/demos/widtrib/browseentry.pl rm -f demos/demos/widtrib/browseentry2.pl rm -f demos/demos/widtrib/dirtree.pl rm -f demos/demos/widtrib/form_mgr.pl rm -f demos/demos/widtrib/labframe.pl rm -f demos/demos/widtrib/notebook.pl rm -f demos/demos/widtrib/progress.pl touch demos/demos/widget_lib/browseentry2.pl chmod 0444 demos/demos/widget_lib/browseentry2.pl touch demos/demos/widget_lib/form_mgr.pl chmod 0444 demos/demos/widget_lib/form_mgr.pl touch demos/demos/widget_lib/labframe.pl chmod 0444 demos/demos/widget_lib/labframe.pl touch demos/demos/widget_lib/browseentry.pl chmod 0444 demos/demos/widget_lib/browseentry.pl touch demos/demos/widget_lib/progress.pl chmod 0444 demos/demos/widget_lib/progress.pl touch demos/demos/widget_lib/dirtree.pl chmod 0444 demos/demos/widget_lib/dirtree.pl touch demos/demos/widget_lib/HList.pl chmod 0444 demos/demos/widget_lib/HList.pl touch demos/demos/widget_lib/HList2.pl chmod 0444 demos/demos/widget_lib/HList2.pl touch demos/demos/widget_lib/notebook.pl chmod 0444 demos/demos/widget_lib/notebook.pl touch demos/demos/widget_lib/balloon.pl chmod 0444 demos/demos/widget_lib/balloon.pl patch -p1 -N <<'__END_OF_PATCH__' Index: Canvas/Canvas.pm --- Tk-804.025_beta11/Canvas/Canvas.pm 2003-09-27 20:25:32.000000000 +0100 +++ Tk-804.025_beta12/Canvas/Canvas.pm 2003-12-21 14:20:15.000000000 +0000 @@ -1,6 +1,6 @@ package Tk::Canvas; use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #7 $ =~ /\D(\d+)\s*$/; +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; use Tk qw($XS_VERSION); @@ -57,7 +57,7 @@ # List of adobe glyph names. Converted from glyphlist.txt, downloaded # from Adobe -our %psglyphs = qw( +$Tk::psglyphs = {qw( 0020 space 0021 exclam 0022 quotedbl @@ -1109,7 +1109,7 @@ FB2B afii57695 FB35 afii57723 FB4B afii57700 -); +)}; sub CreatePostscriptEncoding @@ -1139,7 +1139,7 @@ 50 dict begin % This is a standard prolog for Postscript generated by Tk's canvas % widget. -% RCS: @(#) $Id: //depot/Tkutf8/Canvas/Canvas.pm#7 $ +% RCS: @(#) $Id: //depot/Tkutf8/Canvas/Canvas.pm#8 $ % The definitions below just define all of the variables used in % any of the procedures here. This is needed for obscure reasons Index: Change.log --- Tk-804.025_beta11/Change.log 2003-12-19 13:30:12.000000000 +0000 +++ Tk-804.025_beta12/Change.log 2003-12-21 20:50:19.000000000 +0000 @@ -1,3 +1,53 @@ +Change 3060 on 2003/12/21 by nick@llama + + Fix $hlist->infoChildren for children with spaces + (e.g. Win32 pathnames). The fix is to make Tcl_AppendElement + cause result to be a list. This has consequences that + $listbox->curselection returns a list even when (as is common) + only a single element is selected - so fixup those + as revealed by test suite. + +Change 3059 on 2003/12/21 by nick@llama + + Use platfrom CTL_FONT as default for Tix items. + +Change 3058 on 2003/12/21 by nick@llama + + Fixup UTF-8 chars to PostScript + +Change 3057 on 2003/12/21 by nick@llama + + Automate Change.log and $Tk::CHANGE in mkdist + +Change 3056 on 2003/12/21 by nick@llama + + Tk-804.025_trial Release Preparation + +Change 3055 on 2003/12/21 by nick@llama + + More MANIFEST tweaks + +Change 3054 on 2003/12/21 by nick@llama + + Steve's beta11 relative patch to widget + spelling + corrections, and tweaks to user guide. + +Change 3053 on 2003/12/21 by nick@llama + + Steve's re-work of demos structure + +Change 3052 on 2003/12/21 by nick@llama + + UTF-8 avoidance in Tcl-pTk, remove some debug + +Change 3051 on 2003/12/20 by nick@llama + + Missing '-' on -fill in LabFrame.pm + +Change 3050 on 2003/12/20 by nick@llama + + Update change log + Change 3049 on 2003/12/19 by nick@llama tk8.4.5 tests for image1 etc. already existing with Index: MANIFEST --- Tk-804.025_beta11/MANIFEST 2003-12-14 22:25:34.000000000 +0000 +++ Tk-804.025_beta12/MANIFEST 2003-12-21 11:32:08.000000000 +0000 @@ -99,9 +99,12 @@ demos/demos/LabEnLabRad.pm demos/demos/widget_lib/arrows.pl demos/demos/widget_lib/Ball.pm +demos/demos/widget_lib/balloon.pl demos/demos/widget_lib/bind.pl demos/demos/widget_lib/bitmaps.pl demos/demos/widget_lib/bounce.pl +demos/demos/widget_lib/browseentry.pl +demos/demos/widget_lib/browseentry2.pl demos/demos/widget_lib/button.pl demos/demos/widget_lib/check.pl demos/demos/widget_lib/choosedir.pl @@ -111,18 +114,23 @@ demos/demos/widget_lib/ctext.pl demos/demos/widget_lib/dialog1.pl demos/demos/widget_lib/dialog2.pl +demos/demos/widget_lib/dirtree.pl demos/demos/widget_lib/entry1.pl demos/demos/widget_lib/entry2.pl demos/demos/widget_lib/entry3.pl demos/demos/widget_lib/filebox.pl demos/demos/widget_lib/floor.pl demos/demos/widget_lib/form.pl +demos/demos/widget_lib/form_mgr.pl demos/demos/widget_lib/hello.pl +demos/demos/widget_lib/HList.pl +demos/demos/widget_lib/HList2.pl demos/demos/widget_lib/hscale.pl demos/demos/widget_lib/icon.pl demos/demos/widget_lib/image1.pl demos/demos/widget_lib/image2.pl demos/demos/widget_lib/items.pl +demos/demos/widget_lib/labframe.pl demos/demos/widget_lib/labelframe.pl demos/demos/widget_lib/labels.pl demos/demos/widget_lib/mega.pl @@ -130,12 +138,14 @@ demos/demos/widget_lib/menus.pl demos/demos/widget_lib/menus2.pl demos/demos/widget_lib/msgBox.pl +demos/demos/widget_lib/notebook.pl demos/demos/widget_lib/paned1.pl demos/demos/widget_lib/paned2.pl demos/demos/widget_lib/photo1.pl demos/demos/widget_lib/photo2.pl demos/demos/widget_lib/plot.pl demos/demos/widget_lib/Plot.pm +demos/demos/widget_lib/progress.pl demos/demos/widget_lib/puzzle.pl demos/demos/widget_lib/radio.pl demos/demos/widget_lib/ruler.pl @@ -154,20 +164,10 @@ demos/demos/widget_lib/unicodeout.pl demos/demos/widget_lib/vscale.pl demos/demos/widget_lib/WidgetDemo.pm -demos/demos/widtrib/balloon.pl -demos/demos/widtrib/browseentry.pl -demos/demos/widtrib/browseentry2.pl -demos/demos/widtrib/dirtree.pl -demos/demos/widtrib/form_mgr.pl demos/demos/widtrib/Gedi.pl -demos/demos/widtrib/HList.pl -demos/demos/widtrib/HList2.pl -demos/demos/widtrib/labframe.pl demos/demos/widtrib/lib/npuz/Xcamel.npuz -demos/demos/widtrib/notebook.pl demos/demos/widtrib/npuz.pl demos/demos/widtrib/plop.pl -demos/demos/widtrib/progress.pl demos/demos/widtrib/TEMPLATE.pl demos/demos/widtrib/Tiler.pl demos/dialog Index: PNG/MANIFEST --- Tk-804.025_beta11/PNG/MANIFEST 2003-11-29 11:39:29.000000000 +0000 +++ Tk-804.025_beta12/PNG/MANIFEST 2003-12-21 11:37:31.000000000 +0000 @@ -63,7 +63,6 @@ libpng/contrib/visupng/VisualPng.png libpng/contrib/visupng/VisualPng.rc libpng/example.c -libpng/example.c.diff libpng/INSTALL libpng/KNOWNBUG libpng/libpng.3 @@ -71,14 +70,6 @@ libpng/libpngpf.3 libpng/LICENSE libpng/Makefile.maybe -libpng/makefile.vc -libpng/msvc/libpng.dsp -libpng/msvc/libpng.dsw -libpng/msvc/png.rc -libpng/msvc/png32ms.def -libpng/msvc/README.txt -libpng/msvc/zlib.def -libpng/msvc/zlib.dsp libpng/png.5 libpng/png.c libpng/png.h Index: README --- Tk-804.025_beta11/README 2003-09-28 18:44:35.000000000 +0100 +++ Tk-804.025_beta12/README 2003-12-21 12:26:54.000000000 +0000 @@ -4,16 +4,16 @@ This package is free software; you can redistribute it and/or modify it under the same terms as Perl itself, with the exception of all the files in the pTk sub-directory which have separate terms -derived from those of the orignal Tix4.1.3 or Tk8.4 sources. See doc/license.html -for details of this license. +derived from those of the orignal Tix4.1.3 or Tk8.4.* sources. +See doc/license.html for details of this license. -Tk804.025 is late-alpha/beta level. +Tk804.025 is beta level. (Previous stable release being Tk800.025.) The code itself is probably at least as solid as Tk800 series, but build process/tests need shaking down on non/Linux. This a re-port of a perl interface to Tk8.4. -C code is derived from Tcl/Tk8.4.4. +C code is derived from Tcl/Tk8.4.5. Perl API is essentially the same as Tk800.025 but has not been verified as compliant. @@ -27,7 +27,7 @@ This Tk804 is only likely to work with perl5.8+ Perl's UTF-8 support has improved since int was introduced in perl5.6.0. Some functions (regular expression match in Text widgets) are known -to only work with perl5.8.1 +to only work with perl5.8.1 and later Author has built against: @@ -35,14 +35,19 @@ Earlier versions worked with this - but it has Unicode mis-features. Not tried it recently. - Perl5.8.1-RC* + Note that on RedHat Linux in particular the build process must be + done in a non UTF-8 locale i.e. LANG=en_GB not LANG=en_GB.utf8 + (This is due to bugs in perl5.8.0 as shipped by RedHat.) + + Perl5.8.1 Pentium Suse Linux-8.2 gcc-3.3 - Visual C++ 6.0, Windows-XP, dmake + Visual C++ 6.0, Windows-XP, dmake/nmake Mingw 2.0, Windows-XP, dmake (perl without PERL_IMP_SYS, that is broken for MinGW). + ActivePerl based on 5.8.1 also works with Visual C++ 6.0/nmake - Perl5.8.1 - Pentium Suse Linux-8.2 gcc-3.3 + Perl5.8.2 + Pentium Suse Linux-8.2/9.0 gcc-3.3 Visual C++ 6.0, Windows-XP, dmake/nmake For questions on this package try news:comp.lang.perl.tk or e-mail Index: Tixish/BrowseEntry.pm --- Tk-804.025_beta11/Tixish/BrowseEntry.pm 2003-10-28 21:48:50.000000000 +0000 +++ Tk-804.025_beta12/Tixish/BrowseEntry.pm 2003-12-21 20:45:05.000000000 +0000 @@ -8,7 +8,7 @@ package Tk::BrowseEntry; use vars qw($VERSION); -$VERSION = sprintf '4.%03d', q$Revision: #11 $ =~ /#(\d+)/; +$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; use Tk qw(Ev); use Carp; @@ -323,7 +323,7 @@ sub LbIndex { my ($w, $flag) = @_; - my $sel = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection; + my ($sel) = $w->Subwidget('slistbox')->Subwidget('listbox')->curselection; if (defined $sel) { return int($sel); } else { Index: Tixish/LabFrame.pm --- Tk-804.025_beta11/Tixish/LabFrame.pm 2003-07-20 18:43:28.000000000 +0100 +++ Tk-804.025_beta12/Tixish/LabFrame.pm 2003-12-20 21:11:35.000000000 +0000 @@ -5,7 +5,7 @@ package Tk::LabFrame; use vars qw($VERSION); -$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tixish/LabFrame.pm#10 $ +$VERSION = '4.010'; # $Id: //depot/Tkutf8/Tixish/LabFrame.pm#11 $ use Tk; use base qw(Tk::Frame); @@ -92,7 +92,7 @@ $label->pack(-side => $side); $frame->pack(-expand => 1, -fill => 'both'); - $border->pack(-side => $side, -expand => 1, fill => 'both'); + $border->pack(-side => $side, -expand => 1, -fill => 'both'); $cw->{m_geoMgr} = "pack"; } } Index: Tk.pm --- Tk-804.025_beta11/Tk.pm 2003-12-06 13:38:23.000000000 +0000 +++ Tk-804.025_beta12/Tk.pm 2003-12-21 20:50:19.000000000 +0000 @@ -61,7 +61,7 @@ use Carp; # Record author's perforce depot record -$Tk::CHANGE = q$Change: 3011 $; +$Tk::CHANGE = q$Change: 3061 $; # $tk_version and $tk_patchLevel are reset by pTk when a mainwindow # is created, $VERSION is checked by bootstrap Index: demos/demos/widget_lib/HList.pl --- /dev/null 2003-09-23 18:59:22.000000000 +0100 +++ Tk-804.025_beta12/demos/demos/widget_lib/HList.pl 2003-12-21 11:28:40.000000000 +0000 @@ -0,0 +1,65 @@ +# HList, a hierarchial listbox widget. + +use Tk::HList; +use Cwd; +use subs qw/show_dir/; +use vars qw/$TOP $FILEIMG $FOLDIMG/; + +sub HList { + my($demo) = @_; + $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'HList - A hierarchial listbox widget.', + -geometry_manager => 'grid', + ); + + my $h = $TOP->Scrolled(qw\HList -separator / -selectmode extended -width 30 + -height 20 -indent 35 -scrollbars se + -itemtype imagetext \ + )->grid(qw/-sticky nsew/); + $h->configure(-command => sub { + print "Double click $_[0], size=", $h->info('data', $_[0]) ,".\n"; + }); + + $FILEIMG = $TOP->Bitmap(-file => Tk->findINC('file.xbm')); + $FOLDIMG = $TOP->Bitmap(-file => Tk->findINC('folder.xbm')); + + my $root = Tk->findINC('demos'); + my $olddir = cwd; + chdir $root; + show_dir '.', $root, $h; + chdir $olddir; + my $b = $TOP->Button(-text => 'Select All', -command => [\&select_all, $h]); + Tk::grid($b); +} + +sub select_all +{ + my $h = shift; + my @list = $h->infoChildren(@_); + if (@list) + { + $h->selectionSet($list[0],$list[-1]); + foreach my $e (@list) + { + select_all($h,$e); + } + } +} + +sub show_dir { + my($entry_path, $text, $h) = @_; + opendir H, $entry_path; + my(@dirent) = grep ! /^\.\.?$/, sort(readdir H); + closedir H; + $h->add($entry_path, -text => $text, -image => $FOLDIMG, -data => 'DIR'); + while ($_ = shift @dirent) { + my $file = "$entry_path/$_"; + if (-d $file) { + show_dir $file, $_, $h; + } else { + my $size = -s $file; + $h->add($file, -text => $_, -image => $FILEIMG, -data => $size); + } + } +} # end show_dir Index: demos/demos/widget_lib/HList2.pl --- /dev/null 2003-09-23 18:59:22.000000000 +0100 +++ Tk-804.025_beta12/demos/demos/widget_lib/HList2.pl 2003-12-21 11:28:40.000000000 +0000 @@ -0,0 +1,124 @@ +# HList and ItemStyle, multicolumn listbox with individual cell styles. +# -*- perl -*- + +# +# $Id: $ +# Author: Slaven Rezic +# +# Copyright (C) 1999 Slaven Rezic. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +# +# Mail: eserte@cs.tu-berlin.de +# WWW: http://user.cs.tu-berlin.de/~eserte/ +# + +use Tk::HList; +use Tk::ItemStyle; + +sub HList2 { + my($demo) = @_; + my $TOP = $MW->WidgetDemo( + -name => $demo, + -text => 'HList and ItemStyle, multicolumn listbox with individual cell styles.', + -geometry_manager => 'grid', + ); + + my $h = $TOP->Scrolled + (qw/HList + -header 1 + -columns 4 + -width 50 + -height 20/ + )->grid(qw/-sticky nsew/); + + for (0 .. 3) { + $h->header('create', $_, -text => 'Column ' . $_); + } + + my @img; + foreach ('Xcamel.gif', 'anim.gif', 'icon.gif', 'Camel.xpm') { + push @img, $TOP->Photo(-file => Tk->findINC($_)), + } + + my(@fonts) = ('-*-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*', + '-*-Courier-Medium-R-Normal--*-180-*-*-*-*-*-*', + '-*-times-medium-r-normal--*-240-*-*-*-*-*-*', + '-Adobe-Courier-Bold-O-Normal--*-120-*-*-*-*-*-*', + 'fixed', + ); + + my(@colors) = qw(red green blue yellow red cyan black); + + my $rnd_font = sub { + $fonts[rand($#fonts+1)]; + }; + my $rnd_color = sub { + $colors[rand($#colors+1)]; + }; + my $rnd_image = sub { + my $yn = int(rand(2)); + if ($yn) { + $img[rand($#img+1)]; + } else { + undef; + } + }; + my $rnd_window = sub { + my $yn = int(rand(10)); + if ($yn == 3) { + ('Button', 'Entry')[rand(2)]; + } else { + undef; + } + }; + + for my $y (0 .. 20) { + my $e = $h->addchild(""); + for my $col (0 .. 3) { + my $window = $rnd_window->(); + my $image = $rnd_image->(); + my $fg = $rnd_color->(); + my $bg = $rnd_color->(); + if ($bg eq $fg) { $fg = 'white' } + + my $style_type = ($window ? 'window' : + ($image ? 'imagetext' : 'text')); + my $btn; + my $style = $h->ItemStyle($style_type); + if ($style_type eq 'window') { + $style->configure(-pady => 0, -padx => 0, -anchor => "nw"); + if ($window eq 'Button') { + $btn = $h->Button + (-text => 'Click me!', + -command => sub { + $btn->configure(-activeforeground => $rnd_color->()); + }, + ); + } else { + $btn = $h->Entry; + } + } else { + $style->configure(-foreground => $fg, + -background => $bg, + -font => $rnd_font->(), + ); + } + $h->itemCreate + ($e, $col, + -itemtype => $style_type, + -style => $style, + ($style_type eq 'imagetext' + ? (-image => $image) : () + ), + ($style_type eq 'window' + ? (-widget => $btn) : (-text => 'Cell ' . $y . '/' . $col) + ), + ); + } + } +} + +1; + +__END__ Index: demos/demos/widget_lib/balloon.pl --- /dev/null 2003-09-23 18:59:22.000000000 +0100 +++ Tk-804.025_beta12/demos/demos/widget_lib/balloon.pl 2003-12-21 11:28:40.000000000 +0000 @@ -0,0 +1,164 @@ +# Balloon, pop up help window when mouse lingers over widget. + +use Tk; +use English; +use Carp; + +use Tk::Frame; +use Tk::Balloon; + +my $lmsg = ""; + +my $top = MainWindow->new; +my $f = $top->Frame; + +# status bar widget +my $status = $top->Label(-width => 60, -relief => "sunken", -bd => 1, -anchor => 'w'); +$status->pack(-side => "bottom", -fill => "y", -padx => 2, -pady => 1); + +# create the widgets to be explained +my $mb = $top->Menubutton(-relief => 'raised', + -text => 'Menu button'); +my $xxx = 0; +$mb->checkbutton(-label => 'checkbutton', + -variable => \$xxx); +$mb->cascade(-label => 'cascade entry'); +my $menu = $mb->cget(-menu); +my $cm = $menu->Menu(-tearoff => 0); +$mb->entryconfigure('cascade entry', -menu => $cm); +$cm->command(-label => 'first'); +$cm->command(-label => 'second'); +$mb->separator; +$mb->command(-label => 'Close', + -command => sub {$top->destroy;}); + +my $b1 = $top->Button(-text => "Something Unexpected", + -command => sub {$top->destroy;}); +my $b2 = $top->Button(-text => "Something Else Unexpected"); +$b2->configure(-command => sub {$b2->destroy;}); + +# Pack the created widgets: +$mb->pack(-side => "top", -expand => 1); +$b1->pack(-side => "top", -expand => 1); +$b2->pack(-side => "top", -expand => 1); + +my $t = $top->Text(-height => 10, -cursor => 'top_left_arrow')->pack; +$t->insert('end',<Frame->pack; +my $cf = $clbf->Frame->pack(-side => "left"); + +my $c1 = $cf->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8); +my $c2 = $cf->Canvas(-height => 100, -width => 300, -bg => 'white')->pack(-padx => 8, -pady => 8); +my $id = $c1->create('text', 10, 10, + -anchor => 'nw', + -text => "This is a canvas. You can also attach\nballoons to specific items in a canvas"); +$c1->create('rectangle', 40, 60, 80, 80, + -fill => 'red', + -tags => 'rectangle',); +$c1->create('oval', 100, 50, 140, 90, + -fill => 'blue', + -tags => 'circle',); +$c2->create('text', 10, 10, + -anchor => 'nw', + -text => "Or you can attach the balloon\nto the canvas as a whole."); + +my $lb = $clbf->Listbox->pack(-side => "left"); +$lb->insert(qw/end one two three four/); + +# create the balloon widget +my $b = $top->Balloon(-statusbar => $status); + +$b->attach($mb, + -msg => 'Press and hold this button to see the menu.'); +$b->attach($menu, + #-state => 'status', + -balloonposition => 'mouse', + -msg => ['Use this to tear off the menu.', + 'This is a checkbox entry.', + 'cascade', # Cascade entry (ignored by Balloon) + 'separator', # Separator: never active so no message will be displayed for this entry. + 'This is a command entry - it will close this window.', + ], + ); +$b->attach($cm, + -msg => 'This balloon is attached to the cascade menu, not it\'s entries', + #-statusmsg => 'msg cm', + #-balloonmsg => 'cm msg.', + ); +$b->attach($b1, + -balloonmsg => "Close Window", + -statusmsg => "Press this button to close this window"); +$b->attach($b2, + -balloonmsg => "Self-destruct\nButton", + -statusmsg => "Press this button and it will get rid of itself"); + +my $msg = ''; +my @word = ('', ''); # Indicies surrounding the current word. +my @last = ('', ''); # Same for last word. +$b->attach($t, -msg => \$msg, + -balloonposition => 'mouse', # Not really used since the postcommand returns the real position. + -postcommand => sub { if ($word[0] eq $word[1]) { + # No word under mouse - don't post the balloon. + 0; + } else { + # Have a word under mouse - change the message: + my $word = $t->get($word[0], $word[1]); + # Skip it if it contains non-word chars: + return 0 if $word =~ /\W/; + $msg = "The word under the mouse is: $word"; + $t->tag('add', 'sel', $word[0] => $word[1]); + # Find a good place to put the balloon (right below the last char in the word): + my $i = $t->index("$word[1] - 1 chars"); + my @p = $t->bbox($i); + my $x = $t->rootx + $p[0] + $p[2] - 4; + my $y = $t->rooty + $p[1] + $p[3] + 2; + "$x,$y"; + } + }, + -motioncommand => sub { my $x = $t->pointerx - $t->rootx; + my $y = $t->pointery - $t->rooty; + @word = ($t->index("\@$x,$y wordstart"), $t->index("\@$x,$y wordend")); + if ($word[0] eq $last[0] and $word[1] eq $last[1]) { + # Same word - don't cancel the balloon. + 0; + } else { + # New word under mouse - cancel it so a new balloon will be posted. + $t->SelectionClear; + @last = @word; + 1; + } + }, + ); +$b->attach($c1, + -balloonposition => 'mouse', + -msg => {'rectangle' => 'You are over the red rectangle right now.', + $id => 'You are over the text right now.', + 'circle' => 'You are over the blue circle right now.', + }); +$b->attach($c2, + -msg => 'This balloon is attached to the canvas itself.', + ); + +$b->attach($lb, + -balloonposition => 'mouse', + -msg => [qw/1 2 3 4/], + ); + +# As $b is a child of $top it is destroyed when $top is destroyed. +# Balloon.pm now registers a handler for that, and so +# this hackery is no longer required (and did not actually work +# before). +# $top->OnDestroy(sub { $b->destroy; }); + +MainLoop; + Index: demos/demos/widget_lib/browseentry.pl --- /dev/null 2003-09-23 18:59:22.000000000 +0100 +++ Tk-804.025_beta12/demos/demos/widget_lib/browseentry.pl 2003-12-21 11:28:40.000000000 +0000 @@ -0,0 +1,34 @@ +# BrowseEntry, entry with listbox to select list values. + +use Tk::BrowseEntry; + +my $month = "January"; + +outer: +{ + my $top = MainWindow->new; + my $f = $top->Frame; + my $c = $f->BrowseEntry(-label => "Month:", -variable => \$month); + $c->pack; + $c->insert("end", "January"); + $c->insert("end", "February"); + $c->insert("end", "March"); + $c->insert("end", "April"); + $c->insert("end", "May"); + $c->insert("end", "June"); + $c->insert("end", "July"); + $c->insert("end", "August"); + $c->insert("end", "September"); + $c->insert("end", "October"); + $c->insert("end", "November"); + $c->insert("end", "December"); + my $bf = $f->Frame; + $bf->Button(-text => "Print value", + -command => sub { + print "The month is $month\n"; + }, -relief => "raised")->pack; + + $bf->pack; + $f->pack; + MainLoop; +} Index: demos/demos/widget_lib/browseentry2.pl --- /dev/null 2003-09-23 18:59:22.000000000 +0100 +++ Tk-804.025_beta12/demos/demos/widget_lib/browseentry2.pl 2003-12-21 11:28:41.000000000 +0000 @@ -0,0 +1,39 @@ +# BrowseEntry, another example. +# +# Chris Dean + +use strict; +use Tk; +use Tk::BrowseEntry; + +my $top = new MainWindow( -title => "BrowseEntry 2" ); +main( $top ); +MainLoop(); + +sub main { + my( $top ) = @_; + + my @countries = qw( America Belize Canada Denmark Egypt Fruitopia ); + my @states = qw( normal readonly disabled ); + foreach my $i (0..$#states) { + my $state = $states[$i]; + my $var = $countries[$i]; + my $f = $top->Frame->pack( qw/-side left/ ); + my $be = $f->BrowseEntry( -variable => \$var, + -choices => \@countries, + -state => $state )->pack; + if( $state eq "disabled" ) { + $be->configure( -arrowimage => $f->Getimage( "balArrow" ) ) + } + foreach my $s (@states) { + $f->Radiobutton( -text => $s, + -value => $s, + -variable => \$state, + -command => sub { + $be->configure( -state => $state ); } + )->pack( qw/-anchor w/ ); + } + $f->Button( -text => "Print value", -command => sub { + print "$var\n" } )->pack; + } +} Index: demos/demos/widget_lib/dirtree.pl --- /dev/null 2003-09-23 18:59:22.000000000 +0100 +++ Tk-804.025_beta12/demos/demos/widget_lib/dirtree.pl 2003-12-21 11:28:41.000000000 +0000 @@ -0,0 +1,7 @@ +# DirTree, display directory tree. + +use Tk; +use Tk::DirTree; +my $top = MainWindow->new; +my $dl = $top->Scrolled('DirTree')->pack(-expand => 1 , -fill => 'both'); +MainLoop; Index: demos/demos/widget_lib/form_mgr.pl --- /dev/null 2003-09-23 18:59:22.000000000 +0100 +++ Tk-804.025_beta12/demos/demos/widget_lib/form_mgr.pl 2003-12-21 11:28:41.000000000 +0000 @@ -0,0 +1,21 @@ +# Form, window management by Tix->form. + +use Tk; + +my $Main = MainWindow->new(); + +my $box4 = $Main->Label(-text => 'box4', -borderwidth => 1, -relief => "raised"); +my $box1 = $Main->Label(-text => 'box1',-borderwidth => 1, -relief => "raised"); +my $box2 = $Main->Label(-text => 'box2',-borderwidth => 1, -relief => "raised"); +my $box3 = $Main->Label(-text => 'box3',-borderwidth => 1, -relief => "raised"); + +$box1->form(-top => '%0', -left => '%0', -right => '%100'); +$box2->form(-top => $box1, -left => '%0', -right => '%50', -bottom => +$box4); +$box3->form(-top => $box1, -left => $box2, -right => '%100', -bottom => +$box4); +$box4->form(-left => '%0', -right => '%100', -bottom => '%100'); + +MainLoop; +__END__ + Index: demos/demos/widget_lib/hello.pl --- Tk-804.025_beta11/demos/demos/widget_lib/hello.pl 2003-12-14 22:25:34.000000000 +0000 +++ Tk-804.025_beta12/demos/demos/widget_lib/hello.pl 2003-12-21 12:34:44.000000000 +0000 @@ -1,7 +1,6 @@ # hello.pl use Config; -use File::Basename; use Tk::widgets qw/ ROText /; use vars qw/ $TOP /; use strict; @@ -12,7 +11,13 @@ $TOP = $MW->WidgetDemo( -name => $demo, - -text => "This demonstration describes the basics of Perl/Tk programming. MORE HERE, PLEASE.", + -text => [ "This demonstration describes the basics of Perl/Tk programming. Besides this small user guide, there are various FAQs and other resources and tutorials available on the web, such as: + +http://phaseit.net/claird/comp.lang.perl.tk/ptkFAQ.html +http://www.perltk.org +http://user.cs.tu-berlin.de/~eserte +http://www.lehigh.edu/sol0/ptk +", -wraplength => '7i' ], -title => 'Perl/Tk User Guide', -iconname => 'hello', ); @@ -20,9 +25,9 @@ # Pipe perldoc help output via fileevent() into a Scrolled ROText widget. my $t = $TOP->Scrolled( - qw/ ROText -width 80 -height 25 -wrap none -scrollbars osow/, + qw/ ROText -width 80 -height 25 -wrap none -scrollbars osoe/, ); - my $cmd = dirname( $Config{perlpath} ) . '/perldoc -t Tk::UserGuide'; + my $cmd = $Config{installbin} . '/perldoc -t Tk::UserGuide'; $t->pack( qw/ -expand 1 -fill both / ); open( H, "$cmd|" ) or die "Cannot get pTk user guide: $!"; Index: demos/demos/widget_lib/labframe.pl --- /dev/null 2003-09-23 18:59:22.000000000 +0100 +++ Tk-804.025_beta12/demos/demos/widget_lib/labframe.pl 2003-12-21 11:28:41.000000000 +0000 @@ -0,0 +1,13 @@ +# LabFrame, frame with embedded label. + +use Tk; +use Tk::LabFrame; +use Tk::LabEntry; + +my $test = 'Test this'; + +my $top = MainWindow->new; +my $f = $top->LabFrame(-label => "This is a label", -labelside => "acrosstop"); +$f->LabEntry(-label => "Testing", -textvariable => \$test)->pack; +$f->pack; +MainLoop; Index: demos/demos/widget_lib/mega.pl --- Tk-804.025_beta11/demos/demos/widget_lib/mega.pl 2003-12-14 22:25:34.000000000 +0000 +++ Tk-804.025_beta12/demos/demos/widget_lib/mega.pl 2003-12-21 12:42:00.000000000 +0000 @@ -14,7 +14,7 @@ -iconname => 'mega', ); - my $t = $TOP->Scrolled( qw/ ROText -wrap word -scrollbars ow/ ); + my $t = $TOP->Scrolled( qw/ ROText -wrap word -scrollbars oe/ ); $t->pack( qw/ -fill both -expand 1 / ); $t->insert( 'end', <<'end-of-instructions' ); @@ -46,7 +46,7 @@ my $nil = $mw->Nil; -And an empty Nil window appears that functions just like a Toplevel! But other than that, the Nil widget doesn't do anything more since no additonal subwidgets or behavior has been defined. The purpose of that example was to demonstrate how much the Perl/Tk mega-widget mechanism did for the mega-widget author - a fully functional composite mega-widget in three lines of code. +And an empty Nil window appears that functions just like a Toplevel! But other than that, the Nil widget doesn't do anything more since no additonal subwidgets or behavior have been defined. The purpose of that example was to demonstrate how much the Perl/Tk mega-widget mechanism did for the mega-widget author - a fully functional composite mega-widget in three lines of code. There's a second container-like mega-widget in Perl/Tk, based on a Frame. But other than the logical container, the two mega-widget types are more-or-less equivalent. The third and final mega-widget type we call a derived mega-widget, because it adds or subtracts behavior to/from an existing widget. Index: demos/demos/widget_lib/notebook.pl --- /dev/null 2003-09-23 18:59:22.000000000 +0100 +++ Tk-804.025_beta12/demos/demos/widget_lib/notebook.pl 2003-12-21 11:28:41.000000000 +0000 @@ -0,0 +1,59 @@ +# Notebook, selectable pages. + +use Tk; +use Tk::DialogBox; +use Tk::NoteBook; +use Tk::LabEntry; + +my $name = "Rajappa Iyer"; +my $email = "rsi\@netcom.com"; +my $os = "Linux"; + +use vars qw($top); + +$top = MainWindow->new; +my $pb = $top->Button(-text => "Notebook", -command => \&donotebook); +$pb->pack; +MainLoop; + + +my $f; + +sub donotebook { + if (not defined $f) { + # The current example uses a DialogBox, but you could just + # as easily not use one... replace the following by + # $n = $top->NoteBook(-ipadx => 6, -ipady => 6); + # Of course, then you'd have to take care of the OK and Cancel + # buttons yourself. :-) + $f = $top->DialogBox(-title => "Personal Profile", + -buttons => ["OK", "Cancel"]); + my $n = $f->add('NoteBook', -ipadx => 6, -ipady => 6); + + my $address_p = $n->add("address", -label => "Address", -underline => 0); + my $pref_p = $n->add("pref", -label => "Preferences", -underline => 0); + + $address_p->LabEntry(-label => "Name: ", + -labelPack => [-side => "left", -anchor => "w"], + -width => 20, + -textvariable => \$name)->pack(-side => "top", -anchor => "nw"); + $address_p->LabEntry(-label => "Email Address:", + -labelPack => [-side => "left", -anchor => "w"], + -width => 50, + -textvariable => \$email)->pack(-side => "top", -anchor => "nw"); + $pref_p->LabEntry(-label => "Operating System:", + -labelPack => [-side => "left"], + -width => 15, + -textvariable => \$os)->pack(-side => "top", -anchor => "nw"); + $n->pack(-expand => "yes", + -fill => "both", + -padx => 5, -pady => 5, + -side => "top"); + + } + my $result = $f->Show; + if ($result =~ /OK/) { + print "name = $name, email = $email, os = $os\n"; + } +} + Index: demos/demos/widget_lib/progress.pl --- /dev/null 2003-09-23 18:59:22.000000000 +0100 +++ Tk-804.025_beta12/demos/demos/widget_lib/progress.pl 2003-12-21 11:28:41.000000000 +0000 @@ -0,0 +1,46 @@ +# ProgressBar - display various progress bars. + +use strict; +use Tk; +use Tk::ProgressBar; +use Tk::Scale; + +my $mw = MainWindow->new; + +my $status_var = 0; + +my($fromv,$tov) = (0,100); +foreach my $loop (0..1) { + my $res = 0; + my $blks = 10; + my @p = qw(top bottom left right); + foreach my $dir (qw(n s w e)) { + $mw->ProgressBar( + -borderwidth => 2, + -relief => 'sunken', + -width => 20, + -padx => 2, + -pady => 2, + -variable => \$status_var, + -colors => [0 => 'green', 50 => 'yellow' , 80 => 'red'], + -resolution => $res, + -blocks => $blks, + -anchor => $dir, + -from => $fromv, + -to => $tov + )->pack( + -padx => 10, + -pady => 10, + -side => pop(@p), + -fill => 'both', + -expand => 1 + ); + $blks = abs($blks - ($res * 2)); + $res = abs(5 - $res); + } + ($fromv,$tov) = ($tov,$fromv); +} + +$mw->Scale(-from => 0, -to => 100, -variable => \$status_var)->pack; + +MainLoop; Index: demos/demos/widget_lib/slide.pl --- Tk-804.025_beta11/demos/demos/widget_lib/slide.pl 2003-12-14 22:25:34.000000000 +0000 +++ Tk-804.025_beta12/demos/demos/widget_lib/slide.pl 2003-12-21 11:32:18.000000000 +0000 @@ -75,7 +75,6 @@ package main; -use Tk::widgets qw/ Trace /; use vars qw / $TOP /; use strict; Index: demos/demos/widget_lib/trace2.pl --- Tk-804.025_beta11/demos/demos/widget_lib/trace2.pl 2003-12-14 22:25:37.000000000 +0000 +++ Tk-804.025_beta12/demos/demos/widget_lib/trace2.pl 2003-12-21 11:32:20.000000000 +0000 @@ -4,6 +4,7 @@ package Tk::TraceText; +use Tk::widgets qw/ Trace /; use base qw/ Tk::Derived Tk::Text /; use strict; Index: demos/widget --- Tk-804.025_beta11/demos/widget 2003-12-14 22:25:39.000000000 +0000 +++ Tk-804.025_beta12/demos/widget 2003-12-21 12:42:12.000000000 +0000 @@ -5,7 +5,7 @@ use lib Tk->findINC( 'demos/widget_lib' ); use Tk::widgets qw/ DialogBox ErrorDialog LabEntry ROText /; use WidgetDemo; -use subs qw/ +use subs qw/ build_about_dialog demos invoke lsearch see_code see_vars show_stat view_widget /; @@ -142,101 +142,114 @@ $T->insert('end', "Perl/Tk Widget Demonstrations\n", 'title'); $T->insert('end', -"\nThis application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the ", '', 'See Code', 'bold', " button to see the Perl/Tk code that created the demonstration. If you wish, you can edit the code and click the ", '', "Rerun Demo", 'bold', " button in the code window to reinvoke the demonstration with the modified code.\n"); +"\nThis application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the ", '', 'See Code', 'bold', " button to see the Perl/Tk code that created the demonstration. If you wish, you can edit the code and click the ", '', "Rerun Demo", 'bold', " button in the code window to reinvoke the demonstration with the modified code.\n" +); demos 'Getting Started', ( - 'hello' => 'An introduction to Perl/Tk', + 'hello' => 'An introduction to Perl/Tk', ); demos 'Labels, buttons, checkbuttons, and radiobuttons', ( - 'labels' => 'Labels (text and images)', - 'unicodeout' => 'Labels and Unicode text', - 'button' => 'Buttons', - 'check' => 'Checkbuttons (select any of a group)', - 'radio' => 'Radiobuttons (select one of a group)', - 'puzzle' => 'A 15-puzzle game made out of buttons', - 'icon' => 'Iconic buttons that use bitmaps', - 'image1' => 'Two labels displaying images', - 'image2' => 'A simple user interface for viewing images', - 'labelframe' => 'Labelled frames', + 'labels' => 'Labels (text and images)', + 'unicodeout' => 'Labels and Unicode text', + 'button' => 'Buttons', + 'check' => 'Checkbuttons (select any of a group)', + 'radio' => 'Radiobuttons (select one of a group)', + 'puzzle' => 'A 15-puzzle game made out of buttons', + 'icon' => 'Iconic buttons that use bitmaps', + 'image1' => 'Two labels displaying images', + 'image2' => 'A simple user interface for viewing images', + 'labelframe' => 'Labelled frames', ); demos 'Listboxes', ( - 'states' => 'The 50 states', - 'colors' => 'Change widget\'s color scheme', - 'sayings' => 'A collection of famous and infamous sayings', + 'states' => 'The 50 states', + 'colors' => 'Change widget\'s color scheme', + 'sayings' => 'A collection of famous and infamous sayings', ); demos 'Entries and Spin-boxes', ( - 'entry1' => 'Entries without scrollbars', - 'entry2' => 'Entries with scrollbars', - 'entry3' => 'Validated entries and password fields', - 'spin' => 'Spin-boxes', - 'form' => 'Simple Rolodex-like form', + 'entry1' => 'Entries without scrollbars', + 'entry2' => 'Entries with scrollbars', + 'entry3' => 'Validated entries and password fields', + 'spin' => 'Spin-boxes', + 'form' => 'Simple Rolodex-like form', ); demos 'Text', ( - 'texts' => 'Basic editable text', - 'style' => 'Text display styles', - 'bind' => 'Hypertext (tag bindings)', - 'twind' => 'A text widget with embedded windows', - 'search' => 'A search tool built with a text widget', + 'texts' => 'Basic editable text', + 'style' => 'Text display styles', + 'bind' => 'Hypertext (tag bindings)', + 'twind' => 'A text widget with embedded windows', + 'search' => 'A search tool built with a text widget', ); demos 'Canvases', ( - 'items' => 'The canvas item types', - 'plot' => 'A simple 2-D plot', - 'ctext' => 'Text items in canvases', - 'arrows' => 'An editor for arrowheads on canvas lines', - 'ruler' => 'A ruler with adjustable tab stops', - 'floor' => 'A building floor plan', - 'cscroll' => 'A simple scrollable canvas', - 'transtile' => 'Tiles and transparent images', + 'items' => 'The canvas item types', + 'plot' => 'A simple 2-D plot', + 'ctext' => 'Text items in canvases', + 'arrows' => 'An editor for arrowheads on canvas lines', + 'ruler' => 'A ruler with adjustable tab stops', + 'floor' => 'A building floor plan', + 'cscroll' => 'A simple scrollable canvas', + 'transtile' => 'Tiles and transparent images', ); demos 'Scales', ( - 'hscale' => 'Horizontal scale', - 'vscale' => 'Vertical scale', + 'hscale' => 'Horizontal scale', + 'vscale' => 'Vertical scale', ); demos 'Paned Windows', ( - 'paned1' => 'Horizontal paned window', - 'paned2' => 'Vertical paned window', + 'paned1' => 'Horizontal paned window', + 'paned2' => 'Vertical paned window', ); demos 'Photos and Images', ( - 'photo1' => 'Transparent pixels', - 'photo2' => 'Alpha channel compositing', + 'photo1' => 'Transparent pixels', + 'photo2' => 'Alpha channel compositing', ); demos 'Menus', ( - 'menus' => 'Menus and cascades (sub-menus)', - 'menus2' => 'As above, but using Perl/Tk -menuitems', - 'menbut' => 'Menubuttons', + 'menus' => 'Menus and cascades (sub-menus)', + 'menus2' => 'As above, but using Perl/Tk -menuitems', + 'menbut' => 'Menubuttons', ); demos 'Common Dialogs', ( - 'msgBox' => 'Message boxes', - 'filebox' => 'File selection dialog', - 'choosedir' => 'Directory selection dialog', - 'clrpick' => 'Color picker', + 'msgBox' => 'Message boxes', + 'filebox' => 'File selection dialog', + 'choosedir' => 'Directory selection dialog', + 'clrpick' => 'Color picker', +); + +demos 'Tix Widgets', ( + 'balloon' => 'Popup help window when mouse lingers over widget', + 'browseentry' => 'Entry with Listbox to select list values', + 'browseentry2' => 'Another BrowseEntry example', + 'dirtree' => 'Display a directory tree', + 'form_mgr' => 'The form geometry manager', + 'HList' => 'A hierarchical listbox widget', + 'HList2' => 'Multicolumn listbox with individual cell styles', + 'labframe' => 'A Frame with embedded label (deprecated)', ); demos 'Simulations', ( - 'bounce' => 'Balls bouncing in a cavity', + 'bounce' => 'Balls bouncing in a cavity', ); demos 'Sample Perl Mega-Widgets', ( - 'mega' => 'Introduction to writing pure Perl mega-widgets', - 'slide' => 'Composite Tk::SlideSwitch - binary on/off switch', - 'trace2' => 'Derived Tk::TraceText - Text contents defined by a traced variable', + 'mega' => 'Introduction to writing pure Perl mega-widgets', + 'slide' => 'Composite Tk::SlideSwitch - binary on/off switch', + 'trace2' => 'Derived Tk::TraceText - Text contents defined by a traced variable', ); demos 'Miscellaneous', ( - 'bitmaps' => 'The built-in bitmaps', - 'dialog1' => 'A dialog box with a local grab', - 'dialog2' => 'A dialog box with a global grab', - 'trace1' => 'Trace a variable\'s value', + 'bitmaps' => 'The built-in bitmaps', + 'dialog1' => 'A dialog box with a local grab', + 'dialog2' => 'A dialog box with a global grab', + 'trace1' => 'Trace a variable\'s value', + 'progress' => 'Various ProgressBar widgets', ); $T->insert('end', "\n", '', "User Contributed Demonstrations\n", 'title'); @@ -260,6 +273,7 @@ } build_about_dialog $help; +$T->focus; MainLoop; @@ -331,7 +345,7 @@ $T->insert('end', "\n", '', "$title\n", 'title'); for (my $n = 0; $n <= $#demos; $n += 2) { - $T->insert('end', $n / 2 + 1 . '. ' . $demos[$n + 1] . ".\n", + $T->insert('end', $n / 2 + 1 . '. ' . $demos[$n + 1] . ".\n", ['demo', 'demo-' . $demos[$n]]); } @@ -392,7 +406,7 @@ -command => [$CODE => 'withdraw'], ); $CODE_RERUN = $code_buttons->Button(-text => 'Rerun Demo'); - $CODE_TEXT = $CODE->Scrolled('Text', qw/ -height 40 -scrollbars ow /); + $CODE_TEXT = $CODE->Scrolled('Text', qw/ -height 40 -scrollbars oe /); $code_buttons_dismiss->pack(qw/-side left -expand 1/); $CODE_RERUN->pack(qw/-side left -expand 1/); $CODE_TEXT->pack(qw/-side left -expand 1 -fill both/); @@ -419,6 +433,7 @@ } close CODE; $CODE_TEXT->markSet(qw/insert 1.0/); + $CODE_TEXT->focus; } # end see_code @@ -492,7 +507,7 @@ -command => [$VIEW => 'withdraw'], ); $view_buttons_dismiss->pack(qw/-side left -expand 1/); - $VIEW_TEXT = $VIEW->Scrolled('Text', qw/ -height 40 -wrap none /); + $VIEW_TEXT = $VIEW->Scrolled('Text', qw/ -height 40 -scrollbars oe /); $VIEW_TEXT->pack(qw/-side left -expand 1 -fill both/); } else { $VIEW->deiconify; Index: mkdist --- Tk-804.025_beta11/mkdist 2003-10-20 21:06:14.000000000 +0100 +++ Tk-804.025_beta12/mkdist 2003-12-21 13:04:32.000000000 +0000 @@ -16,6 +16,7 @@ die "Cannot " . join(' ',@_) if (system(@_)); } + open(MF,") { @@ -38,6 +39,29 @@ my $files = maniread(); $dir = 'Tk'; +$opt_sfx = '_'.$opt_sfx if (length($opt_sfx) && $opt_sfx !~ /^_/); + +system(p4 => edit => 'Tk.pm', 'Change.log'); +system("p4 changes -l ./... > Change.log"); +open(my $fh,"|p4 submit -i") || die; +print $fh <<"END"; +Change: new + +Client: llama + +User: nick + +Status: new + +Description: + $dir-$version$opt_sfx Release Preparation + +Files: + //depot/Tkutf8/Change.log # edit + //depot/Tkutf8/Tk.pm # edit +END +close($fh); + my $snag = 0; foreach my $file (keys %$files) @@ -56,7 +80,6 @@ exit(1) if $snag && !$opt_lax; -$opt_sfx = '_'.$opt_sfx if (length($opt_sfx) && $opt_sfx !~ /^_/); my @files = map("$dir-$version$opt_sfx/$_",sort(keys %$files)); chdir(".."); Index: objGlue.c --- Tk-804.025_beta11/objGlue.c 2003-12-02 19:54:45.000000000 +0000 +++ Tk-804.025_beta12/objGlue.c 2003-12-21 19:44:25.000000000 +0000 @@ -702,6 +702,27 @@ return TCL_ERROR; } +void +Tcl_AppendElement(interp, string) +Tcl_Interp *interp; +CONST char *string; +{ + dTHX; + Tcl_Obj *result = Tcl_GetObjResult(interp); + Tcl_Obj *value = Tcl_NewStringObj(string,-1); + if (1 || SvOK(result)) + { + Tcl_ListObjAppendElement(interp,result,value); + } + else + { + SvSetMagicSV(result, value); + LangDumpVec(__FUNCTION__,1,&result); + } +} + + + AV * MaybeForceList(pTHX_ Tcl_Interp *interp, Tcl_Obj *sv) { Index: pTk/Tcl-pTk --- Tk-804.025_beta11/pTk/Tcl-pTk 2003-10-26 13:47:38.000000000 +0000 +++ Tk-804.025_beta12/pTk/Tcl-pTk 2003-12-21 10:47:19.000000000 +0000 @@ -1,7 +1,6 @@ #!/usr/local/bin/perl -w - +use open IO => ':bytes'; # Avoid UTF-8 issues with some perl5.8.0 (RedHat) use Carp; - my $verbose = 0; $SIG{'__WARN__'} = sub { print STDERR $_; Carp::confess(shift) }; Index: pTk/mTk/generic/tkFont.c --- Tk-804.025_beta11/pTk/mTk/generic/tkFont.c 2003-12-19 11:54:52.000000000 +0000 +++ Tk-804.025_beta12/pTk/mTk/generic/tkFont.c 2003-12-21 14:17:34.000000000 +0000 @@ -2865,7 +2865,9 @@ buf[used++] = *glyphname++ ; buf[used++] = '('; } - + else { + LangDebug("No PostScript glyph for U+%04x\n",ch); + } } if (used >= MAXUSE) { buf[used] = '\0'; Index: pTk/mTk/tixGeneric/tixDiITxt.c --- Tk-804.025_beta11/pTk/mTk/tixGeneric/tixDiITxt.c 2003-09-05 12:37:45.000000000 +0100 +++ Tk-804.025_beta12/pTk/mTk/tixGeneric/tixDiITxt.c 2003-12-21 18:47:57.000000000 +0000 @@ -94,7 +94,7 @@ #define DEF_IMAGETEXTSTYLE_DISABLED_BG_COLOR DISABLED_BG #define DEF_IMAGETEXTSTYLE_DISABLED_BG_MONO WHITE -#define DEF_IMAGETEXTSTYLE_FONT "Helvetica -12 bold" +#define DEF_IMAGETEXTSTYLE_FONT CTL_FONT #define DEF_IMAGETEXTSTYLE_GAP "4" #define DEF_IMAGETEXTSTYLE_PADX "2" #define DEF_IMAGETEXTSTYLE_PADY "2" Index: pTk/strGlue.c --- Tk-804.025_beta11/pTk/strGlue.c 2003-07-19 09:39:39.000000000 +0100 +++ Tk-804.025_beta12/pTk/strGlue.c 2003-12-21 14:15:58.000000000 +0000 @@ -15,8 +15,10 @@ Tcl_Obj *temp2 = NULL; Tcl_Obj *ret; if (part2) - temp2 = Tcl_NewStringObj(part2,-1); - ret = Tcl_ObjGetVar2(interp, temp, NULL, flags); + { + temp2 = Tcl_NewStringObj(part2,-1); + } + ret = Tcl_ObjGetVar2(interp, temp, temp2, flags); Tcl_DecrRefCount(temp); if (temp2) Tcl_DecrRefCount(temp2); Index: pod/UserGuide.pod --- Tk-804.025_beta11/pod/UserGuide.pod 2003-12-14 22:25:40.000000000 +0000 +++ Tk-804.025_beta12/pod/UserGuide.pod 2003-12-21 12:32:46.000000000 +0000 @@ -6,19 +6,28 @@ =head1 DESCRIPTION -This document is for beginners. It assumes you know some Perl, and -have it and Tk running. If you are not currently reading this +This document is for beginners. It assumes you know some B, and +have it and Tk running. If you are I currently reading this document courtesy of the B demonstration program, please be -sure to run B, as it will teach you the various widget types +sure to run B, as it will show you the various widget types supported by Tk and how to use them. B should be installed in your default path, so type I at a command prompt. +Here are links to other novice tutorials: + +http://www.lehigh.edu/~sol0/ptk/tpj1.html +http://www.lehigh.edu/~sol0/ptk/perlmonth01/pm1.html + +I is the definitive book on Perl/Tk: + +http://www.oreilly.com/catalog/mastperltk + =head1 Some Background Tk GUI programming is event-driven. (This may already be familiar to you.) In event-driven programs, the main GUI loop is outside of the user program and inside the GUI library. This loop - initiated by -calling B - watches all events of interest and activate +calling B - watches all events of interest and activates the correct handler procedures to handle these events. Some of these handler procedures may be user-supplied; others will be part of the library. @@ -28,96 +37,113 @@ necessary. So, you're not watching for 'raise window / close window / redraw window' requests, but you tell the toolkit which routine will handle such cases, -and the toolkit will call the procedures when required. +and the toolkit will call the procedures when required. These procedures +are known as I, and some of them you write yourself. =head1 First Requirements -Any perl program that uses Tk needs to include C. +B programs that use Tk need to include C. A program should also use C and the B<-w> switch to ensure the program is working without common errors. -Any Tk application starts by creating the Tk main window. You then create -items inside the main window, or create new windows, before starting the -mainloop. -(You can also create more items and windows while you're running.) -The items will be shown on the display after you C them; -more info on this later. -Then you do a Tk mainloop; this will start the GUI and handle all events. -That's your application. -A trivial one-window example is show below: - - #! /usr/bin/perl5 -w - - use strict; - use Tk; - - my $main = MainWindow->new; - $main->Label(-text => 'Hello, world!')->pack; - $main->Button(-text => 'Quit', - -command => [$main => 'destroy'] - )->pack; - MainLoop; - -Please run this example. It shows you two items types also shown in the -widget demo; it also shows you how items are created and packed. -Finally, note the typical Tk style using C<-option> =E C pairs. - -=head1 Item creation - -Tk windows and widgets are hierarchical, S includes one or more -others. You create the first Tk window using Cnew>. -This returns a window handle, assigned to C<$main> in the example above. -Keep track of the main handle. - -You can use any Tk handle to create sub-items within the window or widget. -This is done by calling the Tk constructor method on the variable. -In the example above, the C