# strip everything before this and feed to /bin/sh # # patch -p1 -N <<'__END_OF_PATCH__' Index: Event/Event.pm --- Tk800.023/Event/Event.pm Sat Dec 30 16:12:37 2000 +++ Tk800.024/Event/Event.pm Tue Mar 5 14:27:40 2002 @@ -1,8 +1,8 @@ package Tk::Event; use vars qw($VERSION $XS_VERSION @EXPORT_OK); END { CleanupGlue() } -$VERSION = '3.024'; # $Id: //depot/Tk8/Event/Event.pm#24 $ -$XS_VERSION = '800.023'; +$VERSION = '3.026'; # $Id: //depot/Tk8/Event/Event.pm#26 $ +$XS_VERSION = '800.024'; require DynaLoader; use base qw(Exporter DynaLoader); @EXPORT_OK = qw($XS_VERSION DONT_WAIT WINDOW_EVENTS FILE_EVENTS Index: Event/Event.xs --- Tk800.023/Event/Event.xs Sat Apr 7 17:24:02 2001 +++ Tk800.024/Event/Event.xs Mon Jan 7 09:35:44 2002 @@ -277,8 +277,13 @@ typedef struct PerlIOHandler { struct PerlIOHandler *nextPtr; /* Next in list of all files we care about. */ - SV *handle; - IO *io; + SV *handle; /* Handle we are tied to */ + IO *io; /* Current IO within handle */ + GV *untied; /* Another handle to pass to methods + * it is untied to avoid recusion and + * has IoIFP/IoOFP of its IO dynamically set to those + * of io. + */ LangCallback *readHandler; LangCallback *writeHandler; LangCallback *exceptionHandler; @@ -333,7 +338,15 @@ PerlIOHandler *filePtr; { filePtr->io = sv_2io(filePtr->handle); - return (filePtr->io) ? newRV((SV *) filePtr->io) : &PL_sv_undef; + if (filePtr->io) + { + /* io exists - copy current PerlIO * from io to our un-tied IO */ + IO *tmpio = GvIOp(filePtr->untied); + IoIFP(tmpio) = IoIFP(filePtr->io); + IoOFP(tmpio) = IoOFP(filePtr->io); + return newRV((SV *) filePtr->untied); + } + return &PL_sv_undef; } void @@ -685,14 +698,18 @@ int mask; /* OR'ed TCL_READABLE, TCL_WRITABLE, and TCL_EXCEPTION */ { HV *stash = gv_stashpv(class, TRUE); + GV *tmpgv = newGVgen(class); + IO *tmpio = newIO(); IO *io = sv_2io(fh); SV *obj = newSV(sizeof(PerlIOHandler)); PerlIOHandler *filePtr = (PerlIOHandler *)SvPVX(obj); + GvIOp(tmpgv) = tmpio; if (!initialized) PerlIOEventInit(); Zero(filePtr,1,PerlIOHandler); filePtr->io = io; filePtr->handle = SvREFCNT_inc(fh); + filePtr->untied = tmpgv; filePtr->readyMask = 0; filePtr->handlerMask = 0; filePtr->mask = 0; @@ -817,6 +834,7 @@ { if (!thisPtr || filePtr == thisPtr) { + IO *tmpio; *link = filePtr->nextPtr; PerlIO_unwatch(filePtr); if (filePtr->readHandler) @@ -834,6 +852,10 @@ LangFreeCallback(filePtr->exceptionHandler); filePtr->exceptionHandler = NULL; } + tmpio = GvIOp(filePtr->untied); + IoIFP(tmpio) = NULL; + IoOFP(tmpio) = NULL; + SvREFCNT_dec(filePtr->untied); SvREFCNT_dec(filePtr->handle); } else Index: HList/HList.pm --- Tk800.023/HList/HList.pm Sat Dec 30 16:12:37 2000 +++ Tk800.024/HList/HList.pm Sat Sep 29 18:48:16 2001 @@ -1,7 +1,7 @@ package Tk::HList; use vars qw($VERSION); -$VERSION = '3.035'; # $Id: //depot/Tk8/HList/HList.pm#35 $ +$VERSION = '3.037'; # $Id: //depot/Tk8/HList/HList.pm#37 $ use Tk qw(Ev $XS_VERSION); @@ -264,13 +264,17 @@ } return unless (defined($ent) and length($ent)); - if(exists $w->{tixindicator}) + if (exists $w->{tixindicator}) { return unless delete($w->{tixindicator}) eq $ent; my @info = $w->info('item',$Ev->x, $Ev->y); if(defined($info[1]) && $info[1] eq 'indicator') { $w->Callback(-indicatorcmd => $ent, ''); + } + else + { + $w->Callback(-indicatorcmd => $ent, ''); } return; } Index: Listbox/Listbox.pm --- Tk800.023/Listbox/Listbox.pm Sat Dec 30 16:12:37 2000 +++ Tk800.024/Listbox/Listbox.pm Sat Sep 29 18:48:16 2001 @@ -10,10 +10,33 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# Modifications from standard Listbox.pm +# -------------------------------------- +# 27-JAN-2001 Alasdair Allan +# Modified for local use by adding tied scalar and arrays +# Implemented TIESCALAR, TIEARRAY, FETCH, FETCHSIZE, STORE, CLEAR & EXTEND +# 31-JAN-2001 Alasdair Allan +# Made changes suggested by Tim Jenness +# 03-FEB-2001 Alasdair Allan +# Modified STORE for tied scalars to clear and select elements +# 06-FEB-2001 Alasdair Allan +# Added POD documentation for tied listbox +# 13-FEB-2001 Alasdair Allan +# Implemented EXISTS, DELETE, PUSH, POP, SHIFT & UNSHIFT for tied arrays +# 14-FEB-2001 Alasdair Allan +# Implemented SPLICE for tied arrays, all tied functionality in place +# 16-FEB-2001 Alasdair Allan +# Tweak to STORE interface for tied scalars +# 23-FEB-2001 Alasdair Allan +# Added flag to FETCH for tied scalars, modified to return hashes +# 24-FEB-2001 Alasdair Allan +# Updated Pod documentation +# + package Tk::Listbox; use vars qw($VERSION); -$VERSION = '3.031'; # $Id: //depot/Tk8/Listbox/Listbox.pm#31 $ +$VERSION = '3.033'; # $Id: //depot/Tk8/Listbox/Listbox.pm#33 $ use Tk qw(Ev $XS_VERSION); use Tk::Clipboard (); @@ -107,6 +130,300 @@ $mw->bind($class,'',['scan','dragto',Ev('x'),Ev('y')]); return $class; } + + + +sub TIEARRAY { + my ( $class, $obj, %options ) = @_; + return bless { + OBJECT => \$obj, + OPTION => \%options }, $class; +} + + + +sub TIESCALAR { + my ( $class, $obj, %options ) = @_; + return bless { + OBJECT => \$obj, + OPTION => \%options }, $class; +} + +# FETCH +# ----- +# Return either the full contents or only the selected items in the +# box depending on whether we tied it to an array or scalar respectively +sub FETCH { + my $class = shift; + + my $self = ${$class->{OBJECT}}; + my %options = %{$class->{OPTION}} if defined $class->{OPTION};; + + # Define the return variable + my $result; + + # Check whether we are have a tied array or scalar quantity + if ( @_ ) { + my $i = shift; + # The Tk:: Listbox has been tied to an array, we are returning + # an array list of the current items in the Listbox + $result = $self->get($i); + } else { + # The Tk::Listbox has been tied to a scalar, we are returning a + # reference to an array or hash containing the currently selected items + my ( @array, %hash ); + + if ( defined $options{ReturnType} ) { + + # THREE-WAY SWITCH + if ( $options{ReturnType} eq "index" ) { + $result = [$self->curselection]; + } elsif ( $options{ReturnType} eq "element" ) { + foreach my $selection ( $self->curselection ) { + push(@array,$self->get($selection)); } + $result = \@array; + } elsif ( $options{ReturnType} eq "both" ) { + foreach my $selection ( $self->curselection ) { + %hash = ( %hash, $selection => $self->get($selection)); } + $result = \%hash; + } + } else { + # return elements (default) + foreach my $selection ( $self->curselection ) { + push(@array,$self->get($selection)); } + $result = \@array; + } + } + return $result; +} + +# FETCHSIZE +# --------- +# Return the number of elements in the Listbox when tied to an array +sub FETCHSIZE { + my $class = shift; + return ${$class->{OBJECT}}->size(); +} + +# STORE +# ----- +# If tied to an array we will modify the Listbox contents, while if tied +# to a scalar we will select and clear elements. +sub STORE { + + if ( scalar(@_) == 2 ) { + # we have a tied scalar + my ( $class, $selected ) = @_; + my $self = ${$class->{OBJECT}}; + my %options = %{$class->{OPTION}} if defined $class->{OPTION};; + + # clear currently selected elements + $self->selectionClear(0,'end'); + + # set selected elements + if ( defined $options{ReturnType} ) { + + # THREE-WAY SWITCH + if ( $options{ReturnType} eq "index" ) { + for ( my $i=0; $i < scalar(@$selected) ; $i++ ) { + for ( my $j=0; $j < $self->size() ; $j++ ) { + if( $j == $$selected[$i] ) { + $self->selectionSet($j); last; } + } + } + } elsif ( $options{ReturnType} eq "element" ) { + for ( my $k=0; $k < scalar(@$selected) ; $k++ ) { + for ( my $l=0; $l < $self->size() ; $l++ ) { + if( $self->get($l) eq $$selected[$k] ) { + $self->selectionSet($l); last; } + } + } + } elsif ( $options{ReturnType} eq "both" ) { + foreach my $key ( keys %$selected ) { + $self->selectionSet($key) + if $$selected{$key} eq $self->get($key); + } + } + } else { + # return elements (default) + for ( my $k=0; $k < scalar(@$selected) ; $k++ ) { + for ( my $l=0; $l < $self->size() ; $l++ ) { + if( $self->get($l) eq $$selected[$k] ) { + $self->selectionSet($l); last; } + } + } + } + + } else { + # we have a tied array + my ( $class, $index, $value ) = @_; + my $self = ${$class->{OBJECT}}; + + # check size of current contents list + my $sizeof = $self->size(); + + if ( $index <= $sizeof ) { + # Change a current listbox entry + $self->delete($index); + $self->insert($index, $value); + } else { + # Add a new value + if ( defined $index ) { + $self->insert($index, $value); + } else { + $self->insert("end", $value); + } + } + } +} + +# CLEAR +# ----- +# Empty the Listbox of contents if tied to an array +sub CLEAR { + my $class = shift; + ${$class->{OBJECT}}->delete(0, 'end'); +} + +# EXTEND +# ------ +# Do nothing and be happy about it +sub EXTEND { } + +# PUSH +# ---- +# Append elements onto the Listbox contents +sub PUSH { + my ( $class, @list ) = @_; + ${$class->{OBJECT}}->insert('end', @list); +} + +# POP +# --- +# Remove last element of the array and return it +sub POP { + my $class = shift; + + my $value = ${$class->{OBJECT}}->get('end'); + ${$class->{OBJECT}}->delete('end'); + return $value; +} + +# SHIFT +# ----- +# Removes the first element and returns it +sub SHIFT { + my $class = shift; + + my $value = ${$class->{OBJECT}}->get(0); + ${$class->{OBJECT}}->delete(0); + return $value +} + +# UNSHIFT +# ------- +# Insert elements at the beginning of the Listbox +sub UNSHIFT { + my ( $class, @list ) = @_; + ${$class->{OBJECT}}->insert(0, @list); +} + +# DELETE +# ------ +# Delete element at specified index +sub DELETE { + my ( $class, @list ) = @_; + + my $value = ${$class->{OBJECT}}->get(@list); + ${$class->{OBJECT}}->delete(@list); + return $value; +} + +# EXISTS +# ------ +# Returns true if the index exist, and undef if not +sub EXISTS { + my ( $class, $index ) = @_; + return undef unless ${$class->{OBJECT}}->get($index); +} + +# SPLICE +# ------ +# Performs equivalent of splice on the listbox contents +sub SPLICE { + my $class = shift; + + my $self = ${$class->{OBJECT}}; + + # check for arguments + my @elements; + if ( scalar(@_) == 0 ) { + # none + @elements = $self->get(0,'end'); + $self->delete(0,'end'); + return wantarray ? @elements : $elements[scalar(@elements)-1];; + + } elsif ( scalar(@_) == 1 ) { + # $offset + my ( $offset ) = @_; + if ( $offset < 0 ) { + my $start = $self->size() + $offset; + if ( $start > 0 ) { + @elements = $self->get($start,'end'); + $self->delete($start,'end'); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } else { + return undef; + } + } else { + @elements = $self->get($offset,'end'); + $self->delete($offset,'end'); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } + + } elsif ( scalar(@_) == 2 ) { + # $offset and $length + my ( $offset, $length ) = @_; + if ( $offset < 0 ) { + my $start = $self->size() + $offset; + my $end = $self->size() + $offset + $length - 1; + if ( $start > 0 ) { + @elements = $self->get($start,$end); + $self->delete($start,$end); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } else { + return undef; + } + } else { + @elements = $self->get($offset,$offset+$length-1); + $self->delete($offset,$offset+$length-1); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } + + } else { + # $offset, $length and @list + my ( $offset, $length, @list ) = @_; + if ( $offset < 0 ) { + my $start = $self->size() + $offset; + my $end = $self->size() + $offset + $length - 1; + if ( $start > 0 ) { + @elements = $self->get($start,$end); + $self->delete($start,$end); + $self->insert($start,@list); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } else { + return undef; + } + } else { + @elements = $self->get($offset,$offset+$length-1); + $self->delete($offset,$offset+$length-1); + $self->insert($offset,@list); + return wantarray ? @elements : $elements[scalar(@elements)-1]; + } + } +} + +# ---- 1; __END__ Index: MANIFEST.SKIP --- Tk800.023/MANIFEST.SKIP Sat Dec 30 16:12:37 2000 +++ Tk800.024/MANIFEST.SKIP Mon Mar 13 12:36:37 2000 @@ -101,7 +101,6 @@ pTk/pkgd\.c$ pTk/pkge\.c$ pTk/pkgf\.c$ -pTk/port\.h$ pTk/regexp\.c$ pTk/samAppInit\.c$ pTk/stbDItem\.c$ Index: Makefile.PL --- Tk800.023/Makefile.PL Sat Dec 30 16:12:37 2000 +++ Tk800.024/Makefile.PL Tue Mar 5 14:00:43 2002 @@ -6,7 +6,7 @@ { $IsWin32 = ($^O eq 'MSWin32' || $Config{'ccflags'} =~ /-D_?WIN32_?/); - $VERSION = '800.023'; + $VERSION = '800.024'; $win_arch = shift @ARGV if @ARGV and $ARGV[0] =~ /^(open32|pm|x|MSWin32)$/; require('fix_4_os2.pl'), OS2_massage() if $^O eq 'os2'; @@ -31,7 +31,7 @@ else { my $plibs = $Config{'libs'}; - my $libs = "$xlib -lX11 -lpt"; + my $libs = "$xlib -lX11"; # Used to have -lpt in here as well. my @try = qw(-lsocket -lnsl -lm); push(@try,'-lc') if $^O =~ /svr4/i; my $lib; Index: README --- Tk800.023/README Sat Dec 30 16:12:37 2000 +++ Tk800.024/README Tue Mar 5 14:12:11 2002 @@ -1,20 +1,16 @@ Tk is a Graphical User Interface ToolKit. -Copyright (c) 1995-2000 Nick Ing-Simmons. All rights reserved. +Copyright (c) 1995-2002 Nick Ing-Simmons. All rights reserved. This package is free software; you can redistribute it and/or modify it under the same terms as Perl itself, with the exception of all the files in the pTk sub-directory which have separate terms derived from those of the orignal Tix4.1.0 or Tk8.0 sources. See doc/license.html for details of this license. -Tk800.023 is supposed to be production worthy. -It has minimal changes from Tk800.022 apart from bug fixes. -In particular a rather nasty memory leak that afflicted Canvas rather -badly has been fixed. - -(Consider Tk800.016..Tk800.021 its beta releases, previous stable -release being Tk800.015.) +Tk800.024 is mainly for compatibility with perl-5.7.3 and later +(various parts of perl's internals changed). +It has minimal changes from Tk800.023 apart from bug fixes. For questions on this package try news:comp.lang.perl.tk or e-mail to or @@ -23,45 +19,24 @@ It also includes all the C code parts of Ioi Kim Lam's Tix4.1.0.006 release. The perl code corresponding to Tix's Tcl code is not fully implemented. ->>> TK IS KNOWN NOT TO WORK WITH perl5.005_63 <<< -This Tk has special workrounds for perl-5.6.0 ->isa bug which are -only enabled for exactly that version. -Works with perl-5.7.0 and should work with most other "recent" perl releases. - -This version (Tk800.023) requires perl5.005 or later on Win32 +This version (Tk800.024) 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.2.3) by Jan Nijtmans: http://members1.chello.nl/~j.nijtmans/ Jan's "dash" patch is also merged. -Tk800.023 should build and run on Windows NT using Visual C++, Borland, -or with the Mingw32 port of GCC with perl5.005 or later. +Tk800.024 should build and run on Windows NT using Visual C++, Borland, +or with the MinGW-1.1 port of GCC with perl5.005 or later. Can be built using ActiveState's binary distribution (see README-ActiveState.txt). -The Mingw32 builds are stable now using up-to-date gcc-2.95.2 version -of Mingw32. There are perl build issues though you need -to change 'fpos_t' to 'long long' in Mingw32/2.95.2's . - I have not tried a Borland build recently. Author has built against: - Perl5.7.0 - Pentium Suse Linux-6.4 gcc-2.95.2 - NT4.0 SP4 Mingw32 (gcc-2.95.2) - - Perl5.00503 - SPARC Solaris2.6, gcc-2.8.1 - Pentium Suse Linux-6.1 egcs-1.1.2 - - Perl5.00502 - NT4.0 SP4 VC++6.0 (with ActivePerl build 518) - - Perl5.6.0 - NT4.0 SP4 VC++6.0 (with ActivePerl build 617) + Perl5.7.3 + Pentium Suse Linux-7.3 gcc-2.95.3 + Win2000, MinGW-1.1 (gcc-2.95.3) - Perl5.00404 - Pentium Suse Linux-6.1 egcs-1.1.2 Index: Tk.pm --- Tk800.023/Tk.pm Tue May 15 15:43:00 2001 +++ Tk800.024/Tk.pm Tue Mar 5 13:55:48 2002 @@ -53,7 +53,7 @@ # is created, $VERSION is checked by bootstrap $Tk::version = '8.0'; $Tk::patchLevel = '8.0'; -$Tk::VERSION = '800.023'; +$Tk::VERSION = '800.024'; $Tk::XS_VERSION = $Tk::VERSION; $Tk::strictMotif = 0; Index: Tk/Animation.pm --- Tk800.023/Tk/Animation.pm Sat Dec 30 16:12:37 2000 +++ Tk800.024/Tk/Animation.pm Sat Sep 29 18:48:16 2001 @@ -1,7 +1,7 @@ package Tk::Animation; use vars qw($VERSION); -$VERSION = '3.018'; # $Id: //depot/Tk8/Tk/Animation.pm#18 $ +$VERSION = '3.020'; # $Id: //depot/Tk8/Tk/Animation.pm#20 $ use Tk::Photo; use base qw(Tk::Photo); @@ -53,6 +53,7 @@ my $frames = $obj->{'_frames_'}; return unless $frames && @$frames; $index = 0 unless $index < @$frames; + $obj->blank if 0; # helps some make others worse $obj->copy($frames->[$index]); $obj->{'_frame_index_'} = $index; } Index: Tk/CmdLine.pm --- Tk800.023/Tk/CmdLine.pm Sat Dec 30 16:12:37 2000 +++ Tk800.024/Tk/CmdLine.pm Sat Sep 29 18:48:16 2001 @@ -13,11 +13,14 @@ #/----------------------------------------------------------------------------// use vars qw($VERSION); -$VERSION = '3.028'; # $Id: //depot/Tk8/Tk/CmdLine.pm#28 $ +$VERSION = '3.030'; # $Id: //depot/Tk8/Tk/CmdLine.pm#30 $ use 5.004; use strict; + +use Config; + my $OBJECT = undef; # define the current object #/----------------------------------------------------------------------------// @@ -41,7 +44,7 @@ command => [], synchronous => 0, iconic => 0, - motif => $Tk::strictMotif, + motif => ($Tk::strictMotif || 0), resources => {} }; return bless($self, $class); @@ -182,6 +185,25 @@ use vars qw(&process); *process = \&SetArguments; # alias to keep old code happy #/----------------------------------------------------------------------------// +#/ Get a list of the arguments that have been processed by SetArguments(). +#/ Returns an array. +#/----------------------------------------------------------------------------// + +sub GetArguments # Tk::CmdLine::GetArguments() +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + + $self->SetArguments() unless exists($self->{offset}); # set arguments if not yet done + + return @{$self->{command}}; +} + +#/----------------------------------------------------------------------------// #/ Get the value of a configuration option (default: -class). #/ Returns the option value. #/----------------------------------------------------------------------------// @@ -266,7 +288,7 @@ $self->{iconic} = 0; } - $Tk::strictMotif = $self->{motif}; + $Tk::strictMotif = ($self->{motif} || 0); # Both these are needed to reliably save state # but 'hostname' is tricky to do portably. @@ -348,6 +370,8 @@ @file = { %options }; } + my $delimiter = (($^O eq 'MSWin32') ? ';' : ':'); + foreach my $file (@file) { my $fileSpec = $file->{-spec} = undef; @@ -373,7 +397,10 @@ unless (exists($self->{translation})) { - $self->{translation} = { # %l %C %S currently ignored + $self->{translation} = { + '%l' => '', # ignored + '%C' => '', # ignored + '%S' => '', # ignored '%L' => ($ENV{LANG} || 'C'), # language '%T' => 'app-defaults', # type '%N' => $self->{config}->{-class} # filename @@ -383,7 +410,7 @@ my @postfix = map({ $_ . '/' . $self->{config}->{-class} } ('/' . $self->{translation}->{'%L'}), ''); - ITEM: foreach $fileSpec (split(':', $xpath)) + ITEM: foreach $fileSpec (split($Config{path_sep}, $xpath)) { if ($fileSpec =~ s/(%[A-Za-z])/$self->{translation}->{$1}/g) # File Pattern { @@ -470,3 +497,458 @@ __END__ =cut + +=head1 NAME + +Tk::CmdLine - Process standard X11 command line options and set initial resources + +=for pm Tk/CmdLine.pm + +=for category Creating and Configuring Widgets + +=head1 SYNOPSIS + + Tk::CmdLine::SetArguments([@argument]); + + my $value = Tk::CmdLine::cget([$option]); + + Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]); + + Tk::CmdLine::LoadResources( + [ -symbol => $symbol ] + [ -file => $fileSpec ] + [ -priority => $priority ] + [ -echo => $fileHandle ] ); + +=head1 DESCRIPTION + +Process standard X11 command line options and set initial resources. + +The X11R5 man page for X11 says: "Most X programs attempt to use the same names +for command line options and arguments. All applications written with the +X Toolkit Intrinsics automatically accept the following options: ...". +This module processes these command line options for perl/Tk applications +using the C() function. + +This module can optionally be used to load initial resources explicitly via +function C(), or from specified files (default: the standard X11 +application-specific resource files) via function C(). + +=head2 Command Line Options + +=over 4 + +=item B<-background> I | B<-bg> I + +Specifies the color to be used for the window background. + +=item B<-class> I + +Specifies the class under which resources for the application should be found. +This option is useful in shell aliases to distinguish between invocations +of an application, without resorting to creating links to alter the executable +file name. + +=item B<-display> I | B<-screen> I + +Specifies the name of the X server to be used. + +=item B<-font> I | B<-fn> I + +Specifies the font to be used for displaying text. + +=item B<-foreground> I | B<-fg> I + +Specifies the color to be used for text or graphics. + +=item B<-geometry> I + +Specifies the initial size and location of the I +L. + +=item B<-iconic> + +Indicates that the user would prefer that the application's windows initially +not be visible as if the windows had been immediately iconified by the user. +Window managers may choose not to honor the application's request. + +=item B<-motif> + +Specifies that the application should adhere as closely as possible to Motif +look-and-feel standards. For example, active elements such as buttons and +scrollbar sliders will not change color when the pointer passes over them. + +=item B<-name> I + +Specifies the name under which resources for the application should be found. +This option is useful in shell aliases to distinguish between invocations +of an application, without resorting to creating links to alter the executable +file name. + +=item B<-synchronous> + +Indicates that requests to the X server should be sent synchronously, instead of +asynchronously. Since Xlib normally buffers requests to the server, errors do +do not necessarily get reported immediately after they occur. This option turns +off the buffering so that the application can be debugged. It should never +be used with a working program. + +=item B<-title> I + +This option specifies the title to be used for this window. This information is +sometimes used by a window manager to provide some sort of header identifying +the window. + +=item B<-xrm> I + +Specifies a resource pattern and value to override any defaults. It is also +very useful for setting resources that do not have explicit command line +arguments. + +The I is of the form EIE:EIE, +that is (the first) ':' is used to determine which part is pattern and which +part is value. The (EIE, EIE) pair is entered +into the options database with B (for each +L configured), with I priority. + +=back + +=head2 Initial Resources + +There are several mechanism for initializing the resource database to be used +by an X11 application. Resources may be defined in a $C/.Xdefaults file, +a system application defaults file (e.g. +/usr/lib/X11/app-defaults/EBE), +or a user application defaults file (e.g. $C/EBE). +The Tk::CmdLine functionality for setting initial resources concerns itself +with the latter two. + +Resource files contain data lines of the form +EIE:EIE. +They may also contain blank lines and comment lines (denoted +by a ! character as the first non-blank character). Refer to L +for a description of EIE:EIE. + +=over 4 + +=item System Application Defaults Files + +System application defaults files may be specified via environment variable +$C which, if set, contains a list of file patterns +(joined using the OS-dependent path delimiter, e.g. colon on B). + +=item User Application Defaults Files + +User application defaults files may be specified via environment variables +$C, $C or $C. + +=back + +=head1 METHODS + +=over 4 + +=item B - Tk::CmdLine::SetArguments([@argument]) + +Extract the X11 options contained in a specified array (@ARGV by default). + + Tk::CmdLine::SetArguments([@argument]) + +The X11 options may be specified using a single dash I<-> as per the X11 +convention, or using two dashes I<--> as per the POSIX standard (e.g. +B<-geometry> I<100x100>, B<-geometry> I<100x100> or B<-geometry=>I<100x100>). +The options may be interspersed with other options or arguments. +A I<--> by itself terminates option processing. + +By default, command line options are extracted from @ARGV the first time +a MainWindow is created. The Tk::MainWindow constructor indirectly invokes +C() to do this. + +=item B - Tk::CmdLine::GetArguments() + +Get a list of the X11 options that have been processed by C(). +(C() first invokes C() if it has not already been invoked.) + +=item B - Tk::CmdLine::cget([$option]) + +Get the value of a configuration option specified via C(). +(C() first invokes C() if it has not already been invoked.) + + Tk::CmdLine::cget([$option]) + +The valid options are: B<-class>, B<-name>, B<-screen> and B<-title>. +If no option is specified, B<-class> is implied. + +A typical use of C() might be to obtain the application class in order +to define the name of a resource file to be loaded in via C(). + + my $class = Tk::CmdLine::cget(); # process command line and return class + +=item B - Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) + +Set the initial resources. + + Tk::CmdLine::SetResources((\@resource | $resource) [, $priority]) + +A single resource may be specified using a string of the form +'EIE:EIE'. Multiple resources may be specified +by passing an array reference whose elements are either strings of the above +form, and/or anonymous arrays of the form [ EIE, +EIE ]. The optional second argument specifies the priority, +as defined in L, to be associated with the resources +(default: I). + +Note that C() first invokes C() if it has not already +been invoked. + +=item B - Tk::CmdLine::LoadResources([%options]) + +Load initial resources from one or more files. + + Tk::CmdLine::LoadResources( + [ -symbol => $symbol ] + [ -file => $fileSpec ] + [ -priority => $priority ] + [ -echo => $fileHandle ] ); + +[ B<-symbol> =E $symbol ] specifies the name of an environment variable +that, if set, defines a list of one or more directories and/or file patterns +(joined using the OS-dependent path delimiter, e.g. colon on B). +$C is a special case. +If $C is not set, $C is checked instead. +If $C is not set, $C is checked instead. + +An item is identified as a file pattern if it contains one or more /%[A-Za-z]/ +patterns. Only patterns B<%L>, B<%T> and B<%N> are currently recognized. All +others are replaced with the null string. Pattern B<%L> is translated into +$C. Pattern B<%T> is translated into I. Pattern B<%N> is +translated into the application class name. + +Each file pattern, after substitutions are applied, is assumed to define a +FileSpec to be examined. + +When a directory is specified, FileSpecs +EBE/EBE/EBE +and EBE/EBE are defined, in that order. + +[ B<-file> =E $fileSpec ] specifies a resource file to be loaded in. +The file is silently skipped if if does not exist, or if it is not readable. + +[ B<-priority> =E $priority ] specifies the priority, as defined in +L, to be associated with the resources +(default: I). + +[ B<-echo> =E $fileHandle ] may be used to specify that a line should be +printed to the corresponding FileHandle (default: \*STDOUT) everytime a file +is examined / loaded. + +If no B<-symbol> or B<-file> options are specified, C() +processes symbol $C with priority I and +$C with priority I. +(Note that $C and $C are supposed to +contain only patterns. $C and $C are supposed to be a single +directory. C() does not check/care whether this is the case.) + +For each set of FileSpecs, C() examines each FileSpec to +determine if the file exists and is readable. The first file that meets this +criteria is read in and C() is invoked. + +Note that C() first invokes C() if it has not already +been invoked. + +=back + +=head1 NOTES + +This module is an object-oriented module whose methods can be invoked as object +methods, class methods or regular functions. This is accomplished via an +internally-maintained object reference which is created as necessary, and which +always points to the last object used. C(), C() and +C() return the object reference. + +=head1 EXAMPLES + +=over + +=item 1 + +@ARGV is processed by Tk::CmdLine at MainWindow creation. + + use Tk; + + # + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 2 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +An @ARGV of (--geometry=100x100 -opt1 a b c -bg red) +is equal to (-opt1 a b c) after C() is invoked. + + use Tk; + + Tk::CmdLine::SetArguments(); # Tk::CmdLine->SetArguments() works too + + # + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 3 + +Just like 2) except that default arguments are loaded first. + + use Tk; + + Tk::CmdLine::SetArguments(qw(-name test -iconic)); + Tk::CmdLine::SetArguments(); + + # + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 4 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +Standard resource files are loaded in before MainWindow creation. + + use Tk; + + Tk::CmdLine::SetArguments(); + + # + + Tk::CmdLine::LoadResources(); + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 5 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +Standard resource files are loaded in before MainWindow creation +using non-default priorities. + + use Tk; + + Tk::CmdLine::SetArguments(); + + # + + Tk::CmdLine::LoadResources(-echo => \*STDOUT, + -priority => 65, -symbol => 'XFILESEARCHPATH' ); + Tk::CmdLine::LoadResources(-echo => \*STDOUT, + -priority => 75, -symbol => 'XUSERFILESEARCHPATH' ); + + my $mw = MainWindow->new(); + + MainLoop(); + +=item 6 + +@ARGV is processed by Tk::CmdLine before MainWindow creation. +Standard resource files are loaded in before MainWindow creation. +Individual resources are also loaded in before MainWindow creation. + + use Tk; + + Tk::CmdLine::SetArguments(); + + # + + Tk::CmdLine::LoadResources(); + + Tk::CmdLine::SetResources( # set a single resource + '*Button*background: red', + 'widgetDefault' ); + + Tk::CmdLine::SetResources( # set multiple resources + [ '*Button*background: red', '*Button*foreground: blue' ], + 'widgetDefault' ); + + my $mw = MainWindow->new(); + + MainLoop(); + +=back + +=head1 ENVIRONMENT + +=over 4 + +=item B (optional) + +Home directory which may contain user application defaults files as +$C/$C/EBE or $C/EBE. + +=item B (optional) + +The current language (default: I). + +=item B (optional) + +List of FileSpec patterns +(joined using the OS-dependent path delimiter, e.g. colon on B) +used in defining system application defaults files. + +=item B (optional) + +List of FileSpec patterns +(joined using the OS-dependent path delimiter, e.g. colon on B) +used in defining user application defaults files. + +=item B (optional) + +Directory containing user application defaults files as +$C/$C/EBE or +$C/EBE. + +=back + +=head1 SEE ALSO + +L +L + +=head1 HISTORY + +=over 4 + +=item * + +1999.03.04 Ben Pavon Eben.pavon@hsc.hac.comE + +Rewritten as an object-oriented module. + +Allow one to process command line options in a specified array (@ARGV by default). +Eliminate restrictions on the format and location of the options within the array +(previously the X11 options could not be specified in POSIX format and had to be +at the beginning of the array). + +Added the C() and C() functions to allow the definition +of resources prior to MainWindow creation. + +=item * + +2000.08.31 Ben Pavon Eben.pavon@hsc.hac.comE + +Added the C() method which returns the list of arguments that +have been processed by C(). + +Modified C() to split the symbols using the OS-dependent +path delimiter defined in the B module. + +Modified C() to eliminate a warning message when processing +patterns B<%l>, B<%C>, B<%S>. + +=back + +=cut + Index: Tk/FBox.pm --- Tk800.023/Tk/FBox.pm Sat Dec 30 16:12:37 2000 +++ Tk800.024/Tk/FBox.pm Fri Feb 22 13:47:26 2002 @@ -39,7 +39,7 @@ use strict; use vars qw($VERSION $updirImage $folderImage $fileImage); -$VERSION = '3.019'; # $Id: //depot/Tk8/Tk/FBox.pm#19 $ +$VERSION = '3.020'; # $Id: //depot/Tk8/Tk/FBox.pm#20 $ use base qw(Tk::Toplevel); @@ -72,6 +72,7 @@ my $lab = $f1->Label(-text => 'Directory:', -underline => 0); $w->{'dirMenu'} = my $dirMenu = $f1->Optionmenu(-variable => \$w->{'selectPath'}, + -textvariable => \$w->{'selectPath'}, -command => ['SetPath', $w]); my $upBtn = $f1->Button; if (!defined $updirImage) { Index: Tk/MMutil.pm --- Tk800.023/Tk/MMutil.pm Sat Dec 30 16:12:37 2000 +++ Tk800.024/Tk/MMutil.pm Tue Mar 5 14:27:40 2002 @@ -9,7 +9,7 @@ use File::Basename; use vars qw($VERSION); -$VERSION = '3.050'; # $Id: //depot/Tk8/Tk/MMutil.pm#50 $ +$VERSION = '3.052'; # $Id: //depot/Tk8/Tk/MMutil.pm#52 $ use Tk::MakeDepend; @@ -20,7 +20,7 @@ $IsWin32 = ($^O eq 'MSWin32' || $Config{'ccflags'} =~ /-D_?WIN32_?/) unless defined $IsWin32; -@MYEXPORT = qw(perldepend cflags const_config constants installbin c_o xs_o makefile manifypods); +@MYEXPORT = qw(pasthru perldepend cflags const_config constants installbin c_o xs_o makefile manifypods); sub arch_prune { @@ -198,6 +198,17 @@ my $flags = ''; die 'upgrade_pic is obsolete'; return $flags; +} + +sub pasthru +{ + my $self = shift; + my $str = $self->MM::pasthru; + if ($str =~ s/^\s+INC=.*\n//m) + { + return "\n#Do NOT pasthru INC for Tk - it is computed by subdir\n".$str; + } + return $str; } sub perldepend Index: Tk/TextUndo.pm --- Tk800.023/Tk/TextUndo.pm Sat Dec 30 16:12:37 2000 +++ Tk800.024/Tk/TextUndo.pm Sat Sep 29 18:48:16 2001 @@ -6,7 +6,7 @@ package Tk::TextUndo; use vars qw($VERSION $DoDebug); -$VERSION = '3.048'; # $Id: //depot/Tk8/Tk/TextUndo.pm#48 $ +$VERSION = '3.050'; # $Id: //depot/Tk8/Tk/TextUndo.pm#50 $ $DoDebug = 0; use Tk qw (Ev); @@ -851,6 +851,12 @@ require File::Basename; my $sfx; ($name,$dir,$sfx) = File::Basename::fileparse($name,'\..*'); + # + # it should never happen where we have a file suffix and + # no file name... but fileparse() screws this up with dotfiles. + # + if (length($sfx) && !length($name)) { ($name, $sfx) = ($sfx, $name) } + if (defined($sfx) && length($sfx)) { unshift(@types,['Similar Files',[$sfx]]); Index: Tk/Widget.pm --- Tk800.023/Tk/Widget.pm Sat Dec 30 16:12:37 2000 +++ Tk800.024/Tk/Widget.pm Sat Sep 29 18:48:16 2001 @@ -3,7 +3,7 @@ # modify it under the same terms as Perl itself. package Tk::Widget; use vars qw($VERSION @DefaultMenuLabels); -$VERSION = '3.078'; # $Id: //depot/Tk8/Tk/Widget.pm#78 $ +$VERSION = '3.080'; # $Id: //depot/Tk8/Tk/Widget.pm#80 $ require Tk; use AutoLoader; @@ -798,12 +798,12 @@ my @tags = $w->bindtags; if ($top || defined($c)) { - push(@$restore, sub { $w->configure(-cursor => $c); $w->bindtags(\@tags) }); + push(@$restore, sub { return unless Tk::Exists($w); $w->configure(-cursor => $c); $w->bindtags(\@tags) }); $w->configure(-cursor => $cursor); } else { - push(@$restore, sub { $w->bindtags(\@tags) }); + push(@$restore, sub { return unless Tk::Exists($w); $w->bindtags(\@tags) }); } $w->bindtags(['Busy',@tags]); if ($recurse) Index: grepc --- Tk800.023/grepc Sat Dec 30 12:16:02 2000 +++ Tk800.024/grepc Sat Sep 29 18:48:16 2001 @@ -6,8 +6,10 @@ use File::Find; use Getopt::Std; + my %opt; -getopts("mlce:",\%opt); +getopts("Smlce:",\%opt); +$File::Find::dont_use_nlink = 1 if $opt{'S'}; my $expr = (defined $opt{'e'}) ? $opt{'e'} : shift; warn "Matching '$expr'\n"; @@ -35,7 +37,7 @@ sub wanted { $File::Find::prune = 0; - if (-T $_ && !/%$/ && /\.([chC]|cpp)$/) + if (-T $_ && !/%$/ && /\.([chC]|cpp|cxx|cc)$/) { local $file = ($_); local ($_); Index: pTk/Lang.h --- Tk800.023/pTk/Lang.h Sat Dec 30 16:12:37 2000 +++ Tk800.024/pTk/Lang.h Tue Mar 5 13:55:48 2002 @@ -190,14 +190,17 @@ # endif #endif #else /* __WIN32__ */ +#ifndef VOID +#include +#if 0 /* * The following code is copied from winnt.h */ -#ifndef VOID #define VOID void typedef char CHAR; typedef short SHORT; typedef long LONG; +#endif #endif #endif /* __WIN32__ */ Index: pTk/LangIO.h --- Tk800.023/pTk/LangIO.h Wed Mar 28 20:32:40 2001 +++ Tk800.024/pTk/LangIO.h Sun Sep 23 10:40:12 2001 @@ -8,6 +8,7 @@ !defined(_included_stdio) && \ !defined(_H_STDIO_) && \ !defined(_STDIO_H) && \ + !defined(_FILEDEFED) && \ !defined(_INCLUDED_STDIO) && \ !defined(_STDIO_H_) && \ !defined(__STDIO_H) && \ @@ -29,6 +30,7 @@ #define _included_stdio #define _H_STDIO_ #define _STDIO_H +#define _FILEDEFED #define _INCLUDED_STDIO #define _STDIO_H_ #define __STDIO_H Index: pTk/LangIO.h.PL --- Tk800.023/pTk/LangIO.h.PL Sun Feb 4 19:16:51 2001 +++ Tk800.024/pTk/LangIO.h.PL Fri Jul 13 11:39:41 2001 @@ -1,6 +1,7 @@ #!/usr/local/bin/perl -w use Config; my @gard = qw( +_FILEDEFED STDIO_H _H_STDIO _H_STDIO_ Index: pTk/Xlib.excwin --- Tk800.023/pTk/Xlib.excwin Sat Dec 30 16:12:37 2000 +++ Tk800.024/pTk/Xlib.excwin Fri Jul 13 11:39:41 2001 @@ -20,6 +20,7 @@ XCheckWindowEvent XConvertSelection XGetSelectionOwner +XRectInRegion XClipBox XPutImage XSetRegion Index: pTk/Xlib.m --- Tk800.023/pTk/Xlib.m Wed Apr 4 20:14:18 2001 +++ Tk800.024/pTk/Xlib.m Tue Mar 5 14:13:31 2002 @@ -443,9 +443,11 @@ #endif #endif /* !DO_X_EXCLUDE */ +#ifndef DO_X_EXCLUDE #ifndef XRectInRegion # define XRectInRegion (*XlibVptr->V_XRectInRegion) #endif +#endif /* !DO_X_EXCLUDE */ #ifndef XRefreshKeyboardMapping # define XRefreshKeyboardMapping (*XlibVptr->V_XRefreshKeyboardMapping) Index: pTk/Xlib.t --- Tk800.023/pTk/Xlib.t Wed Apr 4 20:14:18 2001 +++ Tk800.024/pTk/Xlib.t Tue Mar 5 14:13:30 2002 @@ -440,9 +440,11 @@ #endif #endif /* !DO_X_EXCLUDE */ +#ifndef DO_X_EXCLUDE #ifndef XRectInRegion VFUNC(int,XRectInRegion,V_XRectInRegion,_ANSI_ARGS_(( Region,int,int,unsigned,unsigned))) #endif +#endif /* !DO_X_EXCLUDE */ #ifndef XRefreshKeyboardMapping VFUNC(int,XRefreshKeyboardMapping,V_XRefreshKeyboardMapping,_ANSI_ARGS_((XMappingEvent *))) Index: pTk/mTk/generic/tkCanvBmap.c --- Tk800.023/pTk/mTk/generic/tkCanvBmap.c Sat Dec 30 16:12:37 2000 +++ Tk800.024/pTk/mTk/generic/tkCanvBmap.c Tue Mar 5 13:55:48 2002 @@ -106,7 +106,7 @@ static int ConfigureBitmap _ANSI_ARGS_((Tcl_Interp *interp, Tk_Canvas canvas, Tk_Item *itemPtr, int argc, char **argv, int flags)); -static int CreateBitmap _ANSI_ARGS_((Tcl_Interp *interp, +static int CreateTkBitmap _ANSI_ARGS_((Tcl_Interp *interp, Tk_Canvas canvas, struct Tk_Item *itemPtr, int argc, char **argv)); static void DeleteBitmap _ANSI_ARGS_((Tk_Canvas canvas, @@ -128,7 +128,7 @@ Tk_ItemType tkBitmapType = { "bitmap", /* name */ sizeof(BitmapItem), /* itemSize */ - CreateBitmap, /* createProc */ + CreateTkBitmap, /* createProc */ configSpecs, /* configSpecs */ ConfigureBitmap, /* configureProc */ BitmapCoords, /* coordProc */ @@ -173,7 +173,7 @@ */ static int -CreateBitmap(interp, canvas, itemPtr, argc, argv) +CreateTkBitmap(interp, canvas, itemPtr, argc, argv) Tcl_Interp *interp; /* Interpreter for error reporting. */ Tk_Canvas canvas; /* Canvas to hold new item. */ Tk_Item *itemPtr; /* Record to hold new item; header Index: pTk/mTk/generic/tkCanvPs.c --- Tk800.023/pTk/mTk/generic/tkCanvPs.c Sat Dec 30 16:12:37 2000 +++ Tk800.024/pTk/mTk/generic/tkCanvPs.c Fri Jul 13 11:39:42 2001 @@ -13,6 +13,7 @@ * * RCS: @(#) $Id: tkCanvPs.c,v 1.4 1998/09/22 18:57:16 stanton Exp $ */ +#include #include "tkInt.h" #include "tkCanvas.h" Index: pTk/mTk/generic/tkFocus.c --- Tk800.023/pTk/mTk/generic/tkFocus.c Sat Dec 30 16:12:37 2000 +++ Tk800.024/pTk/mTk/generic/tkFocus.c Tue Mar 5 13:55:48 2002 @@ -101,7 +101,7 @@ XEvent *eventPtr)); static void GenerateFocusEvents _ANSI_ARGS_((TkWindow *sourcePtr, TkWindow *destPtr)); -static void SetFocus _ANSI_ARGS_((TkWindow *winPtr, int force)); +static void TkSetFocus _ANSI_ARGS_((TkWindow *winPtr, int force)); /* *-------------------------------------------------------------- @@ -165,7 +165,7 @@ return TCL_ERROR; } if (!(newPtr->flags & TK_ALREADY_DEAD)) { - SetFocus(newPtr, 0); + TkSetFocus(newPtr, 0); } return TCL_OK; } @@ -201,7 +201,7 @@ if (newPtr == NULL) { return TCL_ERROR; } - SetFocus(newPtr, 1); + TkSetFocus(newPtr, 1); break; } case 2: { /* -lastfor */ @@ -303,7 +303,7 @@ if ((eventPtr->xfocus.mode == EMBEDDED_APP_WANTS_FOCUS) && (eventPtr->type == FocusIn)) { - SetFocus(winPtr, eventPtr->xfocus.detail); + TkSetFocus(winPtr, eventPtr->xfocus.detail); return 0; } @@ -524,7 +524,7 @@ /* *---------------------------------------------------------------------- * - * SetFocus -- + * TkSetFocus -- * * This procedure is invoked to change the focus window for a * given display in a given application. @@ -540,7 +540,7 @@ */ static void -SetFocus(winPtr, force) +TkSetFocus(winPtr, force) TkWindow *winPtr; /* Window that is to be the new focus for * its display and application. */ int force; /* If non-zero, set the X focus to this @@ -953,7 +953,7 @@ Tk_DeleteEventHandler((Tk_Window) winPtr, VisibilityChangeMask, FocusMapProc, clientData); displayFocusPtr->focusOnMapPtr = NULL; - SetFocus(winPtr, displayFocusPtr->forceFocus); + TkSetFocus(winPtr, displayFocusPtr->forceFocus); } } Index: pTk/mTk/generic/tkImgPhoto.c --- Tk800.023/pTk/mTk/generic/tkImgPhoto.c Sat Dec 30 16:12:37 2000 +++ Tk800.024/pTk/mTk/generic/tkImgPhoto.c Tue Mar 5 13:55:48 2002 @@ -116,7 +116,7 @@ * Bit definitions for the flags field of a ColorTable. * BLACK_AND_WHITE: 1 means only black and white colors are * available. - * COLOR_WINDOW: 1 means a full 3-D color cube has been + * TK_COLOR_WINDOW: 1 means a full 3-D color cube has been * allocated. * DISPOSE_PENDING: 1 means a call to DisposeColorTable has * been scheduled as an idle handler, but it @@ -126,7 +126,7 @@ */ #define BLACK_AND_WHITE 1 -#define COLOR_WINDOW 2 +#define TK_COLOR_WINDOW 2 #define DISPOSE_PENDING 4 #define MAP_COLORS 8 @@ -3029,7 +3029,7 @@ */ if (!mono) { - colorPtr->flags |= COLOR_WINDOW; + colorPtr->flags |= TK_COLOR_WINDOW; /* * The following is a hairy hack. We only want to index into @@ -4144,7 +4144,7 @@ errPtr = errLinePtr; destBytePtr = dstLinePtr; destLongPtr = (pixel *) dstLinePtr; - if (colorPtr->flags & COLOR_WINDOW) { + if (colorPtr->flags & TK_COLOR_WINDOW) { /* * Color window. We dither the three components * independently, using Floyd-Steinberg dithering, Index: pTk/mTk/tclUnix/tclUnixTime.c --- Tk800.023/pTk/mTk/tclUnix/tclUnixTime.c Sat Dec 30 16:12:37 2000 +++ Tk800.024/pTk/mTk/tclUnix/tclUnixTime.c Fri Jul 13 11:39:42 2001 @@ -14,7 +14,7 @@ #include "tkPort.h" #include "Lang.h" #ifdef TCL_EVENT_IMPLEMENT - +#include #ifdef __EMX__ # include Index: pTk/mTk/win/tkWinMenu.c --- Tk800.023/pTk/mTk/win/tkWinMenu.c Sat Dec 30 16:12:37 2000 +++ Tk800.024/pTk/mTk/win/tkWinMenu.c Tue Mar 5 13:55:48 2002 @@ -16,11 +16,6 @@ #include "tkMenu.h" #include "tkWinInt.h" -/* Mingw32 has not caught up yet with MT_* yet ... */ -#ifndef MT_RIGHTJUSTIFY -#define MF_RIGHTJUSTIFY MF_HELP -#endif - /* * The class of the window for popup menus. */ Index: pod/Animation.pod --- Tk800.023/pod/Animation.pod Sat Dec 30 16:12:37 2000 +++ Tk800.024/pod/Animation.pod Sat Sep 29 18:48:16 2001 @@ -12,25 +12,27 @@ use Tk::Animation my $img = $widget->Animation('-format' => 'gif', -file => 'somefile.gif'); + $img->add_frames(@images); + $img->start_animation($period); $img->stop_animation; - $img->add_frames(@images); =head1 DESCRIPTION In the simple case when C is passed a GIF89 style GIF with multiple 'frames', it will build an internal array of C images. +The C method adds images to the sequence. It is provided +to allow animations to be constructed from separate images. +All images must be Cs and should all be the same size. + C then initiates a C with specified I<$period> -to sequence through these images. +to sequence through these images. As for raw C I<$period> is in milli-seconds, +for a 50Hz monitor it should be at least 20mS. C cancels the C and resets the image to the first image in the sequence. - -The C method adds images to the sequence. It is provided -to allow animations to be constructed from separate images. -All images must be Cs and should all be the same size. =head1 BUGS Index: pod/Listbox.pod --- Tk800.023/pod/Listbox.pod Sat Dec 30 16:12:37 2000 +++ Tk800.024/pod/Listbox.pod Sat Sep 29 18:48:16 2001 @@ -567,9 +567,133 @@ =back +=head1 TIED INTERFACE + +The Tk::Listbox widget can also be tied to a scalar or array variable, with +different behaviour depending on the variable type, with the following +tie commands: + + use Tk; + + my ( @array, $scalar, $other ); + my %options = ( ReturnType => "index" ); + + my $MW = MainWindow->new(); + my $lbox = $MW->Listbox()->pack(); + + my @list = ( "a", "b", "c", "d", "e", "f" ); + $lbox->insert('end', @list ); + + tie @array, "Tk::Listbox", $lbox + tie $scalar, "Tk::Listbox", $lbox; + tie $other, "Tk::Listbox", $lbox, %options; + +currently only one modifier is implemented, a 3 way flag for tied scalars +"ReturnType" which can have values "element", "index" or "both". The default +is "element". + +=over 4 + +=item Tied Arrays + +If you tie an array to the Listbox you can manipulate the items currently +contained by the box in the same manner as a normal array, e.g. + + print @array; + push(@array, @list); + my $popped = pop(@array); + my $shifted = shift(@array); + unshift(@array, @list); + delete $array[$index]; + print $string if exists $array[$i]; + @array = (); + splice @array, $offset, $length, @list + +The delete function is implemented slightly differently from the standard +array implementation. Instead of setting the element at that index to undef +it instead physically removes it from the Listbox. This has the effect of +changing the array indices, so for instance if you had a list on non-continuous +indices you wish to remove from the Listbox you should reverse sort the list +and then apply the delete function, e.g. + + my @list = ( 1, 2, 4, 12, 20 ); + my @remove = reverse sort { $a <=> $b } @list; + delete @array[@remove]; + +would safely remove indices 20, 12, 4, 2 and 1 from the Listbox without +problems. It should also be noted that a similar warning applies to the +splice function (which would normally be used in this context to perform +the same job). + + +=item Tied Scalars + +Unlike tied arrays, if you tie a scalar to the Listbox you can retrieve the +currently selected elements in the box as an array referenced by the scalar, +for instance + + my @list = ( "a", "b", "c", "d", "e", "f" ); + $lbox->insert('end', sort @list ); + $lbox->selectionSet(1); + +inserts @list as elements in an already existing listbox and selects the +element at index 1, which is "b". If we then + + print @$selected; + +this will return the currently selected elements, in this case "b". + +However, if the "ReturnType" arguement is passed when tying the Listbox to the +scalar with value "index" then the indices of the selected elements will be +returned instead of the elements themselves, ie in this case "1". This can be +useful when manipulating both contents and selected elements in the Listbox at +the same time. + +Importantly, if a value "both" is given the scalar will not be tied to an +array, but instead to a hash, with keys being the indices and values being +the elements at those indices + +You can also manipulate the selected items using the scalar. Equating the +scalar to an array reference will select any elements that match elements +in the Listbox, non-matching array items are ignored, e.g. + + my @list = ( "a", "b", "c", "d", "e", "f" ); + $lbox->insert('end', sort @list ); + $lbox->selectionSet(1); + +would insert the array @list into an already existing Listbox and select +element at index 1, i.e. "b" + + @array = ( "a", "b", "f" ); + $selected = \@array; + +would select elements "a", "b" and "f" in the Listbox. + +Again, if the "index" we indicate we want to use indices in the options hash +then the indices are use instead of elements, e.g. + + @array = ( 0, 1, 5 ); + $selected = \@array; + +would have the same effect, selecting elements "a", "b" and "f" if the +$selected variable was tied with %options = ( ReturnType => "index" ). + +If we are returning "both", i.e. the tied scalar points to a hash, both key and +value must match, e.g. + + %hash = ( 0 => "a", 1 => "b", 5 => "f" ); + $selected = \%hash; + +would have the same effect as the previous examples. + +It should be noted that, despite being a reference to an array (or possibly a has), you still can not copy the tied variable without it being untied, instead +you must pass a reference to the tied scalar between subroutines. + +=cut + =head1 KEYWORDS -listbox, widget +listbox, widget, tied =cut Index: tkGlue.c --- Tk800.023/tkGlue.c Wed Apr 4 21:37:27 2001 +++ Tk800.024/tkGlue.c Tue Mar 5 13:55:48 2002 @@ -346,7 +346,7 @@ char *why; { SvREFCNT_inc((SV *) interp); - fprintf(stdout,"%s %p %ld\n",why,interp,SvREFCNT((SV *) interp)); + PerlIO_printf(PerlIO_stdout(),"%s %p %ld\n",why,interp,SvREFCNT((SV *) interp)); return interp; } @@ -356,7 +356,7 @@ char *why; { SvREFCNT_dec((SV *) interp); - fprintf(stdout,"%s %p %ld\n",why,interp,SvREFCNT((SV *) interp)); + PerlIO_printf(PerlIO_stdout(),"%s %p %ld\n",why,interp,SvREFCNT((SV *) interp)); return interp; } @@ -482,7 +482,10 @@ if (!SvROK(sv) || SvTYPE(SvRV(sv)) != type) { STRLEN na; - fprintf(stderr,__FUNCTION__ " "); sv_dump(sv); +#if 0 + PerlIO_printf(PerlIO_stderr(),__FUNCTION__ " "); + sv_dump(sv); +#endif Tcl_Panic("%s not a %u reference %s", key, type, SvPV(sv, na)); } else @@ -2586,7 +2589,7 @@ { if (info->Tk.clientData) { - fprintf(stderr,"cmd %p/%p using %p/%p\n", + PerlIO_printf(PerlIO_stderr(),"cmd %p/%p using %p/%p\n", info->Tk.clientData,info->interp, mw, winfo->interp); } @@ -4913,11 +4916,17 @@ char *string; char *start; { -#ifdef REXEC_COPY - return pregexec(re,string,string+strlen(string),start,0, - Nullsv,NULL,REXEC_COPY); + SV *tmp = sv_newmortal(); + sv_upgrade(tmp,SVt_PV); + SvCUR_set(tmp,strlen(string)); + SvPVX(tmp) = string; + SvLEN(tmp) = 0; +#ifdef REXEC_COPY_STR + return pregexec(re,SvPVX(tmp),SvEND(tmp),start,0, + tmp,REXEC_COPY_STR); #else - return pregexec(re,string,string+strlen(string),start,0,NULL,1); + return pregexec(re,string,string+strlen(string),start,0, + tmp,NULL,REXEC_COPY); #endif } @@ -5090,6 +5099,7 @@ PL_curcop->cop_warnings = old_warn; #endif + initialized = 0; InitVtabs(); #ifdef VERSION __END_OF_PATCH__