From a5ef1b8118d74c0365a700eca71a691819ea47c7 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Sun, 13 Jan 2008 18:38:54 +0000 Subject: update Perl5_lib-TL_inst from what Siep told us git-svn-id: svn://tug.org/texlive/trunk@6211 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/lib/Perl5_lib-TL_inst/Carp/Heavy.pm | 241 ++++++++ Master/tlpkg/lib/Perl5_lib-TL_inst/List/Util.pm | 277 ++++++++++ Master/tlpkg/lib/Perl5_lib-TL_inst/Scalar/Util.pm | 147 +++++ .../tlpkg/lib/Perl5_lib-TL_inst/Tk/Checkbutton.pm | 42 ++ Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm | 122 ++++ Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm | 70 +++ Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm | 135 +++++ Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm | 615 +++++++++++++++++++++ .../tlpkg/lib/Perl5_lib-TL_inst/Tk/Radiobutton.pm | 45 ++ Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/Env.pm | 169 ++++++ .../lib/Perl5_lib-TL_inst/auto/Tk/CancelRepeat.al | 15 + .../auto/Tk/Clipboard/autosplit.ix | 6 + .../auto/Tk/Clipboard/getSelected.al | 15 + .../lib/Perl5_lib-TL_inst/auto/Tk/Entry/Entry.bs | 0 .../lib/Perl5_lib-TL_inst/auto/Tk/Entry/Entry.dll | Bin 0 -> 41472 bytes .../tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Error.al | 20 + .../lib/Perl5_lib-TL_inst/auto/Tk/RepeatId.al | 16 + .../Perl5_lib-TL_inst/auto/Tk/Wm/AnchorAdjust.al | 17 + .../lib/Perl5_lib-TL_inst/auto/Tk/Wm/FullScreen.al | 29 + .../lib/Perl5_lib-TL_inst/auto/Tk/Wm/Popup.al | 50 ++ .../tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/Post.al | 20 + .../Perl5_lib-TL_inst/auto/Tk/Wm/iconposition.al | 24 + .../unicore/lib/gc_sc/Uppercas.pl | 490 ++++++++++++++++ 23 files changed, 2565 insertions(+) create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Carp/Heavy.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/List/Util.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Scalar/Util.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Checkbutton.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Radiobutton.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/Win32/Env.pm create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/CancelRepeat.al create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Clipboard/autosplit.ix create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Clipboard/getSelected.al create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Entry/Entry.bs create mode 100755 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Entry/Entry.dll create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Error.al create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/RepeatId.al create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/AnchorAdjust.al create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/FullScreen.al create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/Popup.al create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/Post.al create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/auto/Tk/Wm/iconposition.al create mode 100644 Master/tlpkg/lib/Perl5_lib-TL_inst/unicore/lib/gc_sc/Uppercas.pl (limited to 'Master/tlpkg/lib') diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp/Heavy.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp/Heavy.pm new file mode 100644 index 00000000000..55bca2b421a --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Carp/Heavy.pm @@ -0,0 +1,241 @@ +# Carp::Heavy uses some variables in common with Carp. +package Carp; + +=head1 NAME + +Carp::Heavy - heavy machinery, no user serviceable parts inside + +=cut + +# use strict; # not yet + +# On one line so MakeMaker will see it. +use Carp; our $VERSION = $Carp::VERSION; + +our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose); + +sub caller_info { + my $i = shift(@_) + 1; + package DB; + my %call_info; + @call_info{ + qw(pack file line sub has_args wantarray evaltext is_require) + } = caller($i); + + unless (defined $call_info{pack}) { + return (); + } + + my $sub_name = Carp::get_subname(\%call_info); + if ($call_info{has_args}) { + my @args = map {Carp::format_arg($_)} @DB::args; + if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? + $#args = $MaxArgNums; + push @args, '...'; + } + # Push the args onto the subroutine + $sub_name .= '(' . join (', ', @args) . ')'; + } + $call_info{sub_name} = $sub_name; + return wantarray() ? %call_info : \%call_info; +} + +# Transform an argument to a function into a string. +sub format_arg { + my $arg = shift; + if (ref($arg)) { + $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; + }elsif (not defined($arg)) { + $arg = 'undef'; + } + $arg =~ s/'/\\'/g; + $arg = str_len_trim($arg, $MaxArgLen); + + # Quote it? + $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; + + # The following handling of "control chars" is direct from + # the original code - it is broken on Unicode though. + # Suggestions? + utf8::is_utf8($arg) + or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; + return $arg; +} + +# Takes an inheritance cache and a package and returns +# an anon hash of known inheritances and anon array of +# inheritances which consequences have not been figured +# for. +sub get_status { + my $cache = shift; + my $pkg = shift; + $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; + return @{$cache->{$pkg}}; +} + +# Takes the info from caller() and figures out the name of +# the sub/require/eval +sub get_subname { + my $info = shift; + if (defined($info->{evaltext})) { + my $eval = $info->{evaltext}; + if ($info->{is_require}) { + return "require $eval"; + } + else { + $eval =~ s/([\\\'])/\\$1/g; + return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'"; + } + } + + return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; +} + +# Figures out what call (from the point of view of the caller) +# the long error backtrace should start at. +sub long_error_loc { + my $i; + my $lvl = $CarpLevel; + { + my $pkg = caller(++$i); + unless(defined($pkg)) { + # This *shouldn't* happen. + if (%Internal) { + local %Internal; + $i = long_error_loc(); + last; + } + else { + # OK, now I am irritated. + return 2; + } + } + redo if $CarpInternal{$pkg}; + redo unless 0 > --$lvl; + redo if $Internal{$pkg}; + } + return $i - 1; +} + + +sub longmess_heavy { + return @_ if ref($_[0]); # don't break references as exceptions + my $i = long_error_loc(); + return ret_backtrace($i, @_); +} + +# Returns a full stack backtrace starting from where it is +# told. +sub ret_backtrace { + my ($i, @error) = @_; + my $mess; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $tid_msg = " thread $tid" if $tid; + } + + my %i = caller_info($i); + $mess = "$err at $i{file} line $i{line}$tid_msg\n"; + + while (my %i = caller_info(++$i)) { + $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; + } + + return $mess; +} + +sub ret_summary { + my ($i, @error) = @_; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $tid_msg = " thread $tid" if $tid; + } + + my %i = caller_info($i); + return "$err at $i{file} line $i{line}$tid_msg\n"; +} + + +sub short_error_loc { + my $cache; + my $i = 1; + my $lvl = $CarpLevel; + { + my $called = caller($i++); + my $caller = caller($i); + return 0 unless defined($caller); # What happened? + redo if $Internal{$caller}; + redo if $CarpInternal{$called}; + redo if trusts($called, $caller, $cache); + redo if trusts($caller, $called, $cache); + redo unless 0 > --$lvl; + } + return $i - 1; +} + +sub shortmess_heavy { + return longmess_heavy(@_) if $Verbose; + return @_ if ref($_[0]); # don't break references as exceptions + my $i = short_error_loc(); + if ($i) { + ret_summary($i, @_); + } + else { + longmess_heavy(@_); + } +} + +# If a string is too long, trims it with ... +sub str_len_trim { + my $str = shift; + my $max = shift || 0; + if (2 < $max and $max < length($str)) { + substr($str, $max - 3) = '...'; + } + return $str; +} + +# Takes two packages and an optional cache. Says whether the +# first inherits from the second. +# +# Recursive versions of this have to work to avoid certain +# possible endless loops, and when following long chains of +# inheritance are less efficient. +sub trusts { + my $child = shift; + my $parent = shift; + my $cache = shift || {}; + my ($known, $partial) = get_status($cache, $child); + # Figure out consequences until we have an answer + while (@$partial and not exists $known->{$parent}) { + my $anc = shift @$partial; + next if exists $known->{$anc}; + $known->{$anc}++; + my ($anc_knows, $anc_partial) = get_status($cache, $anc); + my @found = keys %$anc_knows; + @$known{@found} = (); + push @$partial, @$anc_partial; + } + return exists $known->{$parent}; +} + +# Takes a package and gives a list of those trusted directly +sub trusts_directly { + my $class = shift; + no strict 'refs'; + no warnings 'once'; + return @{"$class\::CARP_NOT"} + ? @{"$class\::CARP_NOT"} + : @{"$class\::ISA"}; +} + +1; + diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/List/Util.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/List/Util.pm new file mode 100644 index 00000000000..cfe31f70123 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/List/Util.pm @@ -0,0 +1,277 @@ +# List::Util.pm +# +# Copyright (c) 1997-2005 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package List::Util; + +use strict; +use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY); +require Exporter; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); +$VERSION = "1.18"; +$XS_VERSION = $VERSION; +$VERSION = eval $VERSION; + +eval { + # PERL_DL_NONLAZY must be false, or any errors in loading will just + # cause the perl code to be tested + local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; + eval { + require XSLoader; + XSLoader::load('List::Util', $XS_VERSION); + 1; + } or do { + require DynaLoader; + local @ISA = qw(DynaLoader); + bootstrap List::Util $XS_VERSION; + }; +} unless $TESTING_PERL_ONLY; + + +# This code is only compiled if the XS did not load +# of for perl < 5.6.0 + +if (!defined &reduce) { +eval <<'ESQ' + +sub reduce (&@) { + my $code = shift; + no strict 'refs'; + + return shift unless @_ > 1; + + use vars qw($a $b); + + my $caller = caller; + local(*{$caller."::a"}) = \my $a; + local(*{$caller."::b"}) = \my $b; + + $a = shift; + foreach (@_) { + $b = $_; + $a = &{$code}(); + } + + $a; +} + +sub first (&@) { + my $code = shift; + + foreach (@_) { + return $_ if &{$code}(); + } + + undef; +} + +ESQ +} + +# This code is only compiled if the XS did not load +eval <<'ESQ' if !defined ∑ + +use vars qw($a $b); + +sub sum (@) { reduce { $a + $b } @_ } + +sub min (@) { reduce { $a < $b ? $a : $b } @_ } + +sub max (@) { reduce { $a > $b ? $a : $b } @_ } + +sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ } + +sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ } + +sub shuffle (@) { + my @a=\(@_); + my $n; + my $i=@_; + map { + $n = rand($i--); + (${$a[$n]}, $a[$n] = $a[$i])[0]; + } @_; +} + +ESQ + +1; + +__END__ + +=head1 NAME + +List::Util - A selection of general-utility list subroutines + +=head1 SYNOPSIS + + use List::Util qw(first max maxstr min minstr reduce shuffle sum); + +=head1 DESCRIPTION + +C contains a selection of subroutines that people have +expressed would be nice to have in the perl core, but the usage would +not really be high enough to warrant the use of a keyword, and the size +so small such that being individual extensions would be wasteful. + +By default C does not export any subroutines. The +subroutines defined are + +=over 4 + +=item first BLOCK LIST + +Similar to C in that it evaluates BLOCK setting C<$_> to each element +of LIST in turn. C returns the first element where the result from +BLOCK is a true value. If BLOCK never returns true or LIST was empty then +C is returned. + + $foo = first { defined($_) } @list # first defined value in @list + $foo = first { $_ > $value } @list # first value in @list which + # is greater than $value + +This function could be implemented using C like this + + $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list + +for example wanted() could be defined() which would return the first +defined value in @list + +=item max LIST + +Returns the entry in the list with the highest numerical value. If the +list is empty then C is returned. + + $foo = max 1..10 # 10 + $foo = max 3,9,12 # 12 + $foo = max @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a > $b ? $a : $b } 1..10 + +=item maxstr LIST + +Similar to C, but treats all the entries in the list as strings +and returns the highest string as defined by the C operator. +If the list is empty then C is returned. + + $foo = maxstr 'A'..'Z' # 'Z' + $foo = maxstr "hello","world" # "world" + $foo = maxstr @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z' + +=item min LIST + +Similar to C but returns the entry in the list with the lowest +numerical value. If the list is empty then C is returned. + + $foo = min 1..10 # 1 + $foo = min 3,9,12 # 3 + $foo = min @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a < $b ? $a : $b } 1..10 + +=item minstr LIST + +Similar to C, but treats all the entries in the list as strings +and returns the lowest string as defined by the C operator. +If the list is empty then C is returned. + + $foo = minstr 'A'..'Z' # 'A' + $foo = minstr "hello","world" # "hello" + $foo = minstr @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z' + +=item reduce BLOCK LIST + +Reduces LIST by calling BLOCK multiple times, setting C<$a> and C<$b> +each time. The first call will be with C<$a> and C<$b> set to the first +two elements of the list, subsequent calls will be done by +setting C<$a> to the result of the previous call and C<$b> to the next +element in the list. + +Returns the result of the last call to BLOCK. If LIST is empty then +C is returned. If LIST only contains one element then that +element is returned and BLOCK is not executed. + + $foo = reduce { $a < $b ? $a : $b } 1..10 # min + $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr + $foo = reduce { $a + $b } 1 .. 10 # sum + $foo = reduce { $a . $b } @bar # concat + +=item shuffle LIST + +Returns the elements of LIST in a random order + + @cards = shuffle 0..51 # 0..51 in a random order + +=item sum LIST + +Returns the sum of all the elements in LIST. If LIST is empty then +C is returned. + + $foo = sum 1..10 # 55 + $foo = sum 3,9,12 # 24 + $foo = sum @bar, @baz # whatever + +This function could be implemented using C like this + + $foo = reduce { $a + $b } 1..10 + +=back + +=head1 KNOWN BUGS + +With perl versions prior to 5.005 there are some cases where reduce +will return an incorrect result. This will show up as test 7 of +reduce.t failing. + +=head1 SUGGESTED ADDITIONS + +The following are additions that have been requested, but I have been reluctant +to add due to them being very simple to implement in perl + + # One argument is true + + sub any { $_ && return 1 for @_; 0 } + + # All arguments are true + + sub all { $_ || return 0 for @_; 1 } + + # All arguments are false + + sub none { $_ && return 0 for @_; 1 } + + # One argument is false + + sub notall { $_ || return 1 for @_; 0 } + + # How many elements are true + + sub true { scalar grep { $_ } @_ } + + # How many elements are false + + sub false { scalar grep { !$_ } @_ } + +=head1 COPYRIGHT + +Copyright (c) 1997-2005 Graham Barr . All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Scalar/Util.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Scalar/Util.pm new file mode 100644 index 00000000000..4ae525a17c0 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Scalar/Util.pm @@ -0,0 +1,147 @@ +# Scalar::Util.pm +# +# Copyright (c) 1997-2005 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Scalar::Util; + +use strict; +use vars qw(@ISA @EXPORT_OK $VERSION); +require Exporter; +require List::Util; # List::Util loads the XS + +@ISA = qw(Exporter); +@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); +$VERSION = "1.18"; +$VERSION = eval $VERSION; + +sub export_fail { + if (grep { /^(weaken|isweak)$/ } @_ ) { + require Carp; + Carp::croak("Weak references are not implemented in the version of perl"); + } + if (grep { /^(isvstring)$/ } @_ ) { + require Carp; + Carp::croak("Vstrings are not implemented in the version of perl"); + } + if (grep { /^(dualvar|set_prototype)$/ } @_ ) { + require Carp; + Carp::croak("$1 is only avaliable with the XS version"); + } + + @_; +} + +sub openhandle ($) { + my $fh = shift; + my $rt = reftype($fh) || ''; + + return defined(fileno($fh)) ? $fh : undef + if $rt eq 'IO'; + + if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) + $fh = \(my $tmp=$fh); + } + elsif ($rt ne 'GLOB') { + return undef; + } + + (tied(*$fh) or defined(fileno($fh))) + ? $fh : undef; +} + +eval <<'ESQ' unless defined &dualvar; + +use vars qw(@EXPORT_FAIL); +push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype); + +# The code beyond here is only used if the XS is not installed + +# Hope nobody defines a sub by this name +sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) } + +sub blessed ($) { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + length(ref($_[0])) + ? eval { $_[0]->a_sub_not_likely_to_be_here } + : undef +} + +sub refaddr($) { + my $pkg = ref($_[0]) or return undef; + if (blessed($_[0])) { + bless $_[0], 'Scalar::Util::Fake'; + } + else { + $pkg = undef; + } + "$_[0]" =~ /0x(\w+)/; + my $i = do { local $^W; hex $1 }; + bless $_[0], $pkg if defined $pkg; + $i; +} + +sub reftype ($) { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + my $r = shift; + my $t; + + length($t = ref($r)) or return undef; + + # This eval will fail if the reference is not blessed + eval { $r->a_sub_not_likely_to_be_here; 1 } + ? do { + $t = eval { + # we have a GLOB or an IO. Stringify a GLOB gives it's name + my $q = *$r; + $q =~ /^\*/ ? "GLOB" : "IO"; + } + or do { + # OK, if we don't have a GLOB what parts of + # a glob will it populate. + # NOTE: A glob always has a SCALAR + local *glob = $r; + defined *glob{ARRAY} && "ARRAY" + or defined *glob{HASH} && "HASH" + or defined *glob{CODE} && "CODE" + or length(ref(${$r})) ? "REF" : "SCALAR"; + } + } + : $t +} + +sub tainted { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + local $^W = 0; + eval { kill 0 * $_[0] }; + $@ =~ /^Insecure/; +} + +sub readonly { + return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR"); + + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + my $tmp = $_[0]; + + !eval { $_[0] = $tmp; 1 }; +} + +sub looks_like_number { + local $_ = shift; + + # checks from perlfaq4 + return 0 if !defined($_) or ref($_); + return 1 if (/^[+-]?\d+$/); # is a +/- integer + return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float + return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); + + 0; +} + +ESQ + +1; + +__END__ + diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Checkbutton.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Checkbutton.pm new file mode 100644 index 00000000000..491d8cd2444 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Checkbutton.pm @@ -0,0 +1,42 @@ +package Tk::Checkbutton; +# Conversion from Tk4.0 button.tcl competed. +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + + +use vars qw($VERSION); +$VERSION = '4.006'; # $Id: //depot/Tkutf8/Tk/Checkbutton.pm#6 $ + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +require Tk::Widget; +require Tk::Button; + +use base qw(Tk::Button); + +Construct Tk::Widget 'Checkbutton'; + +sub Tk_cmd { \&Tk::checkbutton } + + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'', 'Enter'); + $mw->bind($class,'', 'Leave'); + $mw->bind($class,'<1>', 'Invoke'); + $mw->bind($class,'', 'Invoke'); + return $class; +} + +sub Invoke +{ + my $w = shift; + $w->invoke() unless($w->cget('-state') eq 'disabled'); +} + +1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm new file mode 100644 index 00000000000..b0eb0ea2b07 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Clipboard.pm @@ -0,0 +1,122 @@ +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Clipboard; +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/; + +use AutoLoader qw(AUTOLOAD); +use Tk qw(catch); + +sub clipEvents +{ + return qw[Copy Cut Paste]; +} + +sub ClassInit +{ + my ($class,$mw) = @_; + foreach my $op ($class->clipEvents) + { + $mw->Tk::bind($class,"<<$op>>","clipboard$op"); + } + return $class; +} + +sub clipboardSet +{ + my $w = shift; + $w->clipboardClear; + $w->clipboardAppend(@_); +} + +sub clipboardCopy +{ + my $w = shift; + my $val = $w->getSelected; + if (defined $val) + { + $w->clipboardSet('--',$val); + } + return $val; +} + +sub clipboardCut +{ + my $w = shift; + my $val = $w->clipboardCopy; + if (defined $val) + { + $w->deleteSelected; + } + return $val; +} + +sub clipboardGet +{ + my $w = shift; + $w->SelectionGet('-selection','CLIPBOARD',@_); +} + +sub clipboardPaste +{ + my $w = shift; + local $@; + catch + { +## Different from Tcl/Tk version: +# if ($w->windowingsystem eq 'x11') +# { +# catch +# { +# $w->deleteSelected; +# }; +# } + $w->insert("insert", $w->clipboardGet); + $w->SeeInsert if $w->can('SeeInsert'); + }; +} + +sub clipboardOperations +{ + my @class = (); + my $mw = shift; + if (ref $mw) + { + $mw = $mw->DelegateFor('bind'); + } + else + { + push(@class,$mw); + $mw = shift; + } + while (@_) + { + my $op = shift; + $mw->Tk::bind(@class,"<<$op>>","clipboard$op"); + } +} + +# These methods work for Entry and Text +# and can be overridden where they don't work + +sub deleteSelected +{ + my $w = shift; + catch { $w->delete('sel.first','sel.last') }; +} + + +1; +__END__ + +sub getSelected +{ + my $w = shift; + my $val = Tk::catch { $w->get('sel.first','sel.last') }; + return $val; +} + + diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm new file mode 100644 index 00000000000..8173f4a5acc --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Dialog.pm @@ -0,0 +1,70 @@ +package Tk::Dialog; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Dialog.pm#4 $ + +# Dialog - a translation of `tk_dialog' from Tcl/Tk to TkPerl (based on +# John Stoffel's idea). +# +# Stephen O. Lidie, Lehigh University Computing Center. 94/12/27 +# lusol@Lehigh.EDU + +# Documentation after __END__ + +use Carp; +use strict; +use base qw(Tk::DialogBox); + +Construct Tk::Widget 'Dialog'; + +sub Populate +{ + + # Dialog object constructor. Uses `new' method from base class + # to create object container then creates the dialog toplevel. + + my($cw, $args) = @_; + + $cw->SUPER::Populate($args); + + my ($w_bitmap,$w_but,$pad1,$pad2); + + # Create the Toplevel window and divide it into top and bottom parts. + + my (@pl) = (-side => 'top', -fill => 'both'); + + ($pad1, $pad2) = + ([-padx => '3m', -pady => '3m'], [-padx => '3m', -pady => '2m']); + + + $cw->iconname('Dialog'); + + my $w_top = $cw->Subwidget('top'); + + # Fill the top part with the bitmap and message. + + @pl = (-side => 'left'); + + $w_bitmap = $w_top->Label(Name => 'bitmap'); + $w_bitmap->pack(@pl, @$pad1); + + my $w_msg = $w_top->Label( -wraplength => '3i', -justify => 'left' ); + + $w_msg->pack(-side => 'right', -expand => 1, -fill => 'both', @$pad1); + + $cw->Advertise(message => $w_msg); + $cw->Advertise(bitmap => $w_bitmap ); + + $cw->ConfigSpecs( -image => ['bitmap',undef,undef,undef], + -bitmap => ['bitmap',undef,undef,undef], + -font => ['message','font','Font', '-*-Times-Medium-R-Normal--*-180-*-*-*-*-*-*'], + DEFAULT => ['message',undef,undef,undef] + ); +} + +1; + +__END__ + +=cut + diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm new file mode 100644 index 00000000000..13335404e15 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/DialogBox.pm @@ -0,0 +1,135 @@ +# +# DialogBox is similar to Dialog except that it allows any widget +# in the top frame. Widgets can be added with the add method. Currently +# there exists no way of deleting a widget once it has been added. + +package Tk::DialogBox; + +use strict; +use Carp; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #13 $ =~ /\D(\d+)\s*$/; + +use base qw(Tk::Toplevel); + +Tk::Widget->Construct('DialogBox'); + +sub Populate { + my ($cw, $args) = @_; + + $cw->SUPER::Populate($args); + my $buttons = delete $args->{'-buttons'}; + $buttons = ['OK'] unless defined $buttons; + my $default_button = delete $args->{'-default_button'}; + $default_button = $buttons->[0] unless defined $default_button; + + $cw->{'selected_button'} = ''; + $cw->transient($cw->Parent->toplevel); + $cw->withdraw; + if (@$buttons == 1) { + $cw->protocol('WM_DELETE_WINDOW' => sub { $cw->{'default_button'}->invoke }); + } else { + $cw->protocol('WM_DELETE_WINDOW' => sub {}); + } + + # create the two frames + my $top = $cw->Component('Frame', 'top'); + $top->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; + my $bot = $cw->Component('Frame', 'bottom'); + $bot->configure(-relief => 'raised', -bd => 1) unless $Tk::platform eq 'MSWin32'; + $bot->pack(qw/-side bottom -fill both -ipady 3 -ipadx 3/); + $top->pack(qw/-side top -fill both -ipady 3 -ipadx 3 -expand 1/); + + # create a row of buttons in the bottom. + my $bl; # foreach my $var: perl > 5.003_08 + foreach $bl (@$buttons) + { + my $b = $bot->Button(-text => $bl, -command => sub { $cw->{'selected_button'} = "$bl" } ); + $b->bind('' => [ $b, 'Invoke']); + $cw->Advertise("B_$bl" => $b); + if ($Tk::platform eq 'MSWin32') + { + $b->configure(-width => 10, -pady => 0); + } + if ($bl eq $default_button) { + if ($Tk::platform eq 'MSWin32') { + $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); + } else { + my $db = $bot->Frame(-relief => 'sunken', -bd => 1); + $b->raise($db); + $b->pack(-in => $db, -padx => '2', -pady => '2'); + $db->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); + } + $cw->{'default_button'} = $b; + $cw->bind('' => [ $b, 'Invoke']); + } else { + $b->pack(-side => 'left', -expand => 1, -padx => 1, -pady => 1); + } + } + $cw->ConfigSpecs(-command => ['CALLBACK', undef, undef, undef ], + -foreground => ['DESCENDANTS', 'foreground','Foreground', 'black'], + -background => ['DESCENDANTS', 'background','Background', undef], + -focus => ['PASSIVE', undef, undef, undef], + -showcommand => ['CALLBACK', undef, undef, undef], + ); + $cw->Delegates('Construct',$top); +} + +sub add { + my ($cw, $wnam, @args) = @_; + my $w = $cw->Subwidget('top')->$wnam(@args); + $cw->Advertise("\L$wnam" => $w); + return $w; +} + +sub Wait +{ + my $cw = shift; + $cw->Callback(-showcommand => $cw); + $cw->waitVariable(\$cw->{'selected_button'}); + $cw->grabRelease; + $cw->withdraw; + $cw->Callback(-command => $cw->{'selected_button'}); +} + +sub Show { + + croak 'DialogBox: "Show" method requires at least 1 argument' + if scalar @_ < 1; + my $cw = shift; + my ($grab) = @_; + my $old_focus = $cw->focusSave; + my $old_grab = $cw->grabSave; + + shift if defined $grab && length $grab && ($grab =~ /global/); + $cw->Popup(@_); + + Tk::catch { + if (defined $grab && length $grab && ($grab =~ /global/)) { + $cw->grabGlobal; + } else { + $cw->grab; + } + }; + if (my $focusw = $cw->cget(-focus)) { + $focusw->focus; + } elsif (defined $cw->{'default_button'}) { + $cw->{'default_button'}->focus; + } else { + $cw->focus; + } + $cw->Wait; + &$old_focus; + &$old_grab; + return $cw->{'selected_button'}; +} + +sub Exit +{ + my $cw = shift; + #kill the dialogbox, by faking a 'DONE' + $cw->{'selected_button'} = $cw->{'default_button'}->cget(-text); +} + +1; diff --git a/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm new file mode 100644 index 00000000000..51b3f0c6767 --- /dev/null +++ b/Master/tlpkg/lib/Perl5_lib-TL_inst/Tk/Entry.pm @@ -0,0 +1,615 @@ +package Tk::Entry; + +# Converted from entry.tcl -- +# +# This file defines the default bindings for Tk entry widgets. +# +# @(#) entry.tcl 1.22 94/12/17 16:05:14 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + +use vars qw($VERSION); +use strict; +$VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/; + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +use Tk::Widget (); +use Tk::Clipboard (); +use base qw(Tk::Clipboard Tk::Widget); + +import Tk qw(Ev $XS_VERSION); + +Construct Tk::Widget 'Entry'; + +bootstrap Tk::Entry; + +sub Tk_cmd { \&Tk::entry } + +Tk::Methods('bbox','delete','get','icursor','index','insert','scan', + 'selection','validate','xview'); + +use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)], + 'xview' => [qw(moveto scroll)], + ); + +sub wordstart +{my ($w,$pos) = @_; + my $string = $w->get; + $pos = $w->index('insert')-1 unless(defined $pos); + $string = substr($string,0,$pos); + $string =~ s/\S*$//; + length $string; +} + +sub wordend +{my ($w,$pos) = @_; + my $string = $w->get; + my $anc = length $string; + $pos = $w->index('insert') unless(defined $pos); + $string = substr($string,$pos); + $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x; + $anc - length($string); +} + +sub deltainsert +{ + my ($w,$d) = @_; + return $w->index('insert')+$d; +} + +# +# Bind -- +# This procedure is invoked the first time the mouse enters an +# entry widget or an entry widget receives the input focus. It creates +# all of the class bindings for entries. +# +# Arguments: +# event - Indicates which event caused the procedure to be invoked +# (Enter or FocusIn). It is used so that we can carry out +# the functions of that event in addition to setting up +# bindings. +sub ClassInit +{ + my ($class,$mw) = @_; + + $class->SUPER::ClassInit($mw); + + # <>, <> and <> defined in Tk::Clipboard + $mw->bind($class,'<>' => sub { + my $w = shift; + $w->delete("sel.first", "sel.last"); + }); + $mw->bind($class,'<>' => [sub { + my($w, $x) = @_; + # XXX logic in Tcl/Tk version screwed up? + if (!$Tk::strictMotif && !$Tk::mouseMoved) { + $w->Paste($x); + } + }, Ev('x')]); + + # Standard Motif bindings: + # The binding is different from the Tcl/Tk version: + $mw->bind($class,'','selectionClear'); + + $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]); + $mw->bind($class,'',['Button1Release',Ev('x'),Ev('y')]); + $mw->bind($class,'',['Motion',Ev('x'),Ev('y')]); + + $mw->bind($class,'',['MouseSelect',Ev('x'),'word','sel.first']); + $mw->bind($class,'',['MouseSelect',Ev('x'),'word']); + $mw->bind($class,'',['MouseSelect',Ev('x'),'line',0]); + $mw->bind($class,'',['MouseSelect',Ev('x'),'line']); + + $mw->bind($class,'','Shift_1'); + + + $mw->bind($class,'',['AutoScan',Ev('x')]); + $mw->bind($class,'','CancelRepeat'); + $mw->bind($class,'','Control_1'); + $mw->bind($class,'', ['SetCursor',Ev('deltainsert',-1)]); + $mw->bind($class,'',['SetCursor',Ev('deltainsert',1)]); + $mw->bind($class,'',['KeySelect',Ev('deltainsert',-1)]); + $mw->bind($class,'',['KeySelect',Ev('deltainsert',1)]); + $mw->bind($class,'',['SetCursor',Ev(['wordstart'])]); + $mw->bind($class,'',['SetCursor',Ev(['wordend'])]); + $mw->bind($class,'',['KeySelect',Ev(['wordstart'])]); + $mw->bind($class,'',['KeySelect',Ev(['wordend'])]); + $mw->bind($class,'',['SetCursor',0]); + $mw->bind($class,'',['KeySelect',0]); + $mw->bind($class,'',['SetCursor','end']); + $mw->bind($class,'',['KeySelect','end']); + $mw->bind($class,'','Delete'); + + $mw->bind($class,'','Backspace'); + + $mw->bind($class,'',['selectionFrom','insert']); + $mw->bind($class,'