From 9d6afc59622c9ae2797be582216b34b80dd8b5f0 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Mon, 17 Nov 2008 08:27:32 +0000 Subject: adding stuff to installer perl to get progress bars working git-svn-id: svn://tug.org/texlive/trunk@11327 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/installer/perllib/Text/Tabs.pm | 121 ++ Master/tlpkg/installer/perllib/Tie/Watch.pm | 560 +++++++ Master/tlpkg/installer/perllib/Tk/Canvas.pm | 1436 +++++++++++++++++ Master/tlpkg/installer/perllib/Tk/Menu.pm | 1145 ++++++++++++++ Master/tlpkg/installer/perllib/Tk/Menu/Item.pm | 180 +++ Master/tlpkg/installer/perllib/Tk/ProgressBar.pm | 498 ++++++ Master/tlpkg/installer/perllib/Tk/ROText.pm | 43 + Master/tlpkg/installer/perllib/Tk/Scrollbar.pm | 429 +++++ Master/tlpkg/installer/perllib/Tk/Text.pm | 1653 ++++++++++++++++++++ Master/tlpkg/installer/perllib/Tk/Trace.pm | 405 +++++ Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.bs | 0 .../tlpkg/installer/perllib/auto/Fcntl/Fcntl.dll | Bin 0 -> 14848 bytes .../tlpkg/installer/perllib/auto/List/Util/Util.bs | 0 .../installer/perllib/auto/List/Util/Util.dll | Bin 0 -> 26624 bytes Master/tlpkg/installer/perllib/auto/POSIX/POSIX.bs | 0 .../tlpkg/installer/perllib/auto/POSIX/POSIX.dll | Bin 0 -> 97792 bytes Master/tlpkg/installer/perllib/auto/POSIX/abs.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/alarm.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/assert.al | 15 + Master/tlpkg/installer/perllib/auto/POSIX/atan2.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/atexit.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/atof.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/atoi.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/atol.al | 12 + .../installer/perllib/auto/POSIX/autosplit.ix | 159 ++ .../tlpkg/installer/perllib/auto/POSIX/bsearch.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/calloc.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/chdir.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/chmod.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/chown.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/clearerr.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/closedir.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/cos.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/creat.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/div.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/errno.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/execl.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/execle.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/execlp.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/execv.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/execve.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/execvp.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/exit.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/exp.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/fabs.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/fclose.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/fcntl.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/fdopen.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/feof.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/ferror.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/fflush.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/fgetc.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/fgetpos.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/fgets.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/fileno.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/fopen.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/fork.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/fprintf.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/fputc.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/fputs.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/fread.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/free.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/freopen.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/fscanf.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/fseek.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/fsetpos.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/fstat.al | 17 + Master/tlpkg/installer/perllib/auto/POSIX/fsync.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/ftell.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/fwrite.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/getc.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getchar.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getegid.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getenv.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/geteuid.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getgid.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getgrgid.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getgrnam.al | 13 + .../installer/perllib/auto/POSIX/getgroups.al | 14 + .../tlpkg/installer/perllib/auto/POSIX/getlogin.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getpgrp.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getpid.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getppid.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getpwnam.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getpwuid.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/gets.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/getuid.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/gmtime.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/isatty.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/kill.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/labs.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/ldiv.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/link.al | 13 + .../installer/perllib/auto/POSIX/load_imports.al | 225 +++ .../installer/perllib/auto/POSIX/localtime.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/log.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/longjmp.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/malloc.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/memchr.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/memcmp.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/memcpy.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/memmove.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/memset.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/mkdir.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/offsetof.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/opendir.al | 16 + .../tlpkg/installer/perllib/auto/POSIX/perror.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/pow.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/printf.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/putc.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/putchar.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/puts.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/qsort.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/raise.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/rand.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/readdir.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/realloc.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/redef.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/remove.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/rename.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/rewind.al | 13 + .../installer/perllib/auto/POSIX/rewinddir.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/rmdir.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/scanf.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/setbuf.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/setjmp.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/setvbuf.al | 12 + .../installer/perllib/auto/POSIX/siglongjmp.al | 12 + .../installer/perllib/auto/POSIX/sigsetjmp.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/sin.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/sleep.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/sprintf.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/sqrt.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/srand.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/sscanf.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/stat.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/strcat.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strchr.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strcmp.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strcpy.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strcspn.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strerror.al | 14 + .../tlpkg/installer/perllib/auto/POSIX/strlen.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strncat.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strncmp.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strncpy.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strpbrk.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strrchr.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strspn.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/strstr.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/strtok.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/system.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/time.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/tmpfile.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/tolower.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/toupper.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/umask.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/ungetc.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/unimpl.al | 14 + .../tlpkg/installer/perllib/auto/POSIX/unlink.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/usage.al | 13 + Master/tlpkg/installer/perllib/auto/POSIX/utime.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/vfprintf.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/vprintf.al | 12 + .../tlpkg/installer/perllib/auto/POSIX/vsprintf.al | 12 + Master/tlpkg/installer/perllib/auto/POSIX/wait.al | 13 + .../tlpkg/installer/perllib/auto/POSIX/waitpid.al | 13 + .../installer/perllib/auto/Tk/Canvas/Canvas.bs | 0 .../installer/perllib/auto/Tk/Canvas/Canvas.dll | Bin 0 -> 153600 bytes .../perllib/auto/Tk/Frame/AddScrollbars.al | 52 + .../installer/perllib/auto/Tk/Frame/FindMenu.al | 22 + .../perllib/auto/Tk/Frame/freeze_on_map.al | 18 + .../tlpkg/installer/perllib/auto/Tk/Frame/label.al | 24 + .../installer/perllib/auto/Tk/Frame/labelPack.al | 50 + .../perllib/auto/Tk/Frame/labelVariable.al | 27 + .../perllib/auto/Tk/Frame/packscrollbars.al | 86 + .../installer/perllib/auto/Tk/Frame/queuePack.al | 18 + .../tlpkg/installer/perllib/auto/Tk/Frame/sbset.al | 15 + .../installer/perllib/auto/Tk/Frame/scrollbars.al | 24 + .../perllib/auto/Tk/Scrollbar/ButtonDown.al | 55 + .../perllib/auto/Tk/Scrollbar/ButtonUp.al | 26 + .../installer/perllib/auto/Tk/Scrollbar/Drag.al | 43 + .../installer/perllib/auto/Tk/Scrollbar/EndDrag.al | 28 + .../installer/perllib/auto/Tk/Scrollbar/Enter.al | 21 + .../installer/perllib/auto/Tk/Scrollbar/Leave.al | 18 + .../installer/perllib/auto/Tk/Scrollbar/Motion.al | 15 + .../perllib/auto/Tk/Scrollbar/ScrlByPages.al | 38 + .../perllib/auto/Tk/Scrollbar/ScrlByUnits.al | 37 + .../perllib/auto/Tk/Scrollbar/ScrlToPos.al | 35 + .../perllib/auto/Tk/Scrollbar/ScrlTopBottom.al | 32 + .../perllib/auto/Tk/Scrollbar/Scrollbar.bs | 0 .../perllib/auto/Tk/Scrollbar/Scrollbar.dll | Bin 0 -> 21504 bytes .../installer/perllib/auto/Tk/Scrollbar/Select.al | 59 + .../perllib/auto/Tk/Scrollbar/StartDrag.al | 38 + .../perllib/auto/Tk/Scrollbar/autosplit.ix | 30 + .../tlpkg/installer/perllib/auto/Tk/Text/Text.bs | 0 .../tlpkg/installer/perllib/auto/Tk/Text/Text.dll | Bin 0 -> 114176 bytes .../installer/perllib/auto/Tk/Text/autosplit.ix | 3 + Master/tlpkg/installer/perllib/subs.pm | 40 + 199 files changed, 9579 insertions(+) create mode 100644 Master/tlpkg/installer/perllib/Text/Tabs.pm create mode 100644 Master/tlpkg/installer/perllib/Tie/Watch.pm create mode 100644 Master/tlpkg/installer/perllib/Tk/Canvas.pm create mode 100644 Master/tlpkg/installer/perllib/Tk/Menu.pm create mode 100644 Master/tlpkg/installer/perllib/Tk/Menu/Item.pm create mode 100644 Master/tlpkg/installer/perllib/Tk/ProgressBar.pm create mode 100644 Master/tlpkg/installer/perllib/Tk/ROText.pm create mode 100644 Master/tlpkg/installer/perllib/Tk/Scrollbar.pm create mode 100644 Master/tlpkg/installer/perllib/Tk/Text.pm create mode 100644 Master/tlpkg/installer/perllib/Tk/Trace.pm create mode 100644 Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.bs create mode 100755 Master/tlpkg/installer/perllib/auto/Fcntl/Fcntl.dll create mode 100644 Master/tlpkg/installer/perllib/auto/List/Util/Util.bs create mode 100755 Master/tlpkg/installer/perllib/auto/List/Util/Util.dll create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/POSIX.bs create mode 100755 Master/tlpkg/installer/perllib/auto/POSIX/POSIX.dll create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/abs.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/alarm.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/assert.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/atan2.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/atexit.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/atof.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/atoi.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/atol.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/autosplit.ix create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/bsearch.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/calloc.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/chdir.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/chmod.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/chown.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/clearerr.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/closedir.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/cos.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/creat.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/div.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/errno.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execl.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execle.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execlp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execv.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execve.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/execvp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/exit.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/exp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fabs.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fclose.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fcntl.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fdopen.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/feof.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/ferror.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fflush.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fgetc.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fgetpos.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fgets.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fileno.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fopen.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fork.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fprintf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fputc.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fputs.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fread.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/free.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/freopen.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fscanf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fseek.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fsetpos.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fstat.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fsync.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/ftell.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/fwrite.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getc.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getchar.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getegid.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getenv.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/geteuid.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getgid.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getgrgid.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getgrnam.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getgroups.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getlogin.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getpgrp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getpid.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getppid.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getpwnam.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getpwuid.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/gets.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/getuid.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/gmtime.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/isatty.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/kill.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/labs.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/ldiv.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/link.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/load_imports.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/localtime.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/log.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/longjmp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/malloc.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/memchr.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/memcmp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/memcpy.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/memmove.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/memset.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/mkdir.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/offsetof.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/opendir.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/perror.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/pow.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/printf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/putc.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/putchar.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/puts.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/qsort.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/raise.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/rand.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/readdir.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/realloc.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/redef.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/remove.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/rename.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/rewind.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/rewinddir.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/rmdir.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/scanf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/setbuf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/setjmp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/setvbuf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/siglongjmp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sigsetjmp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sin.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sleep.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sprintf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sqrt.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/srand.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/sscanf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/stat.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strcat.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strchr.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strcmp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strcpy.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strcspn.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strerror.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strlen.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strncat.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strncmp.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strncpy.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strpbrk.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strrchr.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strspn.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strstr.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/strtok.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/system.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/time.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/tmpfile.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/tolower.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/toupper.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/umask.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/ungetc.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/unimpl.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/unlink.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/usage.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/utime.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/vfprintf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/vprintf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/vsprintf.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/wait.al create mode 100644 Master/tlpkg/installer/perllib/auto/POSIX/waitpid.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.bs create mode 100755 Master/tlpkg/installer/perllib/auto/Tk/Canvas/Canvas.dll create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/AddScrollbars.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/FindMenu.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/freeze_on_map.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/label.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/labelPack.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/labelVariable.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/packscrollbars.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/queuePack.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/sbset.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Frame/scrollbars.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ButtonDown.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ButtonUp.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Drag.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/EndDrag.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Enter.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Leave.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Motion.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlByPages.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlByUnits.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlToPos.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/ScrlTopBottom.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.bs create mode 100755 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Scrollbar.dll create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/Select.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/StartDrag.al create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Scrollbar/autosplit.ix create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Text/Text.bs create mode 100755 Master/tlpkg/installer/perllib/auto/Tk/Text/Text.dll create mode 100644 Master/tlpkg/installer/perllib/auto/Tk/Text/autosplit.ix create mode 100644 Master/tlpkg/installer/perllib/subs.pm (limited to 'Master/tlpkg/installer/perllib') diff --git a/Master/tlpkg/installer/perllib/Text/Tabs.pm b/Master/tlpkg/installer/perllib/Text/Tabs.pm new file mode 100644 index 00000000000..36107fcfe3e --- /dev/null +++ b/Master/tlpkg/installer/perllib/Text/Tabs.pm @@ -0,0 +1,121 @@ + +package Text::Tabs; + +require Exporter; + +@ISA = (Exporter); +@EXPORT = qw(expand unexpand $tabstop); + +use vars qw($VERSION $tabstop $debug); +$VERSION = 2005.0824; + +use strict; + +BEGIN { + $tabstop = 8; + $debug = 0; +} + +sub expand { + my @l; + my $pad; + for ( @_ ) { + my $s = ''; + for (split(/^/m, $_, -1)) { + my $offs = 0; + s{\t}{ + $pad = $tabstop - (pos() + $offs) % $tabstop; + $offs += $pad - 1; + " " x $pad; + }eg; + $s .= $_; + } + push(@l, $s); + } + return @l if wantarray; + return $l[0]; +} + +sub unexpand +{ + my (@l) = @_; + my @e; + my $x; + my $line; + my @lines; + my $lastbit; + for $x (@l) { + @lines = split("\n", $x, -1); + for $line (@lines) { + $line = expand($line); + @e = split(/(.{$tabstop})/,$line,-1); + $lastbit = pop(@e); + $lastbit = '' unless defined $lastbit; + $lastbit = "\t" + if $lastbit eq " "x$tabstop; + for $_ (@e) { + if ($debug) { + my $x = $_; + $x =~ s/\t/^I\t/gs; + print "sub on '$x'\n"; + } + s/ +$/\t/; + } + $line = join('',@e, $lastbit); + } + $x = join("\n", @lines); + } + return @l if wantarray; + return $l[0]; +} + +1; +__END__ + +sub expand +{ + my (@l) = @_; + for $_ (@l) { + 1 while s/(^|\n)([^\t\n]*)(\t+)/ + $1. $2 . (" " x + ($tabstop * length($3) + - (length($2) % $tabstop))) + /sex; + } + return @l if wantarray; + return $l[0]; +} + + +=head1 NAME + +Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1) + +=head1 SYNOPSIS + + use Text::Tabs; + + $tabstop = 4; + @lines_without_tabs = expand(@lines_with_tabs); + @lines_with_tabs = unexpand(@lines_without_tabs); + +=head1 DESCRIPTION + +Text::Tabs does about what the unix utilities expand(1) and unexpand(1) +do. Given a line with tabs in it, expand will replace the tabs with +the appropriate number of spaces. Given a line with or without tabs in +it, unexpand will add tabs when it can save bytes by doing so. Invisible +compression with plain ascii! + +=head1 BUGS + +expand doesn't handle newlines very quickly -- do not feed it an +entire document in one string. Instead feed it an array of lines. + +=head1 LICENSE + +Copyright (C) 1996-2002,2005 David Muir Sharnoff. +Copyright (C) 2005 Aristotle Pagaltzis +This module may be modified, used, copied, and redistributed at your own risk. +Publicly redistributed modified versions must use a different name. + diff --git a/Master/tlpkg/installer/perllib/Tie/Watch.pm b/Master/tlpkg/installer/perllib/Tie/Watch.pm new file mode 100644 index 00000000000..48f46acd2b0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tie/Watch.pm @@ -0,0 +1,560 @@ +$Tie::Watch::VERSION = '1.2'; + +package Tie::Watch; + +=head1 NAME + + Tie::Watch - place watchpoints on Perl variables. + +=head1 SYNOPSIS + + use Tie::Watch; + + $watch = Tie::Watch->new( + -variable => \$frog, + -debug => 1, + -shadow => 0, + -fetch => [\&fetch, 'arg1', 'arg2', ..., 'argn'], + -store => \&store, + -destroy => sub {print "Final value=$frog.\n"}, + } + %vinfo = $watch->Info; + $args = $watch->Args(-fetch); + $val = $watch->Fetch; + print "val=", $watch->Say($val), ".\n"; + $watch->Store('Hello'); + $watch->Unwatch; + +=head1 DESCRIPTION + +This class module binds one or more subroutines of your devising to a +Perl variable. All variables can have B, B and +B callbacks. Additionally, arrays can define B, +B, B, B, B, B, B, +B, B, B and B callbacks, and hashes +can define B, B, B, B and B +callbacks. If these term are unfamiliar to you, I I suggest +you read L. + +With Tie::Watch you can: + + . alter a variable's value + . prevent a variable's value from being changed + . invoke a Perl/Tk callback when a variable changes + . trace references to a variable + +Callback format is patterned after the Perl/Tk scheme: supply either a +code reference, or, supply an array reference and pass the callback +code reference in the first element of the array, followed by callback +arguments. (See examples in the Synopsis, above.) + +Tie::Watch provides default callbacks for any that you fail to +specify. Other than negatively impacting performance, they perform +the standard action that you'd expect, so the variable behaves +"normally". Once you override a default callback, perhaps to insert +debug code like print statements, your callback normally finishes by +calling the underlying (overridden) method. But you don't have to! + +To map a tied method name to a default callback name simply lowercase +the tied method name and uppercase its first character. So FETCH +becomes Fetch, NEXTKEY becomes Nextkey, etcetera. + +Here are two callbacks for a scalar. The B (read) callback does +nothing other than illustrate the fact that it returns the value to +assign the variable. The B (write) callback uppercases the +variable and returns it. In all cases the callback I return the +correct read or write value - typically, it does this by invoking the +underlying method. + + my $fetch_scalar = sub { + my($self) = @_; + $self->Fetch; + }; + + my $store_scalar = sub { + my($self, $new_val) = @_; + $self->Store(uc $new_val); + }; + +Here are B and B callbacks for either an array or hash. +They do essentially the same thing as the scalar callbacks, but +provide a little more information. + + my $fetch = sub { + my($self, $key) = @_; + my $val = $self->Fetch($key); + print "In fetch callback, key=$key, val=", $self->Say($val); + my $args = $self->Args(-fetch); + print ", args=('", join("', '", @$args), "')" if $args; + print ".\n"; + $val; + }; + + my $store = sub { + my($self, $key, $new_val) = @_; + my $val = $self->Fetch($key); + $new_val = uc $new_val; + $self->Store($key, $new_val); + print "In store callback, key=$key, val=", $self->Say($val), + ", new_val=", $self->Say($new_val); + my $args = $self->Args(-store); + print ", args=('", join("', '", @$args), "')" if $args; + print ".\n"; + $new_val; + }; + +In all cases, the first parameter is a reference to the Watch object, +used to invoke the following class methods. + +=head1 METHODS + +=over 4 + +=item $watch = Tie::Watch->new(-options => values); + +The watchpoint constructor method that accepts option/value pairs to +create and configure the Watch object. The only required option is +B<-variable>. + +B<-variable> is a I to a scalar, array or hash variable. + +B<-debug> (default 0) is 1 to activate debug print statements internal +to Tie::Watch. + +B<-shadow> (default 1) is 0 to disable array and hash shadowing. To +prevent infinite recursion Tie::Watch maintains parallel variables for +arrays and hashes. When the watchpoint is created the parallel shadow +variable is initialized with the watched variable's contents, and when +the watchpoint is deleted the shadow variable is copied to the original +variable. Thus, changes made during the watch process are not lost. +Shadowing is on my default. If you disable shadowing any changes made +to an array or hash are lost when the watchpoint is deleted. + +Specify any of the following relevant callback parameters, in the +format described above: B<-fetch>, B<-store>, B<-destroy>. +Additionally for arrays: B<-clear>, B<-extend>, B<-fetchsize>, +B<-pop>, B<-push>, B<-shift>, B<-splice>, B<-storesize> and +B<-unshift>. Additionally for hashes: B<-clear>, B<-delete>, +B<-exists>, B<-firstkey> and B<-nextkey>. + +=item $args = $watch->Args(-fetch); + +Returns a reference to a list of arguments for the specified callback, +or undefined if none. + +=item $watch->Fetch(); $watch->Fetch($key); + +Returns a variable's current value. $key is required for an array or +hash. + +=item %vinfo = $watch->Info(); + +Returns a hash detailing the internals of the Watch object, with these +keys: + + %vinfo = { + -variable => SCALAR(0x200737f8) + -debug => '0' + -shadow => '1' + -value => 'HELLO SCALAR' + -destroy => ARRAY(0x200f86cc) + -fetch => ARRAY(0x200f8558) + -store => ARRAY(0x200f85a0) + -legible => above data formatted as a list of string, for printing + } + +For array and hash Watch objects, the B<-value> key is replaced with a +B<-ptr> key which is a reference to the parallel array or hash. +Additionally, for an array or hash, there are key/value pairs for +all the variable specific callbacks. + +=item $watch->Say($val); + +Used mainly for debugging, it returns $val in quotes if required, or +the string "undefined" for undefined values. + +=item $watch->Store($new_val); $watch->Store($key, $new_val); + +Store a variable's new value. $key is required for an array or hash. + +=item $watch->Unwatch(); + +Stop watching the variable. + +=back + +=head1 EFFICIENCY CONSIDERATIONS + +If you can live using the class methods provided, please do so. You +can meddle with the object hash directly and improved watch +performance, at the risk of your code breaking in the future. + +=head1 AUTHOR + +Stephen O. Lidie + +=head1 HISTORY + + lusol@Lehigh.EDU, LUCC, 96/05/30 + . Original version 0.92 release, based on the Trace module from Hans Mulder, + and ideas from Tim Bunce. + + lusol@Lehigh.EDU, LUCC, 96/12/25 + . Version 0.96, release two inner references detected by Perl 5.004. + + lusol@Lehigh.EDU, LUCC, 97/01/11 + . Version 0.97, fix Makefile.PL and MANIFEST (thanks Andreas Koenig). + Make sure test.pl doesn't fail if Tk isn't installed. + + Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 97/10/03 + . Version 0.98, implement -shadow option for arrays and hashes. + + Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 98/02/11 + . Version 0.99, finally, with Perl 5.004_57, we can completely watch arrays. + With tied array support this module is essentially complete, so its been + optimized for speed at the expense of clarity - sorry about that. The + Delete() method has been renamed Unwatch() because it conflicts with the + builtin delete(). + + Stephen.O.Lidie@Lehigh.EDU, Lehigh University Computing Center, 99/04/04 + . Version 1.0, for Perl 5.005_03, update Makefile.PL for ActiveState, and + add two examples (one for Perl/Tk). + + sol0@lehigh.edu, Lehigh University Computing Center, 2003/06/07 + . Version 1.1, for Perl 5.8, can trace a reference now, patch from Slaven + Rezic. + + sol0@lehigh.edu, Lehigh University Computing Center, 2005/05/17 + . Version 1.2, for Perl 5.8, per Rob Seegel's suggestion, support array + DELETE and EXISTS. + +=head1 COPYRIGHT + +Copyright (C) 1996 - 2005 Stephen O. Lidie. All rights reserved. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +use 5.004_57;; +use Carp; +use strict; +use subs qw/normalize_callbacks/; +use vars qw/@array_callbacks @hash_callbacks @scalar_callbacks/; + +@array_callbacks = qw/-clear -delete -destroy -exists -extend -fetch + -fetchsize -pop -push -shift -splice -store + -storesize -unshift/; +@hash_callbacks = qw/-clear -delete -destroy -exists -fetch -firstkey + -nextkey -store/; +@scalar_callbacks = qw/-destroy -fetch -store/; + +sub new { + + # Watch constructor. The *real* constructor is Tie::Watch->base_watch(), + # invoked by methods in other Watch packages, depending upon the variable's + # type. Here we supply defaulted parameter values and then verify them, + # normalize all callbacks and bind the variable to the appropriate package. + + my($class, %args) = @_; + my $version = $Tie::Watch::VERSION; + my (%arg_defaults) = (-debug => 0, -shadow => 1); + my $variable = $args{-variable}; + croak "Tie::Watch::new(): -variable is required." if not defined $variable; + + my($type, $watch_obj) = (ref $variable, undef); + if ($type =~ /(SCALAR|REF)/) { + @arg_defaults{@scalar_callbacks} = ( + [\&Tie::Watch::Scalar::Destroy], [\&Tie::Watch::Scalar::Fetch], + [\&Tie::Watch::Scalar::Store]); + } elsif ($type =~ /ARRAY/) { + @arg_defaults{@array_callbacks} = ( + [\&Tie::Watch::Array::Clear], [\&Tie::Watch::Array::Delete], + [\&Tie::Watch::Array::Destroy], [\&Tie::Watch::Array::Exists], + [\&Tie::Watch::Array::Extend], [\&Tie::Watch::Array::Fetch], + [\&Tie::Watch::Array::Fetchsize], [\&Tie::Watch::Array::Pop], + [\&Tie::Watch::Array::Push], [\&Tie::Watch::Array::Shift], + [\&Tie::Watch::Array::Splice], [\&Tie::Watch::Array::Store], + [\&Tie::Watch::Array::Storesize], [\&Tie::Watch::Array::Unshift]); + } elsif ($type =~ /HASH/) { + @arg_defaults{@hash_callbacks} = ( + [\&Tie::Watch::Hash::Clear], [\&Tie::Watch::Hash::Delete], + [\&Tie::Watch::Hash::Destroy], [\&Tie::Watch::Hash::Exists], + [\&Tie::Watch::Hash::Fetch], [\&Tie::Watch::Hash::Firstkey], + [\&Tie::Watch::Hash::Nextkey], [\&Tie::Watch::Hash::Store]); + } else { + croak "Tie::Watch::new() - not a variable reference."; + } + my(@margs, %ahsh, $args, @args); + @margs = grep ! defined $args{$_}, keys %arg_defaults; + %ahsh = %args; # argument hash + @ahsh{@margs} = @arg_defaults{@margs}; # fill in missing values + normalize_callbacks \%ahsh; + + if ($type =~ /(SCALAR|REF)/) { + $watch_obj = tie $$variable, 'Tie::Watch::Scalar', %ahsh; + } elsif ($type =~ /ARRAY/) { + $watch_obj = tie @$variable, 'Tie::Watch::Array', %ahsh; + } elsif ($type =~ /HASH/) { + $watch_obj = tie %$variable, 'Tie::Watch::Hash', %ahsh; + } + $watch_obj; + +} # end new, Watch constructor + +sub Args { + + # Return a reference to a list of callback arguments, or undef if none. + # + # $_[0] = self + # $_[1] = callback type + + defined $_[0]->{$_[1]}->[1] ? [@{$_[0]->{$_[1]}}[1 .. $#{$_[0]->{$_[1]}}]] + : undef; + +} # end Args + +sub Info { + + # Info() method subclassed by other Watch modules. + # + # $_[0] = self + # @_[1 .. $#_] = optional callback types + + my(%vinfo, @results); + my(@info) = (qw/-variable -debug -shadow/); + push @info, @_[1 .. $#_] if scalar @_ >= 2; + foreach my $type (@info) { + push @results, sprintf('%-10s: ', substr $type, 1) . + $_[0]->Say($_[0]->{$type}); + $vinfo{$type} = $_[0]->{$type}; + } + $vinfo{-legible} = [@results]; + %vinfo; + +} # end Info + +sub Say { + + # For debugging, mainly. + # + # $_[0] = self + # $_[1] = value + + defined $_[1] ? (ref($_[1]) ne '' ? $_[1] : "'$_[1]'") : "undefined"; + +} # end Say + +sub Unwatch { + + # Stop watching a variable by releasing the last reference and untieing it. + # Update the original variable with its shadow, if appropriate. + # + # $_[0] = self + + my $variable = $_[0]->{-variable}; + my $type = ref $variable; + my $copy = $_[0]->{-ptr} if $type !~ /(SCALAR|REF)/; + my $shadow = $_[0]->{-shadow}; + undef $_[0]; + if ($type =~ /(SCALAR|REF)/) { + untie $$variable; + } elsif ($type =~ /ARRAY/) { + untie @$variable; + @$variable = @$copy if $shadow; + } elsif ($type =~ /HASH/) { + untie %$variable; + %$variable = %$copy if $shadow; + } else { + croak "Tie::Watch::Delete() - not a variable reference."; + } + +} # end Unwatch + +# Watch private methods. + +sub base_watch { + + # Watch base class constructor invoked by other Watch modules. + + my($class, %args) = @_; + my $watch_obj = {%args}; + $watch_obj; + +} # end base_watch + +sub callback { + + # Execute a Watch callback, either the default or user specified. + # Note that the arguments are those supplied by the tied method, + # not those (if any) specified by the user when the watch object + # was instantiated. This is for performance reasons, and why the + # Args() method exists. + # + # $_[0] = self + # $_[1] = callback type + # $_[2] through $#_ = tied arguments + + &{$_[0]->{$_[1]}->[0]} ($_[0], @_[2 .. $#_]); + +} # end callback + +sub normalize_callbacks { + + # Ensure all callbacks are normalized in [\&code, @args] format. + + my($args_ref) = @_; + my($cb, $ref); + foreach my $arg (keys %$args_ref) { + next if $arg =~ /variable|debug|shadow/; + $cb = $args_ref->{$arg}; + $ref = ref $cb; + if ($ref =~ /CODE/) { + $args_ref->{$arg} = [$cb]; + } elsif ($ref !~ /ARRAY/) { + croak "Tie::Watch: malformed callback $arg=$cb."; + } + } + +} # end normalize_callbacks + +############################################################################### + +package Tie::Watch::Scalar; + +use Carp; +@Tie::Watch::Scalar::ISA = qw/Tie::Watch/; + +sub TIESCALAR { + + my($class, %args) = @_; + my $variable = $args{-variable}; + my $watch_obj = Tie::Watch->base_watch(%args); + $watch_obj->{-value} = $$variable; + print "WatchScalar new: $variable created, \@_=", join(',', @_), "!\n" + if $watch_obj->{-debug}; + bless $watch_obj, $class; + +} # end TIESCALAR + +sub Info {$_[0]->SUPER::Info('-value', @Tie::Watch::scalar_callbacks)} + +# Default scalar callbacks. + +sub Destroy {undef %{$_[0]}} +sub Fetch {$_[0]->{-value}} +sub Store {$_[0]->{-value} = $_[1]} + +# Scalar access methods. + +sub DESTROY {$_[0]->callback('-destroy')} +sub FETCH {$_[0]->callback('-fetch')} +sub STORE {$_[0]->callback('-store', $_[1])} + +############################################################################### + +package Tie::Watch::Array; + +use Carp; +@Tie::Watch::Array::ISA = qw/Tie::Watch/; + +sub TIEARRAY { + + my($class, %args) = @_; + my($variable, $shadow) = @args{-variable, -shadow}; + my @copy = @$variable if $shadow; # make a private copy of user's array + $args{-ptr} = $shadow ? \@copy : []; + my $watch_obj = Tie::Watch->base_watch(%args); + print "WatchArray new: $variable created, \@_=", join(',', @_), "!\n" + if $watch_obj->{-debug}; + bless $watch_obj, $class; + +} # end TIEARRAY + +sub Info {$_[0]->SUPER::Info('-ptr', @Tie::Watch::array_callbacks)} + +# Default array callbacks. + +sub Clear {$_[0]->{-ptr} = ()} +sub Delete {delete $_[0]->{-ptr}->[$_[1]]} +sub Destroy {undef %{$_[0]}} +sub Exists {exists $_[0]->{-ptr}->[$_[1]]} +sub Extend {} +sub Fetch {$_[0]->{-ptr}->[$_[1]]} +sub Fetchsize {scalar @{$_[0]->{-ptr}}} +sub Pop {pop @{$_[0]->{-ptr}}} +sub Push {push @{$_[0]->{-ptr}}, @_[1 .. $#_]} +sub Shift {shift @{$_[0]->{-ptr}}} +sub Splice { + my $n = scalar @_; # splice() is wierd! + return splice @{$_[0]->{-ptr}}, $_[1] if $n == 2; + return splice @{$_[0]->{-ptr}}, $_[1], $_[2] if $n == 3; + return splice @{$_[0]->{-ptr}}, $_[1], $_[2], @_[3 .. $#_] if $n >= 4; +} +sub Store {$_[0]->{-ptr}->[$_[1]] = $_[2]} +sub Storesize {$#{$_[0]->{-ptr}} = $_[1] - 1} +sub Unshift {unshift @{$_[0]->{-ptr}}, @_[1 .. $#_]} + +# Array access methods. + +sub CLEAR {$_[0]->callback('-clear')} +sub DELETE {$_[0]->callback('-delete', $_[1])} +sub DESTROY {$_[0]->callback('-destroy')} +sub EXISTS {$_[0]->callback('-exists', $_[1])} +sub EXTEND {$_[0]->callback('-extend', $_[1])} +sub FETCH {$_[0]->callback('-fetch', $_[1])} +sub FETCHSIZE {$_[0]->callback('-fetchsize')} +sub POP {$_[0]->callback('-pop')} +sub PUSH {$_[0]->callback('-push', @_[1 .. $#_])} +sub SHIFT {$_[0]->callback('-shift')} +sub SPLICE {$_[0]->callback('-splice', @_[1 .. $#_])} +sub STORE {$_[0]->callback('-store', $_[1], $_[2])} +sub STORESIZE {$_[0]->callback('-storesize', $_[1])} +sub UNSHIFT {$_[0]->callback('-unshift', @_[1 .. $#_])} + +############################################################################### + +package Tie::Watch::Hash; + +use Carp; +@Tie::Watch::Hash::ISA = qw/Tie::Watch/; + +sub TIEHASH { + + my($class, %args) = @_; + my($variable, $shadow) = @args{-variable, -shadow}; + my %copy = %$variable if $shadow; # make a private copy of user's hash + $args{-ptr} = $shadow ? \%copy : {}; + my $watch_obj = Tie::Watch->base_watch(%args); + print "WatchHash new: $variable created, \@_=", join(',', @_), "!\n" + if $watch_obj->{-debug}; + bless $watch_obj, $class; + +} # end TIEHASH + +sub Info {$_[0]->SUPER::Info('-ptr', @Tie::Watch::hash_callbacks)} + +# Default hash callbacks. + +sub Clear {$_[0]->{-ptr} = ()} +sub Delete {delete $_[0]->{-ptr}->{$_[1]}} +sub Destroy {undef %{$_[0]}} +sub Exists {exists $_[0]->{-ptr}->{$_[1]}} +sub Fetch {$_[0]->{-ptr}->{$_[1]}} +sub Firstkey {my $c = keys %{$_[0]->{-ptr}}; each %{$_[0]->{-ptr}}} +sub Nextkey {each %{$_[0]->{-ptr}}} +sub Store {$_[0]->{-ptr}->{$_[1]} = $_[2]} + +# Hash access methods. + +sub CLEAR {$_[0]->callback('-clear')} +sub DELETE {$_[0]->callback('-delete', $_[1])} +sub DESTROY {$_[0]->callback('-destroy')} +sub EXISTS {$_[0]->callback('-exists', $_[1])} +sub FETCH {$_[0]->callback('-fetch', $_[1])} +sub FIRSTKEY {$_[0]->callback('-firstkey')} +sub NEXTKEY {$_[0]->callback('-nextkey')} +sub STORE {$_[0]->callback('-store', $_[1], $_[2])} + +1; diff --git a/Master/tlpkg/installer/perllib/Tk/Canvas.pm b/Master/tlpkg/installer/perllib/Tk/Canvas.pm new file mode 100644 index 00000000000..210bc30bfc2 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Canvas.pm @@ -0,0 +1,1436 @@ +package Tk::Canvas; +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #12 $ =~ /\D(\d+)\s*$/; + +use Tk qw($XS_VERSION); + +use base qw(Tk::Widget); +Construct Tk::Widget 'Canvas'; + +bootstrap Tk::Canvas; + +sub Tk_cmd { \&Tk::canvas } + +Tk::Methods('addtag','bbox','bind','canvasx','canvasy','coords','create', + 'dchars','delete','dtag','find','focus','gettags','icursor', + 'index','insert','itemcget','itemconfigure','lower','move', + 'postscript','raise','scale','scan','select','type','xview','yview'); + +use Tk::Submethods ( 'create' => [qw(arc bitmap grid group image line oval + polygon rectangle text window)], + 'scan' => [qw(mark dragto)], + 'select' => [qw(from clear item to)], + 'xview' => [qw(moveto scroll)], + 'yview' => [qw(moveto scroll)], + ); + +*CanvasBind = \&Tk::bind; +*CanvasFocus = \&Tk::focus; + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->XYscrollBind($class); + return $class; +} + +sub BalloonInfo +{ + my ($canvas,$balloon,$X,$Y,@opt) = @_; + my @tags = ($canvas->find('withtag', 'current'),$canvas->gettags('current')); + foreach my $opt (@opt) + { + my $info = $balloon->GetOption($opt,$canvas); + if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'HASH')) + { + $balloon->Subclient($tags[0]); + foreach my $tag (@tags) + { + return $info->{$tag} if exists $info->{$tag}; + } + return ''; + } + return $info; + } +} + +sub get_corners +{ + my $c = shift; + my(@xview) = $c->xview; + my(@yview) = $c->yview; + my(@scrollregion) = @{$c->cget(-scrollregion)}; + return ( + $xview[0] * ($scrollregion[2]-$scrollregion[0]) + $scrollregion[0], + $yview[0] * ($scrollregion[3]-$scrollregion[1]) + $scrollregion[1], + $xview[1] * ($scrollregion[2]-$scrollregion[0]) + $scrollregion[0], + $yview[1] * ($scrollregion[3]-$scrollregion[1]) + $scrollregion[1], + ); +} + +# List of adobe glyph names. Converted from glyphlist.txt, downloaded +# from Adobe + +$Tk::psglyphs = {qw( + 0020 space + 0021 exclam + 0022 quotedbl + 0023 numbersign + 0024 dollar + 0025 percent + 0026 ampersand + 0027 quotesingle + 0028 parenleft + 0029 parenright + 002A asterisk + 002B plus + 002C comma + 002D hyphen + 002E period + 002F slash + 0030 zero + 0031 one + 0032 two + 0033 three + 0034 four + 0035 five + 0036 six + 0037 seven + 0038 eight + 0039 nine + 003A colon + 003B semicolon + 003C less + 003D equal + 003E greater + 003F question + 0040 at + 0041 A + 0042 B + 0043 C + 0044 D + 0045 E + 0046 F + 0047 G + 0048 H + 0049 I + 004A J + 004B K + 004C L + 004D M + 004E N + 004F O + 0050 P + 0051 Q + 0052 R + 0053 S + 0054 T + 0055 U + 0056 V + 0057 W + 0058 X + 0059 Y + 005A Z + 005B bracketleft + 005C backslash + 005D bracketright + 005E asciicircum + 005F underscore + 0060 grave + 0061 a + 0062 b + 0063 c + 0064 d + 0065 e + 0066 f + 0067 g + 0068 h + 0069 i + 006A j + 006B k + 006C l + 006D m + 006E n + 006F o + 0070 p + 0071 q + 0072 r + 0073 s + 0074 t + 0075 u + 0076 v + 0077 w + 0078 x + 0079 y + 007A z + 007B braceleft + 007C bar + 007D braceright + 007E asciitilde + 00A0 space + 00A1 exclamdown + 00A2 cent + 00A3 sterling + 00A4 currency + 00A5 yen + 00A6 brokenbar + 00A7 section + 00A8 dieresis + 00A9 copyright + 00AA ordfeminine + 00AB guillemotleft + 00AC logicalnot + 00AD hyphen + 00AE registered + 00AF macron + 00B0 degree + 00B1 plusminus + 00B2 twosuperior + 00B3 threesuperior + 00B4 acute + 00B5 mu + 00B6 paragraph + 00B7 periodcentered + 00B8 cedilla + 00B9 onesuperior + 00BA ordmasculine + 00BB guillemotright + 00BC onequarter + 00BD onehalf + 00BE threequarters + 00BF questiondown + 00C0 Agrave + 00C1 Aacute + 00C2 Acircumflex + 00C3 Atilde + 00C4 Adieresis + 00C5 Aring + 00C6 AE + 00C7 Ccedilla + 00C8 Egrave + 00C9 Eacute + 00CA Ecircumflex + 00CB Edieresis + 00CC Igrave + 00CD Iacute + 00CE Icircumflex + 00CF Idieresis + 00D0 Eth + 00D1 Ntilde + 00D2 Ograve + 00D3 Oacute + 00D4 Ocircumflex + 00D5 Otilde + 00D6 Odieresis + 00D7 multiply + 00D8 Oslash + 00D9 Ugrave + 00DA Uacute + 00DB Ucircumflex + 00DC Udieresis + 00DD Yacute + 00DE Thorn + 00DF germandbls + 00E0 agrave + 00E1 aacute + 00E2 acircumflex + 00E3 atilde + 00E4 adieresis + 00E5 aring + 00E6 ae + 00E7 ccedilla + 00E8 egrave + 00E9 eacute + 00EA ecircumflex + 00EB edieresis + 00EC igrave + 00ED iacute + 00EE icircumflex + 00EF idieresis + 00F0 eth + 00F1 ntilde + 00F2 ograve + 00F3 oacute + 00F4 ocircumflex + 00F5 otilde + 00F6 odieresis + 00F7 divide + 00F8 oslash + 00F9 ugrave + 00FA uacute + 00FB ucircumflex + 00FC udieresis + 00FD yacute + 00FE thorn + 00FF ydieresis + 0100 Amacron + 0101 amacron + 0102 Abreve + 0103 abreve + 0104 Aogonek + 0105 aogonek + 0106 Cacute + 0107 cacute + 0108 Ccircumflex + 0109 ccircumflex + 010A Cdotaccent + 010B cdotaccent + 010C Ccaron + 010D ccaron + 010E Dcaron + 010F dcaron + 0110 Dcroat + 0111 dcroat + 0112 Emacron + 0113 emacron + 0114 Ebreve + 0115 ebreve + 0116 Edotaccent + 0117 edotaccent + 0118 Eogonek + 0119 eogonek + 011A Ecaron + 011B ecaron + 011C Gcircumflex + 011D gcircumflex + 011E Gbreve + 011F gbreve + 0120 Gdotaccent + 0121 gdotaccent + 0122 Gcommaaccent + 0123 gcommaaccent + 0124 Hcircumflex + 0125 hcircumflex + 0126 Hbar + 0127 hbar + 0128 Itilde + 0129 itilde + 012A Imacron + 012B imacron + 012C Ibreve + 012D ibreve + 012E Iogonek + 012F iogonek + 0130 Idotaccent + 0131 dotlessi + 0132 IJ + 0133 ij + 0134 Jcircumflex + 0135 jcircumflex + 0136 Kcommaaccent + 0137 kcommaaccent + 0138 kgreenlandic + 0139 Lacute + 013A lacute + 013B Lcommaaccent + 013C lcommaaccent + 013D Lcaron + 013E lcaron + 013F Ldot + 0140 ldot + 0141 Lslash + 0142 lslash + 0143 Nacute + 0144 nacute + 0145 Ncommaaccent + 0146 ncommaaccent + 0147 Ncaron + 0148 ncaron + 0149 napostrophe + 014A Eng + 014B eng + 014C Omacron + 014D omacron + 014E Obreve + 014F obreve + 0150 Ohungarumlaut + 0151 ohungarumlaut + 0152 OE + 0153 oe + 0154 Racute + 0155 racute + 0156 Rcommaaccent + 0157 rcommaaccent + 0158 Rcaron + 0159 rcaron + 015A Sacute + 015B sacute + 015C Scircumflex + 015D scircumflex + 015E Scedilla + 015F scedilla + 0160 Scaron + 0161 scaron + 0162 Tcommaaccent + 0163 tcommaaccent + 0164 Tcaron + 0165 tcaron + 0166 Tbar + 0167 tbar + 0168 Utilde + 0169 utilde + 016A Umacron + 016B umacron + 016C Ubreve + 016D ubreve + 016E Uring + 016F uring + 0170 Uhungarumlaut + 0171 uhungarumlaut + 0172 Uogonek + 0173 uogonek + 0174 Wcircumflex + 0175 wcircumflex + 0176 Ycircumflex + 0177 ycircumflex + 0178 Ydieresis + 0179 Zacute + 017A zacute + 017B Zdotaccent + 017C zdotaccent + 017D Zcaron + 017E zcaron + 017F longs + 0192 florin + 01A0 Ohorn + 01A1 ohorn + 01AF Uhorn + 01B0 uhorn + 01E6 Gcaron + 01E7 gcaron + 01FA Aringacute + 01FB aringacute + 01FC AEacute + 01FD aeacute + 01FE Oslashacute + 01FF oslashacute + 0218 Scommaaccent + 0219 scommaaccent + 021A Tcommaaccent + 021B tcommaaccent + 02BC afii57929 + 02BD afii64937 + 02C6 circumflex + 02C7 caron + 02C9 macron + 02D8 breve + 02D9 dotaccent + 02DA ring + 02DB ogonek + 02DC tilde + 02DD hungarumlaut + 0300 gravecomb + 0301 acutecomb + 0303 tildecomb + 0309 hookabovecomb + 0323 dotbelowcomb + 0384 tonos + 0385 dieresistonos + 0386 Alphatonos + 0387 anoteleia + 0388 Epsilontonos + 0389 Etatonos + 038A Iotatonos + 038C Omicrontonos + 038E Upsilontonos + 038F Omegatonos + 0390 iotadieresistonos + 0391 Alpha + 0392 Beta + 0393 Gamma + 0394 Delta + 0395 Epsilon + 0396 Zeta + 0397 Eta + 0398 Theta + 0399 Iota + 039A Kappa + 039B Lambda + 039C Mu + 039D Nu + 039E Xi + 039F Omicron + 03A0 Pi + 03A1 Rho + 03A3 Sigma + 03A4 Tau + 03A5 Upsilon + 03A6 Phi + 03A7 Chi + 03A8 Psi + 03A9 Omega + 03AA Iotadieresis + 03AB Upsilondieresis + 03AC alphatonos + 03AD epsilontonos + 03AE etatonos + 03AF iotatonos + 03B0 upsilondieresistonos + 03B1 alpha + 03B2 beta + 03B3 gamma + 03B4 delta + 03B5 epsilon + 03B6 zeta + 03B7 eta + 03B8 theta + 03B9 iota + 03BA kappa + 03BB lambda + 03BC mu + 03BD nu + 03BE xi + 03BF omicron + 03C0 pi + 03C1 rho + 03C2 sigma1 + 03C3 sigma + 03C4 tau + 03C5 upsilon + 03C6 phi + 03C7 chi + 03C8 psi + 03C9 omega + 03CA iotadieresis + 03CB upsilondieresis + 03CC omicrontonos + 03CD upsilontonos + 03CE omegatonos + 03D1 theta1 + 03D2 Upsilon1 + 03D5 phi1 + 03D6 omega1 + 0401 afii10023 + 0402 afii10051 + 0403 afii10052 + 0404 afii10053 + 0405 afii10054 + 0406 afii10055 + 0407 afii10056 + 0408 afii10057 + 0409 afii10058 + 040A afii10059 + 040B afii10060 + 040C afii10061 + 040E afii10062 + 040F afii10145 + 0410 afii10017 + 0411 afii10018 + 0412 afii10019 + 0413 afii10020 + 0414 afii10021 + 0415 afii10022 + 0416 afii10024 + 0417 afii10025 + 0418 afii10026 + 0419 afii10027 + 041A afii10028 + 041B afii10029 + 041C afii10030 + 041D afii10031 + 041E afii10032 + 041F afii10033 + 0420 afii10034 + 0421 afii10035 + 0422 afii10036 + 0423 afii10037 + 0424 afii10038 + 0425 afii10039 + 0426 afii10040 + 0427 afii10041 + 0428 afii10042 + 0429 afii10043 + 042A afii10044 + 042B afii10045 + 042C afii10046 + 042D afii10047 + 042E afii10048 + 042F afii10049 + 0430 afii10065 + 0431 afii10066 + 0432 afii10067 + 0433 afii10068 + 0434 afii10069 + 0435 afii10070 + 0436 afii10072 + 0437 afii10073 + 0438 afii10074 + 0439 afii10075 + 043A afii10076 + 043B afii10077 + 043C afii10078 + 043D afii10079 + 043E afii10080 + 043F afii10081 + 0440 afii10082 + 0441 afii10083 + 0442 afii10084 + 0443 afii10085 + 0444 afii10086 + 0445 afii10087 + 0446 afii10088 + 0447 afii10089 + 0448 afii10090 + 0449 afii10091 + 044A afii10092 + 044B afii10093 + 044C afii10094 + 044D afii10095 + 044E afii10096 + 044F afii10097 + 0451 afii10071 + 0452 afii10099 + 0453 afii10100 + 0454 afii10101 + 0455 afii10102 + 0456 afii10103 + 0457 afii10104 + 0458 afii10105 + 0459 afii10106 + 045A afii10107 + 045B afii10108 + 045C afii10109 + 045E afii10110 + 045F afii10193 + 0462 afii10146 + 0463 afii10194 + 0472 afii10147 + 0473 afii10195 + 0474 afii10148 + 0475 afii10196 + 0490 afii10050 + 0491 afii10098 + 04D9 afii10846 + 05B0 afii57799 + 05B1 afii57801 + 05B2 afii57800 + 05B3 afii57802 + 05B4 afii57793 + 05B5 afii57794 + 05B6 afii57795 + 05B7 afii57798 + 05B8 afii57797 + 05B9 afii57806 + 05BB afii57796 + 05BC afii57807 + 05BD afii57839 + 05BE afii57645 + 05BF afii57841 + 05C0 afii57842 + 05C1 afii57804 + 05C2 afii57803 + 05C3 afii57658 + 05D0 afii57664 + 05D1 afii57665 + 05D2 afii57666 + 05D3 afii57667 + 05D4 afii57668 + 05D5 afii57669 + 05D6 afii57670 + 05D7 afii57671 + 05D8 afii57672 + 05D9 afii57673 + 05DA afii57674 + 05DB afii57675 + 05DC afii57676 + 05DD afii57677 + 05DE afii57678 + 05DF afii57679 + 05E0 afii57680 + 05E1 afii57681 + 05E2 afii57682 + 05E3 afii57683 + 05E4 afii57684 + 05E5 afii57685 + 05E6 afii57686 + 05E7 afii57687 + 05E8 afii57688 + 05E9 afii57689 + 05EA afii57690 + 05F0 afii57716 + 05F1 afii57717 + 05F2 afii57718 + 060C afii57388 + 061B afii57403 + 061F afii57407 + 0621 afii57409 + 0622 afii57410 + 0623 afii57411 + 0624 afii57412 + 0625 afii57413 + 0626 afii57414 + 0627 afii57415 + 0628 afii57416 + 0629 afii57417 + 062A afii57418 + 062B afii57419 + 062C afii57420 + 062D afii57421 + 062E afii57422 + 062F afii57423 + 0630 afii57424 + 0631 afii57425 + 0632 afii57426 + 0633 afii57427 + 0634 afii57428 + 0635 afii57429 + 0636 afii57430 + 0637 afii57431 + 0638 afii57432 + 0639 afii57433 + 063A afii57434 + 0640 afii57440 + 0641 afii57441 + 0642 afii57442 + 0643 afii57443 + 0644 afii57444 + 0645 afii57445 + 0646 afii57446 + 0647 afii57470 + 0648 afii57448 + 0649 afii57449 + 064A afii57450 + 064B afii57451 + 064C afii57452 + 064D afii57453 + 064E afii57454 + 064F afii57455 + 0650 afii57456 + 0651 afii57457 + 0652 afii57458 + 0660 afii57392 + 0661 afii57393 + 0662 afii57394 + 0663 afii57395 + 0664 afii57396 + 0665 afii57397 + 0666 afii57398 + 0667 afii57399 + 0668 afii57400 + 0669 afii57401 + 066A afii57381 + 066D afii63167 + 0679 afii57511 + 067E afii57506 + 0686 afii57507 + 0688 afii57512 + 0691 afii57513 + 0698 afii57508 + 06A4 afii57505 + 06AF afii57509 + 06BA afii57514 + 06D2 afii57519 + 06D5 afii57534 + 1E80 Wgrave + 1E81 wgrave + 1E82 Wacute + 1E83 wacute + 1E84 Wdieresis + 1E85 wdieresis + 1EF2 Ygrave + 1EF3 ygrave + 200C afii61664 + 200D afii301 + 200E afii299 + 200F afii300 + 2012 figuredash + 2013 endash + 2014 emdash + 2015 afii00208 + 2017 underscoredbl + 2018 quoteleft + 2019 quoteright + 201A quotesinglbase + 201B quotereversed + 201C quotedblleft + 201D quotedblright + 201E quotedblbase + 2020 dagger + 2021 daggerdbl + 2022 bullet + 2024 onedotenleader + 2025 twodotenleader + 2026 ellipsis + 202C afii61573 + 202D afii61574 + 202E afii61575 + 2030 perthousand + 2032 minute + 2033 second + 2039 guilsinglleft + 203A guilsinglright + 203C exclamdbl + 2044 fraction + 2070 zerosuperior + 2074 foursuperior + 2075 fivesuperior + 2076 sixsuperior + 2077 sevensuperior + 2078 eightsuperior + 2079 ninesuperior + 207D parenleftsuperior + 207E parenrightsuperior + 207F nsuperior + 2080 zeroinferior + 2081 oneinferior + 2082 twoinferior + 2083 threeinferior + 2084 fourinferior + 2085 fiveinferior + 2086 sixinferior + 2087 seveninferior + 2088 eightinferior + 2089 nineinferior + 208D parenleftinferior + 208E parenrightinferior + 20A1 colonmonetary + 20A3 franc + 20A4 lira + 20A7 peseta + 20AA afii57636 + 20AB dong + 20AC Euro + 2105 afii61248 + 2111 Ifraktur + 2113 afii61289 + 2116 afii61352 + 2118 weierstrass + 211C Rfraktur + 211E prescription + 2122 trademark + 2126 Omega + 212E estimated + 2135 aleph + 2153 onethird + 2154 twothirds + 215B oneeighth + 215C threeeighths + 215D fiveeighths + 215E seveneighths + 2190 arrowleft + 2191 arrowup + 2192 arrowright + 2193 arrowdown + 2194 arrowboth + 2195 arrowupdn + 21A8 arrowupdnbse + 21B5 carriagereturn + 21D0 arrowdblleft + 21D1 arrowdblup + 21D2 arrowdblright + 21D3 arrowdbldown + 21D4 arrowdblboth + 2200 universal + 2202 partialdiff + 2203 existential + 2205 emptyset + 2206 Delta + 2207 gradient + 2208 element + 2209 notelement + 220B suchthat + 220F product + 2211 summation + 2212 minus + 2215 fraction + 2217 asteriskmath + 2219 periodcentered + 221A radical + 221D proportional + 221E infinity + 221F orthogonal + 2220 angle + 2227 logicaland + 2228 logicalor + 2229 intersection + 222A union + 222B integral + 2234 therefore + 223C similar + 2245 congruent + 2248 approxequal + 2260 notequal + 2261 equivalence + 2264 lessequal + 2265 greaterequal + 2282 propersubset + 2283 propersuperset + 2284 notsubset + 2286 reflexsubset + 2287 reflexsuperset + 2295 circleplus + 2297 circlemultiply + 22A5 perpendicular + 22C5 dotmath + 2302 house + 2310 revlogicalnot + 2320 integraltp + 2321 integralbt + 2329 angleleft + 232A angleright + 2500 SF100000 + 2502 SF110000 + 250C SF010000 + 2510 SF030000 + 2514 SF020000 + 2518 SF040000 + 251C SF080000 + 2524 SF090000 + 252C SF060000 + 2534 SF070000 + 253C SF050000 + 2550 SF430000 + 2551 SF240000 + 2552 SF510000 + 2553 SF520000 + 2554 SF390000 + 2555 SF220000 + 2556 SF210000 + 2557 SF250000 + 2558 SF500000 + 2559 SF490000 + 255A SF380000 + 255B SF280000 + 255C SF270000 + 255D SF260000 + 255E SF360000 + 255F SF370000 + 2560 SF420000 + 2561 SF190000 + 2562 SF200000 + 2563 SF230000 + 2564 SF470000 + 2565 SF480000 + 2566 SF410000 + 2567 SF450000 + 2568 SF460000 + 2569 SF400000 + 256A SF540000 + 256B SF530000 + 256C SF440000 + 2580 upblock + 2584 dnblock + 2588 block + 258C lfblock + 2590 rtblock + 2591 ltshade + 2592 shade + 2593 dkshade + 25A0 filledbox + 25A1 H22073 + 25AA H18543 + 25AB H18551 + 25AC filledrect + 25B2 triagup + 25BA triagrt + 25BC triagdn + 25C4 triaglf + 25CA lozenge + 25CB circle + 25CF H18533 + 25D8 invbullet + 25D9 invcircle + 25E6 openbullet + 263A smileface + 263B invsmileface + 263C sun + 2640 female + 2642 male + 2660 spade + 2663 club + 2665 heart + 2666 diamond + 266A musicalnote + 266B musicalnotedbl + F6BE dotlessj + F6BF LL + F6C0 ll + F6C1 Scedilla + F6C2 scedilla + F6C3 commaaccent + F6C4 afii10063 + F6C5 afii10064 + F6C6 afii10192 + F6C7 afii10831 + F6C8 afii10832 + F6C9 Acute + F6CA Caron + F6CB Dieresis + F6CC DieresisAcute + F6CD DieresisGrave + F6CE Grave + F6CF Hungarumlaut + F6D0 Macron + F6D1 cyrBreve + F6D2 cyrFlex + F6D3 dblGrave + F6D4 cyrbreve + F6D5 cyrflex + F6D6 dblgrave + F6D7 dieresisacute + F6D8 dieresisgrave + F6D9 copyrightserif + F6DA registerserif + F6DB trademarkserif + F6DC onefitted + F6DD rupiah + F6DE threequartersemdash + F6DF centinferior + F6E0 centsuperior + F6E1 commainferior + F6E2 commasuperior + F6E3 dollarinferior + F6E4 dollarsuperior + F6E5 hypheninferior + F6E6 hyphensuperior + F6E7 periodinferior + F6E8 periodsuperior + F6E9 asuperior + F6EA bsuperior + F6EB dsuperior + F6EC esuperior + F6ED isuperior + F6EE lsuperior + F6EF msuperior + F6F0 osuperior + F6F1 rsuperior + F6F2 ssuperior + F6F3 tsuperior + F6F4 Brevesmall + F6F5 Caronsmall + F6F6 Circumflexsmall + F6F7 Dotaccentsmall + F6F8 Hungarumlautsmall + F6F9 Lslashsmall + F6FA OEsmall + F6FB Ogoneksmall + F6FC Ringsmall + F6FD Scaronsmall + F6FE Tildesmall + F6FF Zcaronsmall + F721 exclamsmall + F724 dollaroldstyle + F726 ampersandsmall + F730 zerooldstyle + F731 oneoldstyle + F732 twooldstyle + F733 threeoldstyle + F734 fouroldstyle + F735 fiveoldstyle + F736 sixoldstyle + F737 sevenoldstyle + F738 eightoldstyle + F739 nineoldstyle + F73F questionsmall + F760 Gravesmall + F761 Asmall + F762 Bsmall + F763 Csmall + F764 Dsmall + F765 Esmall + F766 Fsmall + F767 Gsmall + F768 Hsmall + F769 Ismall + F76A Jsmall + F76B Ksmall + F76C Lsmall + F76D Msmall + F76E Nsmall + F76F Osmall + F770 Psmall + F771 Qsmall + F772 Rsmall + F773 Ssmall + F774 Tsmall + F775 Usmall + F776 Vsmall + F777 Wsmall + F778 Xsmall + F779 Ysmall + F77A Zsmall + F7A1 exclamdownsmall + F7A2 centoldstyle + F7A8 Dieresissmall + F7AF Macronsmall + F7B4 Acutesmall + F7B8 Cedillasmall + F7BF questiondownsmall + F7E0 Agravesmall + F7E1 Aacutesmall + F7E2 Acircumflexsmall + F7E3 Atildesmall + F7E4 Adieresissmall + F7E5 Aringsmall + F7E6 AEsmall + F7E7 Ccedillasmall + F7E8 Egravesmall + F7E9 Eacutesmall + F7EA Ecircumflexsmall + F7EB Edieresissmall + F7EC Igravesmall + F7ED Iacutesmall + F7EE Icircumflexsmall + F7EF Idieresissmall + F7F0 Ethsmall + F7F1 Ntildesmall + F7F2 Ogravesmall + F7F3 Oacutesmall + F7F4 Ocircumflexsmall + F7F5 Otildesmall + F7F6 Odieresissmall + F7F8 Oslashsmall + F7F9 Ugravesmall + F7FA Uacutesmall + F7FB Ucircumflexsmall + F7FC Udieresissmall + F7FD Yacutesmall + F7FE Thornsmall + F7FF Ydieresissmall + F8E5 radicalex + F8E6 arrowvertex + F8E7 arrowhorizex + F8E8 registersans + F8E9 copyrightsans + F8EA trademarksans + F8EB parenlefttp + F8EC parenleftex + F8ED parenleftbt + F8EE bracketlefttp + F8EF bracketleftex + F8F0 bracketleftbt + F8F1 bracelefttp + F8F2 braceleftmid + F8F3 braceleftbt + F8F4 braceex + F8F5 integralex + F8F6 parenrighttp + F8F7 parenrightex + F8F8 parenrightbt + F8F9 bracketrighttp + F8FA bracketrightex + F8FB bracketrightbt + F8FC bracerighttp + F8FD bracerightmid + F8FE bracerightbt + FB00 ff + FB01 fi + FB02 fl + FB03 ffi + FB04 ffl + FB1F afii57705 + FB2A afii57694 + FB2B afii57695 + FB35 afii57723 + FB4B afii57700 +)}; + + +sub CreatePostscriptEncoding +{ + my ($encoding) = @_; + my $result = "/CurrentEncoding \[\n"; + for (my $i = 0; $i < 256; $i += 8) + { + for (my $j = 0; $j < 8; $j++) + { + my $ch; + Tk::catch { $ch = $encoding->decode(chr($i+$j),1) }; + if ($@) + { + $result .= '/space'; + } + else + { + my $hexcode = sprintf("%04X",ord($ch)); + $result .= '/'.((exists $Tk::psglyphs->{$hexcode}) ? $Tk::psglyphs->{$hexcode} : 'space'); + } + } + $result .= "\n"; + } + $result .= "\] def\n"; + return $result; +} + +# precalculate entire prolog when this file is loaded +# (to speed things up) +$Tk::ps_preamable = "%%BeginProlog\n". + CreatePostscriptEncoding(Tk::SystemEncoding()). <<'END'; +50 dict begin +% This is a standard prolog for Postscript generated by Tk's canvas +% widget. +% RCS: @(#) $Id: //depot/Tkutf8/Canvas/Canvas.pm#12 $ + +% The definitions below just define all of the variables used in +% any of the procedures here. This is needed for obscure reasons +% explained on p. 716 of the Postscript manual (Section H.2.7, +% "Initializing Variables," in the section on Encapsulated Postscript). + +/baseline 0 def +/stipimage 0 def +/height 0 def +/justify 0 def +/lineLength 0 def +/spacing 0 def +/stipple 0 def +/strings 0 def +/xoffset 0 def +/yoffset 0 def +/tmpstip null def + + +/cstringshow { + { + dup type /stringtype eq + { show } { glyphshow } + ifelse + } + forall +} bind def + + + +/cstringwidth { + 0 exch 0 exch + { + dup type /stringtype eq + { stringwidth } { + currentfont /Encoding get exch 1 exch put (\001) stringwidth + } + ifelse + exch 3 1 roll add 3 1 roll add exch + } + forall +} bind def + +% font ISOEncode font +% This procedure changes the encoding of a font from the default +% Postscript encoding to current system encoding. It's typically invoked just +% before invoking "setfont". The body of this procedure comes from +% Section 5.6.1 of the Postscript book. + +/ISOEncode { + dup length dict begin + {1 index /FID ne {def} {pop pop} ifelse} forall + /Encoding CurrentEncoding def + currentdict + end + + % I'm not sure why it's necessary to use "definefont" on this new + % font, but it seems to be important; just use the name "Temporary" + % for the font. + + /Temporary exch definefont +} bind def + +% StrokeClip +% +% This procedure converts the current path into a clip area under +% the assumption of stroking. It's a bit tricky because some Postscript +% interpreters get errors during strokepath for dashed lines. If +% this happens then turn off dashes and try again. + +/StrokeClip { + {strokepath} stopped { + (This Postscript printer gets limitcheck overflows when) = + (stippling dashed lines; lines will be printed solid instead.) = + [] 0 setdash strokepath} if + clip +} bind def + +% desiredSize EvenPixels closestSize +% +% The procedure below is used for stippling. Given the optimal size +% of a dot in a stipple pattern in the current user coordinate system, +% compute the closest size that is an exact multiple of the device's +% pixel size. This allows stipple patterns to be displayed without +% aliasing effects. + +/EvenPixels { + % Compute exact number of device pixels per stipple dot. + dup 0 matrix currentmatrix dtransform + dup mul exch dup mul add sqrt + + % Round to an integer, make sure the number is at least 1, and compute + % user coord distance corresponding to this. + dup round dup 1 lt {pop 1} if + exch div mul +} bind def + +% width height string StippleFill -- +% +% Given a path already set up and a clipping region generated from +% it, this procedure will fill the clipping region with a stipple +% pattern. "String" contains a proper image description of the +% stipple pattern and "width" and "height" give its dimensions. Each +% stipple dot is assumed to be about one unit across in the current +% user coordinate system. This procedure trashes the graphics state. + +/StippleFill { + % The following code is needed to work around a NeWSprint bug. + + /tmpstip 1 index def + + % Change the scaling so that one user unit in user coordinates + % corresponds to the size of one stipple dot. + 1 EvenPixels dup scale + + % Compute the bounding box occupied by the path (which is now + % the clipping region), and round the lower coordinates down + % to the nearest starting point for the stipple pattern. Be + % careful about negative numbers, since the rounding works + % differently on them. + + pathbbox + 4 2 roll + 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll + 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll + + % Stack now: width height string y1 y2 x1 x2 + % Below is a doubly-nested for loop to iterate across this area + % in units of the stipple pattern size, going up columns then + % across rows, blasting out a stipple-pattern-sized rectangle at + % each position + + 6 index exch { + 2 index 5 index 3 index { + % Stack now: width height string y1 y2 x y + + gsave + 1 index exch translate + 5 index 5 index true matrix tmpstip imagemask + grestore + } for + pop + } for + pop pop pop pop pop +} bind def + +% -- AdjustColor -- +% Given a color value already set for output by the caller, adjusts +% that value to a grayscale or mono value if requested by the CL +% variable. + +/AdjustColor { + CL 2 lt { + currentgray + CL 0 eq { + .5 lt {0} {1} ifelse + } if + setgray + } if +} bind def + +% x y strings spacing xoffset yoffset justify stipple DrawText -- +% This procedure does all of the real work of drawing text. The +% color and font must already have been set by the caller, and the +% following arguments must be on the stack: +% +% x, y - Coordinates at which to draw text. +% strings - An array of strings, one for each line of the text item, +% in order from top to bottom. +% spacing - Spacing between lines. +% xoffset - Horizontal offset for text bbox relative to x and y: 0 for +% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se. +% yoffset - Vertical offset for text bbox relative to x and y: 0 for +% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se. +% justify - 0 for left justification, 0.5 for center, 1 for right justify. +% stipple - Boolean value indicating whether or not text is to be +% drawn in stippled fashion. If text is stippled, +% procedure StippleText must have been defined to call +% StippleFill in the right way. +% +% Also, when this procedure is invoked, the color and font must already +% have been set for the text. + +/DrawText { + /stipple exch def + /justify exch def + /yoffset exch def + /xoffset exch def + /spacing exch def + /strings exch def + + % First scan through all of the text to find the widest line. + + /lineLength 0 def + strings { + cstringwidth pop + dup lineLength gt {/lineLength exch def} {pop} ifelse + newpath + } forall + + % Compute the baseline offset and the actual font height. + + 0 0 moveto (TXygqPZ) false charpath + pathbbox dup /baseline exch def + exch pop exch sub /height exch def pop + newpath + + % Translate coordinates first so that the origin is at the upper-left + % corner of the text's bounding box. Remember that x and y for + % positioning are still on the stack. + + translate + lineLength xoffset mul + strings length 1 sub spacing mul height add yoffset mul translate + + % Now use the baseline and justification information to translate so + % that the origin is at the baseline and positioning point for the + % first line of text. + + justify lineLength mul baseline neg translate + + % Iterate over each of the lines to output it. For each line, + % compute its width again so it can be properly justified, then + % display it. + + strings { + dup cstringwidth pop + justify neg mul 0 moveto + stipple { + + + % The text is stippled, so turn it into a path and print + % by calling StippledText, which in turn calls StippleFill. + % Unfortunately, many Postscript interpreters will get + % overflow errors if we try to do the whole string at + % once, so do it a character at a time. + + gsave + /char (X) def + { + dup type /stringtype eq { + % This segment is a string. + { + char 0 3 -1 roll put + currentpoint + gsave + char true charpath clip StippleText + grestore + char stringwidth translate + moveto + } forall + } { + % This segment is glyph name + % Temporary override + currentfont /Encoding get exch 1 exch put + currentpoint + gsave (\001) true charpath clip StippleText + grestore + (\001) stringwidth translate + moveto + } ifelse + } forall + grestore + } {cstringshow} ifelse + 0 spacing neg translate + } forall +} bind def + +%%EndProlog +END + +1; +__END__ + diff --git a/Master/tlpkg/installer/perllib/Tk/Menu.pm b/Master/tlpkg/installer/perllib/Tk/Menu.pm new file mode 100644 index 00000000000..91e9aceed61 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Menu.pm @@ -0,0 +1,1145 @@ +# Converted from menu.tcl -- +# +# This file defines the default bindings for Tk menus and menubuttons. +# It also implements keyboard traversal of menus and implements a few +# other utility procedures related to menus. +# +# @(#) menu.tcl 1.34 94/12/19 17:09:09 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package Tk::Menu; +require Tk; +require Tk::Widget; +require Tk::Wm; +require Tk::Derived; +require Tk::Menu::Item; + + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #21 $ =~ /\D(\d+)\s*$/; + +use strict; + +use base qw(Tk::Wm Tk::Derived Tk::Widget); + +Construct Tk::Widget 'Menu'; + +sub Tk_cmd { \&Tk::_menu } + +Tk::Methods('activate','add','clone','delete','entrycget','entryconfigure', + 'index','insert','invoke','post','postcascade','type', + 'unpost','yposition'); + +import Tk qw(Ev); + +sub CreateArgs +{ + my ($package,$parent,$args) = @_; + # Remove from hash %$args any configure-like + # options which only apply at create time (e.g. -class for Frame) + # return these as a list of -key => value pairs + my @result = (); + my $opt; + foreach $opt (qw(-type -screen -visual -colormap)) + { + my $val = delete $args->{$opt}; + push(@result, $opt => $val) if (defined $val); + } + return @result; +} + +sub InitObject +{ + my ($menu,$args) = @_; + my $menuitems = delete $args->{-menuitems}; + $menu->SUPER::InitObject($args); + $menu->ConfigSpecs(-foreground => ['SELF']); + if (defined $menuitems) + { + # If any other args do configure now + if (%$args) + { + $menu->configure(%$args); + %$args = (); + } + $menu->AddItems(@$menuitems) + } +} + +sub AddItems +{ + my $menu = shift; + ITEM: + while (@_) + { + my $item = shift; + if (!ref($item)) + { + $menu->separator; # A separator + } + else + { + my ($kind,$name,%minfo) = ( @$item ); + my $invoke = delete $minfo{'-invoke'}; + if (defined $name) + { + $minfo{-label} = $name unless defined($minfo{-label}); + $menu->$kind(%minfo); + } + else + { + $menu->BackTrace("Don't recognize " . join(' ',@$item)); + } + } # A non-separator + } +} + +# +#------------------------------------------------------------------------- +# Elements of tkPriv that are used in this file: +# +# cursor - Saves the -cursor option for the posted menubutton. +# focus - Saves the focus during a menu selection operation. +# Focus gets restored here when the menu is unposted. +# inMenubutton - The name of the menubutton widget containing +# the mouse, or an empty string if the mouse is +# not over any menubutton. +# popup - If a menu has been popped up via tk_popup, this +# gives the name of the menu. Otherwise this +# value is empty. +# postedMb - Name of the menubutton whose menu is currently +# posted, or an empty string if nothing is posted +# A grab is set on this widget. +# relief - Used to save the original relief of the current +# menubutton. +# window - When the mouse is over a menu, this holds the +# name of the menu; it's cleared when the mouse +# leaves the menu. +#------------------------------------------------------------------------- +#------------------------------------------------------------------------- +# Overall note: +# This file is tricky because there are four different ways that menus +# can be used: +# +# 1. As a pulldown from a menubutton. This is the most common usage. +# In this style, the variable tkPriv(postedMb) identifies the posted +# menubutton. +# 2. As a torn-off menu copied from some other menu. In this style +# tkPriv(postedMb) is empty, and the top-level menu is no +# override-redirect. +# 3. As an option menu, triggered from an option menubutton. In thi +# style tkPriv(postedMb) identifies the posted menubutton. +# 4. As a popup menu. In this style tkPriv(postedMb) is empty and +# the top-level menu is override-redirect. +# +# The various binding procedures use the state described above to +# distinguish the various cases and take different actions in each +# case. +#------------------------------------------------------------------------- +# Bind -- +# This procedure is invoked the first time the mouse enters a menubutton +# widget or a menubutton widget receives the input focus. It creates +# all of the class bindings for both menubuttons and menus. +# +# Arguments: +# w - The widget that was just entered or just received +# the input focus. +# 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) = @_; + # Must set focus when mouse enters a menu, in order to allow + # mixed-mode processing using both the mouse and the keyboard. + $mw->bind($class,'', 'NoOp'); + $mw->bind($class,'', 'Enter'); + $mw->bind($class,'', ['Leave',Ev('X'),Ev('Y'),Ev('s')]); + $mw->bind($class,'', ['Motion',Ev('x'),Ev('y'),Ev('s')]); + $mw->bind($class,'','ButtonDown'); + $mw->bind($class,'',['Invoke',1]); + $mw->bind($class,'',['Invoke',0]); + $mw->bind($class,'',['Invoke',0]); + $mw->bind($class,'','Escape'); + $mw->bind($class,'','LeftArrow'); + $mw->bind($class,'','RightArrow'); + $mw->bind($class,'','UpArrow'); + $mw->bind($class,'','DownArrow'); + $mw->bind($class,'', ['TraverseWithinMenu',Ev('K')]); + $mw->bind($class,'', ['TraverseWithinMenu',Ev('K')]); + return $class; +} + +sub UpArrow +{ + my $menu = shift; + if ($menu->cget('-type') eq 'menubar') + { + $menu->NextMenu('left'); + } + else + { + $menu->NextEntry(-1); + } +} + +sub DownArrow +{ + my $menu = shift; + if ($menu->cget('-type') eq 'menubar') + { + $menu->NextMenu('right'); + } + else + { + $menu->NextEntry(1); + } +} + +sub LeftArrow +{ + my $menu = shift; + if ($menu->cget('-type') eq 'menubar') + { + $menu->NextEntry(-1); + } + else + { + $menu->NextMenu('left'); + } +} + +sub RightArrow +{ + my $menu = shift; + if ($menu->cget('-type') eq 'menubar') + { + $menu->NextEntry(1); + } + else + { + $menu->NextMenu('right'); + } +} + + + +# Unpost -- +# This procedure unposts a given menu, plus all of its ancestors up +# to (and including) a menubutton, if any. It also restores various +# values to what they were before the menu was posted, and releases +# a grab if there's a menubutton involved. Special notes: +# 1. It's important to unpost all menus before releasing the grab, so +# that any Enter-Leave events (e.g. from menu back to main +# application) have mode NotifyGrab. +# 2. Be sure to enclose various groups of commands in "catch" so that +# the procedure will complete even if the menubutton or the menu +# or the grab window has been deleted. +# +# Arguments: +# menu - Name of a menu to unpost. Ignored if there +# is a posted menubutton. +sub Unpost +{ + my $menu = shift; + my $mb = $Tk::postedMb; + + # Restore focus right away (otherwise X will take focus away when + # the menu is unmapped and under some window managers (e.g. olvwm) + # we'll lose the focus completely). + + eval {local $SIG{__DIE__}; $Tk::focus->focus() } if (defined $Tk::focus); + undef $Tk::focus; + + # Unpost menu(s) and restore some stuff that's dependent on + # what was posted. + eval {local $SIG{__DIE__}; + if (defined $mb) + { + $menu = $mb->cget('-menu'); + $menu->unpost(); + $Tk::postedMb = undef; + $mb->configure('-cursor',$Tk::cursor); + $mb->configure('-relief',$Tk::relief) + } + elsif (defined $Tk::popup) + { + $Tk::popup->unpost(); + my $grab = $Tk::popup->grabCurrent; + $grab->grabRelease if (defined $grab); + + undef $Tk::popup; + } + elsif (defined $menu && ref $menu && + $menu->cget('-type') ne 'menubar' && + $menu->cget('-type') ne 'tearoff' + ) + { + # We're in a cascaded sub-menu from a torn-off menu or popup. + # Unpost all the menus up to the toplevel one (but not + # including the top-level torn-off one) and deactivate the + # top-level torn off menu if there is one. + while (1) + { + my $parent = $menu->parent; + last if (!$parent->IsMenu || !$parent->ismapped); + $parent->postcascade('none'); + $parent->GenerateMenuSelect; + $parent->activate('none'); + my $type = $parent->cget('-type'); + last if ($type eq 'menubar' || $type eq 'tearoff'); + $menu = $parent + } + $menu->unpost() if ($menu->cget('-type') ne 'menubar'); + } + }; + warn "$@" if ($@); + if ($Tk::tearoff || $Tk::menubar) + { + # Release grab, if any. + if (defined $menu && ref $menu) + { + my $grab = $menu->grabCurrent; + $grab->grabRelease if (defined $grab); + } + RestoreOldGrab(); + if ($Tk::menubar) + { + $Tk::menubar->configure(-cursor => $Tk::cursor); + undef $Tk::menubar; + } + if ($Tk::platform ne 'unix') + { + undef $Tk::tearoff; + } + } +} + +sub RestoreOldGrab +{ + if (defined $Tk::oldGrab) + { + eval + { + local $SIG{__DIE__}; + if ($Tk::grabStatus eq 'global') + { + $Tk::oldGrab->grabGlobal; + } + else + { + $Tk::oldGrab->grab; + } + }; + undef $Tk::oldGrab; + } +} + +sub typeIS +{my $w = shift; + my $type = $w->type(shift); + return defined $type && $type eq shift; +} + +# Motion -- +# This procedure is called to handle mouse motion events for menus. +# It does two things. First, it resets the active element in the +# menu, if the mouse is over the menu. Second, if a mouse button +# is down, it posts and unposts cascade entries to match the mouse +# position. +# +# Arguments: +# menu - The menu window. +# y - The y position of the mouse. +# state - Modifier state (tells whether buttons are down). +sub Motion +{ + my $menu = shift; + my $x = shift; + my $y = shift; + my $state = shift; + my $t = $menu->cget('-type'); + + if ($menu->IS($Tk::window)) + { + if ($menu->cget('-type') eq 'menubar') + { +# if (defined($Tk::focus) && $Tk::focus != $menu) + { + $menu->activate("\@$x,$y"); + $menu->GenerateMenuSelect; + } + } + else + { + $menu->activate("\@$x,$y"); + $menu->GenerateMenuSelect; + } + } + if (($state & 0x1f00) != 0) + { + $menu->postcascade('active') + } +} +# ButtonDown -- +# Handles button presses in menus. There are a couple of tricky things +# here: +# 1. Change the posted cascade entry (if any) to match the mouse position. +# 2. If there is a posted menubutton, must grab to the menubutton so +# that it can track mouse motions over other menubuttons and change +# the posted menu. +# 3. If there's no posted menubutton (e.g. because we're a torn-off menu +# or one of its descendants) must grab to the top-level menu so that +# we can track mouse motions across the entire menu hierarchy. + +# +# Arguments: +# menu - The menu window. +sub ButtonDown +{ + my $menu = shift; + $menu->postcascade('active'); + if (defined $Tk::postedMb) + { + $Tk::postedMb->grabGlobal + } + else + { + while ($menu->cget('-type') eq 'normal' + && $menu->parent->IsMenu + && $menu->parent->ismapped + ) + { + $menu = $menu->parent; + } + + if (!defined $Tk::menuBar) + { + $Tk::menuBar = $menu; + $Tk::cursor = $menu->cget('-cursor'); + $menu->configure(-cursor => 'arrow'); + } + + # Don't update grab information if the grab window isn't changing. + # Otherwise, we'll get an error when we unpost the menus and + # restore the grab, since the old grab window will not be viewable + # anymore. + + $menu->SaveGrabInfo unless ($menu->IS($menu->grabCurrent)); + + # Must re-grab even if the grab window hasn't changed, in order + # to release the implicit grab from the button press. + + $menu->grabGlobal if ($Tk::platform eq 'unix'); + } +} + +sub Enter +{ + my $w = shift; + my $ev = $w->XEvent; + $Tk::window = $w; + if ($w->cget('-type') eq 'tearoff') + { + if ($ev->m ne 'NotifyUngrab') + { + $w->SetFocus if ($Tk::platform eq 'unix'); + } + } + $w->Motion($ev->x, $ev->y, $ev->s); +} + +# Leave -- +# This procedure is invoked to handle Leave events for a menu. It +# deactivates everything unless the active element is a cascade element +# and the mouse is now over the submenu. +# +# Arguments: +# menu - The menu window. +# rootx, rooty - Root coordinates of mouse. +# state - Modifier state. +sub Leave +{ + my $menu = shift; + my $rootx = shift; + my $rooty = shift; + my $state = shift; + undef $Tk::window; + return if ($menu->index('active') eq 'none'); + if ($menu->typeIS('active','cascade')) + { + my $c = $menu->Containing($rootx,$rooty); + return if (defined $c && $menu->entrycget('active','-menu')->IS($c)); + } + $menu->activate('none'); + $menu->GenerateMenuSelect; +} + +# Invoke -- +# This procedure is invoked when button 1 is released over a menu. +# It invokes the appropriate menu action and unposts the menu if +# it came from a menubutton. +# +# Arguments: +# w - Name of the menu widget. +sub Invoke +{ + my $w = shift; + my $release = shift; + + if ($release && !defined($Tk::window)) + { + # Mouse was pressed over a menu without a menu button, then + # dragged off the menu (possibly with a cascade posted) and + # released. Unpost everything and quit. + + $w->postcascade('none'); + $w->activate('none'); + $w->eventGenerate('<>'); + $w->Unpost; + return; + } + + my $type = $w->type('active'); + if ($w->typeIS('active','cascade')) + { + $w->postcascade('active'); + my $menu = $w->entrycget('active','-menu'); + $menu->FirstEntry() if (defined $menu); + } + elsif ($w->typeIS('active','tearoff')) + { + $w->Unpost(); + $w->tearOffMenu(); + } + elsif ($w->typeIS('active','menubar')) + { + $w->postcascade('none'); + $w->activate('none'); + $w->eventGenerate('<>'); + $w->Unpost; + } + else + { + $w->Unpost(); + $w->invoke('active') + } +} +# Escape -- +# This procedure is invoked for the Cancel (or Escape) key. It unposts +# the given menu and, if it is the top-level menu for a menu button, +# unposts the menu button as well. +# +# Arguments: +# menu - Name of the menu window. +sub Escape +{ + my $menu = shift; + my $parent = $menu->parent; + if (!$parent->IsMenu) + { + $menu->Unpost() + } + elsif ($parent->cget('-type') eq 'menubar') + { + $menu->Unpost; + RestoreOldGrab(); + } + else + { + $menu->NextMenu(-1) + } +} +# LeftRight -- +# This procedure is invoked to handle "left" and "right" traversal +# motions in menus. It traverses to the next menu in a menu bar, +# or into or out of a cascaded menu. +# +# Arguments: +# menu - The menu that received the keyboard +# event. +# direction - Direction in which to move: "left" or "right" +sub NextMenu +{ + my $menu = shift; + my $direction = shift; + # First handle traversals into and out of cascaded menus. + my $count; + if ($direction eq 'right') + { + $count = 1; + if ($menu->typeIS('active','cascade')) + { + $menu->postcascade('active'); + my $m2 = $menu->entrycget('active','-menu'); + $m2->FirstEntry if (defined $m2); + return; + } + else + { + my $parent = $menu->parent; + while ($parent->PathName ne '.') + { + if ($parent->IsMenu && $parent->cget('-type') eq 'menubar') + { + $parent->SetFocus; + $parent->NextEntry(1); + return; + } + $parent = $parent->parent; + } + } + } + else + { + $count = -1; + my $m2 = $menu->parent; + if ($m2->IsMenu) + { + if ($m2->cget('-type') ne 'menubar') + { + $menu->activate('none'); + $menu->GenerateMenuSelect; + $m2->SetFocus; + # This code unposts any posted submenu in the parent. + my $tmp = $m2->index('active'); + $m2->activate('none'); + $m2->activate($tmp); + return; + } + } + } + # Can't traverse into or out of a cascaded menu. Go to the next + # or previous menubutton, if that makes sense. + + my $m2 = $menu->parent; + if ($m2->IsMenu) + { + if ($m2->cget('-type') eq 'menubar') + { + $m2->SetFocus; + $m2->NextEntry(-1); + return; + } + } + + my $w = $Tk::postedMb; + return unless defined $w; + my @buttons = $w->parent->children; + my $length = @buttons; + my $i = Tk::lsearch(\@buttons,$w)+$count; + my $mb; + while (1) + { + while ($i < 0) + { + $i += $length + } + while ($i >= $length) + { + $i += -$length + } + $mb = $buttons[$i]; + last if ($mb->IsMenubutton && $mb->cget('-state') ne 'disabled' + && defined($mb->cget('-menu')) + && $mb->cget('-menu')->index('last') ne 'none' + ); + return if ($mb == $w); + $i += $count + } + $mb->PostFirst(); +} +# NextEntry -- +# Activate the next higher or lower entry in the posted menu, +# wrapping around at the ends. Disabled entries are skipped. +# +# Arguments: +# menu - Menu window that received the keystroke. +# count - 1 means go to the next lower entry, +# -1 means go to the next higher entry. +sub NextEntry +{ + my $menu = shift; + my $count = shift; + if ($menu->index('last') eq 'none') + { + return; + } + my $length = $menu->index('last')+1; + my $quitAfter = $length; + my $active = $menu->index('active'); + my $i = ($active eq 'none') ? 0 : $active+$count; + while (1) + { + return if ($quitAfter <= 0); + while ($i < 0) + { + $i += $length + } + while ($i >= $length) + { + $i += -$length + } + my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') }; + last if (defined($state) && $state ne 'disabled'); + return if ($i == $active); + $i += $count; + $quitAfter -= 1; + } + $menu->activate($i); + $menu->GenerateMenuSelect; + if ($menu->cget('-type') eq 'menubar' && $menu->type($i) eq 'cascade') + { + my $cascade = $menu->entrycget($i, '-menu'); + $menu->postcascade($i); + $cascade->FirstEntry if (defined $cascade); + } +} + + +# tkTraverseWithinMenu +# This procedure implements keyboard traversal within a menu. It +# searches for an entry in the menu that has "char" underlined. If +# such an entry is found, it is invoked and the menu is unposted. +# +# Arguments: +# w - The name of the menu widget. +# char - The character to look for; case is +# ignored. If the string is empty then +# nothing happens. +sub TraverseWithinMenu +{ + my $w = shift; + my $char = shift; + return unless (defined $char); + $char = "\L$char"; + my $last = $w->index('last'); + return if ($last eq 'none'); + for (my $i = 0;$i <= $last;$i += 1) + { + my $label = eval {local $SIG{__DIE__}; $w->entrycget($i,'-label') }; + next unless defined($label); + my $ul = $w->entrycget($i,'-underline'); + if (defined $ul && $ul >= 0) + { + $label = substr("\L$label",$ul,1); + if (defined($label) && $label eq $char) + { + if ($w->type($i) eq 'cascade') + { + $w->postcascade($i); + $w->activate($i); + my $m2 = $w->entrycget($i,'-menu'); + $m2->FirstEntry if (defined $m2); + } + else + { + $w->Unpost(); + $w->invoke($i); + } + return; + } + } + } +} + +sub FindMenu +{ + my ($menu,$char) = @_; + if ($menu->cget('-type') eq 'menubar') + { + if (!defined($char) || $char eq '') + { + $menu->FirstEntry; + } + else + { + $menu->TraverseWithinMenu($char); + } + return $menu; + } + return undef; +} + + +# FirstEntry -- +# Given a menu, this procedure finds the first entry that isn't +# disabled or a tear-off or separator, and activates that entry. +# However, if there is already an active entry in the menu (e.g., +# because of a previous call to tkPostOverPoint) then the active +# entry isn't changed. This procedure also sets the input focus +# to the menu. +# +# Arguments: +# menu - Name of the menu window (possibly empty). +sub FirstEntry +{ + my $menu = shift; + return if (!defined($menu) || $menu eq '' || !ref($menu)); + $menu->SetFocus; + return if ($menu->index('active') ne 'none'); + my $last = $menu->index('last'); + return if ($last eq 'none'); + for (my $i = 0;$i <= $last;$i += 1) + { + my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') }; + if (defined $state && $state ne 'disabled' && !$menu->typeIS($i,'tearoff')) + { + $menu->activate($i); + $menu->GenerateMenuSelect; + if ($menu->type($i) eq 'cascade') + { + my $cascade = $menu->entrycget($i,'-menu'); + if (defined $cascade) + { + $menu->postcascade($i); + $cascade->FirstEntry; + } + } + return; + } + } +} + +# FindName -- +# Given a menu and a text string, return the index of the menu entry +# that displays the string as its label. If there is no such entry, +# return an empty string. This procedure is tricky because some names +# like "active" have a special meaning in menu commands, so we can't +# always use the "index" widget command. +# +# Arguments: +# menu - Name of the menu widget. +# s - String to look for. +sub FindName +{ + my $menu = shift; + my $s = shift; + my $i = undef; + if ($s !~ /^active$|^last$|^none$|^[0-9]|^@/) + { + $i = eval {local $SIG{__DIE__}; $menu->index($s) }; + return $i; + } + my $last = $menu->index('last'); + return if ($last eq 'none'); + for ($i = 0;$i <= $last;$i += 1) + { + my $label = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-label') }; + return $i if (defined $label && $label eq $s); + } + return undef; +} +# PostOverPoint -- +# This procedure posts a given menu such that a given entry in the +# menu is centered over a given point in the root window. It also +# activates the given entry. +# +# Arguments: +# menu - Menu to post. +# x, y - Root coordinates of point. +# entry - Index of entry within menu to center over (x,y). +# If omitted or specified as {}, then the menu's +# upper-left corner goes at (x,y). +sub PostOverPoint +{ + my $menu = shift; + my $x = shift; + my $y = shift; + my $entry = shift; + if (defined $entry) + { + if ($entry == $menu->index('last')) + { + $y -= ($menu->yposition($entry)+$menu->height)/2; + } + else + { + $y -= ($menu->yposition($entry)+$menu->yposition($entry+1))/2; + } + $x -= $menu->reqwidth/2; + } + $menu->post($x,$y); + if (defined($entry) && $menu->entrycget($entry,'-state') ne 'disabled') + { + $menu->activate($entry); + $menu->GenerateMenuSelect; + } +} +# tk_popup -- +# This procedure pops up a menu and sets things up for traversing +# the menu and its submenus. +# +# Arguments: +# menu - Name of the menu to be popped up. +# x, y - Root coordinates at which to pop up the +# menu. +# entry - Index of a menu entry to center over (x,y). +# If omitted or specified as {}, then menu's +# upper-left corner goes at (x,y). +sub Post +{ + my $menu = shift; + return unless (defined $menu); + my $x = shift; + my $y = shift; + my $entry = shift; + Unpost(undef) if (defined($Tk::popup) || defined($Tk::postedMb)); + $menu->PostOverPoint($x,$y,$entry); + $menu->grabGlobal; + $Tk::popup = $menu; + $Tk::focus = $menu->focusCurrent; + $menu->focus(); +} + +sub SetFocus +{ + my $menu = shift; + $Tk::focus = $menu->focusCurrent if (!defined($Tk::focus)); + $menu->focus; +} + +sub GenerateMenuSelect +{ + my $menu = shift; + $Tk::activeMenu = $menu; + $Tk::activeItem = $menu->index('active'); + $menu->eventGenerate('<>'); # FIXME +} + +# Converted from tearoff.tcl -- +# +# This file contains procedures that implement tear-off menus. +# +# @(#) tearoff.tcl 1.3 94/12/17 16:05:25 +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# tkTearoffMenu -- +# Given the name of a menu, this procedure creates a torn-off menu +# that is identical to the given menu (including nested submenus). +# The new torn-off menu exists as a toplevel window managed by the +# window manager. The return value is the name of the new menu. +# +# Arguments: +# w - The menu to be torn-off (duplicated). +sub tearOffMenu +{ + my $w = shift; + my $x = (@_) ? shift : 0; + my $y = (@_) ? shift : 0; + + $x = $w->rootx if $x == 0; + $y = $w->rooty if $y == 0; + + # Find a unique name to use for the torn-off menu. Find the first + # ancestor of w that is a toplevel but not a menu, and use this as + # the parent of the new menu. This guarantees that the torn off + # menu will be on the same screen as the original menu. By making + # it a child of the ancestor, rather than a child of the menu, it + # can continue to live even if the menu is deleted; it will go + # away when the toplevel goes away. + + my $parent = $w->parent; + while ($parent->toplevel != $parent || $parent->IsMenu) + { + $parent = $parent->parent; + } + my $menu = $w->clone($parent->PathName,'tearoff'); + + # Pick a title for the new menu by looking at the parent of the + # original: if the parent is a menu, then use the text of the active + # entry. If it's a menubutton then use its text. + my $title = $w->cget('-title'); + # print ref($w),' ',$w->PathName," $w\n"; + unless (defined $title && length($title)) + { + $parent = $w->parent; + if ($parent) + { + if ($parent->IsMenubutton) + { + $title = $parent->cget('-text'); + } + elsif ($parent->IsMenu) + { + $title = $parent->entrycget('active','-label'); + } + } + } + $menu->title($title) if (defined $title && length($title)); + $menu->post($x,$y); + # Set tkPriv(focus) on entry: otherwise the focus will get lost + # after keyboard invocation of a sub-menu (it will stay on the + # submenu). + + + # This seems to conflict with class binding above + # if this fires before the class binding the wrong thing + # will get saved in $Tk::focus + # $menu->bind('','EnterFocus'); + $menu->Callback('-tearoffcommand'); + return $menu; +} + +# tkMenuDup -- +# Given a menu (hierarchy), create a duplicate menu (hierarchy) +# in a given window. +# +# Arguments: +# src - Source window. Must be a menu. It and its +# menu descendants will be duplicated at path. +# path - Name to use for topmost menu in duplicate +# hierarchy. + +sub tkMenuDup +{ + my ($src,$path,$type) = @_; + my ($pname,$name) = $path =~ /^(.*)\.([^\.]*)$/; + ($name) = $src->PathName =~ /^.*\.([^\.]*)$/ unless $name; + my $parent = ($pname) ? $src->Widget($pname) : $src->MainWindow; + my %args = (Name => $name, -type => $type); + foreach my $option ($src->configure()) + { + next if (@$option == 2); + $args{$$option[0]} = $$option[4] unless exists $args{$$option[0]}; + } + my $dst = ref($src)->new($parent,%args); + # print "MenuDup $src $path $name $type ->",$dst->PathName,"\n"; + $_[1] = $dst; + if ($type eq 'tearoff') + { + $dst->transient($parent->toplevel); + } + my $last = $src->index('last'); + if ($last ne 'none') + { + for (my $i = $src->cget('-tearoff'); $i <= $last; $i++) + { + my $type = $src->type($i); + if (defined $type) + { + my @args = (); + foreach my $option ($src->entryconfigure($i)) + { + next if (@$option == 2); + push(@args,$$option[0],$$option[4]) if (defined $$option[4]); + } + $dst->add($type,@args); + } + } + } + # Duplicate the binding tags and bindings from the source menu. + my @bindtags = $src->bindtags; + $path = $src->PathName; + foreach (@bindtags) + { + $_ = $dst if ($_ eq $path); + } + $dst->bindtags([@bindtags]); + foreach my $event ($src->bind) + { + my $cb = $src->bind($event); +# print "$event => $cb\n"; + $dst->bind($event,$cb->Substitute($src,$dst)); + } + return $dst; +} + + + +# Some convenience methods + +sub separator { require Tk::Menu::Item; shift->Separator(@_); } +sub cascade { require Tk::Menu::Item; shift->Cascade(@_); } +sub checkbutton { require Tk::Menu::Item; shift->Checkbutton(@_); } +sub radiobutton { require Tk::Menu::Item; shift->Radiobutton(@_); } + +sub command +{ + my ($menu,%args) = @_; + require Tk::Menu::Item; + if (exists $args{-button}) + { + # Backward compatible stuff from 'Menubar' + my $button = delete $args{-button}; + $button = ['Misc', -underline => 0 ] unless (defined $button); + my @bargs = (); + ($button,@bargs) = @$button if (ref($button) && ref $button eq 'ARRAY'); + $menu = $menu->Menubutton(-label => $button, @bargs); + } + $menu->Command(%args); +} + +sub Menubutton +{ + my ($menu,%args) = @_; + my $name = delete($args{'-text'}) || $args{'-label'};; + $args{'-label'} = $name if (defined $name); + my $items = delete $args{'-menuitems'}; + foreach my $opt (qw(-pack -after -before -side -padx -ipadx -pady -ipady -fill)) + { + delete $args{$opt}; + } + if (defined($name) && !defined($args{-underline})) + { + my $underline = ($name =~ s/^(.*)~/$1/) ? length($1): undef; + if (defined($underline) && ($underline >= 0)) + { + $args{-underline} = $underline; + $args{-label} = $name; + } + } + my $hash = $menu->TkHash('MenuButtons'); + my $mb = $hash->{$name}; + if (defined $mb) + { + delete $args{'-tearoff'}; # too late! + $mb->configure(%args) if %args; + } + else + { + $mb = $menu->cascade(%args); + $hash->{$name} = $mb; + } + $mb->menu->AddItems(@$items) if defined($items) && @$items; + return $mb; +} + +sub BalloonInfo +{ + my ($menu,$balloon,$X,$Y,@opt) = @_; + my $i = $menu->index('active'); + if ($i eq 'none') + { + my $y = $Y - $menu->rooty; + $i = $menu->index("\@$y"); + } + foreach my $opt (@opt) + { + my $info = $balloon->GetOption($opt,$menu); + if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY')) + { + $balloon->Subclient($i); + return '' if $i eq 'none'; + return ${$info}[$i] || ''; + } + return $info; + } +} + +1; + +__END__ + + diff --git a/Master/tlpkg/installer/perllib/Tk/Menu/Item.pm b/Master/tlpkg/installer/perllib/Tk/Menu/Item.pm new file mode 100644 index 00000000000..403052ef5bd --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Menu/Item.pm @@ -0,0 +1,180 @@ +package Tk::Menu::Item; + +require Tk::Menu; + +use Carp; +use strict; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Tk/Menu/Item.pm#4 $ + +sub PreInit +{ + # Dummy (virtual) method + my ($class,$menu,$minfo) = @_; +} + +sub new +{ + my ($class,$menu,%minfo) = @_; + my $kind = $class->kind; + my $name = $minfo{'-label'}; + if (defined $kind) + { + my $invoke = delete $minfo{'-invoke'}; + if (defined $name) + { + # Use ~ in name/label to set -underline + if (defined($minfo{-label}) && !defined($minfo{-underline})) + { + my $cleanlabel = $minfo{-label}; + my $underline = ($cleanlabel =~ s/^(.*)~/$1/) ? length($1): undef; + if (defined($underline) && ($underline >= 0)) + { + $minfo{-underline} = $underline; + $name = $cleanlabel if ($minfo{-label} eq $name); + $minfo{-label} = $cleanlabel; + } + } + } + else + { + $name = $minfo{'-bitmap'} || $minfo{'-image'}; + croak('No -label') unless defined($name); + $minfo{'-label'} = $name; + } + $class->PreInit($menu,\%minfo); + $menu->add($kind,%minfo); + $menu->invoke('last') if ($invoke); + } + else + { + $menu->add('separator'); + } + return bless [$menu,$name],$class; +} + +sub configure +{ + my $obj = shift; + my ($menu,$name) = @$obj; + my %args = @_; + $obj->[1] = $args{'-label'} if exists $args{'-label'}; + $menu->entryconfigure($name,@_); +} + +sub cget +{ + my $obj = shift; + my ($menu,$name) = @$obj; + $menu->entrycget($name,@_); +} + +sub parentMenu +{ + my $obj = shift; + return $obj->[0]; +} + +# Default "kind" is a command +sub kind { return 'command' } + +# Now the derived packages + +package Tk::Menu::Separator; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Separator'; +sub kind { return undef } + +package Tk::Menu::Button; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Button'; +Construct Tk::Menu 'Command'; + +#package Tk::Menu::Command; +#use base qw(Tk::Menu::Button); +#Construct Tk::Menu 'Command'; + +package Tk::Menu::Cascade; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Cascade'; +sub kind { return 'cascade' } +use Carp; + +sub PreInit +{ + my ($class,$menu,$minfo) = @_; + my $tearoff = delete $minfo->{-tearoff}; + my $items = delete $minfo->{-menuitems}; + my $widgetvar = delete $minfo->{-menuvar}; + my $command = delete $minfo->{-postcommand}; + my $name = delete $minfo->{'Name'}; + $name = $minfo->{'-label'} unless defined $name; + my @args = (); + push(@args, '-tearoff' => $tearoff) if (defined $tearoff); + push(@args, '-menuitems' => $items) if (defined $items); + push(@args, '-postcommand' => $command) if (defined $command); + my $submenu = $minfo->{'-menu'}; + unless (defined $submenu) + { + $minfo->{'-menu'} = $submenu = $menu->Menu(Name => $name, @args); + } + $$widgetvar = $submenu if (defined($widgetvar) && ref($widgetvar)); +} + +sub menu +{ + my ($self,%args) = @_; + my $w = $self->parentMenu; + my $menu = $self->cget('-menu'); + if (!defined $menu) + { + require Tk::Menu; + $w->ColorOptions(\%args); + my $name = $self->cget('-label'); + warn "Had to (re-)reate menu for $name"; + $menu = $w->Menu(Name => $name, %args); + $self->configure('-menu'=>$menu); + } + else + { + $menu->configure(%args) if %args; + } + return $menu; +} + +# Some convenience methods + +sub separator { shift->menu->Separator(@_); } +sub command { shift->menu->Command(@_); } +sub cascade { shift->menu->Cascade(@_); } +sub checkbutton { shift->menu->Checkbutton(@_); } +sub radiobutton { shift->menu->Radiobutton(@_); } + +sub pack +{ + my $w = shift; + if ($^W) + { + require Carp; + Carp::carp("Cannot 'pack' $w - done automatically") + } +} + +package Tk::Menu::Checkbutton; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Checkbutton'; +sub kind { return 'checkbutton' } + +package Tk::Menu::Radiobutton; +use base qw(Tk::Menu::Item); +Construct Tk::Menu 'Radiobutton'; +sub kind { return 'radiobutton' } + +package Tk::Menu::Item; + +1; +__END__ + +=cut + diff --git a/Master/tlpkg/installer/perllib/Tk/ProgressBar.pm b/Master/tlpkg/installer/perllib/Tk/ProgressBar.pm new file mode 100644 index 00000000000..206d843ea13 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/ProgressBar.pm @@ -0,0 +1,498 @@ +package Tk::ProgressBar; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; + +use Tk; +use Tk::Canvas; +use Tk::Trace; +use Carp; +use strict; + +use base qw(Tk::Derived Tk::Canvas); + +Construct Tk::Widget 'ProgressBar'; + +sub ClassInit { + my ($class,$mw) = @_; + + $class->SUPER::ClassInit($mw); + + $mw->bind($class,'', ['_layoutRequest',1]); +} + + +sub Populate { + my($c,$args) = @_; + + $c->ConfigSpecs( + -width => [PASSIVE => undef, undef, 0], + '-length' => [PASSIVE => undef, undef, 0], + -from => [PASSIVE => undef, undef, 0], + -to => [PASSIVE => undef, undef, 100], + -blocks => [PASSIVE => undef, undef, 10], + -padx => [PASSIVE => 'padX', 'Pad', 0], + -pady => [PASSIVE => 'padY', 'Pad', 0], + -gap => [PASSIVE => undef, undef, 1], + -colors => [PASSIVE => undef, undef, undef], + -relief => [SELF => 'relief', 'Relief', 'sunken'], + -value => [METHOD => undef, undef, undef], + -variable => [METHOD => undef, undef, undef], + -anchor => [METHOD => 'anchor', 'Anchor', 'w'], + -resolution + => [PASSIVE => undef, undef, 1.0], + -highlightthickness + => [SELF => 'highlightThickness','HighlightThickness',0], + -troughcolor + => [PASSIVE => 'troughColor', 'Background', 'grey55'], + ); + _layoutRequest($c,1); + $c->OnDestroy(['Destroyed' => $c]); +} + +sub anchor { + my $c = shift; + my $var = \$c->{Configure}{'-anchor'}; + my $old = $$var; + + if(@_) { + my $new = shift; + croak "bad anchor position \"$new\": must be n, s, w or e" + unless $new =~ /^[news]$/; + $$var = $new; + } + + $old; +} + +sub _layoutRequest { + my $c = shift; + my $why = shift; + $c->afterIdle(['_arrange',$c]) unless $c->{'layout_pending'}; + $c->{'layout_pending'} |= $why; +} + +sub _arrange { + my $c = shift; + my $why = $c->{'layout_pending'}; + + $c->{'layout_pending'} = 0; + + my $w = $c->Width; + my $h = $c->Height; + my $bw = $c->cget('-borderwidth') + $c->cget('-highlightthickness'); + my $x = abs(int($c->{Configure}{'-padx'})) + $bw; + my $y = abs(int($c->{Configure}{'-pady'})) + $bw; + my $value = $c->value; + my $from = $c->{Configure}{'-from'}; + my $to = $c->{Configure}{'-to'}; + my $horz = $c->{Configure}{'-anchor'} =~ /[ew]/i ? 1 : 0; + my $dir = $c->{Configure}{'-anchor'} =~ /[se]/i ? -1 : 1; + + my($minv,$maxv) = $from < $to ? ($from,$to) : ($to,$from); + + if($w == 1 && $h == 1) { + my $bw = $c->cget('-borderwidth'); + my $defw = 10 + $y*2 + $bw *2; + my $defl = ($maxv - $minv) + $x*2 + $bw*2; + + $h = $c->pixels($c->{Configure}{'-length'}) || $defl; + $w = $c->pixels($c->{Configure}{'-width'}) || $defw; + + ($w,$h) = ($h,$w) if $horz; + $c->GeometryRequest($w,$h); + $c->parent->update; + $c->update; + + $w = $c->Width; + $h = $c->Height; + } + + $w -= $x*2; + $h -= $y*2; + + my $length = $horz ? $w : $h; + my $width = $horz ? $h : $w; + + my $blocks = int($c->{Configure}{'-blocks'}); + my $gap = int($c->{Configure}{'-gap'}); + + $blocks = 1 if $blocks < 1; + + my $gwidth = $gap * ( $blocks - 1); + my $bwidth = ($length - $gwidth) / $blocks; + + if($bwidth < 3 || $blocks <= 1 || $gap <= 0) { + $blocks = 1; + $bwidth = $length; + $gap = 0; + } + + if($why & 1) { + my $colors = $c->{Configure}{'-colors'} || []; + my $bdir = $from < $to ? $dir : 0 - $dir; + + $c->delete($c->find('all')); + + $c->createRectangle(0,0,$w+$x*2,$h+$y*2, + -fill => $c->{Configure}{'-troughcolor'}, + -width => 0, + -outline => undef); + + $c->{'cover'} = $c->createRectangle($x,$y,$w,$h, + -fill => $c->{Configure}{'-troughcolor'}, + -width => 0, + -outline => undef); + + my($x0,$y0,$x1,$y1); + + if($horz) { + if($bdir > 0) { + ($x0,$y0) = ($x - $gap,$y); + } + else { + ($x0,$y0) = ($length + $x + $gap,$y); + } + ($x1,$y1) = ($x0,$y0 + $width); + } + else { + if($bdir > 0) { + ($x0,$y0) = ($x,$y - $gap); + } + else { + ($x0,$y0) = ($x,$length + $y + $gap); + } + ($x1,$y1) = ($x0 + $width,$y0); + } + + my $blks = $blocks; + my $dval = ($maxv - $minv) / $blocks; + my $color = $c->cget('-foreground'); + my $pos = 0; + my $val = $minv; + + while($val < $maxv) { + my($bw,$nval); + + while(($pos < @$colors) && $colors->[$pos] <= $val) { + $color = $colors->[$pos+1]; + $pos += 2; + } + + if($blocks == 1) { + $nval = defined($colors->[$pos]) + ? $colors->[$pos] : $maxv; + $bw = (($nval - $val) / ($maxv - $minv)) * $length; + } + else { + $bw = $bwidth; + $nval = $val + $dval if($blocks > 1); + } + + if($horz) { + if($bdir > 0) { + $x0 = $x1 + $gap; + $x1 = $x0 + $bw; + } + else { + $x1 = $x0 - $gap; + $x0 = $x1 - $bw; + } + } + else { + if($bdir > 0) { + $y0 = $y1 + $gap; + $y1 = $y0 + $bw; + } + else { + $y1 = $y0 - $gap; + $y0 = $y1 - $bw; + } + } + + $c->createRectangle($x0,$y0,$x1,$y1, + -fill => $color, + -width => 0, + -outline => undef + ); + $val = $nval; + } + } + + my $cover = $c->{'cover'}; + my $ddir = $from > $to ? 1 : -1; + + if(($value <=> $to) == (0-$ddir)) { + $c->lower($cover); + } + elsif(($value <=> $from) == $ddir) { + $c->raise($cover); + my $x1 = $horz ? $x + $length : $x + $width; + my $y1 = $horz ? $y + $width : $y + $length; + $c->coords($cover,$x,$y,$x1,$y1); + } + else { + my $step; + $value = int($value / $step) * $step + if(defined($step = $c->{Configure}{'-resolution'}) && $step > 0); + + $maxv = $minv+1 + if $minv == $maxv; + + my $range = $maxv - $minv; + my $bval = $range / $blocks; + my $offset = abs($value - $from); + my $ioff = int($offset / $bval); + my $start = $ioff * ($bwidth + $gap); + $start += ($offset - ($ioff * $bval)) / $bval * $bwidth; + + my($x0,$x1,$y0,$y1); + + if($horz) { + $y0 = $y; + $y1 = $y + $h; + if($dir > 0) { + $x0 = $x + $start; + $x1 = $x + $w; + } + else { + $x0 = $x; + $x1 = $w + $x - $start; + } + } + else { + $x0 = $x; + $x1 = $x + $w; + if($dir > 0) { + $y0 = $y + $start; + $y1 = $y + $h; + } + else { + $y0 = $y; + $y1 = $h + $y - $start; + } + } + + + $c->raise($cover); + $c->coords($cover,$x0,$y0,$x1,$y1); + } +} + +sub value { + my $c = shift; + my $val = defined($c->{'-variable'}) + ? $c->{'-variable'} + : \$c->{'-value'}; + my $old = defined($$val) ? $$val : $c->{Configure}{'-from'}; + + if(@_) { + my $value = shift; + $$val = defined($value) ? $value : $c->{Configure}{'-from'}; + _layoutRequest($c,2); + } + + $old; +} + +sub variable { + my $c = shift; + my $oldvarref = $c->{'-variable'}; + my $oldval = $$oldvarref if $oldvarref; + if(@_) { + my $varref = shift; + if ($oldvarref) + { + $c->traceVdelete($oldvarref); + } + $c->{'-variable'} = $varref; + $c->traceVariable($varref, 'w', sub { $c->value($_[1]) }); + $$varref = $oldval; + _layoutRequest($c,2); + } + $oldval; +} + +sub Destroyed +{ + my $c = shift; + my $var = delete $c->{'-variable'}; + $c->traceVdelete($var); +} + +1; +__END__ + +=head1 NAME + +Tk::ProgressBar - A graphical progress bar + +=for category Derived Widgets + +=head1 SYNOPSIS + + use Tk::ProgressBar; + + $progress = $parent->ProgressBar( + -width => 200, + -length => 20, + -anchor => 's', + -from => 0, + -to => 100, + -blocks => 10, + -colors => [0, 'green', 50, 'yellow' , 80, 'red'], + -variable => \$percent_done + ); + + $progress->value($position); + +=head1 DESCRIPTION + +B provides a widget which will show a graphical representation +of a value, given maximum and minimum reference values. + +=head1 STANDARD OPTIONS + +The following standard widget options are supported: + +=over 4 + +=item B<-borderwidth> + +=item B<-highlightthickness> + +Defaults to 0. + +=item B<-padx> + +Defaults to 0. + +=item B<-pady> + +Defaults to 0. + +=item B<-relief> + +Defaults to C + +=item B<-troughcolor> + +The color to be used for the background (trough) of the progress bar. +Default is to use grey55. + +=back + +=head1 WIDGET-SPECIFIC OPTIONS + +=over 4 + +=item B<-anchor> + +This can be used to position the start point of the bar. Default +is 'w' (horizontal bar starting from the left). A vertical bar can be +configured by using either 's' or 'n'. + +=item B<-blocks> + +This controls the number of blocks to be used to construct the progress +bar. The default is to break the bar into 10 blocks. + +=item B<-colors> + +Controls the colors to be used for different positions of the progress bar. +The colors should be supplied as a reference to an array containing pairs +of positions and colors. + + -colors => [ 0, 'green', 50, 'red' ] + +means that for the range 0 to 50 the progress bar should be green +and for higher values it should be red. + + +=item B<-from> + +This sets the lower limit of the progress bar. If the bar is set to a +value below the lower limt no bar will be displayed. Defaults to 0. +See the C<-to> description for more information. + +=item B<-gap> + +This is the spacing (in pixels) between each block. Defaults to 1. +Use 0 to get a continuous bar. + + +=item B<-length> + +Specifies the desired long dimension of the ProgressBar in screen +units (i.e. any of the forms acceptable to Tk_GetPixels). For vertical +ProgressBars this is the ProgressBars height; for horizontal scales it +is the ProgressBars width. The default length is calculated from the +values of C<-padx>, C<-borderwidth>, C<-highlightthickness> and the +difference between C<-from> and C<-to>. + + +=item B<-resolution> + +A real value specifying the resolution for the scale. If this value is greater +than zero then the scale's value will always be rounded to an even multiple of +this value, as will tick marks and the endpoints of the scale. If the value is +less than zero then no rounding occurs. Defaults to 1 (i.e., the value will be +integral). + +=item B<-to> + +This sets the upper limit of the progress bar. If a value is specified +(for example, using the C method) that lies above this value the +full progress bar will be displayed. Defaults to 100. + + + +=item B<-variable> + +Specifies the reference to a scalar variable to link to the ProgressBar. +Whenever the value of the variable changes, the ProgressBar will upate +to reflect this value. (See also the B method below.) + +=item B<-value> + +The can be used to set the current position of the progress bar +when used in conjunction with the standard C. It is +usually recommended to use the B method instead. + + +=item B<-width> + +Specifies the desired narrow dimension of the ProgressBar in screen +units (i.e. any of the forms acceptable to Tk_GetPixels). For +vertical ProgressBars this is the ProgressBars width; for horizontal +bars this is the ProgressBars height. The default width is derived +from the values of C<-borderwidth> and C<-pady> and C<-highlightthickness>. + +=back + +=head1 WIDGET METHODS + +=over 4 + +=item I<$ProgressBar>-EB(?I?) + +If I is omitted, returns the current value of the ProgressBar. If +I is given, the value of the ProgressBar is set. If I<$value> is +given but undefined the value of the option B<-from> is used. + +=back + + +=head1 AUTHOR + +Graham Barr EFE + +=head1 COPYRIGHT + +Copyright (c) 1997-1998 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/installer/perllib/Tk/ROText.pm b/Master/tlpkg/installer/perllib/Tk/ROText.pm new file mode 100644 index 00000000000..cc5634f5475 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/ROText.pm @@ -0,0 +1,43 @@ +# 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::ROText; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #10 $ =~ /\D(\d+)\s*$/; + +use Tk::Text; +use base qw(Tk::Derived Tk::Text); + +Construct Tk::Widget 'ROText'; + +sub clipEvents +{ + return qw[Copy]; +} + +sub ClassInit +{ + my ($class,$mw) = @_; + my $val = $class->bindRdOnly($mw); + my $cb = $mw->bind($class,''); + $mw->bind($class,'',$cb) if (defined $cb); + $cb = $mw->bind($class,''); + $mw->bind($class,'',$cb) if (defined $cb); + $class->clipboardOperations($mw,'Copy'); + return $val; +} + +sub Populate { + my($self,$args) = @_; + $self->SUPER::Populate($args); + my $m = $self->menu->entrycget($self->menu->index('Search'), '-menu'); + $m->delete($m->index('Replace')); +} + +sub Tk::Widget::ScrlROText { shift->Scrolled('ROText' => @_) } + +1; + +__END__ + diff --git a/Master/tlpkg/installer/perllib/Tk/Scrollbar.pm b/Master/tlpkg/installer/perllib/Tk/Scrollbar.pm new file mode 100644 index 00000000000..6b416e04b30 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Scrollbar.pm @@ -0,0 +1,429 @@ +# Conversion from Tk4.0 scrollbar.tcl competed. +package Tk::Scrollbar; + +use vars qw($VERSION); +$VERSION = '4.010'; # $Id: //depot/Tkutf8/Scrollbar/Scrollbar.pm#10 $ + +use Tk qw($XS_VERSION Ev); +use AutoLoader; + +use base qw(Tk::Widget); + +#use strict; +#use vars qw($pressX $pressY @initValues $initPos $activeBg); + +Construct Tk::Widget 'Scrollbar'; + +bootstrap Tk::Scrollbar; + +sub Tk_cmd { \&Tk::scrollbar } + +Tk::Methods('activate','delta','fraction','get','identify','set'); + +sub Needed +{ + my ($sb) = @_; + my @val = $sb->get; + return 1 unless (@val == 2); + return 1 if $val[0] != 0.0; + return 1 if $val[1] != 1.0; + return 0; +} + + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class, '', 'Enter'); + $mw->bind($class, '', 'Motion'); + $mw->bind($class, '', 'Leave'); + + $mw->bind($class, '<1>', 'ButtonDown'); + $mw->bind($class, '', ['Drag', Ev('x'), Ev('y')]); + $mw->bind($class, '', 'ButtonUp'); + $mw->bind($class, '', 'NoOp'); # prevent generic + $mw->bind($class, '', 'NoOp'); # prevent generic + $mw->bind($class, '', 'ScrlTopBottom'); + + $mw->bind($class, '<2>', 'ButtonDown'); + $mw->bind($class, '', ['Drag', Ev('x'), Ev('y')]); + $mw->bind($class, '', 'ButtonUp'); + $mw->bind($class, '', 'NoOp'); # prevent generic + $mw->bind($class, '', 'NoOp'); # prevent generic + $mw->bind($class, '', 'ScrlTopBottom'); + + $mw->bind($class, '', ['ScrlByUnits','v',-1]); + $mw->bind($class, '', ['ScrlByUnits','v', 1]); + $mw->bind($class, '', ['ScrlByPages','v',-1]); + $mw->bind($class, '', ['ScrlByPages','v', 1]); + + $mw->bind($class, '', ['ScrlByUnits','h',-1]); + $mw->bind($class, '', ['ScrlByUnits','h', 1]); + $mw->bind($class, '', ['ScrlByPages','h',-1]); + $mw->bind($class, '', ['ScrlByPages','h', 1]); + + $mw->bind($class, '', ['ScrlByPages','hv',-1]); + $mw->bind($class, '', ['ScrlByPages','hv', 1]); + + # X11 mousewheel - honour for horizontal too. + $mw->bind($class, '<4>', ['ScrlByUnits','hv',-5]); + $mw->bind($class, '<5>', ['ScrlByUnits','hv', 5]); + + $mw->bind($class, '', ['ScrlToPos', 0]); + $mw->bind($class, '', ['ScrlToPos', 1]); + + $mw->bind($class, '<4>', ['ScrlByUnits','v',-3]); + $mw->bind($class, '<5>', ['ScrlByUnits','v', 3]); + + return $class; + +} + +1; + +__END__ + +sub Enter +{ + my $w = shift; + my $e = $w->XEvent; + if ($Tk::strictMotif) + { + my $bg = $w->cget('-background'); + $activeBg = $w->cget('-activebackground'); + $w->configure('-activebackground' => $bg); + } + $w->activate($w->identify($e->x,$e->y)); +} + +sub Leave +{ + my $w = shift; + if ($Tk::strictMotif) + { + $w->configure('-activebackground' => $activeBg) if (defined $activeBg) ; + } + $w->activate(''); +} + +sub Motion +{ + my $w = shift; + my $e = $w->XEvent; + $w->activate($w->identify($e->x,$e->y)); +} + +# tkScrollButtonDown -- +# This procedure is invoked when a button is pressed in a scrollbar. +# It changes the way the scrollbar is displayed and takes actions +# depending on where the mouse is. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates. + +sub ButtonDown +{my $w = shift; + my $e = $w->XEvent; + my $element = $w->identify($e->x,$e->y); + $w->configure('-activerelief' => 'sunken'); + if ($e->b == 1 and + (defined($element) && $element eq 'slider')) + { + $w->StartDrag($e->x,$e->y); + } + elsif ($e->b == 2 and + (defined($element) && $element =~ /^(trough[12]|slider)$/o)) + { + my $pos = $w->fraction($e->x, $e->y); + my($head, $tail) = $w->get; + my $len = $tail - $head; + + $head = $pos - $len/2; + $tail = $pos + $len/2; + if ($head < 0) { + $head = 0; + $tail = $len; + } + elsif ($tail > 1) { + $head = 1 - $len; + $tail = 1; + } + $w->ScrlToPos($head); + $w->set($head, $tail); + + $w->StartDrag($e->x,$e->y); + } + else + { + $w->Select($element,'initial'); + } +} + +# tkScrollButtonUp -- +# This procedure is invoked when a button is released in a scrollbar. +# It cancels scans and auto-repeats that were in progress, and restores +# the way the active element is displayed. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates. + +sub ButtonUp +{my $w = shift; + my $e = $w->XEvent; + $w->CancelRepeat; + $w->configure('-activerelief' => 'raised'); + $w->EndDrag($e->x,$e->y); + $w->activate($w->identify($e->x,$e->y)); +} + +# tkScrollSelect -- +# This procedure is invoked when button 1 is pressed over the scrollbar. +# It invokes one of several scrolling actions depending on where in +# the scrollbar the button was pressed. +# +# Arguments: +# w - The scrollbar widget. +# element - The element of the scrollbar that was selected, such +# as "arrow1" or "trough2". Shouldn't be "slider". +# repeat - Whether and how to auto-repeat the action: "noRepeat" +# means don't auto-repeat, "initial" means this is the +# first action in an auto-repeat sequence, and "again" +# means this is the second repetition or later. + +sub Select +{ + my $w = shift; + my $element = shift; + my $repeat = shift; + return unless defined ($element); + if ($element eq 'arrow1') + { + $w->ScrlByUnits('hv',-1); + } + elsif ($element eq 'trough1') + { + $w->ScrlByPages('hv',-1); + } + elsif ($element eq 'trough2') + { + $w->ScrlByPages('hv', 1); + } + elsif ($element eq 'arrow2') + { + $w->ScrlByUnits('hv', 1); + } + else + { + return; + } + + if ($repeat eq 'again') + { + $w->RepeatId($w->after($w->cget('-repeatinterval'),['Select',$w,$element,'again'])); + } + elsif ($repeat eq 'initial') + { + $w->RepeatId($w->after($w->cget('-repeatdelay'),['Select',$w,$element,'again'])); + } +} + +# tkScrollStartDrag -- +# This procedure is called to initiate a drag of the slider. It just +# remembers the starting position of the slider. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The mouse position at the start of the drag operation. + +sub StartDrag +{ + my($w,$x,$y) = @_; + return unless (defined ($w->cget('-command'))); + $pressX = $x; + $pressY = $y; + @initValues = $w->get; + my $iv0 = $initValues[0]; + if (@initValues == 2) + { + $initPos = $iv0; + } + elsif ($iv0 == 0) + { + $initPos = 0; + } + else + { + $initPos = $initValues[2]/$initValues[0]; + } +} + +# tkScrollDrag -- +# This procedure is called for each mouse motion even when the slider +# is being dragged. It notifies the associated widget if we're not +# jump scrolling, and it just updates the scrollbar if we are jump +# scrolling. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The current mouse position. + +sub Drag +{ + my($w,$x,$y) = @_; + return if !defined $initPos; + my $delta = $w->delta($x-$pressX, $y-$pressY); + if ($w->cget('-jump')) + { + if (@initValues == 2) + { + $w->set($initValues[0]+$delta, $initValues[1]+$delta); + } + else + { + $delta = sprintf "%d", $delta * $initValues[0]; # round() + $initValues[2] += $delta; + $initValues[3] += $delta; + $w->set(@initValues[2,3]); + } + } + else + { + $w->ScrlToPos($initPos+$delta); + } +} + +# tkScrollEndDrag -- +# This procedure is called to end an interactive drag of the slider. +# It scrolls the window if we're in jump mode, otherwise it does nothing. +# +# Arguments: +# w - The scrollbar widget. +# x, y - The mouse position at the end of the drag operation. + +sub EndDrag +{ + my($w,$x,$y) = @_; + return if (!defined $initPos); + if ($w->cget('-jump')) + { + my $delta = $w->delta($x-$pressX, $y-$pressY); + $w->ScrlToPos($initPos+$delta); + } + undef $initPos; +} + +# tkScrlByUnits -- +# This procedure tells the scrollbar's associated widget to scroll up +# or down by a given number of units. It notifies the associated widget +# in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# orient - Which kinds of scrollbars this applies to: "h" for +# horizontal, "v" for vertical, "hv" for both. +# amount - How many units to scroll: typically 1 or -1. + +sub ScrlByUnits +{my $w = shift; + my $orient = shift; + my $amount = shift; + my $cmd = $w->cget('-command'); + return unless (defined $cmd); + return if (index($orient,substr($w->cget('-orient'),0,1)) < 0); + my @info = $w->get; + if (@info == 2) + { + $cmd->Call('scroll',$amount,'units'); + } + else + { + $cmd->Call($info[2]+$amount); + } +} + +# tkScrlByPages -- +# This procedure tells the scrollbar's associated widget to scroll up +# or down by a given number of screenfuls. It notifies the associated +# widget in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# orient - Which kinds of scrollbars this applies to: "h" for +# horizontal, "v" for vertical, "hv" for both. +# amount - How many screens to scroll: typically 1 or -1. + +sub ScrlByPages +{ + my $w = shift; + my $orient = shift; + my $amount = shift; + my $cmd = $w->cget('-command'); + return unless (defined $cmd); + return if (index($orient,substr($w->cget('-orient'),0,1)) < 0); + my @info = $w->get; + if (@info == 2) + { + $cmd->Call('scroll',$amount,'pages'); + } + else + { + $cmd->Call($info[2]+$amount*($info[1]-1)); + } +} + +# tkScrlToPos -- +# This procedure tells the scrollbar's associated widget to scroll to +# a particular location, given by a fraction between 0 and 1. It notifies +# the associated widget in different ways for old and new command syntaxes. +# +# Arguments: +# w - The scrollbar widget. +# pos - A fraction between 0 and 1 indicating a desired position +# in the document. + +sub ScrlToPos +{ + my $w = shift; + my $pos = shift; + my $cmd = $w->cget('-command'); + return unless (defined $cmd); + my @info = $w->get; + if (@info == 2) + { + $cmd->Call('moveto',$pos); + } + else + { + $cmd->Call(int($info[0]*$pos)); + } +} + +# tkScrlTopBottom +# Scroll to the top or bottom of the document, depending on the mouse +# position. +# +# Arguments: +# w - The scrollbar widget. +# x, y - Mouse coordinates within the widget. + +sub ScrlTopBottom +{ + my $w = shift; + my $e = $w->XEvent; + my $element = $w->identify($e->x,$e->y); + return unless ($element); + if ($element =~ /1$/) + { + $w->ScrlToPos(0); + } + elsif ($element =~ /2$/) + { + $w->ScrlToPos(1); + } +} + + + + diff --git a/Master/tlpkg/installer/perllib/Tk/Text.pm b/Master/tlpkg/installer/perllib/Tk/Text.pm new file mode 100644 index 00000000000..fe0aa0bf4c1 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tk/Text.pm @@ -0,0 +1,1653 @@ +# text.tcl -- +# +# This file defines the default bindings for Tk text widgets. +# +# @(#) text.tcl 1.18 94/12/17 16:05:26 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# perl/Tk version: +# Copyright (c) 1995-2004 Nick Ing-Simmons +# Copyright (c) 1999 Greg London +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +package Tk::Text; +use AutoLoader; +use Carp; +use strict; + +use Text::Tabs; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d', q$Revision: #24 $ =~ /\D(\d+)\s*$/; + +use Tk qw(Ev $XS_VERSION); +use base qw(Tk::Clipboard Tk::Widget); + +Construct Tk::Widget 'Text'; + +bootstrap Tk::Text; + +sub Tk_cmd { \&Tk::text } + +sub Tk::Widget::ScrlText { shift->Scrolled('Text' => @_) } + +Tk::Methods('bbox','compare','debug','delete','dlineinfo','dump','edit', + 'get','image','index','insert','mark','scan','search', + 'see','tag','window','xview','yview'); + +use Tk::Submethods ( 'mark' => [qw(gravity names next previous set unset)], + 'scan' => [qw(mark dragto)], + 'tag' => [qw(add bind cget configure delete lower + names nextrange prevrange raise ranges remove)], + 'window' => [qw(cget configure create names)], + 'image' => [qw(cget configure create names)], + 'xview' => [qw(moveto scroll)], + 'yview' => [qw(moveto scroll)], + 'edit' => [qw(modified redo reset separator undo)], + ); + +sub Tag; +sub Tags; + +sub bindRdOnly +{ + + my ($class,$mw) = @_; + + # Standard Motif bindings: + $mw->bind($class,'','NoOp'); + $mw->bind($class,'','NoOp'); + $mw->bind($class,'','NoOp'); + $mw->bind($class,'','unselectAll'); + + $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]); + $mw->bind($class,'','B1_Motion' ) ; + $mw->bind($class,'','B1_Leave' ) ; + $mw->bind($class,'','CancelRepeat'); + $mw->bind($class,'','CancelRepeat'); + $mw->bind($class,'',['markSet','insert',Ev('@')]); + + $mw->bind($class,'','selectWord' ) ; + $mw->bind($class,'','selectLine' ) ; + $mw->bind($class,'','adjustSelect' ) ; + $mw->bind($class,'',['SelectTo',Ev('@'),'word']); + $mw->bind($class,'',['SelectTo',Ev('@'),'line']); + + $mw->bind($class,'',['SetCursor',Ev('index','insert-1c')]); + $mw->bind($class,'',['KeySelect',Ev('index','insert-1c')]); + $mw->bind($class,'',['SetCursor',Ev('index','insert-1c wordstart')]); + $mw->bind($class,'',['KeySelect',Ev('index','insert-1c wordstart')]); + + $mw->bind($class,'',['SetCursor',Ev('index','insert+1c')]); + $mw->bind($class,'',['KeySelect',Ev('index','insert+1c')]); + $mw->bind($class,'',['SetCursor',Ev('index','insert+1c wordend')]); + $mw->bind($class,'',['KeySelect',Ev('index','insert wordend')]); + + $mw->bind($class,'',['SetCursor',Ev('UpDownLine',-1)]); + $mw->bind($class,'',['KeySelect',Ev('UpDownLine',-1)]); + $mw->bind($class,'',['SetCursor',Ev('PrevPara','insert')]); + $mw->bind($class,'',['KeySelect',Ev('PrevPara','insert')]); + + $mw->bind($class,'',['SetCursor',Ev('UpDownLine',1)]); + $mw->bind($class,'',['KeySelect',Ev('UpDownLine',1)]); + $mw->bind($class,'',['SetCursor',Ev('NextPara','insert')]); + $mw->bind($class,'',['KeySelect',Ev('NextPara','insert')]); + + $mw->bind($class,'',['SetCursor','insert linestart']); + $mw->bind($class,'',['KeySelect','insert linestart']); + $mw->bind($class,'',['SetCursor','1.0']); + $mw->bind($class,'',['KeySelect','1.0']); + + $mw->bind($class,'',['SetCursor','insert lineend']); + $mw->bind($class,'',['KeySelect','insert lineend']); + $mw->bind($class,'',['SetCursor','end-1char']); + $mw->bind($class,'',['KeySelect','end-1char']); + + $mw->bind($class,'',['SetCursor',Ev('ScrollPages',-1)]); + $mw->bind($class,'',['KeySelect',Ev('ScrollPages',-1)]); + $mw->bind($class,'',['xview','scroll',-1,'page']); + + $mw->bind($class,'',['SetCursor',Ev('ScrollPages',1)]); + $mw->bind($class,'',['KeySelect',Ev('ScrollPages',1)]); + $mw->bind($class,'',['xview','scroll',1,'page']); + + $mw->bind($class,'', 'NoOp'); # Needed only to keep binding from triggering; does not have to actually do anything. + $mw->bind($class,'','focusNext'); + $mw->bind($class,'','focusPrev'); + + $mw->bind($class,'',['markSet','anchor','insert']); + $mw->bind($class,'