# strip everything before this and feed to /bin/sh # # rm -f Tk/MsgBox.pm rm -f pod/configspec.pod touch README.OpenBSD chmod 0444 README.OpenBSD touch t/autoload.t chmod 0444 t/autoload.t touch pod/ConfigSpecs.pod chmod 0444 pod/ConfigSpecs.pod touch t/fileevent.t chmod 0444 t/fileevent.t touch icon chmod 0444 icon patch -p1 -N <<'__END_OF_PATCH__' Index: Change.log --- Tk800.020/Change.log Mon Mar 27 15:35:42 2000 +++ Tk800.021/Change.log Fri Apr 21 10:08:52 2000 @@ -1,3 +1,160 @@ +Change 1826 on 2000/04/21 by nick@bactrian + + A few more sprintf's converted to return int SVs directly + +Change 1825 on 2000/04/21 by nick@bactrian + + Fix REFCNT botch which has been plaguing us for so long. + +Change 1824 on 2000/04/20 by nick@pluto + + Use private handle for reading director for FBox + +Change 1823 on 2000/04/20 by nick@pluto + + Attempting to debug PERL_DESTRUCT_LEVEL=3 issues. + Seems to SEGFAULT during exit of t/fbox.t (Linux and Solaris2.7, + perl5.005_03). + + Two more exit cleanup attempts: + 1. Stop using raw sharepvn() for Tk_GetUid() so we + don't get all the refcount issues with string table. + 2. Remove (redundant?) self-reference in Tcl_TraceVar* 'U' magic. + +Change 1822 on 2000/04/15 by nick@linux + + 'Too late for INIT hackery for Event.xs' + +Change 1821 on 2000/04/15 by nick@bactrian + + Re-enable B::C compile (at least with 5.00503) + +Change 1820 on 2000/04/10 by nick@bactrian + + Fix new Optionmenu to not call callback unless it is + setting value or FBox at least goes into a loop. + Also remove work-round for old Optionmenu behaviour from FBox + +Change 1819 on 2000/04/10 by nick@pluto + + Add aliases to BrowseEntry config options to make it more like Optionmenu. + Make both Optionmenu and BrowseEntry honour incoming -textvariable + if valid, but re-set it if -options set to list which + does not include it. + +Change 1818 on 2000/04/07 by nick@bactrian + + Avoid use of undef when Entry part of BrowseEntry gets + ButtonMotion events. + +Change 1815 on 2000/04/05 by nick@pluto + + Don't hard-code /usr/local/perl + +Change 1814 on 2000/04/03 by nick@bactrian + + dTHR -> dTHX everywhere (+ fallback to dTHR if not defined). + +Change 1813 on 2000/04/02 by nick@bactrian + + Fix typo + +Change 1812 on 2000/04/02 by nick@bactrian + + Increment version to 800.021 for testing + +Change 1811 on 2000/04/02 by nick@bactrian + + Win32-ish tolerance of (e.g. C:/) as path in Fbox. + +Change 1810 on 2000/04/02 by nick@bactrian + + Avoid READABLE/readable name clash in Event.xs for VMS. + +Change 1809 on 2000/04/01 by nick@bactrian + + Merge img1.2.3 builds and passes t/photo.t + +Change 1808 on 2000/04/01 by nick@bactrian + + Raw merge of img1.2.3 + +Change 1805 on 2000/04/01 by nick@bactrian + + Make patch for XrmOption tidier + +Change 1804 on 2000/04/01 by nick@bactrian + + Fix Tk::Xrm with multiple mainwindows + +Change 1803 on 2000/03/31 by nick@bactrian + + VERSION tweaks (I must automate that somehow ...) + +Change 1802 on 2000/03/31 by nick@bactrian + + - allow ->index in TList + - Exist check in Table's layout method + - Document corner in Scrolled. + +Change 1801 on 2000/03/31 by nick@bactrian + + Various tweaks from mailbox backlog + - Tiler scroll behaviour + - remove 'use English' from demos/widget. + - rename configspec.pod ConfigSpecs.pod + - Loose MsgBox.pm + +Change 1800 on 2000/03/31 by nick@bactrian + + Dialog(Box) foreground/background propagation + Add as <> + Protect Tiler from divide by zero + Avoid gcc options to non gcc. + +Change 1799 on 2000/03/31 by nick@bactrian + + Fix Tix style issues with multiple MainWindows. + +Change 1798 on 2000/03/31 by nick@bactrian + + Steve's -labelXxxx patch. + More + +Change 1797 on 2000/03/30 by nick@bactrian + + Dratted $VERSION again. + +Change 1796 on 2000/03/30 by nick@bactrian + + Document and attempt to work round the -Bforcearchive issue on OpenBSD. + While in there restrict types of files in t directory that are considered. + +Change 1794 on 2000/03/30 by nick@bactrian + + Don't create callback for BackgroundError with raw array. + +Change 1792 on 2000/03/30 by nick@bactrian + + Update versions of patched files. + +Change 1791 on 2000/03/30 by nick@linux + + Avoid ->Delegate AUTOLOAD scheme if not appropriate + +Change 1790 on 2000/03/30 by nick@bactrian + + Add README.OpenBSD discussing the -Bforcearchive issue. + Steve's fileevent.t + +Change 1788 on 2000/03/27 by nick@bactrian + + Steve's tweak to untie issue with Tk::Event::IO + +Change 1787 on 2000/03/27 by nick@bactrian + + Tk800.020 release prep. + Change 1786 on 2000/03/27 by nick@bactrian_nt An attempt to get 'ActiveWindow' right on Win32 Index: Changes --- Tk800.020/Changes Mon Mar 27 15:40:54 2000 +++ Tk800.021/Changes Fri Apr 21 10:18:56 2000 @@ -4,6 +4,19 @@ Change.log is generated from perforce database, it is therefore complete, but short on detail. +Changes in Tk800.021 + Steve's patches for fileevent and -labelXxxxx + Fixed the 'Delagate' bug introduced trying to make AUTOLOAD clean. + Tweaks to Optionmenu and BrowseEntry to make them more like each other + and better tolerate changing the options/choices list. + Made B::C* work again for perl5.005_03 (perl5.6.0 has problems). + Use dTHX every where we had dTHR - should build against threaded perl + (STILL NOT THREAD SAFE). + Fix name clash in Event for VMS. + Merge production Img1.2.3 + Fix Tk::Xrm and Tix Style with multiple MainWindows + Found and fixed the 'Attempt to free unreferenced scalar' issue. + Changes in Tk800.020 Various tweaks for perl5.6.0 Fix ->itemconfigure of grouped canvas items. Index: DragDrop/DragDrop.pm --- Tk800.020/DragDrop/DragDrop.pm Sat Oct 2 17:44:27 1999 +++ Tk800.021/DragDrop/DragDrop.pm Fri Apr 21 10:56:19 2000 @@ -4,7 +4,7 @@ require Tk::Label; use vars qw($VERSION); -$VERSION = '3.027'; # $Id: //depot/Tk8/DragDrop/DragDrop.pm#27 $ +$VERSION = '3.029'; # $Id: //depot/Tk8/DragDrop/DragDrop.pm#29 $ use base qw(Tk::DragDrop::Common Tk::Toplevel); @@ -251,7 +251,7 @@ { my ($token,$seln) = @_; my $w = $token->parent; - $token->configure(-selection => $seln) if $seln; + $token->configure('-selection' => $seln) if $seln; $seln = $token->cget('-selection'); if ($token->{InstallHandlers}) { Index: Entry/Entry.pm --- Tk800.020/Entry/Entry.pm Sat Oct 2 17:44:27 1999 +++ Tk800.021/Entry/Entry.pm Fri Apr 7 16:44:29 2000 @@ -12,7 +12,7 @@ # This program is free software; you can redistribute it and/or use vars qw($VERSION); -$VERSION = '3.032'; # $Id: //depot/Tk8/Entry/Entry.pm#32 $ +$VERSION = '3.033'; # $Id: //depot/Tk8/Entry/Entry.pm#33 $ # modify it under the same terms as Perl itself, subject # to additional disclaimer in license.terms due to partial @@ -281,7 +281,9 @@ my $x = shift; $Tk::selectMode = shift if (@_); my $cur = $w->index('@' . $x); + return unless defined $cur; my $anchor = $w->index('anchor'); + return unless defined $anchor; if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3)) { $Tk::mouseMoved = 1 Index: Event/Event.pm --- Tk800.020/Event/Event.pm Sat Mar 25 09:08:47 2000 +++ Tk800.021/Event/Event.pm Sun Apr 2 13:45:18 2000 @@ -1,8 +1,8 @@ package Tk::Event; use vars qw($VERSION $XS_VERSION @EXPORT_OK); END { CleanupGlue() } -$VERSION = '3.021'; # $Id: //depot/Tk8/Event/Event.pm#21 $ -$XS_VERSION = '800.020'; +$VERSION = '3.022'; # $Id: //depot/Tk8/Event/Event.pm#22 $ +$XS_VERSION = '800.021'; require DynaLoader; use base qw(Exporter DynaLoader); @EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS Index: Event/Event.xs --- Tk800.020/Event/Event.xs Wed Mar 22 16:41:39 2000 +++ Tk800.021/Event/Event.xs Sat Apr 15 17:36:41 2000 @@ -399,7 +399,7 @@ } int -PerlIO_writable(filePtr) +PerlIO_is_writable(filePtr) PerlIOHandler *filePtr; { if (!(filePtr->readyMask & TCL_WRITABLE)) @@ -417,7 +417,7 @@ } int -PerlIO_readable(filePtr) +PerlIO_is_readable(filePtr) PerlIOHandler *filePtr; { if (!(filePtr->readyMask & TCL_READABLE)) @@ -436,7 +436,7 @@ } int -PerlIO_exception(filePtr) +PerlIO_has_exception(filePtr) PerlIOHandler *filePtr; { return (filePtr->readyMask & TCL_EXCEPTION); @@ -457,13 +457,13 @@ switch (mask) { case TCL_EXCEPTION: - check = PerlIO_exception; + check = PerlIO_has_exception; break; case TCL_WRITABLE: - check = PerlIO_writable; + check = PerlIO_is_writable; break; case TCL_READABLE: - check = PerlIO_readable; + check = PerlIO_is_readable; break; default: croak("Invalid wait type %d",mask); @@ -516,13 +516,13 @@ { /* file is ready do not block */ if ((filePtr->mask & TCL_READABLE) - && PerlIO_readable(filePtr)) + && PerlIO_is_readable(filePtr)) Tcl_SetMaxBlockTime(&blockTime); if ((filePtr->mask & TCL_WRITABLE) - && PerlIO_writable(filePtr)) + && PerlIO_is_writable(filePtr)) Tcl_SetMaxBlockTime(&blockTime); if ((filePtr->mask & TCL_EXCEPTION) - && PerlIO_exception(filePtr)) + && PerlIO_has_exception(filePtr)) Tcl_SetMaxBlockTime(&blockTime); filePtr = filePtr->nextPtr; } @@ -539,7 +539,7 @@ { PerlIOEvent *fileEvPtr = (PerlIOEvent *) evPtr; PerlIOHandler *filePtr = firstPerlIOHandler; - dTHR; + dTHX; /* * Search through the file handlers to find the one whose handle matches * the event. We do this rather than keeping a pointer to the file @@ -1054,6 +1054,16 @@ #define Const_IDLE_EVENTS() (TCL_IDLE_EVENTS) #define Const_ALL_EVENTS() (TCL_ALL_EVENTS) +#define Event_INIT() + +extern XSdec(XS_Tk__Event_INIT); +XS(XS_Tk__Event_INIT) +{ + dXSARGS; + install_vtab("TkeventVtab",TkeventVGet(),sizeof(TkeventVtab)); + XSRETURN_EMPTY; +} + MODULE = Tk::Event PACKAGE = Tk::Callback PREFIX = Callback_ PROTOTYPES: DISABLE @@ -1125,15 +1135,15 @@ int mode int -PerlIO_readable(filePtr) +PerlIO_is_readable(filePtr) PerlIOHandler * filePtr int -PerlIO_exception(filePtr) +PerlIO_has_exception(filePtr) PerlIOHandler * filePtr int -PerlIO_writable(filePtr) +PerlIO_is_writable(filePtr) PerlIOHandler * filePtr SV * @@ -1302,6 +1312,14 @@ BOOT: { +#ifdef pWARN_NONE + SV *old_warn = PL_curcop->cop_warnings; + PL_curcop->cop_warnings = pWARN_NONE; +#endif + newXS("Tk::Event::INIT", XS_Tk__Event_INIT, file); +#ifdef pWARN_NONE + PL_curcop->cop_warnings = old_warn; +#endif newXS("Tk::Callback::Call", XS_Tk__Callback_Call, __FILE__); install_vtab("TkeventVtab",TkeventVGet(),sizeof(TkeventVtab)); } Index: Event/Event/IO.pm --- Tk800.020/Event/Event/IO.pm Fri Mar 24 17:28:08 2000 +++ Tk800.021/Event/Event/IO.pm Thu Mar 30 14:23:21 2000 @@ -1,7 +1,7 @@ package Tk::Event::IO; use vars qw($VERSION @EXPORT_OK); -$VERSION = '3.034'; # $Id: //depot/Tk8/Event/Event/IO.pm#10 $ +24 +$VERSION = '3.036'; # $Id: //depot/Tk8/Event/Event/IO.pm#12 $ +24 use base qw(Exporter); use Symbol (); @@ -112,7 +112,9 @@ } else { - untie *$file unless $obj->handler($imode,$cb); + my $h = $obj->handler($imode,$cb); + undef $obj; + untie *$file unless $h; } } Index: Event/pTkCallback.c --- Tk800.020/Event/pTkCallback.c Wed Mar 22 16:00:56 2000 +++ Tk800.021/Event/pTkCallback.c Fri Apr 21 09:13:10 2000 @@ -37,7 +37,7 @@ { if (sv) { - dTHR; + dTHX; AV *av; int old_taint = PL_tainted; if (SvTAINTED(sv)) Index: MANIFEST --- Tk800.020/MANIFEST Wed Mar 22 13:23:02 2000 +++ Tk800.021/MANIFEST Fri Apr 21 10:24:25 2000 @@ -118,6 +118,7 @@ README.HPUX README.IRIX README.OSF +README.OpenBSD README.SCO README.SVR4 README.Solaris @@ -211,7 +212,6 @@ Tk/Menu/Item.pm Tk/Menubar.pm Tk/Message.pm -Tk/MsgBox.pm Tk/Optionmenu.pm Tk/Pane.pm Tk/Pretty.pm @@ -478,6 +478,7 @@ hlfm hlist_bg hlist_demo +icon iconimg iconwin image_test @@ -1210,6 +1211,7 @@ pod/ColorEditor.pod pod/Common.pod pod/Compound.pod +pod/ConfigSpecs.pod pod/DItem.pod pod/Derived.pod pod/Dialog.pod @@ -1273,7 +1275,6 @@ pod/callbacks.pod pod/chooseColor.pod pod/composite.pod -pod/configspec.pod pod/event.pod pod/exit.pod pod/extract/extpod @@ -1404,10 +1405,12 @@ t/Require.t t/Trace.t t/X.t +t/autoload.t t/balloon.t t/browseentry.t t/create.t t/fbox.t +t/fileevent.t t/fileselect.t t/font.t t/geomgr.t Index: Makefile.PL --- Tk800.020/Makefile.PL Fri Mar 24 16:46:32 2000 +++ Tk800.021/Makefile.PL Sun Apr 2 13:43:23 2000 @@ -6,7 +6,7 @@ { $IsWin32 = ($^O eq 'MSWin32' || $Config{'ccflags'} =~ /-D_?WIN32_?/); - $VERSION = '800.020'; + $VERSION = '800.021'; $win_arch = shift @ARGV if @ARGV and $ARGV[0] =~ /^(open32|pm|x|MSWin32)$/; require('fix_4_os2.pl'), OS2_massage() if $^O eq 'os2'; @@ -132,7 +132,7 @@ sub MY::test { my ($self,%attrib) = @_; - my @tests = sort glob($self->catfile('t','*')); + my @tests = sort glob($self->catfile('t','*.t')); eval { require Test }; if ($@) { Index: README --- Tk800.020/README Mon Mar 27 15:41:38 2000 +++ Tk800.021/README Fri Apr 21 10:25:25 2000 @@ -7,7 +7,7 @@ derived from those of the orignal Tix4.1.0 or Tk8.0 sources. See doc/license.html for details of this license. -Hopefully Tk800.020 should be production worthy. +Hopefully Tk800.021 should be production worthy. (Consider Tk800.016..Tk800.019 its beta releases, previous stable release being Tk800.015.) @@ -24,14 +24,14 @@ But does work with perl5.6.0 - although this required a couple of work-rounds for perl5.6.0 ->isa bug. -This version (Tk800.020) requires perl5.005 or later on Win32 +This version (Tk800.021) requires perl5.005 or later on Win32 and 5.004_04 or later on UNIX. This version also contains re-worked Image code based on tcl/tk Img extension -(version img1.2b2) by Jan Nijtmans: http://members1.chello.nl/~j.nijtmans/ +(version img1.2.3) by Jan Nijtmans: http://members1.chello.nl/~j.nijtmans/ Jan's "dash" patch is also merged. -Tk800.020 should build and run on Windows NT using Visual C++, Borland, +Tk800.021 should build and run on Windows NT using Visual C++, Borland, or with the Mingw32 port of GCC with perl5.005 or later. Can be built using ActiveState's binrary distribution (see README-ActiveState.txt). @@ -44,6 +44,9 @@ Author has built against: Perl5.6.0 + Pentium Suse Linux-6.1 egcs-1.1.2 + + Perl5.6.0 (ithreads) Pentium Suse Linux-6.1 egcs-1.1.2 Perl5.00503 Index: README.OSF --- Tk800.020/README.OSF Tue Jul 27 19:20:07 1999 +++ Tk800.021/README.OSF Thu Apr 20 18:32:03 2000 @@ -22,5 +22,14 @@ Note that the cp -r does *not* do quite the same as a make install, in particular the binaries are not separated from the scripts. + +On Alpha if you get something like: + +GC already registered in Tk_GetGC +Tcl_Panic at ... + +Then it has been reported that reducing optimize from -O4 to -O3 +fixes the problem. + Index: README.OpenBSD --- /dev/null Sat Jun 19 13:46:56 1999 +++ Tk800.021/README.OpenBSD Thu Mar 30 21:35:03 2000 @@ -0,0 +1,17 @@ + +OpenBSD's default perl Config.pm includes -Bforcearchive in the link +flags for loadable extensions. + +The way Tk build is supposed to work is that all the converted Tcl/Tk +.c files get compiled in pTk subdirectory and put in the archive library +libpTk.a . Then each of Tk widgets and sub-systems links their own +.o files and libpTk.a - with the intent of only picking the bits from +libpTk.a they need. But -Bforcearchive tells linker to include ALL +of the .o files in the .a file - which not only leads to huge loadables +full of unused code, but also gives multiple definitions +of symbols in Tk::Event which expects to be able to override some +of the generic routines. + +So Tk/MMutil.pm attempts to remove the option from LDDLFLAGS when +perl's $^O eq 'openbsd'. + Index: TList/TList.pm --- Tk800.020/TList/TList.pm Sat Oct 2 17:44:27 1999 +++ Tk800.021/TList/TList.pm Fri Mar 31 16:14:05 2000 @@ -1,7 +1,7 @@ package Tk::TList; use vars qw($VERSION); -$VERSION = '3.016'; # $Id: //depot/Tk8/TList/TList.pm#16 $ +$VERSION = '3.018'; # $Id: //depot/Tk8/TList/TList.pm#18 $ use Tk qw(Ev $XS_VERSION); @@ -15,7 +15,7 @@ sub Tk_cmd { \&Tk::tlist } -Tk::Methods qw(insert anchor delete dragsite dropsite entrycget +Tk::Methods qw(insert index anchor delete dragsite dropsite entrycget entryconfigure info nearest see selection xview yview); use Tk::Submethods ( 'delete' => [qw(all entry offsprings siblings)], Index: Text/Text.pm --- Tk800.020/Text/Text.pm Sat Jan 22 14:28:19 2000 +++ Tk800.021/Text/Text.pm Fri Apr 21 10:56:19 2000 @@ -20,7 +20,7 @@ use Text::Tabs; use vars qw($VERSION); -$VERSION = '3.040'; # $Id: //depot/Tk8/Text/Text.pm#40 $ +$VERSION = '3.042'; # $Id: //depot/Tk8/Text/Text.pm#42 $ use Tk qw(Ev $XS_VERSION); use base qw(Tk::Clipboard Tk::Widget); @@ -1039,7 +1039,7 @@ command => sub {$w->FindNext ($direction,$mode,$case,$find_entry->get()),} ) -> pack(-anchor=>'nw'); - $find_entry -> pack(-anchor=>'nw', -expand => 'yes' , -fill => 'x'); # autosizing + $find_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); # autosizing ###### if any $w text is selected, put it in the find entry ###### could be more than one text block selected, get first selection @@ -1076,7 +1076,7 @@ command => sub {$w->ReplaceSelectionsWith($replace_entry->get());} ) -> pack(-anchor=>'nw'); - $replace_entry -> pack(-anchor=>'nw', -expand => 'yes' , -fill => 'x'); + $replace_entry -> pack(-anchor=>'nw', '-expand' => 'yes' , -fill => 'x'); } ###################################################### Index: Tixish/BrowseEntry.pm --- Tk800.020/Tixish/BrowseEntry.pm Sat Oct 2 17:44:27 1999 +++ Tk800.021/Tixish/BrowseEntry.pm Mon Apr 10 11:30:34 2000 @@ -4,7 +4,7 @@ package Tk::BrowseEntry; use vars qw($VERSION); -$VERSION = '3.026'; # $Id: //depot/Tk8/Tixish/BrowseEntry.pm#26 $ +$VERSION = '3.027'; # $Id: //depot/Tk8/Tixish/BrowseEntry.pm#27 $ use Tk qw(Ev); use Carp; @@ -56,6 +56,8 @@ -arrowimage => [ {-image => $b}, qw/arrowImage ArrowImage/, undef], -variable => '-textvariable', -colorstate => [qw/PASSIVE colorState ColorState/, undef], + -command => '-browsecmd', + -options => '-choices', DEFAULT => [$e] ); } @@ -263,17 +265,26 @@ } } -sub choices { - my $w = shift; - unless( @_ ) { - return( $w->get( qw/0 end/ ) ); - } else { - my $choices = shift; - if( $choices ) { +sub choices +{ + my ($w,$choices) = @_; + if (@_ > 1) + { $w->delete( qw/0 end/ ); - $w->insert( 'end', @$choices ); + my %hash; + my $var = $w->cget('-textvariable'); + my $old = $$var; + foreach my $val (@$choices) + { + $w->insert( 'end', $val); + $hash{$val} = 1; + } + $old = $choices->[0] unless exists $hash{$old}; + $$var = $old; } - return( '' ); + else + { + return( $w->get( qw/0 end/ ) ); } } Index: Tixish/DialogBox.pm --- Tk800.020/Tixish/DialogBox.pm Fri Mar 24 17:28:08 2000 +++ Tk800.021/Tixish/DialogBox.pm Fri Mar 31 13:09:33 2000 @@ -9,7 +9,7 @@ use Carp; use vars qw($VERSION); -$VERSION = '3.031'; # $Id: //depot/Tk8/Tixish/DialogBox.pm#31 $ +$VERSION = '3.032'; # $Id: //depot/Tk8/Tixish/DialogBox.pm#32 $ use base qw(Tk::Toplevel); @@ -63,8 +63,8 @@ } } $cw->ConfigSpecs(-command => ['CALLBACK', undef, undef, undef ], - -foreground => ['ADVERTISED', undef, undef, undef], - -background => ['ADVERTISED', undef, undef, undef], + -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'], + -background => ['DESCENDANTS', 'background','Background', undef], ); $cw->Delegates('Construct',$top); } Index: Tixish/DirTree.pm --- Tk800.020/Tixish/DirTree.pm Sun Mar 26 11:52:57 2000 +++ Tk800.021/Tixish/DirTree.pm Fri Apr 21 10:56:19 2000 @@ -6,7 +6,7 @@ # Chris Dean use vars qw($VERSION); -$VERSION = '3.021'; # $Id: //depot/Tk8/Tixish/DirTree.pm#21 $ +$VERSION = '3.023'; # $Id: //depot/Tk8/Tixish/DirTree.pm#23 $ use Tk; use Tk::Derived; @@ -73,7 +73,7 @@ # We have a default for -image, so its being undefined # is probably caused by order of handling config defaults # so defer it. - $w->afterIdle([$w, chdir => $val]); + $w->afterIdle([$w, 'chdir' => $val]); } } Index: Tk.pm --- Tk800.020/Tk.pm Sat Mar 25 08:58:01 2000 +++ Tk800.021/Tk.pm Sun Apr 2 13:45:18 2000 @@ -42,7 +42,7 @@ # is created, $VERSION is checked by bootstrap $Tk::version = '8.0'; $Tk::patchLevel = '8.0'; -$Tk::VERSION = '800.020'; +$Tk::VERSION = '800.021'; $Tk::XS_VERSION = $Tk::VERSION; $Tk::strictMotif = 0; Index: Tk/Derived.pm --- Tk800.020/Tk/Derived.pm Sat Jan 22 14:28:19 2000 +++ Tk800.021/Tk/Derived.pm Fri Mar 31 13:09:33 2000 @@ -8,7 +8,7 @@ use Carp; use vars qw($VERSION); -$VERSION = '3.042'; # $Id: //depot/Tk8/Tk/Derived.pm#42 $ +$VERSION = '3.044'; # $Id: //depot/Tk8/Tk/Derived.pm#44 $ $Tk::Derived::Debug = 0; @@ -280,6 +280,9 @@ my %changed = (); my ($opt,$val); my $config = $cw->TkHash('Configure'); + + $cw->labelPack([]) if grep /^-label\w+/, keys %args; + while (($opt,$val) = each %args) { my $var = \$config->{$opt}; Index: Tk/FBox.pm --- Tk800.020/Tk/FBox.pm Sat Feb 19 14:26:22 2000 +++ Tk800.021/Tk/FBox.pm Fri Apr 21 10:26:46 2000 @@ -39,7 +39,7 @@ use strict; use vars qw($VERSION $updirImage $folderImage $fileImage); -$VERSION = '3.013'; # $Id: //depot/Tk8/Tk/FBox.pm#13 $ +$VERSION = '3.019'; # $Id: //depot/Tk8/Tk/FBox.pm#19 $ use base qw(Tk::Toplevel); @@ -383,6 +383,7 @@ my $flt = join('|', split(' ', $w->cget(-filter)) ); $flt =~ s!([\.\+])!\\$1!g; $flt =~ s!\*!.*!g; + local *FDIR; if( opendir( FDIR, _cwd() )) { my @files; foreach my $f (sort { lc($a) cmp lc($b) } readdir FDIR) { @@ -404,10 +405,7 @@ push @list, $dir; } my $dirMenu = $w->{'dirMenu'}; - $dirMenu->options([]); - my $var = $w->{'selectPath'}; - $dirMenu->addOptions(@list); - $w->{'selectPath'} = $var; # workaround + $dirMenu->configure(-options => \@list); # Restore the PWD to the application's PWD ext_chdir($appPWD); @@ -655,6 +653,9 @@ my $path = ''; foreach (@_) { if (m|^/|) { + $path = $_; + } + elsif (m|^[a-z]:/|i) { # DOS-ish $path = $_; } elsif ($_ eq '~') { $path = _get_homedir(); Index: Tk/Frame.pm --- Tk800.020/Tk/Frame.pm Fri Dec 24 09:41:43 1999 +++ Tk800.021/Tk/Frame.pm Fri Apr 21 10:56:19 2000 @@ -14,7 +14,7 @@ use vars qw($VERSION); -$VERSION = '3.026'; # $Id: //depot/Tk8/Tk/Frame.pm#26 $ +$VERSION = '3.028'; # $Id: //depot/Tk8/Tk/Frame.pm#28 $ sub Tk_cmd { \&Tk::frame } @@ -103,7 +103,7 @@ else { $menu = $frame->Menu(-type => 'menubar',@_); - $frame->configure(-menu => $menu); + $frame->configure('-menu' => $menu); } $frame->Advertise('menubar' => $menu); return $menu; Index: Tk/MMutil.pm --- Tk800.020/Tk/MMutil.pm Fri Mar 24 17:28:08 2000 +++ Tk800.021/Tk/MMutil.pm Thu Mar 30 21:37:15 2000 @@ -9,7 +9,7 @@ use File::Basename; use vars qw($VERSION); -$VERSION = '3.047'; # $Id: //depot/Tk8/Tk/MMutil.pm#47 $ +$VERSION = '3.049'; # $Id: //depot/Tk8/Tk/MMutil.pm#49 $ use Tk::MakeDepend; @@ -247,6 +247,11 @@ { $self->{'LDFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g; $self->{'LDDLFLAGS'} =~ s/-(debug|pdb:\w+)\s+//g; + } + elsif ($^O =~ /(openbsd)/i) + { + # -Bforcearchive is bad news for Tk - we don't want all of libpTk.a in all .so-s. + $self->{'LDDLFLAGS'} =~ s/-Bforcearchive\s*//g; } return $self->MM::const_config; } Index: Tk/MainWindow.pm --- Tk800.020/Tk/MainWindow.pm Thu Dec 30 18:47:21 1999 +++ Tk800.021/Tk/MainWindow.pm Fri Mar 31 13:09:33 2000 @@ -8,7 +8,7 @@ use strict; use vars qw($VERSION); -$VERSION = '3.046'; # $Id: //depot/Tk8/Tk/MainWindow.pm#46 $ +$VERSION = '3.047'; # $Id: //depot/Tk8/Tk/MainWindow.pm#47 $ use Tk::CmdLine; use Tk qw(catch); @@ -89,7 +89,8 @@ $mw->eventAdd(qw[<> ]); $mw->eventAdd(qw[<> ]); $mw->eventAdd(qw[<> ]); - $mw->eventAdd(qw[<> ]); + $mw->eventAdd(qw[<> + ]); $mw->eventAdd(qw[<> ]); } else Index: Tk/Optionmenu.pm --- Tk800.020/Tk/Optionmenu.pm Sat Oct 2 17:44:27 1999 +++ Tk800.021/Tk/Optionmenu.pm Fri Apr 21 10:26:46 2000 @@ -6,7 +6,7 @@ require Tk::Menu; use vars qw($VERSION); -$VERSION = '3.020'; # $Id: //depot/Tk8/Tk/Optionmenu.pm#20 $ +$VERSION = '3.023'; # $Id: //depot/Tk8/Tk/Optionmenu.pm#23 $ use base qw(Tk::Derived Tk::Menubutton); @@ -20,7 +20,7 @@ $w->SUPER::Populate($args); $args->{-indicatoron} = 1; my $var = delete $args->{-textvariable}; - unless (defined $var && exists $args->{-variable}) + if (!defined($var) && exists($args->{-variable})) { $var = $args->{-variable}; } @@ -45,7 +45,10 @@ ); - $w->configure(-variable => delete $args->{-variable}); + # configure -variable and -command now so that when -options + # is set by main-line configure they are there to be set/called. + $w->configure(-variable => $var) if ($var = delete $args->{-variable}); + $w->configure(-command => $var) if ($var = delete $args->{-command}); } sub setOption @@ -64,7 +67,10 @@ my $w = shift; my $menu = $w->menu; my $var = $w->cget(-textvariable); + my $old = $$var; my $width = $w->cget('-width'); + my %hash; + my $first; while (@_) { my $val = shift; @@ -76,7 +82,12 @@ my $len = length($label); $width = $len if (!defined($width) || $len > $width); $menu->command(-label => $label, -command => [ $w , 'setOption', $label, $val ]); - $w->setOption($label, $val) unless (defined $$var); + $hash{$label} = $val; + $first = $label unless defined $first; + } + if (!defined($old) || !exists($hash{$old})) + { + $w->setOption($first, $hash{$first}) if defined $first; } $w->configure('-width' => $width); } Index: Tk/Region.pm --- Tk800.020/Tk/Region.pm Fri Dec 24 09:41:43 1999 +++ Tk800.021/Tk/Region.pm Fri Apr 21 10:56:19 2000 @@ -5,13 +5,13 @@ use strict; use vars qw($VERSION); -$VERSION = '3.002'; # $Id: //depot/Tk8/Tk/Region.pm#2 $ +$VERSION = '3.004'; # $Id: //depot/Tk8/Tk/Region.pm#4 $ use Tk::Widget (); Construct Tk::Widget 'Region'; -my %index = (-widget => 1, -x => 2, -y => 3, -width => 4, -height => 5); +my %index = (-widget => 1, '-x' => 2, '-y' => 3, -width => 4, -height => 5); sub _attr { Index: Tk/Table.pm --- Tk800.020/Tk/Table.pm Sat Dec 18 19:57:53 1999 +++ Tk800.021/Tk/Table.pm Fri Mar 31 16:14:05 2000 @@ -5,7 +5,7 @@ use strict; use vars qw($VERSION); -$VERSION = '3.018'; # $Id: //depot/Tk8/Tk/Table.pm#18 $ +$VERSION = '3.020'; # $Id: //depot/Tk8/Tk/Table.pm#20 $ use Tk::Pretty; use AutoLoader; @@ -144,6 +144,7 @@ sub Layout { my ($t) = @_; + return unless Tk::Exists($t); my $rows = @{$t->{Row}}; my $bw = $t->cget(-highlightthickness); my $frows = $t->cget(-fixedrows); Index: Tk/TextUndo.pm --- Tk800.020/Tk/TextUndo.pm Sat Jan 22 14:28:19 2000 +++ Tk800.021/Tk/TextUndo.pm Fri Apr 21 10:56:19 2000 @@ -6,7 +6,7 @@ package Tk::TextUndo; use vars qw($VERSION $DoDebug); -$VERSION = '3.045'; # $Id: //depot/Tk8/Tk/TextUndo.pm#45 $ +$VERSION = '3.047'; # $Id: //depot/Tk8/Tk/TextUndo.pm#47 $ $DoDebug = 0; use Tk qw (Ev); @@ -623,7 +623,7 @@ $popup->{FILENAME} = "Filename: $filename"; if (defined($val) && defined($total) && $total != 0) { - $popup->{PROGBAR}->place(-x => 0, -y => 0, -relheight => 1, -relwidth => $val/$total); + $popup->{PROGBAR}->place('-x' => 0, '-y' => 0, -relheight => 1, -relwidth => $val/$total); } else { Index: Tk/Tiler.pm --- Tk800.020/Tk/Tiler.pm Sat Dec 18 19:57:53 1999 +++ Tk800.021/Tk/Tiler.pm Fri Mar 31 14:49:57 2000 @@ -7,7 +7,7 @@ require Tk::Frame; use vars qw($VERSION); -$VERSION = '3.014'; # $Id: //depot/Tk8/Tk/Tiler.pm#14 $ +$VERSION = '3.016'; # $Id: //depot/Tk8/Tk/Tiler.pm#16 $ use base qw(Tk::Frame); @@ -65,10 +65,11 @@ my $y = $bw; my $start = 0; # Set size and position of slaves - my $rows = $m->{Rows} = ($H-2*$bw)/$h; - my $cols = $m->{Cols} = ($W-2*$bw)/$w; + my $rows = $m->{Rows} = int(($H-2*$bw)/$h) || 1; + my $cols = $m->{Cols} = int(($W-2*$bw)/$w) || 1; my $need = $m->{Need} = int( (@{$m->{Slaves}}+$cols-1)/$cols ); $m->{Start} = ($need - $rows) if ($m->{Start} + $rows > $need); + $m->{Start} = 0 if ($m->{Start} < 0); my $row = 0; my @posn = (); @@ -103,7 +104,7 @@ } $s->ResizeWindow($w,$h) if ($why & 1); } - $row++ if ($x); + $row++ if ($x > $bw); if (defined $m->{Prev} && $m->{Prev} > $m->{Start}) { @posn = reverse(@posn); @@ -116,7 +117,7 @@ $s->MapWindow; } $m->{Prev} = $m->{Start}; - $m->Callback(-yscrollcommand => $m->{Start}/$need,$row/$need); + $m->Callback(-yscrollcommand => $m->{Start}/$need,$row/$need) if $need; } sub QueueLayout Index: Tk/Widget.pm --- Tk800.020/Tk/Widget.pm Mon Mar 27 11:41:23 2000 +++ Tk800.021/Tk/Widget.pm Thu Mar 30 14:23:21 2000 @@ -3,7 +3,7 @@ # modify it under the same terms as Perl itself. package Tk::Widget; use vars qw($VERSION @DefaultMenuLabels); -$VERSION = '3.072'; # $Id: //depot/Tk8/Tk/Widget.pm#72 $ +$VERSION = '3.074'; # $Id: //depot/Tk8/Tk/Widget.pm#74 $ require Tk; use AutoLoader; @@ -269,6 +269,7 @@ my $what = $Tk::Widget::AUTOLOAD; my $save = $@; my $name; + # warn "AUTOLOAD $what ".(ref($_[0]) || $_[0])."\n"; # Braces used to preserve $1 et al. { my ($pkg,$func) = $what =~ /(.*)::([^:]+)$/; @@ -291,7 +292,9 @@ { croak $@ unless ($@ =~ /Can't locate\s+(?:file\s+)?'?\Q$name\E'?/); my($package,$method) = ($what =~ /^(.*)::([^:]*)$/); - if (ref $_[0] && $method !~ /^(ConfigSpecs|Delegates)/ ) + if (ref $_[0] && !$_[0]->can($method) + && $_[0]->can('Delegate') + && $method !~ /^(ConfigSpecs|Delegates)/ ) { my $delegate = $_[0]->Delegates; if (%$delegate || tied %$delegate) Index: TkXSUB.def --- Tk800.020/TkXSUB.def Thu Dec 23 22:22:19 1999 +++ Tk800.021/TkXSUB.def Sat Apr 15 11:22:38 2000 @@ -39,7 +39,7 @@ MkXSUB("Tk::checkbutton", XS_Tk_checkbutton, XStoTclCmd, Tk_CheckbuttonCmd) MkXSUB("Tk::label", XS_Tk_label, XStoTclCmd, Tk_LabelCmd) MkXSUB("Tk::message", XS_Tk_message, XStoTclCmd, Tk_MessageCmd) -MkXSUB("Tk::_menu", XS_Tk_menu, XStoTclCmd, Tk_MenuCmd) +MkXSUB("Tk::_menu", XS_Tk__menu, XStoTclCmd, Tk_MenuCmd) MkXSUB("Tk::radiobutton", XS_Tk_radiobutton, XStoTclCmd, Tk_RadiobuttonCmd) MkXSUB("Tk::frame", XS_Tk_frame, XStoTclCmd, Tk_FrameCmd) MkXSUB("Tk::toplevel", XS_Tk_toplevel, XStoTclCmd, Tk_ToplevelCmd) Index: demos/demos/widtrib/progress.pl --- Tk800.020/demos/demos/widtrib/progress.pl Thu Dec 30 15:22:39 1999 +++ Tk800.021/demos/demos/widtrib/progress.pl Fri Mar 31 13:50:34 2000 @@ -1,11 +1,11 @@ -# ProgressBar, progress bars +# ProgressBar - display various progress bars. use strict; use Tk; use Tk::ProgressBar; use Tk::Scale; -my $mw = Tk::MainWindow->new; +my $mw = MainWindow->new; my $status_var = 0; @@ -43,4 +43,4 @@ $mw->Scale(-from => 0, -to => 100, -variable => \$status_var)->pack; -Tk::MainLoop; +MainLoop; Index: demos/widget --- Tk800.020/demos/widget Wed Mar 22 13:23:02 2000 +++ Tk800.021/demos/widget Fri Mar 31 13:55:09 2000 @@ -1,11 +1,7 @@ #!/usr/local/bin/perl -w -eval 'exec /usr/local/bin/perl -w -S $0 ${1+"$@"}' - if 0; # not running under some shell - require 5.004; -use English; use Tk 800.000; use lib Tk->findINC('demos/widget_lib'); use Tk::widgets qw/Dialog ErrorDialog ROText/; @@ -99,7 +95,7 @@ '#303080'); } -$T->tagBind(qw/demo / => sub {invoke $T->index('current')}); +$T->tagBind(qw/demo / => \&invoke); my $last_line = ''; $T->tagBind(qw/demo / => [sub { my($text, $sv) = @_; @@ -219,14 +215,17 @@ [qw/demo demo-dialog2/]); $T->insert('end', "\n", '', "User Contributed Demonstrations\n", 'title'); -opendir(C, $WIDTRIB) or warn "Cannot open $WIDTRIB: $OS_ERROR!"; +opendir(C, $WIDTRIB) or warn "Cannot open $WIDTRIB: $!"; my(@dirent) = grep /^.+\.pl$/, sort(readdir C); closedir C; unshift @dirent, 'TEMPLATE.pl'; # I want it first my $i = 0; while ($_ = shift @dirent) { next if /TEMPLATE\.pl/ and $i != 0; - open(C, "$WIDTRIB/$_") or warn "Cannot open $_: $OS_ERROR!"; + unless (open(C, "$WIDTRIB/$_")) { + warn "Cannot open $_: $!" unless /TEMPLATE\.pl/; + next; + } my($name) = /^(.*)\.pl$/; $_ = ; my($title) = /^#\s*(.*)$/; @@ -271,7 +270,7 @@ $DEMO_FILE = "$WIDTRIB/${demo}.pl" if -f "$WIDTRIB/${demo}.pl"; $DEMO_FILE = "$widget_lib/${demo}.pl" if -f "$widget_lib/${demo}.pl"; do $DEMO_FILE; - warn $EVAL_ERROR if $EVAL_ERROR; + warn $@ if $@; } $T->Unbusy; goto &$::AUTOLOAD if defined &$::AUTOLOAD; @@ -307,8 +306,9 @@ # This procedure is called when the user clicks on a demo description. - my($index) = @_; + my($text) = @_; + my $index = $text->index('current'); my @tags = $T->tagNames($index); my $i = lsearch('demo\-.*', @tags); return if $i < 0; @@ -374,9 +374,9 @@ $file = "$widget_lib/${demo}.pl" if -f "$widget_lib/${demo}.pl"; $CODE->title("Demo code: $file"); $CODE_TEXT->delete(qw/1.0 end/); - open(CODE, "<$file") or warn "Cannot open demo file $file: $OS_ERROR!"; + open(CODE, "<$file") or warn "Cannot open demo file $file: $!"; { - local $INPUT_RECORD_SEPARATOR = undef; + local $/ = undef; $CODE_TEXT->insert('1.0', ); } close CODE; @@ -464,9 +464,9 @@ $VIEW->title("Demo code: $widget"); $VIEW_TEXT->configure(qw/-state normal/); $VIEW_TEXT->delete(qw/1.0 end/); - open(VIEW, "<$widget") or warn "Cannot open demo file $widget: $OS_ERROR!"; + open(VIEW, "<$widget") or warn "Cannot open demo file $widget: $!"; { - local $INPUT_RECORD_SEPARATOR = undef; + local $/ = undef; $VIEW_TEXT->insert('1.0', ); } close VIEW; @@ -498,7 +498,7 @@ contributed demonstrations. If no directory name is specified when widget is invoked and the environment variable WIDTRIB is defined then demonstrations are loaded from the WIDTRIB directory. If WIDTRIB is undefined then widget -defaults to the released user contributed directory. +defaults to the released user contributed directory, "widtrib". =head2 History Index: icon --- /dev/null Sat Jun 19 13:46:56 1999 +++ Tk800.021/icon Mon Mar 27 15:23:48 2000 @@ -0,0 +1,7 @@ +#!/tools/local/perl -w +use Tk; +my $mw = MainWindow->new; +my $image = $mw->Photo('-file' => Tk->findINC("icon.gif")); +$mw->iconimage($image); +$mw->iconify; +MainLoop; Index: myConfig --- Tk800.020/myConfig Sat Jan 15 20:14:42 2000 +++ Tk800.021/myConfig Fri Mar 31 11:06:53 2000 @@ -13,12 +13,6 @@ $xlib = ""; $define = ''; $gccopt = ""; -@macro = (); - -# -# Convert perls Config info into -DXXXX for Tk -# - @macro = ( macro => {} ); if (defined $Config{'gccversion'}) @@ -34,11 +28,7 @@ { # This is the author - catch as many bugs as possible $gccopt .= " -MMD -Werror"; - # $gccopt .= " -ansi -D__EXTENSIONS__" if ($^O eq 'solaris'); - # $gccopt .= " -Wmissing-prototypes" if (-f "/etc/shadow"); - @macro = ( macro => { INSTALLDIRS => 'perl' , - WINARCH => $win_arch } , - ); + @macro = ( macro => { INSTALLDIRS => 'perl' }); } } } @@ -62,6 +52,10 @@ $macro[1]->{WINARCH} = $win_arch; +# +# Convert perls Config info into -DXXXX for Tk +# + $define{'USE_PROTOTYPE'} = 1 if ($Config{'prototype'}); $define{'HAVE_UNISTD_H'} = 1 if ($Config{'i_unistd'}); $define{'HAVE_SYS_SELECT_H'} = 1 if ($Config{'i_sysselct'}); @@ -85,7 +79,6 @@ $define{'LSEEK_TYPE'} =$type; } - my $voidflags = $Config{'voidflags'}; my $voidused = $Config{'defvoidused'}+0; @@ -139,6 +132,7 @@ print STDERR "Generic gettimeofday()\n"; } } + # # Hunt down X Library - first a function # @@ -317,7 +311,9 @@ die "Cannot find X include files anywhere" unless (defined $xinc); - if (defined($Config{'gccversion'}) && $xinc =~ /^-I(.*openwin.*)$/) + if (defined($Config{'gccversion'}) && + $Config{'gccversion'} =~ /\S/ && + $xinc =~ /^-I(.*openwin.*)$/) { $gccopt .= " -isystem $1"; } Index: objGlue.c --- Tk800.020/objGlue.c Mon Mar 13 15:42:20 2000 +++ Tk800.021/objGlue.c Fri Apr 21 09:36:23 2000 @@ -480,7 +480,12 @@ MaybeForceList(Tcl_Interp *interp, Tcl_Obj *sv) { AV *av; - if (SvIOK(sv) || SvNOK(sv)) + int object = sv_isobject(sv); + if (!object && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) + { + return (AV *) SvRV(sv); + } + else if (!object && (SvIOK(sv) || SvNOK(sv))) { av = newAV(); av_store(av,0,SvREFCNT_inc(sv)); @@ -500,7 +505,8 @@ /* If there was more than one element set the SV */ if (av && av_len(av) > 0) { - sv_setsv(sv,MakeReference((SV *) av)); + /* AV is mortal - so we want newRV not MakeReference as we need extra REFCNT */ + sv_setsv(sv,newRV((SV *) av)); } return av; } Index: pTk/XrmOption.c --- Tk800.020/pTk/XrmOption.c Tue Jul 27 19:20:25 1999 +++ Tk800.021/pTk/XrmOption.c Sat Apr 1 11:43:15 2000 @@ -443,7 +443,11 @@ if ((winPtr->mainPtr->winPtr == winPtr) && (winPtr->mainPtr->optionRootPtr != NULL)) { - ClearOptionTree(winPtr->mainPtr); + if (winPtr->dispPtr->refCount <= 0) + { + XrmDestroyDatabase((XrmDatabase) winPtr->mainPtr->optionRootPtr); + XrmSetDatabase(winPtr->display,(XrmDatabase) NULL); + } winPtr->mainPtr->optionRootPtr = NULL; } } @@ -738,7 +742,6 @@ { if (mainPtr->optionRootPtr) { - XrmDestroyDatabase((XrmDatabase) mainPtr->optionRootPtr); mainPtr->optionRootPtr = NULL; } } Index: pTk/imgInt.m --- Tk800.020/pTk/imgInt.m Mon Mar 13 16:01:15 2000 +++ Tk800.021/pTk/imgInt.m Sat Apr 1 16:36:02 2000 @@ -2,6 +2,18 @@ #define _IMGINT_VM #include "imgInt_f.h" #ifndef NO_VTABLES +#ifndef ImgFixChanMatchProc +# define ImgFixChanMatchProc (*ImgintVptr->V_ImgFixChanMatchProc) +#endif + +#ifndef ImgFixObjMatchProc +# define ImgFixObjMatchProc (*ImgintVptr->V_ImgFixObjMatchProc) +#endif + +#ifndef ImgFixStringWriteProc +# define ImgFixStringWriteProc (*ImgintVptr->V_ImgFixStringWriteProc) +#endif + #ifndef ImgGetByteArrayFromObj # define ImgGetByteArrayFromObj (*ImgintVptr->V_ImgGetByteArrayFromObj) #endif @@ -16,6 +28,10 @@ #ifndef ImgObjInit # define ImgObjInit (*ImgintVptr->V_ImgObjInit) +#endif + +#ifndef ImgOpenFileChannel +# define ImgOpenFileChannel (*ImgintVptr->V_ImgOpenFileChannel) #endif #ifndef ImgPhotoPutBlock Index: pTk/imgInt.t --- Tk800.020/pTk/imgInt.t Mon Mar 13 16:01:15 2000 +++ Tk800.021/pTk/imgInt.t Sat Apr 1 16:36:02 2000 @@ -1,4 +1,19 @@ #ifdef _IMGINT +#ifndef ImgFixChanMatchProc +VFUNC(void,ImgFixChanMatchProc,V_ImgFixChanMatchProc,_ANSI_ARGS_((Tcl_Interp **interp, Tcl_Channel *chan, + Tcl_Obj **file, Tcl_Obj **format, int **width, int **height))) +#endif + +#ifndef ImgFixObjMatchProc +VFUNC(void,ImgFixObjMatchProc,V_ImgFixObjMatchProc,_ANSI_ARGS_((Tcl_Interp **interp, Tcl_Obj **data, + Tcl_Obj **format, int **width, int **height))) +#endif + +#ifndef ImgFixStringWriteProc +VFUNC(void,ImgFixStringWriteProc,V_ImgFixStringWriteProc,_ANSI_ARGS_((Tcl_DString *data, Tcl_Interp **interp, + Tcl_DString **dataPtr, Tcl_Obj **format, Tk_PhotoImageBlock **blockPtr))) +#endif + #ifndef ImgGetByteArrayFromObj VFUNC(char *,ImgGetByteArrayFromObj,V_ImgGetByteArrayFromObj,_ANSI_ARGS_((Tcl_Obj *objPtr, int *lengthPtr))) @@ -15,6 +30,11 @@ #ifndef ImgObjInit VFUNC(int,ImgObjInit,V_ImgObjInit,_ANSI_ARGS_((Tcl_Interp *interp))) +#endif + +#ifndef ImgOpenFileChannel +VFUNC(Tcl_Channel,ImgOpenFileChannel,V_ImgOpenFileChannel,_ANSI_ARGS_((Tcl_Interp *interp, + CONST char *fileName, int permissions))) #endif #ifndef ImgPhotoPutBlock Index: pTk/mTk/additions/img.h --- Tk800.020/pTk/mTk/additions/img.h Tue Jul 27 19:20:26 1999 +++ Tk800.021/pTk/mTk/additions/img.h Sat Apr 1 16:04:29 2000 @@ -9,10 +9,10 @@ #define IMG_MAJOR_VERSION 1 #define IMG_MINOR_VERSION 2 #define IMG_RELEASE_LEVEL 1 -#define IMG_RELEASE_SERIAL 1 +#define IMG_RELEASE_SERIAL 2 #define IMG_VERSION "1.2" -#define IMG_PATCH_LEVEL "1.2b1" +#define IMG_PATCH_LEVEL "1.2.3" #ifndef RESOURCE_INCLUDED Index: pTk/mTk/additions/imgBMP.c --- Tk800.020/pTk/mTk/additions/imgBMP.c Mon Nov 15 14:59:25 1999 +++ Tk800.021/pTk/mTk/additions/imgBMP.c Sat Apr 1 16:42:41 2000 @@ -35,7 +35,7 @@ Tk_PhotoImageBlock *blockPtr)); Tk_PhotoImageFormat imgFmtBMP = { - "BMP", /* name */ + "bmp", /* name */ ChnMatchBMP, /* fileMatchProc */ ObjMatchBMP, /* stringMatchProc */ ChnReadBMP, /* fileReadProc */ @@ -67,21 +67,25 @@ { MFile handle; + ImgFixChanMatchProc(&interp, &chan, &fileName, &format, &widthPtr, &heightPtr); + handle.data = (char *) chan; handle.state = IMG_CHAN; return CommonMatchBMP(&handle, widthPtr, heightPtr, NULL, NULL, NULL, NULL); } -static int ObjMatchBMP(interp, dataObj, format, widthPtr, heightPtr) +static int ObjMatchBMP(interp, data, format, widthPtr, heightPtr) Tcl_Interp *interp; - Tcl_Obj *dataObj; + Tcl_Obj *data; Tcl_Obj *format; int *widthPtr, *heightPtr; { MFile handle; - if (!ImgReadInit(dataObj,'B',&handle)) { + ImgFixObjMatchProc(&interp, &data, &format, &widthPtr, &heightPtr); + + if (!ImgReadInit(data,'B',&handle)) { return 0; } return CommonMatchBMP(&handle, widthPtr, heightPtr, NULL, NULL, NULL, NULL); @@ -245,6 +249,7 @@ block.offset[0] = 2; block.offset[1] = 1; block.offset[2] = 0; + block.offset[3] = block.offset[0]; switch (numBits) { case 24: block.pixelPtr = line + srcX*3; @@ -342,13 +347,10 @@ MFile handle; int result; - chan = Tcl_OpenFileChannel(interp, filename, "w", 0644); + chan = ImgOpenFileChannel(interp, filename, 0644); if (!chan) { return TCL_ERROR; } - if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK) { - return TCL_ERROR; - } handle.data = (char *) chan; handle.state = IMG_CHAN; @@ -360,18 +362,25 @@ return result; } -static int StringWriteBMP(interp, data, format, blockPtr) +static int StringWriteBMP(interp, dataPtr, format, blockPtr) Tcl_Interp *interp; - Tcl_DString *data; + Tcl_DString *dataPtr; Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; { MFile handle; int result; + Tcl_DString data; + + ImgFixStringWriteProc(&data, &interp, &dataPtr, &format, &blockPtr); - ImgWriteInit(data, &handle); + ImgWriteInit(dataPtr, &handle); result = CommonWriteBMP(interp, &handle, blockPtr); ImgPutc(IMG_DONE, &handle); + + if ((result == TCL_OK) && (dataPtr == &data)) { + Tcl_DStringResult(interp, dataPtr); + } return result; } @@ -395,15 +404,48 @@ int bperline, nbytes, ncolors, i, x, y, greenOffset, blueOffset, alphaOffset; unsigned char *imagePtr, *pixelPtr; unsigned char buf[4]; + int colors[256]; + int testnum = 10; - if (blockPtr->offset[0] == blockPtr->offset[1]) { - /* we have a grayscale image */ + greenOffset = blockPtr->offset[1] - blockPtr->offset[0]; + blueOffset = blockPtr->offset[2] - blockPtr->offset[0]; + alphaOffset = blockPtr->offset[0]; + if (alphaOffset < blockPtr->offset[2]) { + alphaOffset = blockPtr->offset[2]; + } + if (++alphaOffset < blockPtr->pixelSize) { + alphaOffset -= blockPtr->offset[0]; + } else { + alphaOffset = 0; + } + ncolors = 0; + if (greenOffset || blueOffset) { + for (y = 0; ncolors <= 256 && y < blockPtr->height; y++) { + pixelPtr = blockPtr->pixelPtr + y*blockPtr->pitch + blockPtr->offset[0]; + for (x=0; ncolors <= 256 && xwidth; x++) { + int pixel; + if (alphaOffset && (pixelPtr[alphaOffset] == 0)) + pixel = 0xd9d9d9; + else + pixel = (pixelPtr[0]<<16) | (pixelPtr[greenOffset]<<8) | pixelPtr[blueOffset]; + for (i = 0; i < ncolors && pixel != colors[i]; i++); + if ((i == ncolors) && (ncolors < 256)) + colors[ncolors++] = pixel; + pixelPtr += blockPtr->pixelSize; + } + } + if (ncolors <= 256 && (blockPtr->width * blockPtr->height >= 512)) { + while (ncolors < 256) { + colors[ncolors++] = 0; + } nbytes = 1; - ncolors = 256; } else { nbytes = 3; ncolors = 0; } + } else { + nbytes = 1; + } bperline = ((blockPtr->width * nbytes + 3) / 4) * 4; @@ -423,7 +465,7 @@ putint(handle, ncolors); for (i = 0; i < ncolors ; i++) { - putint(handle, i*65793); + putint(handle, colors[i]); } bperline -= blockPtr->width * nbytes; @@ -444,7 +486,15 @@ for (y = 0; y < blockPtr->height; y++) { pixelPtr = imagePtr -= blockPtr->pitch; for (x=0; xwidth; x++) { - if (alphaOffset && (pixelPtr[alphaOffset] == 0)) { + if (ncolors) { + int pixel; + if (alphaOffset && (pixelPtr[alphaOffset] == 0)) + pixel = 0xd9d9d9; + else + pixel = (pixelPtr[0]<<16)|(pixelPtr[greenOffset]<<8)|pixelPtr[blueOffset]; + for (i = 0; i < ncolors && pixel != colors[i]; i += 1); + buf[0] = i; + } else if (alphaOffset && (pixelPtr[alphaOffset] == 0)) { buf[0] = buf[1] = buf[2] = 0xd9; } else { buf[0] = pixelPtr[blueOffset]; @@ -452,6 +502,9 @@ buf[2] = pixelPtr[0]; } ImgWrite(handle, (char *) buf, nbytes); + if (testnum >0) { + testnum--; + } pixelPtr += blockPtr->pixelSize; } if (bperline) { Index: pTk/mTk/additions/imgGIF.c --- Tk800.020/pTk/mTk/additions/imgGIF.c Mon Nov 15 14:59:25 1999 +++ Tk800.021/pTk/mTk/additions/imgGIF.c Sat Apr 1 16:43:48 2000 @@ -77,25 +77,25 @@ Tk_PhotoHandle imageHandle, int destX, int destY, int width, int height, int srcX, int srcY)); static int ObjReadGIF _ANSI_ARGS_((Tcl_Interp *interp, - struct Tcl_Obj *data, struct Tcl_Obj *format, + Tcl_Obj *data, Tcl_Obj *format, Tk_PhotoHandle imageHandle, int destX, int destY, int width, int height, int srcX, int srcY)); static int ChanWriteGIF _ANSI_ARGS_(( Tcl_Interp *interp, - char *filename, struct Tcl_Obj *format, + char *filename, Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr)); static int StringWriteGIF _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_DString *dataPtr, struct Tcl_Obj *format, + Tcl_DString *dataPtr, Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr)); static int CommonReadGIF _ANSI_ARGS_((Tcl_Interp *interp, - MFile *handle, char *fileName, struct Tcl_Obj *format, + MFile *handle, CONST char *fileName, Tcl_Obj *format, Tk_PhotoHandle imageHandle, int destX, int destY, int width, int height, int srcX, int srcY)); static int CommonWriteGIF _ANSI_ARGS_((Tcl_Interp *interp, - MFile *handle, struct Tcl_Obj *format, + MFile *handle, Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr)); Tk_PhotoImageFormat imgFmtGIF = { - "GIF", /* name */ + "gif", /* name */ ChanMatchGIF, /* fileMatchProc */ ObjMatchGIF, /* stringMatchProc */ ChanReadGIF, /* fileReadProc */ @@ -169,6 +169,8 @@ { MFile handle; + ImgFixChanMatchProc(&interp, &chan, &fileName, &format, &widthPtr, &heightPtr); + handle.data = (char *) chan; handle.state = IMG_CHAN; @@ -253,8 +255,8 @@ width, height, srcX, srcY) Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ MFile *handle; /* The image file, open for reading. */ - char *fileName; /* The name of the image file. */ - struct Tcl_Obj *format; /* User-specified format object, or NULL. */ + CONST char *fileName; /* The name of the image file. */ + Tcl_Obj *format; /* User-specified format object, or NULL. */ Tk_PhotoHandle imageHandle; /* The photo image to write into. */ int destX, destY; /* Coordinates of top-left pixel in * photo image to be written to. */ @@ -266,7 +268,6 @@ int fileWidth, fileHeight; int nBytes, index = 0, objc = 0; Tcl_Obj **objv = NULL; - char *c = ""; myblock bl; unsigned char buf[100]; int bitPixel; @@ -280,14 +281,14 @@ return TCL_ERROR; } if (objc > 1) { - c = Tcl_GetStringFromObj(objv[1], &nBytes); - } + char *c = Tcl_GetStringFromObj(objv[1], &nBytes); if ((objc > 3) || ((objc == 3) && ((c[0] != '-') || (c[1] != 'i') || strncmp(c, "-index", strlen(c))))) { Tcl_AppendResult(interp, "invalid format: \"", ImgGetStringFromObj(format, NULL), "\"", (char *) NULL); return TCL_ERROR; } + } if (objc > 1) { if (Tcl_GetIntFromObj(interp, objv[objc-1], &index) != TCL_OK) { return TCL_ERROR; @@ -519,14 +520,16 @@ static int ObjMatchGIF(interp, data, format, widthPtr, heightPtr) - Tcl_Interp *interp; - struct Tcl_Obj *data; /* the object containing the image data */ - struct Tcl_Obj *format; /* the image format object */ + Tcl_Interp *interp; /* interpreter */ + Tcl_Obj *data; /* the object containing the image data */ + Tcl_Obj *format; /* the image format object */ int *widthPtr; /* where to put the image width */ int *heightPtr; /* where to put the image height */ { MFile handle; + ImgFixObjMatchProc(&interp, &data, &format, &widthPtr, &heightPtr); + if (!ImgReadInit(data, 'G', &handle)) { return 0; } @@ -558,15 +561,14 @@ ObjReadGIF(interp, data, format, imageHandle, destX, destY, width, height, srcX, srcY) Tcl_Interp *interp; /* interpreter for reporting errors in */ - struct Tcl_Obj *data; /* object containing the image */ - struct Tcl_Obj *format; /* format object if any */ + Tcl_Obj *data; /* object containing the image */ + Tcl_Obj *format; /* format object if any */ Tk_PhotoHandle imageHandle; /* the image to write this data into */ int destX, destY; /* The rectangular region of the */ int width, height; /* image to copy */ int srcX, srcY; { MFile handle; - int code; ImgReadInit(data, 'G', &handle); return CommonReadGIF(interp, &handle, "inline data", format, @@ -1066,20 +1068,17 @@ ChanWriteGIF (interp, filename, format, blockPtr) Tcl_Interp *interp; /* Interpreter to use for reporting errors. */ char *filename; - struct Tcl_Obj *format; + Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; { Tcl_Channel chan = NULL; MFile handle; int result; - chan = Tcl_OpenFileChannel(interp, filename, "w", 0644); + chan = ImgOpenFileChannel(interp, filename, 0644); if (!chan) { return TCL_ERROR; } - if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK) { - return TCL_ERROR; - } handle.data = (char *) chan; handle.state = IMG_CHAN; @@ -1095,11 +1094,14 @@ StringWriteGIF(interp, dataPtr, format, blockPtr) Tcl_Interp *interp; Tcl_DString *dataPtr; - struct Tcl_Obj *format; + Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; { int result; MFile handle; + Tcl_DString data; + + ImgFixStringWriteProc(&data, &interp, &dataPtr, &format, &blockPtr); Tcl_DStringSetLength(dataPtr, 1024); ImgWriteInit(dataPtr, &handle); @@ -1107,14 +1109,17 @@ result = CommonWriteGIF(interp, &handle, format, blockPtr); ImgPutc(IMG_DONE, &handle); - return(result); + if ((result == TCL_OK) && (dataPtr == &data)) { + Tcl_DStringResult(interp, dataPtr); + } + return result; } static int CommonWriteGIF(interp, handle, format, blockPtr) Tcl_Interp *interp; MFile *handle; - struct Tcl_Obj *format; + Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; { int resolution; @@ -1348,373 +1353,6 @@ -#ifdef IMG_USE_LZW - -/* - * - * GIF Image compression - modified 'compress' - * - * Based on: compress.c - File compression ala IEEE Computer, June 1984. - * - * By Authors: Spencer W. Thomas (decvax!harpo!utah-cs!utah-gr!thomas) - * Jim McKie (decvax!mcvax!jim) - * Steve Davies (decvax!vax135!petsd!peora!srd) - * Ken Turkowski (decvax!decwrl!turtlevax!ken) - * James A. Woods (decvax!ihnp4!ames!jaw) - * Joe Orost (decvax!vax135!petsd!joe) - * - */ -#include - -static void output _ANSI_ARGS_((long code)); -static void cl_block _ANSI_ARGS_((void)); -static void cl_hash _ANSI_ARGS_((int hsize)); -static void char_init _ANSI_ARGS_((void)); -static void char_out _ANSI_ARGS_((int c)); -static void flush_char _ANSI_ARGS_((void)); - -static int n_bits; /* number of bits/code */ -static int maxbits = GIFBITS; /* user settable max # bits/code */ -static long maxcode; /* maximum code, given n_bits */ -static long maxmaxcode = (long)1 << GIFBITS; - /* should NEVER generate this code */ -#define MAXCODE(n_bits) (((long) 1 << (n_bits)) - 1) - -static int htab[HSIZE]; -static unsigned int codetab[HSIZE]; -#define HashTabOf(i) htab[i] -#define CodeTabOf(i) codetab[i] - -static long hsize = HSIZE; /* for dynamic table sizing */ - -/* - * To save much memory, we overlay the table used by compress() with those - * used by decompress(). The tab_prefix table is the same size and type - * as the codetab. The tab_suffix table needs 2**GIFBITS characters. We - * get this from the beginning of htab. The output stack uses the rest - * of htab, and contains characters. There is plenty of room for any - * possible stack (stack used to be 8000 characters). - */ - -static int free_ent = 0; /* first unused entry */ - -/* - * block compression parameters -- after all codes are used up, - * and compression rate changes, start over. - */ -static int clear_flg = 0; - -static int offset; -static unsigned int in_count = 1; /* length of input */ -static unsigned int out_count = 0; /* # of codes output (for debugging) */ - -/* - * compress stdin to stdout - * - * Algorithm: use open addressing double hashing (no chaining) on the - * prefix code / next character combination. We do a variant of Knuth's - * algorithm D (vol. 3, sec. 6.4) along with G. Knott's relatively-prime - * secondary probe. Here, the modular division first probe is gives way - * to a faster exclusive-or manipulation. Also do block compression with - * an adaptive reset, whereby the code table is cleared when the compression - * ratio decreases, but after the table fills. The variable-length output - * codes are re-sized at this point, and a special CLEAR code is generated - * for the decompressor. Late addition: construct the table according to - * file size for noticeable speed improvement on small files. Please direct - * questions about this implementation to ames!jaw. - */ - -static int g_init_bits; -static MFile *g_outfile; - -static int ClearCode; -static int EOFCode; - -static void compress( init_bits, handle, readValue ) - int init_bits; - MFile *handle; - ifunptr readValue; -{ - register long fcode; - register long i = 0; - register int c; - register long ent; - register long disp; - register long hsize_reg; - register int hshift; - - /* - * Set up the globals: g_init_bits - initial number of bits - * g_outfile - pointer to output file - */ - g_init_bits = init_bits; - g_outfile = handle; - - /* - * Set up the necessary values - */ - offset = 0; - out_count = 0; - clear_flg = 0; - in_count = 1; - maxcode = MAXCODE(n_bits = g_init_bits); - - ClearCode = (1 << (init_bits - 1)); - EOFCode = ClearCode + 1; - free_ent = ClearCode + 2; - - char_init(); - - ent = readValue(); - - hshift = 0; - for ( fcode = (long) hsize; fcode < 65536L; fcode *= 2L ) - hshift++; - hshift = 8 - hshift; /* set hash code range bound */ - - hsize_reg = hsize; - cl_hash( (int) hsize_reg); /* clear hash table */ - - output( (long)ClearCode ); - -#ifdef SIGNED_COMPARE_SLOW - while ( (c = readValue() ) != (unsigned) EOF ) { -#else - while ( (c = readValue()) != EOF ) { -#endif - - in_count++; - - fcode = (long) (((long) c << maxbits) + ent); - i = (((long)c << hshift) ^ ent); /* xor hashing */ - - if ( HashTabOf (i) == fcode ) { - ent = CodeTabOf (i); - continue; - } else if ( (long) HashTabOf (i) < 0 ) /* empty slot */ - goto nomatch; - disp = hsize_reg - i; /* secondary hash (after G. Knott) */ - if ( i == 0 ) - disp = 1; -probe: - if ( (i -= disp) < 0 ) - i += hsize_reg; - - if ( HashTabOf(i) == fcode ) { - ent = CodeTabOf (i); - continue; - } - if ( (long) HashTabOf(i) > 0 ) - goto probe; -nomatch: - output ( (long) ent ); - out_count++; - ent = c; -#ifdef SIGNED_COMPARE_SLOW - if ( (unsigned) free_ent < (unsigned) maxmaxcode) { -#else - if ( free_ent < maxmaxcode ) { -#endif - CodeTabOf (i) = free_ent++; /* code -> hashtable */ - HashTabOf (i) = fcode; - } else - cl_block(); - } - /* - * Put out the final code. - */ - output( (long)ent ); - out_count++; - output( (long) EOFCode ); - - return; -} - -/***************************************************************** - * TAG( output ) - * - * Output the given code. - * Inputs: - * code: A n_bits-bit integer. If == -1, then EOF. This assumes - * that n_bits =< (long) wordsize - 1. - * Outputs: - * Outputs code to the file. - * Assumptions: - * Chars are 8 bits long. - * Algorithm: - * Maintain a GIFBITS character long buffer (so that 8 codes will - * fit in it exactly). Use the VAX insv instruction to insert each - * code in turn. When the buffer fills up empty it and start over. - */ - -static unsigned long cur_accum = 0; -static int cur_bits = 0; - -static -unsigned long masks[] = { 0x0000, 0x0001, 0x0003, 0x0007, 0x000F, - 0x001F, 0x003F, 0x007F, 0x00FF, - 0x01FF, 0x03FF, 0x07FF, 0x0FFF, - 0x1FFF, 0x3FFF, 0x7FFF, 0xFFFF }; - -static void -output(code) - long code; -{ - cur_accum &= masks[cur_bits]; - - if (cur_bits > 0) { - cur_accum |= ((long) code << cur_bits); - } else { - cur_accum = code; - } - - cur_bits += n_bits; - - while (cur_bits >= 8 ) { - char_out((unsigned int)(cur_accum & 0xff)); - cur_accum >>= 8; - cur_bits -= 8; - } - - /* - * If the next entry is going to be too big for the code size, - * then increase it, if possible. - */ - - if ((free_ent > maxcode)|| clear_flg ) { - if (clear_flg) { - maxcode = MAXCODE(n_bits = g_init_bits); - clear_flg = 0; - } else { - n_bits++; - if (n_bits == maxbits) { - maxcode = maxmaxcode; - } else { - maxcode = MAXCODE(n_bits); - } - } - } - - if (code == EOFCode) { - /* - * At EOF, write the rest of the buffer. - */ - while (cur_bits > 0) { - char_out((unsigned int)(cur_accum & 0xff)); - cur_accum >>= 8; - cur_bits -= 8; - } - flush_char(); - } -} - -/* - * Clear out the hash table - */ -static void -cl_block() /* table clear for block compress */ -{ - - cl_hash ( (int) hsize ); - free_ent = ClearCode + 2; - clear_flg = 1; - - output((long) ClearCode); -} - -static void -cl_hash(hsize) /* reset code table */ - int hsize; -{ - register int *htab_p = htab+hsize; - register long i; - register long m1 = -1; - - i = hsize - 16; - do { /* might use Sys V memset(3) here */ - *(htab_p-16) = m1; - *(htab_p-15) = m1; - *(htab_p-14) = m1; - *(htab_p-13) = m1; - *(htab_p-12) = m1; - *(htab_p-11) = m1; - *(htab_p-10) = m1; - *(htab_p-9) = m1; - *(htab_p-8) = m1; - *(htab_p-7) = m1; - *(htab_p-6) = m1; - *(htab_p-5) = m1; - *(htab_p-4) = m1; - *(htab_p-3) = m1; - *(htab_p-2) = m1; - *(htab_p-1) = m1; - htab_p -= 16; - } while ((i -= 16) >= 0); - - for (i += 16; i > 0; i--) { - *--htab_p = m1; - } -} - - -/****************************************************************************** - * - * GIF Specific routines - * - ******************************************************************************/ - -/* - * Number of characters so far in this 'packet' - */ -static int a_count; - -/* - * Set up the 'byte output' routine - */ -static void -char_init() -{ - a_count = 0; - cur_accum = 0; - cur_bits = 0; -} - -/* - * Define the storage for the packet accumulator - */ -static unsigned char accum[256]; - -/* - * Add a character to the end of the current packet, and if it is 254 - * characters, flush the packet to disk. - */ -static void -char_out( c ) - int c; -{ - accum[a_count++] = c; - if (a_count >= 254) { - flush_char(); - } -} - -/* - * Flush the packet to disk, and reset the accumulator - */ -static void -flush_char() -{ - unsigned char c; - if (a_count > 0) { - c = a_count; - ImgWrite(g_outfile, (CONST char *) &c, 1); - ImgWrite(g_outfile, (CONST char *) accum, a_count); - a_count = 0; - } -} - -/* The End */ -#else /*----------------------------------------------------------------------- * * miGIF Compression - mouse and ivo's GIF-compatible compression @@ -2129,6 +1767,3 @@ * End of miGIF section - See copyright notice at start of section. * *-----------------------------------------------------------------------*/ - - -#endif Index: pTk/mTk/additions/imgInit.c --- Tk800.020/pTk/mTk/additions/imgInit.c Mon Nov 15 14:59:25 1999 +++ Tk800.021/pTk/mTk/additions/imgInit.c Sat Apr 1 16:04:41 2000 @@ -29,12 +29,12 @@ #ifndef USE_TCL_STUBS #undef Tcl_InitStubs -#define Tcl_InitStubs(a,b,c) Tcl_PkgRequire(a,"Tcl",b,c) +#define Tcl_InitStubs(a,b,c) Tcl_PkgRequire(a,"Tcl",TCL_VERSION,1) #endif #ifndef USE_TK_STUBS #undef Tk_InitStubs -#define Tk_InitStubs(a,b,c) Tcl_PkgRequire(a,"Tk",b,c) +#define Tk_InitStubs(a,b,c) Tcl_PkgRequire(a,"Tk",TK_VERSION,1) #endif /* @@ -70,9 +70,6 @@ static Tk_PhotoImageFormat *Formats[] = { &imgFmtTIFF, -/* &imgFmtRAW,*/ -/* &imgFmtRAS,*/ -/* &imgFmtRGB,*/ &imgFmtPS, &imgFmtPDF, &imgFmtXBM, @@ -120,10 +117,10 @@ Tk_PhotoImageFormat **formatPtr = Formats; char *version; - if ((version = Tcl_InitStubs(interp, "8", 0)) == NULL) { + if ((version = Tcl_InitStubs(interp, "8.0", 0)) == NULL) { return TCL_ERROR; } - if (Tk_InitStubs(interp, "8", 0) == NULL) { + if (Tk_InitStubs(interp, "8.0", 0) == NULL) { return TCL_ERROR; } @@ -142,7 +139,7 @@ Tcl_CreateObjCommand(interp,"img_to_base64", tob64, (ClientData) NULL, NULL); Tcl_CreateObjCommand(interp,"img_from_base64", fromb64, (ClientData) NULL, NULL); #endif - return Tcl_PkgProvide(interp,"Img","1.2"); + return Tcl_PkgProvide(interp,"Img", IMG_PATCH_LEVEL); } EXPORT(int,Img_SafeInit)(interp) @@ -567,17 +564,14 @@ int len; if (argc != 2) { - Tcl_WrongNumArgs(interp, objv, 1, "filename"); + Tcl_WrongNumArgs(interp, 1, objv, "filename"); return TCL_ERROR; } - chan = Tcl_OpenFileChannel(interp, Tcl_GetStringFromObj(objv[1], &len), "r", 0); + chan = ImgOpenFileChannel(interp, Tcl_GetStringFromObj(objv[1], &len), 0); if (!chan) { return TCL_ERROR; } - if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK) { - return TCL_ERROR; - } Tcl_DStringInit(&dstring); ImgWriteInit(&dstring, &handle); @@ -627,15 +621,12 @@ int len; if (argc != 3) { - Tcl_WrongNumArgs(interp, objv, 1, "filename data"); + Tcl_WrongNumArgs(interp, 1, objv, "filename data"); return TCL_ERROR; } - chan = Tcl_OpenFileChannel(interp, Tcl_GetStringFromObj(objv[1], &len), "w", 0644); + chan = ImgOpenFileChannel(interp, Tcl_GetStringFromObj(objv[1], &len), 0644); if (!chan) { - return TCL_ERROR; - } - if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK) { return TCL_ERROR; } Index: pTk/mTk/additions/imgInt.h --- Tk800.020/pTk/mTk/additions/imgInt.h Tue Jul 27 19:20:26 1999 +++ Tk800.021/pTk/mTk/additions/imgInt.h Sat Apr 1 16:35:58 2000 @@ -32,6 +32,7 @@ #define IMG_TCL (1<<9) #define IMG_OBJS (1<<10) #define IMG_PERL (1<<11) +#define IMG_UTF (1<<12) EXTERN int ImgPhotoPutBlock _ANSI_ARGS_((Tk_PhotoHandle handle, Tk_PhotoImageBlock *blockPtr, int x, int y, int width, int height)); @@ -55,6 +56,14 @@ EXTERN int ImgSeek _ANSI_ARGS_((MFile *handle, int off, int whence)); EXTERN void ImgWriteInit _ANSI_ARGS_((Tcl_DString *buffer, MFile *handle)); EXTERN int ImgReadInit _ANSI_ARGS_((Tcl_Obj *data, int c, MFile *handle)); +EXTERN Tcl_Channel ImgOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *fileName, int permissions)); +EXTERN void ImgFixChanMatchProc _ANSI_ARGS_((Tcl_Interp **interp, Tcl_Channel *chan, + Tcl_Obj **file, Tcl_Obj **format, int **width, int **height)); +EXTERN void ImgFixObjMatchProc _ANSI_ARGS_((Tcl_Interp **interp, Tcl_Obj **data, + Tcl_Obj **format, int **width, int **height)); +EXTERN void ImgFixStringWriteProc _ANSI_ARGS_((Tcl_DString *data, Tcl_Interp **interp, + Tcl_DString **dataPtr, Tcl_Obj **format, Tk_PhotoImageBlock **blockPtr)); EXTERN int ImgInitTIFFzip _ANSI_ARGS_((VOID *, int)); EXTERN int ImgInitTIFFjpeg _ANSI_ARGS_((VOID *, int)); Index: pTk/mTk/additions/imgObj.c --- Tk800.020/pTk/mTk/additions/imgObj.c Mon Nov 15 14:59:25 1999 +++ Tk800.021/pTk/mTk/additions/imgObj.c Sat Apr 1 16:50:25 2000 @@ -14,7 +14,8 @@ * * IMG_PERL perl * IMG_TCL Tcl - * IMG_OBJS using Tcl_Obj in stead of char * + * IMG_OBJS using (Tcl_Obj *) in stead of (char *) + * IMG_UTF Tcl supports UTF-8 * * These flags will be determined at runtime (except the IMG_PERL * flag, for now), so we can use the same dynamic library for all @@ -32,6 +33,7 @@ #ifdef _LANG return (initialized = IMG_PERL|IMG_OBJS); #else + char *version; initialized = IMG_TCL; if (!Tcl_GetCommandInfo(interp,"image", &cmdInfo)) { Tcl_AppendResult(interp, "cannot find the \"image\" command", @@ -42,6 +44,10 @@ if (cmdInfo.isNativeObjectProc == 1) { initialized |= IMG_OBJS; /* we use objects */ } + version = Tcl_PkgRequire(interp, "Tcl", "8.0", 0); + if (version && (version[2] > '0')) { + initialized |= IMG_UTF; + } return initialized; #endif } @@ -235,4 +241,118 @@ } #endif return Tcl_ListObjGetElements(interp, objPtr, objc, objv); +} +/* + *---------------------------------------------------------------------- + * + * ImgOpenFileChannel -- + * + * Open a file channel in binary mode. If permissions is 0, the + * file will be opened in read mode, otherwise in write mode. + * + * Results: + * The same as Tcl_OpenFileChannel, only the file will + * always be opened in binary mode without encoding. + * + * Side effects: + * If function fails, an error message will be left in the + * interpreter. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +ImgOpenFileChannel(interp, fileName, permissions) + Tcl_Interp *interp; + CONST char *fileName; + int permissions; +{ + Tcl_Channel chan = Tcl_OpenFileChannel(interp, (char *) fileName, + permissions?"w":"r", permissions); + if (!chan) { + return (Tcl_Channel) NULL; + } + if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK) { + Tcl_Close(interp, chan); + return (Tcl_Channel) NULL; + } + return chan; +} + +/* + * Various Compatibility functions + */ + +void +ImgFixChanMatchProc(interp, chan, file, format, width, height) + Tcl_Interp **interp; + Tcl_Channel *chan; + Tcl_Obj **file; + Tcl_Obj **format; + int **width; + int **height; +{ +#ifndef _LANG + Tcl_Interp *tmp; + + if (initialized & IMG_PERL) { + return; + } + if (initialized & IMG_OBJS) { + tmp = (Tcl_Interp *) *height; + } else { + tmp = (Tcl_Interp *) NULL; + } + + *height = *width; + *width = (int *) *format; + *format = (Tcl_Obj *) *file; + *file = (CONST char *) *chan; + *chan = (Tcl_Channel) *interp; + *interp = tmp; +#endif +} + + +void +ImgFixObjMatchProc(interp, data, format, width, height) + Tcl_Interp **interp; + Tcl_Obj **data; + Tcl_Obj **format; + int **width; + int **height; +{ +#ifndef _LANG + Tcl_Interp *tmp; + + if (initialized & IMG_PERL) { + return; + } + if (initialized & IMG_OBJS) { + tmp = (Tcl_Interp *) *height; + } else { + tmp = (Tcl_Interp *) NULL; + } + *height = *width; + *width = (int *) *format; + *format = (Tcl_Obj *) *data; + *data = (Tcl_Obj *) *interp; + *interp = tmp; +#endif +} + +void +ImgFixStringWriteProc(data, interp, dataPtr, format, blockPtr) + Tcl_DString *data; + Tcl_Interp **interp; + Tcl_DString **dataPtr; + Tcl_Obj **format; + Tk_PhotoImageBlock **blockPtr; +{ + if (!*blockPtr) { + *blockPtr = (Tk_PhotoImageBlock *) *format; + *format = (Tcl_Obj *) *dataPtr; + *dataPtr = data; + Tcl_DStringInit(data); + } } Index: pTk/mTk/additions/imgPS.c --- Tk800.020/pTk/mTk/additions/imgPS.c Mon Nov 15 14:59:25 1999 +++ Tk800.021/pTk/mTk/additions/imgPS.c Sat Apr 1 16:04:50 2000 @@ -17,34 +17,34 @@ * The format record for the PS file format: */ -static int ChanMatchPS _ANSI_ARGS_((Tcl_Channel chan, char *fileName, +static int ChanMatchPS _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan, + CONST char *fileName, Tcl_Obj *format, int *widthPtr, int *heightPtr)); +static int ObjMatchPS _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *dataObj, Tcl_Obj *format, int *widthPtr, int *heightPtr)); -static int ObjMatchPS _ANSI_ARGS_((Tcl_Obj *dataObj, - Tcl_Obj *format, int *widthPtr, int *heightPtr)); -static int ChanMatchPDF _ANSI_ARGS_((Tcl_Channel chan, char *fileName, - Tcl_Obj *format, int *widthPtr, int *heightPtr)); -static int ObjMatchPDF _ANSI_ARGS_((Tcl_Obj *dataObj, +static int ChanMatchPDF _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan, + CONST char *fileName, Tcl_Obj *format, int *widthPtr, int *heightPtr)); +static int ObjMatchPDF _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *dataObj, Tcl_Obj *format, int *widthPtr, int *heightPtr)); static int ChanReadPS _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan, - char *fileName, Tcl_Obj *format, Tk_PhotoHandle imageHandle, + CONST char *fileName, Tcl_Obj *format, Tk_PhotoHandle imageHandle, int destX, int destY, int width, int height, int srcX, int srcY)); static int ObjReadPS _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *dataObj, Tcl_Obj *format, Tk_PhotoHandle imageHandle, int destX, int destY, int width, int height, int srcX, int srcY)); static int ChanReadPDF _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan, - char *fileName, Tcl_Obj *format, Tk_PhotoHandle imageHandle, + CONST char *fileName, Tcl_Obj *format, Tk_PhotoHandle imageHandle, int destX, int destY, int width, int height, int srcX, int srcY)); static int ObjReadPDF _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *dataObj, Tcl_Obj *format, Tk_PhotoHandle imageHandle, int destX, int destY, int width, int height, int srcX, int srcY)); -static int ChanWritePS _ANSI_ARGS_((Tcl_Interp *interp, char *filename, +static int ChanWritePS _ANSI_ARGS_((Tcl_Interp *interp, CONST char *filename, Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr)); static int StringWritePS _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *dataPtr, Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr)); Tk_PhotoImageFormat imgFmtPS = { - "POSTSCRIPT", /* name */ + "postscript", /* name */ (Tk_ImageFileMatchProc *) ChanMatchPS, /* fileMatchProc */ (Tk_ImageStringMatchProc *) ObjMatchPS, /* stringMatchProc */ (Tk_ImageFileReadProc *) ChanReadPS, /* fileReadProc */ @@ -54,7 +54,7 @@ }; Tk_PhotoImageFormat imgFmtPDF = { - "PDF", /* name */ + "pdf", /* name */ (Tk_ImageFileMatchProc *) ChanMatchPDF, /* fileMatchProc */ (Tk_ImageStringMatchProc *) ObjMatchPDF, /* stringMatchProc */ (Tk_ImageFileReadProc *) ChanReadPDF, /* fileReadProc */ @@ -139,28 +139,34 @@ return index; } -static int ChanMatchPS(chan, fileName, format, widthPtr, heightPtr) +static int ChanMatchPS(interp, chan, fileName, format, widthPtr, heightPtr) + Tcl_Interp *interp; Tcl_Channel chan; - char *fileName; + CONST char *fileName; Tcl_Obj *format; int *widthPtr, *heightPtr; { MFile handle; + ImgFixChanMatchProc(&interp, &chan, &fileName, &format, &widthPtr, &heightPtr); + handle.data = (char *) chan; handle.state = IMG_CHAN; return CommonMatchPS(&handle, format, widthPtr, heightPtr); } -static int ObjMatchPS(dataObj, format, widthPtr, heightPtr) - Tcl_Obj *dataObj; +static int ObjMatchPS(interp, data, format, widthPtr, heightPtr) + Tcl_Interp *interp; + Tcl_Obj *data; Tcl_Obj *format; int *widthPtr, *heightPtr; { MFile handle; - handle.data = ImgGetStringFromObj(dataObj, &handle.length); + ImgFixObjMatchProc(&interp, &data, &format, &widthPtr, &heightPtr); + + handle.data = ImgGetStringFromObj(data, &handle.length); handle.state = IMG_STRING; return CommonMatchPS(&handle, format, widthPtr, heightPtr); @@ -208,7 +214,7 @@ destX, destY, width, height, srcX, srcY) Tcl_Interp *interp; Tcl_Channel chan; - char *fileName; + CONST char *fileName; Tcl_Obj *format; Tk_PhotoHandle imageHandle; int destX, destY; @@ -387,7 +393,7 @@ break; case '5': line = (unsigned char *) ckalloc(fileWidth); - while (srcY--) { + while (srcY-- > 0) { Tcl_Read(chan, (char *) line, fileWidth); } block.pixelPtr = line + srcX; @@ -406,7 +412,7 @@ case '6': i = 3 * fileWidth; line = NULL; - while (srcY--) { + while (srcY-- > 0) { Tcl_Read(chan, (char *) line3, i); } block.pixelPtr = line3 + (3 * srcX); @@ -443,7 +449,7 @@ destX, destY, width, height, srcX, srcY) Tcl_Interp *interp; Tcl_Channel chan; - char *fileName; + CONST char *fileName; Tcl_Obj *format; Tk_PhotoHandle imageHandle; int destX, destY; @@ -470,7 +476,7 @@ static int ChanWritePS(interp, filename, format, blockPtr) Tcl_Interp *interp; - char *filename; + CONST char *filename; Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; { @@ -478,13 +484,10 @@ MFile handle; int result; - chan = Tcl_OpenFileChannel(interp, filename, "w", 0644); + chan = ImgOpenFileChannel(interp, filename, 0644); if (!chan) { return TCL_ERROR; } - if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK) { - return TCL_ERROR; - } handle.data = (char *) chan; handle.state = IMG_CHAN; @@ -496,18 +499,22 @@ return result; } -static int StringWritePS(interp, data, format, blockPtr) +static int StringWritePS(interp, dataPtr, format, blockPtr) Tcl_Interp *interp; - Tcl_DString *data; + Tcl_DString *dataPtr; Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; { MFile handle; int result; - - ImgWriteInit(data, &handle); + Tcl_DString data; + ImgFixStringWriteProc(&data, &interp, &dataPtr, &format, &blockPtr); + ImgWriteInit(dataPtr, &handle); result = CommonWritePS(interp, &handle, format, blockPtr); ImgPutc(IMG_DONE, &handle); + if ((result == TCL_OK) && (dataPtr == &data)) { + Tcl_DStringResult(interp, dataPtr); + } return result; } @@ -517,31 +524,37 @@ Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; { - return(TCL_OK); + return TCL_OK; } -static int ChanMatchPDF(chan, fileName, format, widthPtr, heightPtr) +static int ChanMatchPDF(interp, chan, fileName, format, widthPtr, heightPtr) + Tcl_Interp *interp; Tcl_Channel chan; - char *fileName; + CONST char *fileName; Tcl_Obj *format; int *widthPtr, *heightPtr; { MFile handle; + ImgFixChanMatchProc(&interp, &chan, &fileName, &format, &widthPtr, &heightPtr); + handle.data = (char *) chan; handle.state = IMG_CHAN; return CommonMatchPDF(&handle, format, widthPtr, heightPtr); } -static int ObjMatchPDF(dataObj, format, widthPtr, heightPtr) - Tcl_Obj *dataObj; +static int ObjMatchPDF(interp, data, format, widthPtr, heightPtr) + Tcl_Interp *interp; + Tcl_Obj *data; Tcl_Obj *format; int *widthPtr, *heightPtr; { MFile handle; - if (!ImgReadInit(dataObj,'%',&handle)) { + ImgFixObjMatchProc(&interp, &data, &format, &widthPtr, &heightPtr); + + if (!ImgReadInit(data, '%', &handle)) { return 0; } @@ -564,7 +577,7 @@ /* Here w and h should be set to the bounding box of the pdf * data. But I don't know how to extract that from the file. * For now I just assume A4-size with 72 pixels/inch. If anyone - * has a better idea, please mail to . + * has a better idea, please mail to . */ w = 612/10; Index: pTk/mTk/additions/imgPmap.c --- Tk800.020/pTk/mTk/additions/imgPmap.c Mon Nov 15 14:59:25 1999 +++ Tk800.021/pTk/mTk/additions/imgPmap.c Sat Apr 1 16:15:13 2000 @@ -14,6 +14,7 @@ #include #include #include +#include #include #if defined(__WIN32__) && !defined (__GNUC__) @@ -25,23 +26,18 @@ #include #endif -extern int strncasecmp _ANSI_ARGS_((CONST char *s1, - CONST char *s2, size_t n)); -extern int strncmp _ANSI_ARGS_((CONST char *s1, CONST char *s2, - size_t nChars)); -extern char * strncpy _ANSI_ARGS_((char *dst, CONST char *src, - size_t numChars)); - #ifndef TCL_STUB_MAGIC EXTERN void panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); #endif +#define UCHAR(c) ((unsigned char) (c)) + /* * Prototypes for procedures used only locally in this file: */ static int ImgXpmCreate _ANSI_ARGS_((Tcl_Interp *interp, - char *name, int argc, Tcl_Obj *CONST objv[], + char *name, int argc, Tcl_Obj *objv[], Tk_ImageType *typePtr, Tk_ImageMaster master, ClientData *clientDataPtr)); static ClientData ImgXpmGet _ANSI_ARGS_((Tk_Window tkwin, @@ -140,7 +136,7 @@ * Convert the objc/objv arguments into string equivalent. */ if (argc > 10) { - argv = (char **) ckalloc(argc * sizeof(char *)); + args = (char **) ckalloc(argc * sizeof(char *)); } for (i = 0; i < argc; i++) { args[i] = ImgGetStringFromObj(objv[i], NULL); @@ -162,8 +158,8 @@ if (ImgXpmConfigureMaster(masterPtr, argc, objv, 0) != TCL_OK) { ImgXpmDelete((ClientData) masterPtr); #if 0 - if (argv != argvbuf) { - ckfree((char *) argv); + if (args != argvbuf) { + ckfree((char *) args); } #endif return TCL_ERROR; @@ -517,13 +513,10 @@ char ** data = (char **) NULL; char *cmdBuffer = NULL; - chan = Tcl_OpenFileChannel(interp, fileName, "r", 0); + chan = ImgOpenFileChannel(interp, fileName, 0); if (!chan) { return (char **) NULL; } - if (Tcl_SetChannelOption(interp, chan, "-translation", "binary") != TCL_OK) { - return (char **) NULL; - } size = Tcl_Seek(chan, 0, SEEK_END); if (size > 0) { Index: pTk/mTk/additions/imgTIFF.c --- Tk800.020/pTk/mTk/additions/imgTIFF.c Mon Nov 15 14:59:25 1999 +++ Tk800.021/pTk/mTk/additions/imgTIFF.c Sat Apr 1 16:04:54 2000 @@ -51,12 +51,12 @@ * Prototypes for local procedures defined in this file: */ -static int ChnMatchTIFF _ANSI_ARGS_((Tcl_Channel chan, char *fileName, - Tcl_Obj *format, int *widthPtr, int *heightPtr)); -static int ObjMatchTIFF _ANSI_ARGS_((Tcl_Obj *dataObj, +static int ChnMatchTIFF _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan, + CONST char *fileName, Tcl_Obj *format, int *widthPtr, int *heightPtr)); +static int ObjMatchTIFF _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *dataObj, Tcl_Obj *format, int *widthPtr, int *heightPtr)); static int ChnReadTIFF _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan, - char *fileName, Tcl_Obj *format, Tk_PhotoHandle imageHandle, + CONST char *fileName, Tcl_Obj *format, Tk_PhotoHandle imageHandle, int destX, int destY, int width, int height, int srcX, int srcY)); static int ObjReadTIFF _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *dataObj, Tcl_Obj *format, @@ -69,7 +69,7 @@ Tk_PhotoImageBlock *blockPtr)); Tk_PhotoImageFormat imgFmtTIFF = { - "TIFF", /* name */ + "tiff", /* name */ (Tk_ImageFileMatchProc *) ChnMatchTIFF, /* fileMatchProc */ (Tk_ImageStringMatchProc *) ObjMatchTIFF, /* stringMatchProc */ (Tk_ImageFileReadProc *) ChnReadTIFF, /* fileReadProc */ @@ -590,7 +590,8 @@ */ static int -ObjMatchTIFF(data, format, widthPtr, heightPtr) +ObjMatchTIFF(interp, data, format, widthPtr, heightPtr) + Tcl_Interp *interp; Tcl_Obj *data; /* the object containing the image data */ Tcl_Obj *format; /* the image format string */ int *widthPtr; /* where to put the string width */ @@ -598,6 +599,8 @@ { MFile handle; + ImgFixObjMatchProc(&interp, &data, &format, &widthPtr, &heightPtr); + if (!ImgReadInit(data, '\111', &handle) && !ImgReadInit(data, '\115', &handle)) { return 0; @@ -606,14 +609,17 @@ return CommonMatchTIFF(&handle, widthPtr, heightPtr); } -static int ChnMatchTIFF(chan, fileName, format, widthPtr, heightPtr) +static int ChnMatchTIFF(interp, chan, fileName, format, widthPtr, heightPtr) + Tcl_Interp *interp; Tcl_Channel chan; - char *fileName; + CONST char *fileName; Tcl_Obj *format; int *widthPtr, *heightPtr; { MFile handle; + ImgFixChanMatchProc(&interp, &chan, &fileName, &format, &widthPtr, &heightPtr); + handle.data = (char *) chan; handle.state = IMG_CHAN; @@ -706,13 +712,10 @@ } else { Tcl_Channel outchan; tmpnam(tempFileName); - outchan = Tcl_OpenFileChannel(interp, tempFileName, "w", 0644); + outchan = ImgOpenFileChannel(interp, tempFileName, 0644); if (!outchan) { return TCL_ERROR; } - if (Tcl_SetChannelOption(interp, outchan, "-translation", "binary") != TCL_OK) { - return TCL_ERROR; - } count = ImgRead(&handle, buffer, 1024); while (count == 1024) { @@ -752,7 +755,7 @@ destX, destY, width, height, srcX, srcY) Tcl_Interp *interp; Tcl_Channel chan; - char *fileName; + CONST char *fileName; Tcl_Obj *format; Tk_PhotoHandle imageHandle; int destX, destY; @@ -779,13 +782,10 @@ } else { Tcl_Channel outchan; tmpnam(tempFileName); - outchan = Tcl_OpenFileChannel(interp, tempFileName, "w", 0644); + outchan = ImgOpenFileChannel(interp, tempFileName, 0644); if (!outchan) { return TCL_ERROR; } - if (Tcl_SetChannelOption(interp, outchan, "-translation", "binary") != TCL_OK) { - return TCL_ERROR; - } count = Tcl_Read(chan, buffer, 1024); while (count == 1024) { @@ -914,11 +914,14 @@ char tempFileName[256]; Tcl_DString dstring; char *mode; + Tcl_DString data; if (load_tiff_library(interp) != TCL_OK) { return TCL_ERROR; } + ImgFixStringWriteProc(&data, &interp, &dataPtr, &format, &blockPtr); + if (ParseWriteFormat(interp, format, &comp, &mode) != TCL_OK) { return TCL_ERROR; } @@ -951,13 +954,10 @@ if (tempFileName[0]) { Tcl_Channel inchan; char buffer[1024]; - inchan = Tcl_OpenFileChannel(interp, tempFileName, "w", 0644); + inchan = ImgOpenFileChannel(interp, tempFileName, 0644); if (!inchan) { return TCL_ERROR; } - if (Tcl_SetChannelOption(interp, inchan, "-translation", "binary") != TCL_OK) { - return TCL_ERROR; - } ImgWriteInit(dataPtr, &handle); result = Tcl_Read(inchan, buffer, 1024); @@ -977,6 +977,9 @@ Tcl_DStringFree(&dstring); } ImgPutc(IMG_DONE, &handle); + if ((result == TCL_OK) && (dataPtr == &data)) { + Tcl_DStringResult(interp, dataPtr); + } return result; } @@ -1061,10 +1064,12 @@ *comp = COMPRESSION_DEFLATE; } else if ((c == 'j') && (!strncmp(compression,"jpeg",length))) { *comp = COMPRESSION_JPEG; - } else if ((c == 'l') && (length>1) && (!strncmp(compression,"logluv",length))) { + } else if ((c == 'l') && (!strncmp(compression,"logluv",length))) { *comp = COMPRESSION_SGILOG; +/* disabled, because of patented lzw-algorithm. } else if ((c == 'l') && (length>1) && (!strncmp(compression,"lzw",length))) { *comp = COMPRESSION_LZW; +*/ } else if ((c == 'p') && (length>1) && (!strncmp(compression,"packbits",length))) { *comp = COMPRESSION_PACKBITS; } else if ((c == 'p') && (length>1) && (!strncmp(compression,"pixarlog",length))) { Index: pTk/mTk/additions/imgTIFFpixar.c --- Tk800.020/pTk/mTk/additions/imgTIFFpixar.c Mon Nov 15 14:59:25 1999 +++ Tk800.021/pTk/mTk/additions/imgTIFFpixar.c Sat Apr 1 16:04:56 2000 @@ -94,6 +94,8 @@ #ifdef __WIN32__ #define Z_LIB_NAME "zlib.dll" +#else +#define WINAPI /**/ #endif #ifndef Z_LIB_NAME @@ -120,16 +122,16 @@ static struct LibzFunctions { VOID *handle; - int (* deflate) _ANSI_ARGS_((z_streamp, int)); - int (* dInit) _ANSI_ARGS_((z_streamp, int, CONST char *, int)); - int (* deflateReset) _ANSI_ARGS_((z_streamp)); - int (* deflateParams) _ANSI_ARGS_((z_streamp, int, int)); - int (* deflateEnd) _ANSI_ARGS_((z_streamp)); - int (* inflate) _ANSI_ARGS_((z_streamp, int)); - int (* iInit) _ANSI_ARGS_((z_streamp, CONST char *, int)); - int (* inflateReset) _ANSI_ARGS_((z_streamp)); - int (* inflateSync) _ANSI_ARGS_((z_streamp)); - int (* inflateEnd) _ANSI_ARGS_((z_streamp)); + int (WINAPI * deflate) _ANSI_ARGS_((z_streamp, int)); + int (WINAPI * dInit) _ANSI_ARGS_((z_streamp, int, CONST char *, int)); + int (WINAPI * deflateReset) _ANSI_ARGS_((z_streamp)); + int (WINAPI * deflateParams) _ANSI_ARGS_((z_streamp, int, int)); + int (WINAPI * deflateEnd) _ANSI_ARGS_((z_streamp)); + int (WINAPI * inflate) _ANSI_ARGS_((z_streamp, int)); + int (WINAPI * iInit) _ANSI_ARGS_((z_streamp, CONST char *, int)); + int (WINAPI * inflateReset) _ANSI_ARGS_((z_streamp)); + int (WINAPI * inflateSync) _ANSI_ARGS_((z_streamp)); + int (WINAPI * inflateEnd) _ANSI_ARGS_((z_streamp)); } zlib = {0}; static char *symbols[] = { Index: pTk/mTk/additions/imgTIFFzip.c --- Tk800.020/pTk/mTk/additions/imgTIFFzip.c Mon Nov 15 14:59:25 1999 +++ Tk800.021/pTk/mTk/additions/imgTIFFzip.c Sat Apr 1 16:04:56 2000 @@ -56,6 +56,8 @@ #ifdef __WIN32__ #define Z_LIB_NAME "zlib.dll" +#else +#define WINAPI /**/ #endif #ifndef Z_LIB_NAME @@ -97,16 +99,16 @@ static struct LibzFunctions { VOID *handle; - int (* deflate) _ANSI_ARGS_((z_streamp, int)); - int (* dInit) _ANSI_ARGS_((z_streamp, int, CONST char *, int)); - int (* deflateReset) _ANSI_ARGS_((z_streamp)); - int (* deflateParams) _ANSI_ARGS_((z_streamp, int, int)); - int (* deflateEnd) _ANSI_ARGS_((z_streamp)); - int (* inflate) _ANSI_ARGS_((z_streamp, int)); - int (* iInit) _ANSI_ARGS_((z_streamp, CONST char *, int)); - int (* inflateReset) _ANSI_ARGS_((z_streamp)); - int (* inflateSync) _ANSI_ARGS_((z_streamp)); - int (* inflateEnd) _ANSI_ARGS_((z_streamp)); + int (WINAPI * deflate) _ANSI_ARGS_((z_streamp, int)); + int (WINAPI * dInit) _ANSI_ARGS_((z_streamp, int, CONST char *, int)); + int (WINAPI * deflateReset) _ANSI_ARGS_((z_streamp)); + int (WINAPI * deflateParams) _ANSI_ARGS_((z_streamp, int, int)); + int (WINAPI * deflateEnd) _ANSI_ARGS_((z_streamp)); + int (WINAPI * inflate) _ANSI_ARGS_((z_streamp, int)); + int (WINAPI * iInit) _ANSI_ARGS_((z_streamp, CONST char *, int)); + int (WINAPI * inflateReset) _ANSI_ARGS_((z_streamp)); + int (WINAPI * inflateSync) _ANSI_ARGS_((z_streamp)); + int (WINAPI * inflateEnd) _ANSI_ARGS_((z_streamp)); } zlib = {0}; static char *symbols[] = { Index: pTk/mTk/additions/imgWindow.c --- Tk800.020/pTk/mTk/additions/imgWindow.c Mon Nov 15 14:59:25 1999 +++ Tk800.021/pTk/mTk/additions/imgWindow.c Sat Apr 1 16:26:53 2000 @@ -42,7 +42,7 @@ #endif Tk_PhotoImageFormat imgFmtWin = { - "WINDOW", /* name */ + "window", /* name */ ChanMatchWin, /* fileMatchProc */ ObjMatchWin, /* stringMatchProc */ (Tk_ImageFileReadProc *) NULL, /* fileReadProc */ @@ -111,11 +111,11 @@ */ static int ChanMatchWin(interp, chan, filename, format, widthPtr, heightPtr) + Tcl_Interp *interp; Tcl_Channel chan; Tcl_Obj *filename; Tcl_Obj *format; int *widthPtr, *heightPtr; - Tcl_Interp *interp; { return 0; } @@ -144,9 +144,13 @@ int *widthPtr, *heightPtr; { Tk_Window tkwin; - char *name = ImgGetStringFromObj(data, NULL); + char *name; + + ImgFixObjMatchProc(&interp, &data, &format, &widthPtr, &heightPtr); + + name = ImgGetStringFromObj(data, NULL); - if ((name[0] == '.') && ((name[1] == 0) || islower(UCHAR(name[1])))) { + if (interp && name && (name[0] == '.') && ((name[1] == 0) || islower(UCHAR(name[1])))) { tkwin = Tk_MainWindow(interp); if (tkwin == NULL) { return 0; Index: pTk/mTk/additions/imgXBM.c --- Tk800.020/pTk/mTk/additions/imgXBM.c Thu Mar 16 12:37:30 2000 +++ Tk800.021/pTk/mTk/additions/imgXBM.c Sat Apr 1 16:53:28 2000 @@ -6,9 +6,9 @@ * Written by: * Jan Nijtmans * CMG (Computer Management Group) Arnhem B.V. - * email: Jan.Nijtmans@wxs.nl (private) - * Jan.Nijtmans@cmg.nl (work) - * url: http://home.wxs.nl/~nijtmans/ + * email: j.nijtmans@chello.nl (private) + * jan.nijtmans@cmg.nl (work) + * url: http://purl.oclc.org/net/nijtmans/ * */ #include "tk.h" @@ -55,12 +55,12 @@ Tcl_Obj *dataObj, Tcl_Obj *format, Tk_PhotoHandle imageHandle, int destX, int destY, int width, int height, int srcX, int srcY)); -static int StringWriteXBM _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_DString *dataPtr, Tcl_Obj *format, - Tk_PhotoImageBlock *blockPtr)); static int ChnWriteXBM _ANSI_ARGS_((Tcl_Interp *interp, char *fileName, Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr)); +static int StringWriteXBM _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *dataPtr, Tcl_Obj *format, + Tk_PhotoImageBlock *blockPtr)); static int CommonReadXBM _ANSI_ARGS_((Tcl_Interp *interp, ParseInfo *parseInfo, @@ -68,11 +68,11 @@ int destX, int destY, int width, int height, int srcX, int srcY)); static int CommonWriteXBM _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName, Tcl_DString *dataPtr, + CONST char *fileName, Tcl_DString *dataPtr, Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr)); Tk_PhotoImageFormat imgFmtXBM = { - "XBM", /* name */ + "xbm", /* name */ ChnMatchXBM, /* fileMatchProc */ ObjMatchXBM, /* stringMatchProc */ ChnReadXBM, /* fileReadProc */ @@ -117,6 +117,8 @@ { ParseInfo parseInfo; + ImgFixObjMatchProc(&interp, &data, &format, &widthPtr, &heightPtr); + parseInfo.handle.data = ImgGetStringFromObj(data, &parseInfo.handle.length); parseInfo.handle.state = IMG_STRING; @@ -154,6 +156,8 @@ { ParseInfo parseInfo; + ImgFixChanMatchProc(&interp, &chan, &fileName, &format, &widthPtr, &heightPtr); + parseInfo.handle.data = (char *) chan; parseInfo.handle.state = IMG_CHAN; @@ -569,7 +573,17 @@ Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; { - return CommonWriteXBM(interp, (char *) NULL, dataPtr, format, blockPtr); + int result; + Tcl_DString data; + + ImgFixStringWriteProc(&data, &interp, &dataPtr, &format, &blockPtr); + + result = CommonWriteXBM(interp, (CONST char *) NULL, dataPtr, format, blockPtr); + + if ((result == TCL_OK) && (dataPtr == &data)) { + Tcl_DStringResult(interp, dataPtr); + } + return result; } @@ -597,7 +611,7 @@ static int CommonWriteXBM(interp, fileName, dataPtr, format, blockPtr) Tcl_Interp *interp; - char *fileName; + CONST char *fileName; Tcl_DString *dataPtr; Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; @@ -626,7 +640,7 @@ /* open the output file (if needed) */ if (fileName) { - chan = Tcl_OpenFileChannel(interp, fileName, "w", 0644); + chan = Tcl_OpenFileChannel(interp, (char *) fileName, "w", 0644); if (!chan) { return TCL_ERROR; } @@ -648,7 +662,7 @@ } p = strchr(fileName, '.'); if (p) { - *p = 0; + *(char *)p = 0; } } else { fileName = "unknown"; Index: pTk/mTk/additions/imgXPM.c --- Tk800.020/pTk/mTk/additions/imgXPM.c Fri Mar 24 13:49:35 2000 +++ Tk800.021/pTk/mTk/additions/imgXPM.c Sat Apr 1 16:54:37 2000 @@ -6,9 +6,9 @@ * Written by: * Jan Nijtmans * CMG (Computer Management Group) Arnhem B.V. - * email: Jan.Nijtmans@wxs.nl (private) - * Jan.Nijtmans@cmg.nl (work) - * url: http://home.wxs.nl/~nijtmans/ + * email: j.nijtmans@chello.nl (private) + * jan.nijtmans@cmg.nl (work) + * url: http://purl.oclc.org/net/nijtmans/ * * (with some code stolen from the XPM image type and the GIF handler) * @@ -74,12 +74,12 @@ static int FileWriteXPM _ANSI_ARGS_((Tcl_Interp *interp, char *fileName, Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr)); -static int CommonWriteXPM _ANSI_ARGS_((Tcl_Interp *interp, char *fileName, +static int CommonWriteXPM _ANSI_ARGS_((Tcl_Interp *interp, CONST char *fileName, Tcl_DString *dataPtr, Tcl_Obj *format, Tk_PhotoImageBlock *blockPtr)); Tk_PhotoImageFormat imgFmtXPM = { - "XPM", /* name */ + "xpm", /* name */ ChanMatchXPM, /* fileMatchProc */ ObjMatchXPM, /* stringMatchProc */ ChanReadXPM, /* fileReadProc */ @@ -169,6 +169,8 @@ int numColors, byteSize; MFile handle; + ImgFixObjMatchProc(&interp, &dataObj, &format, &widthPtr, &heightPtr); + handle.data = ImgGetStringFromObj(dataObj, &handle.length); handle.state = IMG_STRING; @@ -207,6 +209,8 @@ int numColors, byteSize; MFile handle; + ImgFixChanMatchProc(&interp, &chan, &fileName, &format, &widthPtr, &heightPtr); + handle.data = (char *) chan; handle.state = IMG_CHAN; @@ -833,7 +837,14 @@ Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; { - return CommonWriteXPM(interp, "unknown", dataPtr, format, blockPtr); + int result; + Tcl_DString data; + ImgFixStringWriteProc(&data, &interp, &dataPtr, &format, &blockPtr); + result = CommonWriteXPM(interp, "unknown", dataPtr, format, blockPtr); + if ((result == TCL_OK) && (dataPtr == &data)) { + Tcl_DStringResult(interp, dataPtr); + } + return result; } @@ -865,7 +876,7 @@ static int CommonWriteXPM(interp, fileName, dataPtr, format, blockPtr) Tcl_Interp *interp; - char *fileName; + CONST char *fileName; Tcl_DString *dataPtr; Tcl_Obj *format; Tk_PhotoImageBlock *blockPtr; @@ -908,7 +919,7 @@ /* open the output file (if needed) */ if (!dataPtr) { - chan = Tcl_OpenFileChannel(interp, fileName, "w", 0644); + chan = Tcl_OpenFileChannel(interp, (char *) fileName, "w", 0644); if (!chan) { return TCL_ERROR; } Index: pTk/mTk/tixGeneric/tixDiStyle.c --- Tk800.020/pTk/mTk/tixGeneric/tixDiStyle.c Sun Dec 12 13:58:37 1999 +++ Tk800.021/pTk/mTk/tixGeneric/tixDiStyle.c Fri Mar 31 13:04:30 2000 @@ -14,6 +14,7 @@ #include "tixPort.h" #include "tix.h" #include "tixInt.h" +#include "tkInt.h" #ifdef _LANG #define FORWARD extern @@ -47,9 +48,9 @@ ClientData clientData, Tk_Window tkwin, char *widRec, int offset, Tcl_FreeProc **freeProcPtr)); -static Tix_DItemStyle* FindDefaultStyle _ANSI_ARGS_(( +static Tix_DItemStyle* FindDefaultStyle _ANSI_ARGS_((Tcl_Interp *interp, Tix_DItemInfo * diTypePtr, Tk_Window tkwin)); -static Tix_DItemStyle* FindStyle _ANSI_ARGS_(( +static Tix_DItemStyle* FindStyle _ANSI_ARGS_((Tcl_Interp *interp, char *styleName)); static Tix_DItemStyle* GetDItemStyle _ANSI_ARGS_(( Tix_DispData * ddPtr, Tix_DItemInfo * diTypePtr, @@ -75,16 +76,66 @@ ClientData clientData, XEvent *eventPtr)); static void SetDefaultStyle _ANSI_ARGS_((Tix_DItemInfo *diTypePtr, Tk_Window tkwin, Tix_DItemStyle * stylePtr)); +static Tcl_HashTable * GetDefaultTable _ANSI_ARGS_((Tcl_Interp *interp)); +static Tcl_HashTable * GetStyleTable _ANSI_ARGS_((Tcl_Interp *interp)); +void DestroyDefaultTable _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +void DestroyStyleTable _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); static TIX_DECLARE_SUBCMD(StyleConfigCmd); static TIX_DECLARE_SUBCMD(StyleCGetCmd); static TIX_DECLARE_SUBCMD(StyleDeleteCmd); extern TIX_DECLARE_SUBCMD(Tix_ItemStyleCmd); -static Tcl_HashTable styleTable; -static Tcl_HashTable defaultTable; static int tableInited = 0; +void +DestroyDefaultTable(clientData,interp) +ClientData clientData; +Tcl_Interp *interp; +{ + Tcl_DeleteHashTable((Tcl_HashTable *) clientData); + ckfree((char *) clientData); +} + +void +DestroyStyleTable(clientData,interp) +ClientData clientData; +Tcl_Interp *interp; +{ + Tcl_DeleteHashTable((Tcl_HashTable *) clientData); + ckfree((char *) clientData); +} + +Tcl_HashTable * +GetDefaultTable(interp) + Tcl_Interp *interp; +{ + Tcl_HashTable *table = (Tcl_HashTable *) Tcl_GetAssocData(interp, "TixDefaultStyle", NULL); + if (table == NULL) { + table = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(table, TCL_ONE_WORD_KEYS); + Tcl_SetAssocData(interp, "TixDefaultStyle", DestroyDefaultTable, + (ClientData) table); + } + return table; +} + +Tcl_HashTable * +GetStyleTable(interp) + Tcl_Interp *interp; +{ + Tcl_HashTable *table = (Tcl_HashTable *) Tcl_GetAssocData(interp, "TixStyles", NULL); + if (table == NULL) { + table = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(table, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, "TixStyles", DestroyStyleTable, + (ClientData) table); + } + return table; +} + /* *-------------------------------------------------------------- @@ -144,10 +195,6 @@ static int counter = 0; Tix_DItemStyle * stylePtr; - if (tableInited == 0) { - InitHashTables(); - } - if (argc < 2) { return Tix_ArgcError(interp, argc, argv, 1, "itemtype ?option value ..."); @@ -180,7 +227,7 @@ } if (strncmp(argv[i], "-stylename", len) == 0) { styleName = argv[i+1]; - if (FindStyle(styleName) != NULL) { + if (FindStyle(interp,styleName) != NULL) { Tcl_AppendResult(interp, "style \"", argv[i+1], "\" already exist", NULL); return TCL_ERROR; @@ -415,7 +462,7 @@ Tcl_GetCommandName(stylePtr->base.interp, stylePtr->base.styleCmd)); } - hashPtr=Tcl_FindHashEntry(&styleTable, stylePtr->base.name); + hashPtr=Tcl_FindHashEntry(GetStyleTable(stylePtr->base.interp), stylePtr->base.name); if (hashPtr != NULL) { Tcl_DeleteHashEntry(hashPtr); } @@ -441,7 +488,8 @@ */ static Tix_DItemStyle* -FindDefaultStyle(diTypePtr, tkwin) +FindDefaultStyle(interp, diTypePtr, tkwin) + Tcl_Interp *interp; Tix_DItemInfo * diTypePtr; Tk_Window tkwin; { @@ -449,10 +497,7 @@ StyleInfo * infoPtr; StyleLink * linkPtr; - if (tableInited == 0) { - InitHashTables(); - } - if ((hashPtr=Tcl_FindHashEntry(&defaultTable, (char*)tkwin)) == NULL) { + if ((hashPtr=Tcl_FindHashEntry(GetDefaultTable(interp), (char*)tkwin)) == NULL) { return NULL; } infoPtr = (StyleInfo *)Tcl_GetHashValue(hashPtr); @@ -474,15 +519,11 @@ StyleLink * newPtr; int isNew; - if (tableInited == 0) { - InitHashTables(); - } - newPtr = (StyleLink *)ckalloc(sizeof(StyleLink)); newPtr->diTypePtr = diTypePtr; newPtr->stylePtr = stylePtr; - hashPtr = Tcl_CreateHashEntry(&defaultTable, (char*)tkwin, &isNew); + hashPtr = Tcl_CreateHashEntry(GetDefaultTable(stylePtr->base.interp), (char*)tkwin, &isNew); if (!isNew) { infoPtr = (StyleInfo *)Tcl_GetHashValue(hashPtr); @@ -531,11 +572,7 @@ Tix_DItemStyle* stylePtr; int isNew; - if (tableInited == 0) { - InitHashTables(); - } - - stylePtr = FindDefaultStyle(diTypePtr, ddPtr->tkwin); + stylePtr = FindDefaultStyle(ddPtr->interp, diTypePtr, ddPtr->tkwin); if (stylePtr == NULL) { /* * Format default name for this style+window @@ -572,16 +609,14 @@ Tk_Window tkwin; Tix_StyleTemplate * tmplPtr; { + TkWindow *winPtr = (TkWindow *) tkwin; + Tcl_Interp *interp = winPtr->mainPtr->interp; Tcl_HashEntry * hashPtr; StyleInfo * infoPtr; StyleLink * linkPtr; int isNew; - if (tableInited == 0) { - InitHashTables(); - } - - hashPtr=Tcl_CreateHashEntry(&defaultTable, (char*)tkwin, &isNew); + hashPtr=Tcl_CreateHashEntry(GetDefaultTable(interp), (char*)tkwin, &isNew); if (!isNew) { infoPtr = (StyleInfo *)Tcl_GetHashValue(hashPtr); infoPtr->tmplPtr = &infoPtr->tmpl; @@ -630,11 +665,7 @@ int isNew; Tix_DItemStyle * stylePtr; - if (tableInited == 0) { - InitHashTables(); - } - - hashPtr = Tcl_CreateHashEntry(&styleTable, styleName, &isNew); + hashPtr = Tcl_CreateHashEntry(GetStyleTable(ddPtr->interp), styleName, &isNew); if (!isNew) { stylePtr = (Tix_DItemStyle *)Tcl_GetHashValue(hashPtr); } @@ -663,15 +694,13 @@ return stylePtr; } -static Tix_DItemStyle* FindStyle(styleName) +static Tix_DItemStyle* FindStyle(interp, styleName) + Tcl_Interp *interp; char *styleName; { Tcl_HashEntry *hashPtr; - if (tableInited == 0) { - InitHashTables(); - } - if ((hashPtr=Tcl_FindHashEntry(&styleTable, styleName)) == NULL) { + if ((hashPtr=Tcl_FindHashEntry(GetStyleTable(interp), styleName)) == NULL) { return NULL; } @@ -769,16 +798,6 @@ } } -static void -InitHashTables() -{ - if (tableInited == 0) { - Tcl_InitHashTable(&styleTable, TCL_STRING_KEYS); - Tcl_InitHashTable(&defaultTable, TCL_ONE_WORD_KEYS); - tableInited = 1; - } -} - /* *-------------------------------------------------------------- * @@ -802,6 +821,8 @@ XEvent *eventPtr; /* Describes what just happened. */ { Tk_Window tkwin = (Tk_Window)clientData; + TkWindow *winPtr = (TkWindow *) tkwin; + Tcl_Interp *interp = winPtr->mainPtr->interp; Tcl_HashEntry *hashPtr; StyleInfo * infoPtr; StyleLink * linkPtr, *toFree; @@ -809,10 +830,7 @@ if (eventPtr->type != DestroyNotify) { return; } - if (tableInited == 0) { - InitHashTables(); - } - if ((hashPtr=Tcl_FindHashEntry(&defaultTable, (char*)tkwin)) == NULL) { + if ((hashPtr=Tcl_FindHashEntry(GetDefaultTable(interp), (char*)tkwin)) == NULL) { return; } infoPtr = (StyleInfo *)Tcl_GetHashValue(hashPtr); @@ -900,11 +918,6 @@ Tix_DItemStyle * oldPtr = *ptr; Tix_DItemStyle * newPtr; - - if (tableInited == 0) { - InitHashTables(); - } - if (value == NULL || strlen(LangString(value)) == 0) { /* * User gives a NULL string -- meaning he wants the default @@ -923,7 +936,7 @@ newPtr = NULL; } } else { - if ((newPtr = FindStyle(LangString(value))) == NULL) { + if ((newPtr = FindStyle(interp,LangString(value))) == NULL) { goto not_found; } if (newPtr->base.flags & TIX_STYLE_DELETED) { Index: pTk/mTk/tixGeneric/tixForm.c --- Tk800.020/pTk/mTk/tixGeneric/tixForm.c Mon Nov 15 14:59:29 1999 +++ Tk800.021/pTk/mTk/tixGeneric/tixForm.c Fri Apr 21 09:51:34 2000 @@ -250,8 +250,7 @@ } if (argc == 1) { - sprintf(buff, "%d %d", masterPtr->grids[0], masterPtr->grids[1]); - Tcl_AppendResult(interp, buff, NULL); + Tcl_IntResults(interp, 2, 0, masterPtr->grids[0], masterPtr->grids[1]); } else { int x, y; Index: pTk/mTk/tixGeneric/tixHLInd.c --- Tk800.020/pTk/mTk/tixGeneric/tixHLInd.c Mon Nov 15 14:59:29 1999 +++ Tk800.021/pTk/mTk/tixGeneric/tixHLInd.c Fri Apr 21 09:54:02 2000 @@ -270,9 +270,8 @@ "\" does not have an indicator", (char*)NULL); return TCL_ERROR; } - sprintf(buff, "%d %d", + Tcl_IntResults(interp, 2, 0, Tix_DItemWidth(chPtr->indicator), Tix_DItemHeight(chPtr->indicator)); - Tcl_AppendResult(interp, buff, NULL); return TCL_OK; } Index: pTk/mTk/tixGeneric/tixNBFrame.c --- Tk800.020/pTk/mTk/tixGeneric/tixNBFrame.c Mon Nov 15 14:59:29 1999 +++ Tk800.021/pTk/mTk/tixGeneric/tixNBFrame.c Fri Apr 21 09:55:33 2000 @@ -554,12 +554,8 @@ RedrawWhenIdle(wPtr); } else if ((c == 'g') && (strncmp(argv[1], "geometryinfo", length) == 0)) { - char buff[20]; - ComputeGeometry(wPtr); - sprintf(buff, "%d %d", wPtr->width, wPtr->height); - - Tcl_AppendResult(interp, buff, NULL); + Tcl_IntResults(interp, 2, 0, wPtr->width, wPtr->height); } else if ((c == 'i') && (strncmp(argv[1], "identify", length) == 0)) { if (argc != 4) { Index: pTk/mTk/tixGeneric/tixTList.c --- Tk800.020/pTk/mTk/tixGeneric/tixTList.c Sat Mar 4 15:04:07 2000 +++ Tk800.021/pTk/mTk/tixGeneric/tixTList.c Fri Apr 21 10:01:36 2000 @@ -1535,9 +1535,14 @@ &first[i], &last[i]); } +#if 0 + /* FIXME */ sprintf(string, "{%f %f} {%f %f}", first[0], last[0], first[1], last[1]); Tcl_AppendResult(interp, string, NULL); - +#else + /* Not quite right - one list of four rather than two lists of two */ + Tcl_DoubleResults(interp, 4, 1, first[0], last[0], first[1], last[1]); +#endif return TCL_OK; } Index: pod/Checkbutton.pod --- Tk800.020/pod/Checkbutton.pod Tue Nov 9 13:18:00 1999 +++ Tk800.021/pod/Checkbutton.pod Fri Mar 31 14:02:17 2000 @@ -137,7 +137,7 @@ or not this button is selected. Defaults to C<\$widget-E{'Value'}> member of the widget's hash. In general perl variables are C unless specifically initialized which will not match either default B<-onvalue> or -deafult B<-offvalue>. +default B<-offvalue>. =item Name: B Index: pod/ConfigSpecs.pod --- /dev/null Sat Jun 19 13:46:56 1999 +++ Tk800.021/pod/ConfigSpecs.pod Fri Mar 31 14:26:18 2000 @@ -0,0 +1,239 @@ +# $Id: configspec.pod 1.2 Wed, 12 Nov 1997 00:30:45 +0100 ach $ + +=head1 NAME + +Tk::ConfigSpecs - Defining behaviour of 'configure' for composite widgets. + +=for category Derived Widgets + +=head1 SYNOPSIS + + sub Populate + { + my ($composite,$args) = @_; + ... + $composite->ConfigSpecs('-attribute' => [ where,dbName,dbClass,default ]); + $composite->ConfigSpecs('-alias' => '-otherattribute'); + $composite->ConfigSpecs('DEFAULT' => [ where ]); + ... + } + + $composite->configure(-attribute => value); + +=head1 DESCRIPTION + +The aim is to make the composite widget configure method look as much like +a regular Tk widget's configure as possible. +(See L for a description of this behaviour.) +To enable this the attributes that the composite as a whole accepts +needs to be defined. + +=head2 Defining the ConfigSpecs for a class. + +Typically a widget will have one or more calls like the following + + $composite->ConfigSpecs(-attribute => [where,dbName,dbClass,default]); + +in its B method. When B is called this way +(with arguments) the arguments are used to construct or augment/replace +a hash table for the widget. (More than one I<-option>=EI +pair can be specified to a single call.) + +B, B and default are only used by B described +below, or to respond to 'inquiry' configure commands. + +It may be either one of the values below, or a list of such values +enclosed in B<[]>. + +The currently permitted values of B are: + +=over 4 + +=item B<'ADVERTISED'> + +apply B to I subwidgets. + +=item B<'DESCENDANTS'> + +apply B recursively to all descendants. + +=item B<'CALLBACK'> + +Setting the attribute does Cnew($value)> before storing +in C<$composite-E{Configure}{-attribute}>. This is appropriate for +C<-command =E ...> attributes that are handled by the composite and not +forwarded to a subwidget. (E.g. B has C<-yscrollcommand> to +allow it to have scrollbar attached.) + +This may be the first of several 'validating' keywords (e.g. font, cursor, +anchor etc.) that core Tk makes special for C code. + +=item B<'CHILDREN'> + +apply B to all children. (Children are the immediate +descendants of a widget.) + +=item B<'METHOD'> + +Call C<$cw-Eattribute(value)> + +This is the most general case. Simply have a method of the composite +class with the same name as the attribute. The method may do any +validation and have whatever side-effects you like. (It is probably +worth 'queueing' using B for more complex side-effects.) + +=item B<'PASSIVE'> + +Simply store value in C<$composite-E{Configure}{-attribute}>. + +This form is also a useful placeholder for attributes which you +currently only handle at create time. + +=item B<'SELF'> + +Apply B to the core widget (e.g. B) that is the basis of +the composite. (This is the default behaviour for most attributes which +makes a simple Frame behave the way you would expect.) Note that once +you have specified B for an attribute you must explicitly +include C<'SELF'> in the list if you want the attribute to apply to the +composite itself (this avoids nasty infinite recursion problems). + +=item B<$reference> (blessed) + +Call B<$reference>->configure(-attribute => value) + +A common case is where B<$reference> is a subwidget. + +$reference may also be result of + + Tk::Config->new(setmethod,getmethod,args,...); + +B class is used to implement all the above keyword types. The +class has C and C methods so allows higher level code to +I just call one of those methods on an I of some kind. + +=item B + +Defining: + + $cw->ConfigSpecs( + ... + -option => [ { -optionX=>$w1, -optionY=>[$w2, $w3] }, + dbname dbclass default ], + ... + ); + +So C<$cw-Econfigure(-option =E value)> actually does + + $w1->configure(-optionX => value); + $w2->configure(-optionY => value); + $w3->configure(-optionY => value); + +=item B<'otherstring'> + +Call + + $composite->Subwidget('otherstring')->configure( -attribute => value ); + +While this is here for backward compatibility with Tk-b5, it is probably +better just to use the subwidget reference directly. The only +case for retaining this form is to allow an additional layer of +abstraction - perhaps having a 'current' subwidget - this is unproven. + +=item B + +C '-otherattribute' )> is used to make C<-alias> +equivalent to C<-otherattribute>. For example the aliases + + -fg => '-foreground', + -bg => '-background' + +are provided automatically (if not already specified). + +=back + +=head2 Default Values + +When the B method returns B is called. This calls + + $composite->ConfigSpecs; + +(with no arguments) to return a reference to a hash. Entries in the hash +take the form: + + '-attribute' => [ where, dbName, dbClass, default ] + +B ignores 'where' completely (and also the DEFAULT entry) and +checks the 'options' database on the widget's behalf, and if an entry is +present matching dbName/dbClass + + -attribute => value + +is added to the list of options that B will eventually apply to the +widget. Likewise if there is not a match and default is defined this +default value will be added. + +Alias entries in the hash are used to convert user-specified values for the +alias into values for the real attribute. + +=head2 New()-time Configure + +Once control returns to B, the list of user-supplied options +augmented by those from B are applied to the widget using the +B method below. + +Widgets are most flexible and most Tk-like if they handle the majority of +their attributes this way. + +=head2 Configuring composites + +Once the above have occurred calls of the form: + + $composite->configure( -attribute => value ); + +should behave like any other widget as far as end-user code is concerned. +B will be handled by B as follows: + + $composite->ConfigSpecs; + +is called (with no arguments) to return a reference to a hash B<-attribute> is +looked up in this hash, if B<-attribute> is not present in the hash then +B<'DEFAULT'> is looked for instead. (Aliases are tried as well and cause +redirection to the aliased attribute). The result should be a reference to a +list like: + + [ where, dbName, dbClass, default ] + +at this stage only I is of interest, it maps to a list of object +references (maybe only one) foreach one + + $object->configure( -attribute => value ); + +is Bed. + +=head2 Inquiring attributes of composites + + $composite->cget( '-attribute' ); + +This is handled by B in a similar manner to configure. At +present if I is a list of more than one object it is ignored completely +and the "cached" value in + + $composite->{Configure}{-attribute}. + +is returned. + +=head1 CAVEATS + +It is the author's intention to port as many of the "Tix" composite widgets +as make sense. The mechanism described above may have to evolve in order to +make this possible, although now aliases are handled I think the above is +sufficient. + +=head1 SEE ALSO + +L, +L + +=cut + Index: pod/Scrolled.pod --- Tk800.020/pod/Scrolled.pod Tue Nov 9 13:18:00 1999 +++ Tk800.021/pod/Scrolled.pod Fri Mar 31 14:58:50 2000 @@ -55,6 +55,10 @@ the B widget used for vertical scrolling (if it exists) +=item corner + +a frame in the corner between the vertical and horizontal scrolbar + =back =head1 BUGS Index: t/autoload.t --- /dev/null Sat Jun 19 13:46:56 1999 +++ Tk800.021/t/autoload.t Sun Mar 26 13:11:06 2000 @@ -0,0 +1,27 @@ +BEGIN { $^W = 1; $| = 1;} +use Test; +plan tests => 5; +use Tk; +my $method; + +sub warn_handler +{ + local $_ = shift; + ok($_ =~ /^Assuming 'require Tk::$method;/,1,"Wrong warning:$_"); +} + +$SIG{'__WARN__'} = \&warn_handler; + +my $mw = MainWindow->new; +$method = 'Nonwidget'; +Tk::catch { $mw->$method() }; +ok($@ =~ /Can't locate/,1,"Wrong error:$@"); +$method = 'BrowseEntry'; +$mw->$method(); +ok(defined(&Tk::Widget::BrowseEntry),1,"Autoload failed"); +$method = 'Entry'; +$mw->$method(); +ok(defined(&Tk::Widget::Entry),1,"Autoload failed"); + + + Index: t/fileevent.t --- /dev/null Sat Jun 19 13:46:56 1999 +++ Tk800.021/t/fileevent.t Wed Apr 5 08:37:36 2000 @@ -0,0 +1,372 @@ +BEGIN { $^W = 1; $| = 1;} +use Test; + +#!/usr/local/bin/perl -w +# +# Severely hacked test based on IPC example from +# Advanced Perl/Tk Programming. + +use 5.005; +use Carp; +#use IPADM; +use IO::Socket; +use Tk; +use Tk::LabEntry; +use Tk::ROText; +use strict; +use vars qw/$EXIT $HN $ME $MW $PID/; +use subs qw/do_command fini init ipsnd list_subnet open_subnet + pipe_in pipe_out read_sdb start_ipc_helper/; + +use vars qw/$AUTHORIZED_CLIENTS $DAEMON_HOST $DAEMON_PORT $DEBUG + $EOF $MOD_DB_PATH $ORGANIZATION $SDB_PATH $VERSION/; + +BEGIN { plan test => 1} + +if ($^O eq 'MSWin32') { + skip(1, 'Cannot test pipe/fork/exec/fileevent on Win32 systems.'); + exit; +} + +$AUTHORIZED_CLIENTS = 'localhost|loopback'; # a regex +$DAEMON_HOST = 'localhost'; +$DAEMON_PORT = 1234; +$DEBUG = 1; +$EOF = '_END_OF_INFORMATION_'; +$ORGANIZATION = 'Subnet List for ACME Rocket Supply, Inc.'; + +init; +MainLoop; +fini; + +sub do_command { + + # Issue a single IPADM command and wait for a reply. Using + # pipes and fileevent() allows X11 events to continue flowing. + + pipe_out @_; + return pipe_in; + +} # end do_command + +sub pipe_in { + + # Now that the IPADM command has been issued, keep sysread-ing + # until the $EOF string is read, and return all the accumulated + # data, excluding $EOF. + + my(@data, $sysbuf, $sysdata, $sysstat, $wait); + + $MW->fileevent(\*PR, 'readable' => sub { + +# print STDERR "IN: about to sysread ...\n" if $DEBUG; + if ( ($Tk::VERSION cmp '800.015') <= 0 ) { +# if ( defined($ARGV[0]) ) { + $sysbuf = ; +# print STDERR "IN: sysbuf=$sysbuf\n" if $DEBUG; + } else { + $sysstat = sysread PR, $sysbuf, 7; + die "ipadm: sysread error $!" unless defined $sysstat; +# print STDERR "IN: bytes=$sysstat\n" if $DEBUG; + } + $sysdata .= $sysbuf; + if ($sysdata =~ /$EOF$/s) { + @data = split /\n/, $sysdata; + $#data--; # throw $EOF away + $wait++; # unblock waitVariable() + } + + }); + + $MW->waitVariable(\$wait); + $MW->fileevent(\*PR, 'readable' => ''); +# print STDERR "IN: @data\n" if $DEBUG; + + @data; + +} # end pipe_in + +sub pipe_out { + + # Issue an IPADM command by syswrite-ing all the data plus + # the terminating $EOF. + + return unless defined $_[0]; + + my($bytes, $offset, $sysdata, $sysstat, $wait); + + $sysdata = join '', @_, "$EOF\n"; + $bytes = length $sysdata; + $offset = 0; + + $MW->fileevent(\*PW, 'writable' => sub { + + while ($bytes > 0) { + $sysstat = syswrite PW, $sysdata, $bytes, $offset; + die "ipadm: syswrite error $!" unless defined $sysstat; + $bytes -= $sysstat; + $offset += $sysstat; + } + $wait++; + + }); + + $MW->waitVariable(\$wait); + $MW->fileevent(\*PW, 'writable' => ''); +# print STDERR "OT: $sysdata\n" if $DEBUG; + +} # end pipe_out + +sub fini { + kill 'SIGTERM', $PID; + unlink '/tmp/ipadmh'; + exit $EXIT; +} + +sub init { + + my $frog = defined $ARGV[0] ? '' : 'sysread()'; + my $well = 'all is well'; + if ( (($Tk::VERSION cmp '800.015') <= 0) and ($frog eq 'sysread()') ) { + $well = 'all is NOT well'; + } + if ( (($Tk::VERSION cmp '800.015') > 0) and ($frog eq '') ) { + $well = 'all is NOT well'; + } + + open(HELPER, ">/tmp/ipadmh") or die "cannot write helper program: $!"; + while ($_ = ) { + print HELPER; + } + close HELPER or die $!; + chmod 0755, '/tmp/ipadmh'; + + $MW = MainWindow->new; + $MW->title('ipadm - Administer IP Nodes'); + $MW->iconname('ipadm'); + $MW->minsize(50, 50); + $MW->protocol('WM_DELETE_WINDOW' => \&fini); + + # Create the menubar and friends. + + my $menubar = $MW->Menu; + $MW->configure(-menu => $menubar); + + my $file = $menubar->cascade(-label => '~File'); + my $edit = $menubar->cascade(-label => '~Edit'); + my $help = $menubar->cascade(-label => '~Help'); + + $file->command(-label => 'Quit', -command => \&fini); + $edit->command(-label => 'Fast Find', -command => [$MW => 'bell']); + $help->command(-label => 'About', -command => sub { + $MW->messageBox(-message => "ipadm $VERSION\n\n99/07/15")}); + + # Create the subnets table, a list of hypertext links, and some tags + # to highlight the active entry and a binding to load a subnet. + + my $t = $MW->Scrolled('ROText', + qw/-width 80 -height 10 -relief ridge -scrollbars w/); + $t->pack(qw/-padx 5 -pady 3 -fill both -expand 1/); + + $t->tagConfigure(qw/title -font/ => 'Helvetica 18 bold'); + $t->tagConfigure(qw/subnet -lmargin1 .5c -lmargin2 1c -foreground blue/); + $t->tagConfigure(qw/hot -relief raised -borderwidth 1 -background green/); + + start_ipc_helper; + + $t->insert('end', "\n$ORGANIZATION\n\n", ['title']); + + # Get a list of subnets from ipadmd, sort the subnets by + # IP number, and add the title string to the text widget, + # tagged with the SDB file name. + + my($status, @subnet_list) = do_command "get_subnet_list\n"; + die "Cannot get SDB list" unless $status =~ /OK/; + + foreach (sort numerically @subnet_list) { + my($sdb, $title) = /^(\S+)\s+(.*)$/; + $t->insert('end', "$title\n", ['subnet', $sdb]); + } + + #$t->tagBind(qw/subnet / => \&open_subnet); + + my $last_hot = ''; + $t->tagBind(qw/subnet / => sub { + my $text = shift; # SUBTLE STATEMENT HERE (-: + my($x, $y) = ($Tk::event->x, $Tk::event->y); + $last_hot = $text->index("\@$x,$y linestart"); + $text->tagAdd('hot', $last_hot, "$last_hot lineend"); + }); + $t->tagBind(qw/subnet / => sub { + shift->tagRemove(qw/hot 1.0 end/); + }); + $t->tagBind(qw/subnet / => sub { + my $text = shift; + my($x, $y) = ($Tk::event->x, $Tk::event->y); + my $new_hot = $text->index("\@$x,$y linestart"); + if ($new_hot ne $last_hot) { + $text->tagRemove(qw/hot 1.0 end/); + $text->tagAdd('hot', $new_hot, "$new_hot lineend"); + $last_hot = $new_hot; + } + }); + + chomp($HN = `hostname`); + $ME = getlogin; + + # Sanity check, see if the 4th line was read. + + my $fourth = 'Subnet 128B, ACME Rubber Band Development'; + $MW->update; + $MW->after(1000); + my $data = $t->get('7.0', '7.0 lineend'); + #print "four=$fourth!\n"; + #print "data=$data!\n"; + $EXIT = ($data eq $fourth) ? 0 : 1; + ok($data, $fourth); + $MW->destroy; + +} # end init + +sub lsearch { # $o = lsearch $regexp, @list; + + # Search the list using the supplied regular expression and return it's + # ordinal, or -1 if not found. + + my($regexp, @list) = @_; + my($i); + + for ($i=0; $i<=$#list; $i++) { + return $i if $list[$i] =~ /$regexp/; + } + return -1; + +} # end lsearch + +sub numerically { + my($n1, $n2); + ($n1) = $a =~ /Subnet_(\d+)/; + ($n2) = $b =~ /Subnet_(\d+)/; + if ($n1 != $n2) { + $n1 <=> $n2; + } else { + $a cmp $b; + } +} + +sub start_ipc_helper { + + # Start a child process and use pipes to talk with it. The child + # uses sockets to talk to the remote IPADM daemon. + + $SIG{PIPE} = sub {print STDERR "ipadmh pipe failure.\n"; exit}; + + pipe CR, PW or die "cr/pw pipe $!"; + pipe PR, CW or die "pr/cw pipe $!"; + + if ($PID = fork) { # parent, ipadm/Tk + close CR; + close CW; + PW->autoflush(1); + } elsif (defined $PID) { # child, exec ipadmh + close PR; + close PW; + open STDIN, "<&CR" or die "STDIN open $!"; + open STDOUT, ">&CW" or die "STDOUT open $!"; + open STDERR, ">&CW" or die "STDERR open $!"; + STDOUT->autoflush(1); + STDERR->autoflush(1); + exec($^X,"/tmp/ipadmh", $DAEMON_HOST, $DAEMON_PORT) or die "exec $!"; + die "exec warp $!"; + } else { + die "fork $!"; + } # ifend fork + + my(@stat) = do_command undef; # did helper make a connection? + return if $stat[0] =~ /Connect OK/; + + $MW->messageBox(-message => "Cannot connect to remote IPADM daemon " . + "$DAEMON_HOST:$DAEMON_PORT. Please try again later.", + -title => 'Daemon is Dead', -icon => 'warning', + -type => 'OK'); + fini; + +} # end start_ipc_helper +__DATA__ +#!/usr/local/bin/perl + +use 5.005; +#use IPADM; +use IO::Socket; +use strict; + +my $EOF = '_END_OF_INFORMATION_'; + +do {print "Usage: ipadmh host port\n"; exit} unless @ARGV == 2; + +STDOUT->autoflush(1); # unbuffer output +sub timeout {print "1 Socket Timeout\n$EOF\n"; $SIG{ALRM} = \&timeout} +$SIG{PIPE} = sub {print "2 Pipe Error.\n$EOF\n"}; + +my $sock = 'defined'; +print +((defined $sock) ? "0 Connect OK" : "3 Connect Failed"), "\n$EOF\n"; + + +while() { + last if /^$EOF$/; +} + +my(@data) = (); +$SIG{ALRM} = \&timeout; # reset handler +alarm 60; + +@data = <<"END-DATA"; +0 OK +Subnet_1.sdb Subnet 1, ACME Bean Counting Department +Subnet_128A.sdb Subnet 128A, ACME Coil Spring Development +Subnet_128B.sdb Subnet 128B, ACME Rubber Band Development +Subnet_2.sdb Subnet 2, ACME Purchasing Department +$EOF +END-DATA + +alarm 0; +#print (/^$EOF$/ ? @data : "4 Daemon Failure\n$EOF\n"); +print @data; +__END__ + print <<"END-HELP"; + +Run this program with or without a command line argument. If +\$ARGV[0] is defined then is used by the fileevent() +callback to read from the pipe. If \$ARGV[0] is not defined, +then sysread() is used. + +This is Tk version $Tk::VERSION, and we'll use $frog to read +from the pipe. + +When all is well, you should see a MainWindow with the heading +"Subnet List for ACME Rocket Supply, Inc", followed by a list +of (4) subnets. + +================================================================ += With this combination of Tk $Tk::VERSION and $frog I suspect += $well! +================================================================ + +The subnet list comes from a helper program via a pipe - the +real helper program gets this data via a socket from a server, +but for this demo the subnet data is hardcoded in the helper. + +Regardless, the parent Tk program execs the helper and first +"asks" for the subnet list by issuing a command on its write +pipe, which the helper reads on its STDIN. For this demo, the +helper doesn't even look at what it reads but simply writes the +subnet list to its STDOUT. + +Now for the bug: the Perl/Tk parent needs to read this subnet +list from its input pipe, but the fileevent() *mechanism* +changed after Tk version 800.015. The subroutine pipe_in() in +the Tk parent "ipadm" needs to read via a for Tk800.015 +and before, but sysread() for Tk800.018. + +END-HELP + Index: tkGlue.c --- Tk800.020/tkGlue.c Sat Mar 25 13:11:50 2000 +++ Tk800.021/tkGlue.c Fri Apr 21 09:13:10 2000 @@ -51,7 +51,6 @@ Tcl_VarTraceProc *proc; ClientData clientData; Tcl_Interp *interp; - SV *sv; char *part2; } Tk_TraceInfo; @@ -736,7 +735,7 @@ void DumpStack _((void)) { - dTHR; + dTHX; do_watch(); LangDumpVec("stack", PL_stack_sp - PL_stack_base, PL_stack_base + 1); } @@ -1549,7 +1548,7 @@ Check_Eval(interp) Tcl_Interp *interp; { - dTHR; + dTHX; STRLEN na; SV *sv = ERRSV; if (SvTRUE(sv)) @@ -1867,7 +1866,7 @@ int count = 0; int code; SV *cb = sv; - dTHR; + dTHX; ENTER; SAVETMPS; if (interp) @@ -1910,7 +1909,7 @@ ClientData clientData; {Tcl_Interp *interp = (Tcl_Interp *) clientData; AV *pend = FindAv(interp, "HandleBgErrors", 0, "_PendingErrors_"); - dTHR; + dTHX; ENTER; SAVETMPS; TAINT_NOT; @@ -1947,7 +1946,7 @@ Tcl_BackgroundError(interp) Tcl_Interp *interp; { - dTHR; + dTHX; int old_taint = PL_tainted; TAINT_NOT; if (InterpHv(interp,0)) @@ -1968,7 +1967,7 @@ av_store(av, 0, newSVpv("Tk::Error",0)); av_store(av, 1, obj); av_store(av, 2, newSVpv(Tcl_GetResult(interp),0)); - av_push( pend, LangMakeCallback((SV *) av)); + av_push( pend, LangMakeCallback(MakeReference((SV *) av))); if (av_len(pend) <= 0) { /* 1st one - setup callback */ @@ -3384,7 +3383,6 @@ { Tk_TraceInfo *p = (Tk_TraceInfo *) ix; char *result; - assert(sv == p->sv); /* We are a "magic" set processor, whether we like it or not because this is the hook we use to get called. @@ -3419,7 +3417,6 @@ { Tk_TraceInfo *p = (Tk_TraceInfo *) ix; char *result; - assert(sv == p->sv); /* We are a "magic" set processor, whether we like it or not because this is the hook we use to get called. @@ -3444,17 +3441,16 @@ if (!SvIOK(sv) && SvIOKp(sv)) SvIOK_on(sv); + ENTER; + SvREFCNT_inc(sv); + save_freesv(sv); result = (*p->proc) (p->clientData, p->interp, sv, p->part2, 0); if (result) Tcl_Panic("Tcl_VarTraceProc returned '%s'", result); + LEAVE; return 0; } -#ifdef __MINGW32__ -#undef vtbl_uvar -static MGVTBL vtbl_uvar = { magic_getuvar, magic_setuvar, 0, 0, 0}; -#endif - int Tcl_TraceVar2(interp, sv, part2, flags, tkproc, clientData) Tcl_Interp *interp; @@ -3496,7 +3492,6 @@ p->proc = tkproc; p->clientData = clientData; p->interp = interp; - p->sv = SvREFCNT_inc(sv); p->part2 = part2; /* We want to be last in the chain so that any @@ -3505,15 +3500,18 @@ */ mg_list = SvMAGIC(sv); SvMAGIC(sv) = NULL; + + /* Add 'U' magic to sv with all NULL args */ sv_magic(sv, 0, 'U', 0, 0); - New(666, ufp, 1, struct ufuncs); + Newz(666, ufp, 1, struct ufuncs); ufp->uf_val = Perl_Value; ufp->uf_set = Perl_Trace; ufp->uf_index = (IV) p; mg = SvMAGIC(sv); mg->mg_ptr = (char *) ufp; + mg->mg_len = sizeof(struct ufuncs); /* put list back and add mg to end */ @@ -3686,19 +3684,21 @@ * Trawl through the linked list of magic looking * for the 'U' one which is our proc and ix. */ - if (mg->mg_type == 'U' - && mg->mg_ptr - && ((struct ufuncs *) (mg->mg_ptr))->uf_set == Perl_Trace) - { - Tk_TraceInfo *p = (Tk_TraceInfo *) (((struct ufuncs *) (mg->mg_ptr))->uf_index); - if (p->proc == tkproc && p->interp == interp && + if (mg->mg_type == 'U' && mg->mg_ptr && + mg->mg_len == sizeof(struct ufuncs) && + ((struct ufuncs *) (mg->mg_ptr))->uf_set == Perl_Trace) + { + struct ufuncs *uf = (struct ufuncs *) (mg->mg_ptr); + Tk_TraceInfo *p = (Tk_TraceInfo *) (uf->uf_index); + if (p && p->proc == tkproc && p->interp == interp && p->clientData == clientData) { *mgp = mg->mg_moremagic; + Safefree(p); + uf->uf_index = 0; Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; Safefree(mg); - SvREFCNT_dec(p->sv); - Safefree(p); } else mgp = &mg->mg_moremagic; @@ -3706,6 +3706,11 @@ else mgp = &mg->mg_moremagic; } + if (!SvMAGIC(sv)) + { + SvMAGICAL_off(sv); + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + } } } @@ -3798,7 +3803,7 @@ Var *vp; int type; { - dTHR; + dTHX; STRLEN na; int old_taint = PL_tainted; TAINT_NOT; @@ -3830,7 +3835,7 @@ } else if (SvPOK(sv)) { - dTHR; + dTHX; HV *old_stash = CopSTASH(PL_curcop); char *name; SV *x = NULL; @@ -5097,14 +5102,21 @@ /* FIXME: What should this do ? */ } + +static HV *uidHV; + Tk_Uid Tk_GetUid(key) CONST char *key; /* String to convert. */ { - STRLEN klen = strlen(key); - U32 hash = 0; - PERL_HASH(hash, (char *) key, klen); - return (Tk_Uid) sharepvn( (char *) key, klen, hash); + STRLEN klen; + SV *svkey = newSVpv((char *)key,strlen(key)); + HE *he; + if (!uidHV) + uidHV = newHV(); + he = hv_fetch_ent(uidHV,svkey,1,0); + SvREFCNT_dec(svkey); + return (Tk_Uid) HePV(he,klen); } long Index: tkGlue.def --- Tk800.020/tkGlue.def Sat Feb 12 15:33:45 2000 +++ Tk800.021/tkGlue.def Mon Apr 3 19:24:48 2000 @@ -22,6 +22,9 @@ #define CopSTASH_set(c,h) (CopSTASH(c) = h) #endif +#ifndef dTHX +#define dTHX dTHR +#endif #ifndef dTHR #define dTHR int maybeTHR Index: two_main --- Tk800.020/two_main Tue Jul 27 19:21:25 1999 +++ Tk800.021/two_main Sat Apr 1 08:33:59 2000 @@ -1,6 +1,8 @@ #!/usr/local/bin/perl -w use Tk; +use Tk::Xrm; +use Tk::widgets qw(DirTree Button); # This does not work properly yet @@ -15,6 +17,7 @@ $top->Button('-text'=>"Quit",'-command'=>['destroy',$top])->pack; $top->Button('-textvariable'=>\$name, '-command'=> [ sub { my $name = shift; print "$name\n"},$name])->pack; + $top->DirTree()->pack; $top->title($name); } __END_OF_PATCH__