From fbf4a6e8014789c67a381e0b4f05de5bdadbce24 Mon Sep 17 00:00:00 2001 From: Staszek Wawrykiewicz Date: Mon, 18 Dec 2006 03:24:34 +0000 Subject: perltl added git-svn-id: svn://tug.org/texlive/trunk@2778 c570f23f-e606-0410-a88d-b1316a301751 --- Master/perltl/site/lib/Tk.pm | 696 +++++++++ Master/perltl/site/lib/Tk/Adjuster.pm | 435 ++++++ Master/perltl/site/lib/Tk/After.pm | 88 ++ Master/perltl/site/lib/Tk/Bitmap.pm | 18 + Master/perltl/site/lib/Tk/Button.pm | 148 ++ Master/perltl/site/lib/Tk/Camel.xpm | 41 + Master/perltl/site/lib/Tk/Canvas.pm | 60 + Master/perltl/site/lib/Tk/Checkbutton.pm | 42 + Master/perltl/site/lib/Tk/Clipboard.pm | 110 ++ Master/perltl/site/lib/Tk/CmdLine.pm | 954 ++++++++++++ Master/perltl/site/lib/Tk/ColorEdit.xpm | 58 + Master/perltl/site/lib/Tk/ColorEditor.pm | 759 ++++++++++ Master/perltl/site/lib/Tk/Config.pm | 12 + Master/perltl/site/lib/Tk/Configure.pm | 69 + Master/perltl/site/lib/Tk/Derived.pm | 510 +++++++ Master/perltl/site/lib/Tk/Dialog.pm | 70 + Master/perltl/site/lib/Tk/DialogBox.pm | 115 ++ Master/perltl/site/lib/Tk/Entry.pm | 517 +++++++ Master/perltl/site/lib/Tk/Event.pm | 13 + Master/perltl/site/lib/Tk/Event/IO.pm | 122 ++ Master/perltl/site/lib/Tk/FBox.pm | 891 +++++++++++ Master/perltl/site/lib/Tk/Frame.pm | 373 +++++ Master/perltl/site/lib/Tk/IconList.pm | 536 +++++++ Master/perltl/site/lib/Tk/Image.pm | 73 + Master/perltl/site/lib/Tk/Label.pm | 21 + Master/perltl/site/lib/Tk/Listbox.pm | 856 +++++++++++ Master/perltl/site/lib/Tk/MainWindow.pm | 188 +++ Master/perltl/site/lib/Tk/Menu.pm | 1130 ++++++++++++++ Master/perltl/site/lib/Tk/Menu/Item.pm | 180 +++ Master/perltl/site/lib/Tk/Menubutton.pm | 398 +++++ Master/perltl/site/lib/Tk/Optionmenu.pm | 110 ++ Master/perltl/site/lib/Tk/Pixmap.pm | 19 + Master/perltl/site/lib/Tk/Pretty.pm | 93 ++ Master/perltl/site/lib/Tk/ROText.pm | 36 + Master/perltl/site/lib/Tk/Radiobutton.pm | 45 + Master/perltl/site/lib/Tk/Scale.pm | 278 ++++ Master/perltl/site/lib/Tk/Scrollbar.pm | 414 +++++ Master/perltl/site/lib/Tk/Submethods.pm | 46 + Master/perltl/site/lib/Tk/Text.pm | 1600 ++++++++++++++++++++ Master/perltl/site/lib/Tk/Text/Tag.pm | 46 + Master/perltl/site/lib/Tk/Tk.xbm | 44 + Master/perltl/site/lib/Tk/Tk.xpm | 41 + Master/perltl/site/lib/Tk/Toplevel.pm | 211 +++ Master/perltl/site/lib/Tk/Widget.pm | 1298 ++++++++++++++++ Master/perltl/site/lib/Tk/Wm.pm | 165 ++ Master/perltl/site/lib/Tk/X.pm | 398 +++++ Master/perltl/site/lib/Tk/X11/license.terms | 32 + Master/perltl/site/lib/Tk/Xcamel.gif | Bin 0 -> 4193 bytes Master/perltl/site/lib/Tk/act_folder.xbm | 5 + Master/perltl/site/lib/Tk/act_folder.xpm | 22 + Master/perltl/site/lib/Tk/anim.gif | Bin 0 -> 2533 bytes Master/perltl/site/lib/Tk/balArrow.xbm | 4 + Master/perltl/site/lib/Tk/cbxarrow.xbm | 6 + Master/perltl/site/lib/Tk/file.xbm | 5 + Master/perltl/site/lib/Tk/file.xpm | 18 + Master/perltl/site/lib/Tk/folder.xbm | 5 + Master/perltl/site/lib/Tk/folder.xpm | 21 + Master/perltl/site/lib/Tk/icon.gif | Bin 0 -> 1924 bytes Master/perltl/site/lib/Tk/license.terms | 35 + Master/perltl/site/lib/Tk/openfile.xbm | 5 + Master/perltl/site/lib/Tk/openfolder.xbm | 5 + Master/perltl/site/lib/Tk/openfolder.xpm | 21 + Master/perltl/site/lib/Tk/prolog.ps | 284 ++++ Master/perltl/site/lib/Tk/srcfile.xpm | 18 + Master/perltl/site/lib/Tk/textfile.xpm | 18 + Master/perltl/site/lib/Tk/tranicon.gif | Bin 0 -> 1718 bytes Master/perltl/site/lib/Tk/widgets.pm | 21 + Master/perltl/site/lib/Tk/win.xbm | 6 + Master/perltl/site/lib/Tk/winfolder.xpm | 39 + Master/perltl/site/lib/Tk/wintext.xpm | 42 + Master/perltl/site/lib/Win32/API.pm | 719 +++++++++ Master/perltl/site/lib/Win32/API/Struct.pm | 528 +++++++ Master/perltl/site/lib/Win32/API/Type.pm | 440 ++++++ Master/perltl/site/lib/XML/Parser.pm | 1089 +++++++++++++ Master/perltl/site/lib/XML/Parser/Expat.pm | 1231 +++++++++++++++ Master/perltl/site/lib/auto/Tk/Bitmap/Bitmap.dll | Bin 0 -> 6144 bytes Master/perltl/site/lib/auto/Tk/CancelRepeat.al | 15 + Master/perltl/site/lib/auto/Tk/Canvas/Canvas.dll | Bin 0 -> 139264 bytes .../perltl/site/lib/auto/Tk/Clipboard/autosplit.ix | 6 + .../site/lib/auto/Tk/Clipboard/getSelected.al | 15 + Master/perltl/site/lib/auto/Tk/EnterFocus.al | 26 + Master/perltl/site/lib/auto/Tk/Entry/Entry.dll | Bin 0 -> 23040 bytes Master/perltl/site/lib/auto/Tk/Error.al | 20 + Master/perltl/site/lib/auto/Tk/Event/Event.dll | Bin 0 -> 53248 bytes Master/perltl/site/lib/auto/Tk/FirstMenu.al | 21 + Master/perltl/site/lib/auto/Tk/FocusChildren.al | 35 + Master/perltl/site/lib/auto/Tk/FocusOK.al | 33 + .../perltl/site/lib/auto/Tk/Frame/AddScrollbars.al | 52 + Master/perltl/site/lib/auto/Tk/Frame/FindMenu.al | 22 + Master/perltl/site/lib/auto/Tk/Frame/autosplit.ix | 24 + .../perltl/site/lib/auto/Tk/Frame/freeze_on_map.al | 18 + Master/perltl/site/lib/auto/Tk/Frame/label.al | 24 + Master/perltl/site/lib/auto/Tk/Frame/labelPack.al | 50 + .../perltl/site/lib/auto/Tk/Frame/labelVariable.al | 27 + .../site/lib/auto/Tk/Frame/packscrollbars.al | 86 ++ Master/perltl/site/lib/auto/Tk/Frame/queuePack.al | 18 + Master/perltl/site/lib/auto/Tk/Frame/sbset.al | 15 + Master/perltl/site/lib/auto/Tk/Frame/scrollbars.al | 24 + Master/perltl/site/lib/auto/Tk/ImageNames.al | 13 + Master/perltl/site/lib/auto/Tk/ImageTypes.al | 13 + Master/perltl/site/lib/auto/Tk/Listbox/AutoScan.al | 48 + .../perltl/site/lib/auto/Tk/Listbox/BeginExtend.al | 29 + .../perltl/site/lib/auto/Tk/Listbox/BeginSelect.al | 45 + .../perltl/site/lib/auto/Tk/Listbox/BeginToggle.al | 39 + .../site/lib/auto/Tk/Listbox/ButtonRelease_1.al | 16 + Master/perltl/site/lib/auto/Tk/Listbox/Cancel.al | 43 + .../perltl/site/lib/auto/Tk/Listbox/Cntrl_End.al | 18 + .../perltl/site/lib/auto/Tk/Listbox/Cntrl_Home.al | 18 + .../site/lib/auto/Tk/Listbox/Cntrl_backslash.al | 18 + .../perltl/site/lib/auto/Tk/Listbox/DataExtend.al | 39 + .../site/lib/auto/Tk/Listbox/ExtendUpDown.al | 30 + Master/perltl/site/lib/auto/Tk/Listbox/Listbox.dll | Bin 0 -> 20992 bytes Master/perltl/site/lib/auto/Tk/Listbox/Motion.al | 66 + .../perltl/site/lib/auto/Tk/Listbox/SelectAll.al | 31 + Master/perltl/site/lib/auto/Tk/Listbox/SetList.al | 15 + Master/perltl/site/lib/auto/Tk/Listbox/UpDown.al | 39 + .../perltl/site/lib/auto/Tk/Listbox/autosplit.ix | 42 + .../site/lib/auto/Tk/Listbox/clipboardPaste.al | 21 + .../site/lib/auto/Tk/Listbox/deleteSelected.al | 18 + .../perltl/site/lib/auto/Tk/Listbox/getSelected.al | 22 + Master/perltl/site/lib/auto/Tk/Listbox/xyIndex.al | 27 + .../site/lib/auto/Tk/Menubutton/Menubutton.dll | Bin 0 -> 14848 bytes Master/perltl/site/lib/auto/Tk/Pixmap/Pixmap.dll | Bin 0 -> 19968 bytes Master/perltl/site/lib/auto/Tk/Receive.al | 23 + Master/perltl/site/lib/auto/Tk/RepeatId.al | 16 + Master/perltl/site/lib/auto/Tk/Scale/Activate.al | 33 + Master/perltl/site/lib/auto/Tk/Scale/ButtonDown.al | 40 + Master/perltl/site/lib/auto/Tk/Scale/ButtonUp.al | 16 + .../perltl/site/lib/auto/Tk/Scale/ControlPress.al | 31 + Master/perltl/site/lib/auto/Tk/Scale/Drag.al | 29 + Master/perltl/site/lib/auto/Tk/Scale/EndDrag.al | 23 + Master/perltl/site/lib/auto/Tk/Scale/Enter.al | 19 + Master/perltl/site/lib/auto/Tk/Scale/Increment.al | 61 + Master/perltl/site/lib/auto/Tk/Scale/Leave.al | 15 + Master/perltl/site/lib/auto/Tk/Scale/Scale.dll | Bin 0 -> 20992 bytes Master/perltl/site/lib/auto/Tk/Scale/autosplit.ix | 22 + .../site/lib/auto/Tk/Scrollbar/ButtonDown.al | 55 + .../perltl/site/lib/auto/Tk/Scrollbar/ButtonUp.al | 26 + Master/perltl/site/lib/auto/Tk/Scrollbar/Drag.al | 44 + .../perltl/site/lib/auto/Tk/Scrollbar/EndDrag.al | 29 + Master/perltl/site/lib/auto/Tk/Scrollbar/Enter.al | 21 + Master/perltl/site/lib/auto/Tk/Scrollbar/Leave.al | 18 + Master/perltl/site/lib/auto/Tk/Scrollbar/Motion.al | 15 + .../site/lib/auto/Tk/Scrollbar/ScrlByPages.al | 38 + .../site/lib/auto/Tk/Scrollbar/ScrlByUnits.al | 37 + .../perltl/site/lib/auto/Tk/Scrollbar/ScrlToPos.al | 35 + .../site/lib/auto/Tk/Scrollbar/ScrlTopBottom.al | 32 + .../site/lib/auto/Tk/Scrollbar/Scrollbar.dll | Bin 0 -> 15872 bytes Master/perltl/site/lib/auto/Tk/Scrollbar/Select.al | 59 + .../perltl/site/lib/auto/Tk/Scrollbar/StartDrag.al | 33 + .../perltl/site/lib/auto/Tk/Scrollbar/autosplit.ix | 30 + Master/perltl/site/lib/auto/Tk/Selection.al | 18 + Master/perltl/site/lib/auto/Tk/Text/Text.dll | Bin 0 -> 94208 bytes Master/perltl/site/lib/auto/Tk/Text/autosplit.ix | 3 + Master/perltl/site/lib/auto/Tk/Tk.dll | Bin 0 -> 573440 bytes .../perltl/site/lib/auto/Tk/Toplevel/FG_BindIn.al | 19 + .../perltl/site/lib/auto/Tk/Toplevel/FG_BindOut.al | 20 + .../perltl/site/lib/auto/Tk/Toplevel/FG_Create.al | 56 + .../perltl/site/lib/auto/Tk/Toplevel/FG_Destroy.al | 29 + Master/perltl/site/lib/auto/Tk/Toplevel/FG_In.al | 24 + Master/perltl/site/lib/auto/Tk/Toplevel/FG_Out.al | 32 + .../perltl/site/lib/auto/Tk/Toplevel/autosplit.ix | 10 + Master/perltl/site/lib/auto/Tk/TraverseToMenu.al | 27 + Master/perltl/site/lib/auto/Tk/Widget/ASkludge.al | 30 + Master/perltl/site/lib/auto/Tk/Widget/autosplit.ix | 10 + .../site/lib/auto/Tk/Widget/clipboardKeysyms.al | 51 + Master/perltl/site/lib/auto/Tk/Widget/pathname.al | 15 + Master/perltl/site/lib/auto/Tk/Wm/AnchorAdjust.al | 17 + Master/perltl/site/lib/auto/Tk/Wm/FullScreen.al | 29 + Master/perltl/site/lib/auto/Tk/Wm/Popup.al | 45 + Master/perltl/site/lib/auto/Tk/Wm/Post.al | 20 + Master/perltl/site/lib/auto/Tk/Wm/autosplit.ix | 14 + Master/perltl/site/lib/auto/Tk/Wm/iconposition.al | 24 + Master/perltl/site/lib/auto/Tk/X/X.dll | Bin 0 -> 19968 bytes Master/perltl/site/lib/auto/Tk/X/autosplit.ix | 3 + Master/perltl/site/lib/auto/Tk/autosplit.ix | 43 + Master/perltl/site/lib/auto/Tk/break.al | 13 + .../perltl/site/lib/auto/Tk/focusFollowsMouse.al | 14 + Master/perltl/site/lib/auto/Tk/focusNext.al | 45 + Master/perltl/site/lib/auto/Tk/focusPrev.al | 65 + Master/perltl/site/lib/auto/Tk/interps.al | 14 + Master/perltl/site/lib/auto/Tk/lsearch.al | 19 + Master/perltl/site/lib/auto/Tk/tabFocus.al | 13 + Master/perltl/site/lib/auto/Tk/updateWidgets.al | 17 + Master/perltl/site/lib/auto/Win32/API/API.dll | Bin 0 -> 20480 bytes .../site/lib/auto/XML/Parser/Expat/Expat.dll | Bin 0 -> 163840 bytes 186 files changed, 21666 insertions(+) create mode 100644 Master/perltl/site/lib/Tk.pm create mode 100644 Master/perltl/site/lib/Tk/Adjuster.pm create mode 100644 Master/perltl/site/lib/Tk/After.pm create mode 100644 Master/perltl/site/lib/Tk/Bitmap.pm create mode 100644 Master/perltl/site/lib/Tk/Button.pm create mode 100644 Master/perltl/site/lib/Tk/Camel.xpm create mode 100644 Master/perltl/site/lib/Tk/Canvas.pm create mode 100644 Master/perltl/site/lib/Tk/Checkbutton.pm create mode 100644 Master/perltl/site/lib/Tk/Clipboard.pm create mode 100644 Master/perltl/site/lib/Tk/CmdLine.pm create mode 100644 Master/perltl/site/lib/Tk/ColorEdit.xpm create mode 100644 Master/perltl/site/lib/Tk/ColorEditor.pm create mode 100644 Master/perltl/site/lib/Tk/Config.pm create mode 100644 Master/perltl/site/lib/Tk/Configure.pm create mode 100644 Master/perltl/site/lib/Tk/Derived.pm create mode 100644 Master/perltl/site/lib/Tk/Dialog.pm create mode 100644 Master/perltl/site/lib/Tk/DialogBox.pm create mode 100644 Master/perltl/site/lib/Tk/Entry.pm create mode 100644 Master/perltl/site/lib/Tk/Event.pm create mode 100644 Master/perltl/site/lib/Tk/Event/IO.pm create mode 100644 Master/perltl/site/lib/Tk/FBox.pm create mode 100644 Master/perltl/site/lib/Tk/Frame.pm create mode 100644 Master/perltl/site/lib/Tk/IconList.pm create mode 100644 Master/perltl/site/lib/Tk/Image.pm create mode 100644 Master/perltl/site/lib/Tk/Label.pm create mode 100644 Master/perltl/site/lib/Tk/Listbox.pm create mode 100644 Master/perltl/site/lib/Tk/MainWindow.pm create mode 100644 Master/perltl/site/lib/Tk/Menu.pm create mode 100644 Master/perltl/site/lib/Tk/Menu/Item.pm create mode 100644 Master/perltl/site/lib/Tk/Menubutton.pm create mode 100644 Master/perltl/site/lib/Tk/Optionmenu.pm create mode 100644 Master/perltl/site/lib/Tk/Pixmap.pm create mode 100644 Master/perltl/site/lib/Tk/Pretty.pm create mode 100644 Master/perltl/site/lib/Tk/ROText.pm create mode 100644 Master/perltl/site/lib/Tk/Radiobutton.pm create mode 100644 Master/perltl/site/lib/Tk/Scale.pm create mode 100644 Master/perltl/site/lib/Tk/Scrollbar.pm create mode 100644 Master/perltl/site/lib/Tk/Submethods.pm create mode 100644 Master/perltl/site/lib/Tk/Text.pm create mode 100644 Master/perltl/site/lib/Tk/Text/Tag.pm create mode 100644 Master/perltl/site/lib/Tk/Tk.xbm create mode 100644 Master/perltl/site/lib/Tk/Tk.xpm create mode 100644 Master/perltl/site/lib/Tk/Toplevel.pm create mode 100644 Master/perltl/site/lib/Tk/Widget.pm create mode 100644 Master/perltl/site/lib/Tk/Wm.pm create mode 100644 Master/perltl/site/lib/Tk/X.pm create mode 100644 Master/perltl/site/lib/Tk/X11/license.terms create mode 100644 Master/perltl/site/lib/Tk/Xcamel.gif create mode 100644 Master/perltl/site/lib/Tk/act_folder.xbm create mode 100644 Master/perltl/site/lib/Tk/act_folder.xpm create mode 100644 Master/perltl/site/lib/Tk/anim.gif create mode 100644 Master/perltl/site/lib/Tk/balArrow.xbm create mode 100644 Master/perltl/site/lib/Tk/cbxarrow.xbm create mode 100644 Master/perltl/site/lib/Tk/file.xbm create mode 100644 Master/perltl/site/lib/Tk/file.xpm create mode 100644 Master/perltl/site/lib/Tk/folder.xbm create mode 100644 Master/perltl/site/lib/Tk/folder.xpm create mode 100644 Master/perltl/site/lib/Tk/icon.gif create mode 100644 Master/perltl/site/lib/Tk/license.terms create mode 100644 Master/perltl/site/lib/Tk/openfile.xbm create mode 100644 Master/perltl/site/lib/Tk/openfolder.xbm create mode 100644 Master/perltl/site/lib/Tk/openfolder.xpm create mode 100644 Master/perltl/site/lib/Tk/prolog.ps create mode 100644 Master/perltl/site/lib/Tk/srcfile.xpm create mode 100644 Master/perltl/site/lib/Tk/textfile.xpm create mode 100644 Master/perltl/site/lib/Tk/tranicon.gif create mode 100644 Master/perltl/site/lib/Tk/widgets.pm create mode 100644 Master/perltl/site/lib/Tk/win.xbm create mode 100644 Master/perltl/site/lib/Tk/winfolder.xpm create mode 100644 Master/perltl/site/lib/Tk/wintext.xpm create mode 100644 Master/perltl/site/lib/Win32/API.pm create mode 100644 Master/perltl/site/lib/Win32/API/Struct.pm create mode 100644 Master/perltl/site/lib/Win32/API/Type.pm create mode 100644 Master/perltl/site/lib/XML/Parser.pm create mode 100644 Master/perltl/site/lib/XML/Parser/Expat.pm create mode 100644 Master/perltl/site/lib/auto/Tk/Bitmap/Bitmap.dll create mode 100644 Master/perltl/site/lib/auto/Tk/CancelRepeat.al create mode 100644 Master/perltl/site/lib/auto/Tk/Canvas/Canvas.dll create mode 100644 Master/perltl/site/lib/auto/Tk/Clipboard/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/Clipboard/getSelected.al create mode 100644 Master/perltl/site/lib/auto/Tk/EnterFocus.al create mode 100644 Master/perltl/site/lib/auto/Tk/Entry/Entry.dll create mode 100644 Master/perltl/site/lib/auto/Tk/Error.al create mode 100644 Master/perltl/site/lib/auto/Tk/Event/Event.dll create mode 100644 Master/perltl/site/lib/auto/Tk/FirstMenu.al create mode 100644 Master/perltl/site/lib/auto/Tk/FocusChildren.al create mode 100644 Master/perltl/site/lib/auto/Tk/FocusOK.al create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/AddScrollbars.al create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/FindMenu.al create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/freeze_on_map.al create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/label.al create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/labelPack.al create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/labelVariable.al create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/packscrollbars.al create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/queuePack.al create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/sbset.al create mode 100644 Master/perltl/site/lib/auto/Tk/Frame/scrollbars.al create mode 100644 Master/perltl/site/lib/auto/Tk/ImageNames.al create mode 100644 Master/perltl/site/lib/auto/Tk/ImageTypes.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/AutoScan.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/BeginExtend.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/BeginSelect.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/BeginToggle.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/ButtonRelease_1.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/Cancel.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/Cntrl_End.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/Cntrl_Home.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/Cntrl_backslash.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/DataExtend.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/ExtendUpDown.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/Listbox.dll create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/Motion.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/SelectAll.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/SetList.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/UpDown.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/clipboardPaste.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/deleteSelected.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/getSelected.al create mode 100644 Master/perltl/site/lib/auto/Tk/Listbox/xyIndex.al create mode 100644 Master/perltl/site/lib/auto/Tk/Menubutton/Menubutton.dll create mode 100644 Master/perltl/site/lib/auto/Tk/Pixmap/Pixmap.dll create mode 100644 Master/perltl/site/lib/auto/Tk/Receive.al create mode 100644 Master/perltl/site/lib/auto/Tk/RepeatId.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/Activate.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/ButtonDown.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/ButtonUp.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/ControlPress.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/Drag.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/EndDrag.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/Enter.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/Increment.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/Leave.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/Scale.dll create mode 100644 Master/perltl/site/lib/auto/Tk/Scale/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/ButtonDown.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/ButtonUp.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/Drag.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/EndDrag.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/Enter.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/Leave.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/Motion.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/ScrlByPages.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/ScrlByUnits.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/ScrlToPos.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/ScrlTopBottom.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/Scrollbar.dll create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/Select.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/StartDrag.al create mode 100644 Master/perltl/site/lib/auto/Tk/Scrollbar/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/Selection.al create mode 100644 Master/perltl/site/lib/auto/Tk/Text/Text.dll create mode 100644 Master/perltl/site/lib/auto/Tk/Text/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/Tk.dll create mode 100644 Master/perltl/site/lib/auto/Tk/Toplevel/FG_BindIn.al create mode 100644 Master/perltl/site/lib/auto/Tk/Toplevel/FG_BindOut.al create mode 100644 Master/perltl/site/lib/auto/Tk/Toplevel/FG_Create.al create mode 100644 Master/perltl/site/lib/auto/Tk/Toplevel/FG_Destroy.al create mode 100644 Master/perltl/site/lib/auto/Tk/Toplevel/FG_In.al create mode 100644 Master/perltl/site/lib/auto/Tk/Toplevel/FG_Out.al create mode 100644 Master/perltl/site/lib/auto/Tk/Toplevel/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/TraverseToMenu.al create mode 100644 Master/perltl/site/lib/auto/Tk/Widget/ASkludge.al create mode 100644 Master/perltl/site/lib/auto/Tk/Widget/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/Widget/clipboardKeysyms.al create mode 100644 Master/perltl/site/lib/auto/Tk/Widget/pathname.al create mode 100644 Master/perltl/site/lib/auto/Tk/Wm/AnchorAdjust.al create mode 100644 Master/perltl/site/lib/auto/Tk/Wm/FullScreen.al create mode 100644 Master/perltl/site/lib/auto/Tk/Wm/Popup.al create mode 100644 Master/perltl/site/lib/auto/Tk/Wm/Post.al create mode 100644 Master/perltl/site/lib/auto/Tk/Wm/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/Wm/iconposition.al create mode 100644 Master/perltl/site/lib/auto/Tk/X/X.dll create mode 100644 Master/perltl/site/lib/auto/Tk/X/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/autosplit.ix create mode 100644 Master/perltl/site/lib/auto/Tk/break.al create mode 100644 Master/perltl/site/lib/auto/Tk/focusFollowsMouse.al create mode 100644 Master/perltl/site/lib/auto/Tk/focusNext.al create mode 100644 Master/perltl/site/lib/auto/Tk/focusPrev.al create mode 100644 Master/perltl/site/lib/auto/Tk/interps.al create mode 100644 Master/perltl/site/lib/auto/Tk/lsearch.al create mode 100644 Master/perltl/site/lib/auto/Tk/tabFocus.al create mode 100644 Master/perltl/site/lib/auto/Tk/updateWidgets.al create mode 100644 Master/perltl/site/lib/auto/Win32/API/API.dll create mode 100644 Master/perltl/site/lib/auto/XML/Parser/Expat/Expat.dll (limited to 'Master/perltl/site') diff --git a/Master/perltl/site/lib/Tk.pm b/Master/perltl/site/lib/Tk.pm new file mode 100644 index 00000000000..db05463d66d --- /dev/null +++ b/Master/perltl/site/lib/Tk.pm @@ -0,0 +1,696 @@ +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-1999 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, subject +# to additional disclaimer in Tk/license.terms due to partial +# derivation from Tk8.0 sources. +# +package Tk; +require 5.00404; +use Tk::Event (); +use AutoLoader qw(AUTOLOAD); +use DynaLoader; +use base qw(Exporter DynaLoader); + +*fileevent = \&Tk::Event::IO::fileevent; + +BEGIN { + if($^O eq 'cygwin') + { + require Tk::Config; + $Tk::platform = $Tk::Config::win_arch; + $Tk::platform = 'unix' if $Tk::platform eq 'x'; + } + else + { + $Tk::platform = ($^O eq 'MSWin32') ? $^O : 'unix'; + } +}; + +$Tk::tearoff = 1 if ($Tk::platform eq 'unix'); + +@EXPORT = qw(Exists Ev exit MainLoop DoOneEvent tkinit); +@EXPORT_OK = qw(NoOp after *widget *event lsearch catch $XS_VERSION + DONT_WAIT WINDOW_EVENTS FILE_EVENTS TIMER_EVENTS + IDLE_EVENTS ALL_EVENTS + NORMAL_BG ACTIVE_BG SELECT_BG + SELECT_FG TROUGH INDICATOR DISABLED BLACK WHITE); +%EXPORT_TAGS = (eventtypes => [qw(DONT_WAIT WINDOW_EVENTS FILE_EVENTS + TIMER_EVENTS IDLE_EVENTS ALL_EVENTS)], + variables => [qw(*widget *event)], + colors => [qw(NORMAL_BG ACTIVE_BG SELECT_BG SELECT_FG + TROUGH INDICATOR DISABLED BLACK WHITE)], + ); + +use strict; + +use Carp; + +# $tk_version and $tk_patchLevel are reset by pTk when a mainwindow +# is created, $VERSION is checked by bootstrap +$Tk::version = '8.0'; +$Tk::patchLevel = '8.0'; +$Tk::VERSION = '800.024'; +$Tk::XS_VERSION = $Tk::VERSION; +$Tk::strictMotif = 0; + +{($Tk::library) = __FILE__ =~ /^(.*)\.pm$/;} +$Tk::library = Tk->findINC('.') unless (defined($Tk::library) && -d $Tk::library); + +$Tk::widget = undef; +$Tk::event = undef; + +use vars qw($inMainLoop); + +bootstrap Tk; + +my $boot_time = timeofday(); + +# This is a workround for Solaris X11 locale handling +Preload(DynaLoader::dl_findfile('-L/usr/openwin/lib','-lX11')) + if (NeedPreload() && -d '/usr/openwin/lib'); + +use Tk::Submethods ('option' => [qw(add get clear readfile)], + 'clipboard' => [qw(clear append)] + ); + +sub _backTrace +{ + my $w = shift; + my $i = 1; + my ($pack,$file,$line,$sub) = caller($i++); + while (1) + { + my $loc = "at $file line $line"; + ($pack,$file,$line,$sub) = caller($i++); + last unless defined($sub); + return 1 if $sub eq '(eval)'; + $w->AddErrorInfo("$sub $loc"); + } + return 0; +} + +sub BackTrace +{ + my $w = shift; + return unless (@_ || $@); + my $mess = (@_) ? shift : "$@"; + die "$mess\n" if $w->_backTrace; + # if we get here we are not in an eval so report now + $w->Fail($mess); + $w->idletasks; + die "$mess\n"; +} + +# +# This is a $SIG{__DIE__} handler which does not change the $@ +# string in the way 'croak' does, but rather add to Tk's ErrorInfo. +# It stops at 1st enclosing eval on assumption that the eval +# is part of Tk call process and will add its own context to ErrorInfo +# and then pass on the error. +# +sub __DIE__ +{ + my $mess = shift; + my $w = $Tk::widget; + # Note that if a __DIE__ handler returns it re-dies up the chain. + return unless defined $w; + return if $w->_backTrace; + # Not in an eval - should not happen +} + +sub XEvent::xy { shift->Info('xy') } + +sub XEvent::AUTOLOAD +{ + my ($meth) = $XEvent::AUTOLOAD =~ /(\w)$/; + no strict 'refs'; + *{$XEvent::AUTOLOAD} = sub { shift->Info($meth) }; + goto &$XEvent::AUTOLOAD; +} + +sub NoOp { } + +sub Ev +{ + my @args = @_; + my $obj; + if (@args == 1) + { + my $arg = pop(@args); + $obj = (ref $arg) ? $arg : \$arg; + } + else + { + $obj = \@args; + } + return bless $obj,'Tk::Ev'; +} + +sub InitClass +{ + my ($package,$parent) = @_; + croak "Unexpected type of parent $parent" unless(ref $parent); + croak "$parent is not a widget" unless($parent->IsWidget); + my $mw = $parent->MainWindow; + my $hash = $mw->TkHash('_ClassInit_'); + unless (exists $hash->{$package}) + { + $package->Install($mw); + $hash->{$package} = $package->ClassInit($mw); + } +} + +require Tk::Widget; +require Tk::Image; +require Tk::MainWindow; + +sub Exists +{my $w = shift; + return defined($w) && ref($w) && $w->IsWidget && $w->exists; +} + +sub Time_So_Far +{ + return timeofday() - $boot_time; +} + +# Selection* are not autoloaded as names are too long. + +sub SelectionOwn +{my $widget = shift; + selection('own',(@_,$widget)); +} + +sub SelectionOwner +{ + selection('own','-displayof',@_); +} + +sub SelectionClear +{ + selection('clear','-displayof',@_); +} + +sub SelectionExists +{ + selection('exists','-displayof',@_); +} + +sub SelectionHandle +{my $widget = shift; + my $command = pop; + selection('handle',@_,$widget,$command); +} + +sub SplitString +{ + local $_ = shift; + my (@arr, $tmp); + while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) { + if (defined $1) { push @arr, $1 } + else { $tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp } + } + # carp '('.join(',',@arr).")"; + return @arr; +} + +sub Methods +{ + my ($package) = caller; + no strict 'refs'; + foreach my $meth (@_) + { + my $name = $meth; + *{$package."::$meth"} = sub { shift->WidgetMethod($name,@_) }; + } +} + + +sub MessageBox { + my ($kind,%args) = @_; + require Tk::Dialog; + my $parent = delete $args{'-parent'}; + my $args = \%args; + + $args->{-bitmap} = delete $args->{-icon} if defined $args->{-icon}; + $args->{-text} = delete $args->{-message} if defined $args->{-message}; + $args->{-type} = 'OK' unless defined $args->{-type}; + + my $type; + if (defined($type = delete $args->{-type})) { + delete $args->{-type}; + my @buttons = grep($_,map(ucfirst($_), + split(/(abort|retry|ignore|yes|no|cancel|ok)/, + lc($type)))); + $args->{-buttons} = [@buttons]; + $args->{-default_button} = delete $args->{-default} if + defined $args->{-default}; + if (not defined $args->{-default_button} and scalar(@buttons) == 1) { + $args->{-default_button} = $buttons[0]; + } + my $md = $parent->Dialog(%$args); + my $an = $md->Show; + $md->destroy; + return $an; + } +} # end messageBox + +sub messageBox +{ + my ($widget,%args) = @_; + $args{'-type'} = (exists $args{'-type'}) ? lc($args{'-type'}) : 'ok'; + tk_messageBox(-parent => $widget, %args); +} + +sub getOpenFile +{ + tk_getOpenFile(-parent => shift,@_); +} + +sub getSaveFile +{ + tk_getSaveFile(-parent => shift,@_); +} + +sub chooseColor +{ + tk_chooseColor(-parent => shift,@_); +} + +sub DialogWrapper +{ + my ($method,$kind,%args) = @_; + my $created = 0; + my $w = delete $args{'-parent'}; + if (defined $w) + { + $args{'-popover'} = $w; + } + else + { + $w = MainWindow->new; + $w->withdraw; + $created = 1; + } + my $mw = $w->MainWindow; + my $fs = $mw->{$kind}; + unless (defined $fs) + { + $mw->{$kind} = $fs = $mw->$method(%args); + } + else + { + $fs->configure(%args); + } + my $val = $fs->Show; + $w->destroy if $created; + return $val; +} + +sub ColorDialog +{ + require Tk::ColorEditor; + DialogWrapper('ColorDialog',@_); +} + +sub FDialog +{ + require Tk::FBox; + my $cmd = shift; + if ($cmd =~ /Save/) + { + push @_, -type => 'save'; + } + DialogWrapper('FBox', $cmd, @_); +} + +*MotifFDialog = \&FDialog; + +sub MainLoop +{ + unless ($inMainLoop) + { + local $inMainLoop = 1; + while (Tk::MainWindow->Count) + { + DoOneEvent(0); + } + } +} + +sub tkinit { return MainWindow->new(@_) } + +# a wrapper on eval which turns off user $SIG{__DIE__} +sub catch (&) +{ + my $sub = shift; + eval {local $SIG{'__DIE__'}; &$sub }; +} + +my $Home; + +sub TranslateFileName +{ + local $_ = shift; + unless (defined $Home) + { + $Home = $ENV{'HOME'} || ($ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'}); + $Home =~ s#\\#/#g; + $Home .= '/' unless $Home =~ m#/$#; + } + s#~/#$Home#g; + # warn $_; + return $_; +} + +sub findINC +{ + my $file = join('/',@_); + my $dir; + $file =~ s,::,/,g; + foreach $dir (@INC) + { + my $path; + return $path if (-e ($path = "$dir/$file")); + } + return undef; +} + +sub idletasks +{ + shift->update('idletasks'); +} + + +1; + +__END__ + +sub Error +{my $w = shift; + my $error = shift; + if (Exists($w)) + { + my $grab = $w->grab('current'); + $grab->Unbusy if (defined $grab); + } + chomp($error); + warn "Tk::Error: $error\n " . join("\n ",@_)."\n"; +} + +sub CancelRepeat +{ + my $w = shift->MainWindow; + my $id = delete $w->{_afterId_}; + $w->after('cancel',$id) if (defined $id); +} + +sub RepeatId +{ + my ($w,$id) = @_; + $w = $w->MainWindow; + $w->CancelRepeat; + $w->{_afterId_} = $id; +} + + + +#---------------------------------------------------------------------------- +# focus.tcl -- +# +# This file defines several procedures for managing the input +# focus. +# +# @(#) focus.tcl 1.6 94/12/19 17:06:46 +# +# 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. + +sub FocusChildren { shift->children } + +# +# focusNext -- +# This procedure is invoked to move the input focus to the next window +# after a given one. "Next" is defined in terms of the window +# stacking order, with all the windows underneath a given top-level +# (no matter how deeply nested in the hierarchy) considered except +# for frames and toplevels. +# +# Arguments: +# w - Name of a window: the procedure will set the focus +# to the next window after this one in the traversal +# order. +sub focusNext +{ + my $w = shift; + my $cur = $w; + while (1) + { + # Descend to just before the first child of the current widget. + my $parent = $cur; + my @children = $cur->FocusChildren(); + my $i = -1; + # Look for the next sibling that isn't a top-level. + while (1) + { + $i += 1; + if ($i < @children) + { + $cur = $children[$i]; + next if ($cur->toplevel == $cur); + last + } + # No more siblings, so go to the current widget's parent. + # If it's a top-level, break out of the loop, otherwise + # look for its next sibling. + $cur = $parent; + last if ($cur->toplevel() == $cur); + $parent = $parent->parent(); + @children = $parent->FocusChildren(); + $i = lsearch(\@children,$cur); + } + if ($cur == $w || $cur->FocusOK) + { + $cur->tabFocus; + return; + } + } +} +# focusPrev -- +# This procedure is invoked to move the input focus to the previous +# window before a given one. "Previous" is defined in terms of the +# window stacking order, with all the windows underneath a given +# top-level (no matter how deeply nested in the hierarchy) considered. +# +# Arguments: +# w - Name of a window: the procedure will set the focus +# to the previous window before this one in the traversal +# order. +sub focusPrev +{ + my $w = shift; + my $cur = $w; + my @children; + my $i; + my $parent; + while (1) + { + # Collect information about the current window's position + # among its siblings. Also, if the window is a top-level, + # then reposition to just after the last child of the window. + if ($cur->toplevel() == $cur) + { + $parent = $cur; + @children = $cur->FocusChildren(); + $i = @children; + } + else + { + $parent = $cur->parent(); + @children = $parent->FocusChildren(); + $i = lsearch(\@children,$cur); + } + # Go to the previous sibling, then descend to its last descendant + # (highest in stacking order. While doing this, ignore top-levels + # and their descendants. When we run out of descendants, go up + # one level to the parent. + while ($i > 0) + { + $i--; + $cur = $children[$i]; + next if ($cur->toplevel() == $cur); + $parent = $cur; + @children = $parent->FocusChildren(); + $i = @children; + } + $cur = $parent; + if ($cur == $w || $cur->FocusOK) + { + $cur->tabFocus; + return; + } + } + +} + +sub FocusOK +{ + my $w = shift; + my $value; + catch { $value = $w->cget('-takefocus') }; + if (!$@ && defined($value)) + { + return 0 if ($value eq '0'); + return $w->viewable if ($value eq '1'); + $value = $w->$value(); + return $value if (defined $value); + } + if (!$w->viewable) + { + return 0; + } + catch { $value = $w->cget('-state') } ; + if (!$@ && defined($value) && $value eq 'disabled') + { + return 0; + } + $value = grep(/Key|Focus/,$w->Tk::bind(),$w->Tk::bind(ref($w))); + return $value; +} + + +# focusFollowsMouse +# +# If this procedure is invoked, Tk will enter "focus-follows-mouse" +# mode, where the focus is always on whatever window contains the +# mouse. If this procedure isn't invoked, then the user typically +# has to click on a window to give it the focus. +# +# Arguments: +# None. + +sub EnterFocus +{ + my $w = shift; + my $Ev = $w->XEvent; + my $d = $Ev->d; + $w->Tk::focus() if ($d eq 'NotifyAncestor' || $d eq 'NotifyNonlinear' || $d eq 'NotifyInferior'); +} + +sub tabFocus +{ + shift->Tk::focus; +} + +sub focusFollowsMouse +{ + my $widget = shift; + $widget->bind('all','','EnterFocus'); +} + +# tkTraverseToMenu -- +# This procedure implements keyboard traversal of menus. Given an +# ASCII character "char", it looks for a menubutton with that character +# underlined. If one is found, it posts the menubutton's menu +# +# Arguments: +# w - Window in which the key was typed (selects +# a toplevel window). +# char - Character that selects a menu. The case +# is ignored. If an empty string, nothing +# happens. +sub TraverseToMenu +{ + my $w = shift; + my $char = shift; + return unless(defined $char && $char ne ''); + $w = $w->toplevel->FindMenu($char); +} +# tkFirstMenu -- +# This procedure traverses to the first menubutton in the toplevel +# for a given window, and posts that menubutton's menu. +# +# Arguments: +# w - Name of a window. Selects which toplevel +# to search for menubuttons. +sub FirstMenu +{ + my $w = shift; + $w = $w->toplevel->FindMenu(''); +} + +# These wrappers don't use method syntax so need to live +# in same package as raw Tk routines are newXS'ed into. + +sub Selection +{my $widget = shift; + my $cmd = shift; + croak 'Use SelectionOwn/SelectionOwner' if ($cmd eq 'own'); + croak "Use Selection\u$cmd()"; +} + +# If we have sub Clipboard in Tk then use base qw(Tk::Clipboard ....) +# calls it when it does its eval "require $base" +#sub Clipboard +#{my $w = shift; +# my $cmd = shift; +# croak "Use clipboard\u$cmd()"; +#} + +sub Receive +{ + my $w = shift; + warn 'Receive(' . join(',',@_) .')'; + die 'Tk rejects send(' . join(',',@_) .")\n"; +} + +sub break +{ + die "_TK_BREAK_\n"; +} + +sub updateWidgets +{ + my ($w) = @_; + while ($w->DoOneEvent(DONT_WAIT|IDLE_EVENTS|WINDOW_EVENTS)) + { + } + $w; +} + +sub ImageNames +{ + image('names'); +} + +sub ImageTypes +{ + image('types'); +} + +sub interps +{ + my $w = shift; + return $w->winfo('interps','-displayof'); +} + +sub lsearch +{my $ar = shift; + my $x = shift; + my $i; + for ($i = 0; $i < scalar @$ar; $i++) + { + return $i if ($$ar[$i] eq $x); + } + return -1; +} + + + + diff --git a/Master/perltl/site/lib/Tk/Adjuster.pm b/Master/perltl/site/lib/Tk/Adjuster.pm new file mode 100644 index 00000000000..0fd5b4f765a --- /dev/null +++ b/Master/perltl/site/lib/Tk/Adjuster.pm @@ -0,0 +1,435 @@ +package Tk::Adjuster; + +use vars qw($VERSION); +$VERSION = '3.025'; # $Id: //depot/Tk8/Tk/Adjuster.pm#25 $ + +use base qw(Tk::Frame); + +# We cannot do this : + +# Construct Tk::Widget 'packAdjust'; + +# because if managed object is Derived (e.g. a Scrolled) then our 'new' +# will be delegated and hierachy gets turned inside-out +# So packAdjust is autoloaded in Widget.pm + + +Construct Tk::Widget qw(Adjuster); + +{package Tk::Adjuster::Item; + +use strict; +use base qw(Tk::Frame); + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'<1>',['BDown', 1]); + $mw->bind($class,'',['BDown', 0]); + $mw->bind($class,'',['Motion',1]); + $mw->bind($class,'',['Motion',0]); + $mw->bind($class,'',['Motion',0]); + return $class; +} + +sub BDown +{ + my($w, $delay_mask) = @_; + $w->{'start_x'} = $w->XEvent->x; + $w->{'start_y'} = $w->XEvent->y; + my $adj = $w->Parent; + delete $adj->{'lin_info'}; + my $delay = $delay_mask && $adj->cget('-delay'); + if ($delay) + { + $adj->vert ? $adj->delta_width_bar(0) : $adj->delta_height_bar(0); + } +} + +sub Motion +{ + my($w, $delay_mask) = @_; + my $ev = $w->XEvent; + my $adj = $w->Parent; + + my $delay = $delay_mask && $adj->cget('-delay'); + if ($adj->vert) + { + my $dx = $ev->x - $w->{'start_x'}; + $delay ? $adj->delta_width_bar($dx) : $adj->delta_width($dx); + } + else + { + my $dy = $ev->y - $w->{'start_y'}; + $delay ? $adj->delta_height_bar($dy) : $adj->delta_height($dy); + } +} + +} + + + +sub packAfter +{ + my ($w,$s,%args) = @_; + my $side = $args{'-side'} ? $args{'-side'} : 'top'; + $w->configure(-side => $side, -widget => $s); + $w->packed($s, %args); +} + +sub packForget +{ + my ($w,$forget_slave) = @_; + $w->Tk::Widget::packForget; + $w->slave->packForget if $forget_slave; +} + +# Called by Tk::Widget::packAdjust. It was here before packAfter was added +sub packed +{ + my ($w,$s,%args) = @_; + delete $args{'-before'}; + $args{'-expand'} = 0; + $args{'-after'} = $s; + $args{'-fill'} = (($w->vert) ? 'y' : 'x'); + $w->pack(%args); +} + +sub gridded +{ + my ($w,$s,%args) = @_; + # delete $args{'-before'}; + # $args{'-expand'} = 0; + # $args{'-after'} = $s; + # $args{'-fill'} = (($w->vert) ? 'y' : 'x'); + $w->grid(%args); +} + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'','SizeChange'); + $mw->bind($class,'','Restore'); + $mw->bind($class,'','Mapped'); + return $class; +} + +sub SizeChange +{ + my $w = shift; + # reqwidth/height of Adjuster is stored here. If it is partially pushed out + # of the window, then $w->width/height returns that of the visible part. + if ($w->vert) + { + my $sx = ($w->Width - $w->{'sep'}->Width)/2; + $w->{'but'}->place('-x' => 0, '-y' => $w->Height-18); + $w->{'sep'}->place('-x' => $sx, '-y' => 0, -relheight => 1); + $w->configure(-width => $w->{'but'}->ReqWidth); + $w->{'reqwidth'} = $w->reqwidth; + } + else + { + my $sy = ($w->Height - $w->{'sep'}->Height)/2; + $w->{'but'}->place('-x' => $w->Width-18, '-y' => 0); + $w->{'sep'}->place('-x' => 0, '-y' => $sy, -relwidth => 1); + $w->configure(-height => $w->{'but'}->ReqHeight); + $w->{'reqheight'} = $w->reqheight; + } + # Turn off geometry propagation in the slave. Do only if necessary, as this + # causes repacking. + my $s = $w->slave; + $s->packPropagate('0') if $s->packSlaves && $s->packPropagate(); + $s->gridPropagate('0') if $s->gridSlaves && $s->gridPropagate(); +} + +sub Mapped +{ + my $w = shift; + $w->idletasks; + my $m = $w->manager; + if ($m =~ /^(?:pack|grid)$/) + { + my %info = $w->$m('info'); + my $master = $info{'-in'}; + $master->$m('propagate',0); + $w->{'master'} = $master; + } + $w->slave_expand_off; +} + +sub Populate +{ + my ($w,$args) = @_; + $w->SUPER::Populate($args); + $w->{'sep'} = Tk::Adjuster::Item->new($w,-bd => 1, -relief => 'sunken'); + $w->{'but'} = Tk::Adjuster::Item->new($w,-bd => 1, -width => 8, -height => 8, -relief => 'raised'); + + # Need to explicitly set frame width to 0 for Win32 + my $l = $w->{'lin'} = $w->toplevel->Frame(-bd => 0); + + my $cs = $w->ConfigSpecs(-widget => ['PASSIVE','widget','Widget',$w->Parent], + -side => ['METHOD','side','Side','top'], + -delay => ['PASSIVE','delay','Delay', 1], + -background => [['SELF',$w->{'sep'},$w->{'but'}],'background','Background',undef], + -foreground => [Tk::Configure->new($w->{'lin'},'-background'),'foreground','Foreground','black'], + -restore => ['PASSIVE','restore', 'Restore', 1], + ); + $w->_OnDestroy(qw(sep but lin master)); +} + +sub side +{ + my ($w,$val) = @_; + if (@_ > 1) + { + $w->{'side'} = $val; + my $cursor; + if ($w->vert) + { + $cursor = 'sb_h_double_arrow'; + $w->{'sep'}->configure(-width => 2, -height => 10000); + } + else + { + $cursor = 'sb_v_double_arrow'; + $w->{'sep'}->configure(-height => 2, -width => 10000); + } + my $x; + foreach $x ($w->{'sep'},$w->{'but'}) + { + $x->configure(-cursor => $cursor); + } + } + return $w->{'side'}; +} + +sub slave +{ + my $w = shift; + my $s = $w->cget('-widget'); + return $s; +} + +sub vert +{ + my $w = shift; + my $side = $w->cget('-side'); + return 1 if $side eq 'left'; + return -1 if $side eq 'right'; + return 0; +} + +# If the Adjuster gets unmapped, it attempts to restore itself. If its +# slave is mapped, then it reduces the size of the slave so that there is +# then room in the master for the Adjuster widget. +sub Restore +{ + my $w = shift; + return if ! $w->toplevel->IsMapped || + ! $w->slave->IsMapped || + ! $w->cget('-restore'); + $w->vert ? $w->delta_width(0) : $w->delta_height(0); +} + +sub delta_width_bar +{ + my ($w,$dx) = @_; + my $l = $w->{'lin'}; + my $r = $w->{'sep'}; + my $t = $w->toplevel; + my $m = $w->{'master'}; + my $s = $w->slave; + my ($min_rootx, $max_rootx, $t_border); + if (! $w->{'lin_info'}) + { + my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); + $t_border = $t->cget('-bd') + $t->cget('-highlightthickness'); + if ($w->cget('-side') eq 'right') + { + $min_rootx = $m->rootx + $m_border; + $max_rootx = $s->rootx + $s->width - 1; + } + else + { + $min_rootx = $s->rootx; + $max_rootx = $m->rootx + $m->width - $m_border - 1; + } + $w->{'lin_info'} = [$min_rootx, $max_rootx, $t_border]; + } + else + { + ($min_rootx, $max_rootx, $t_border) = @{$w->{'lin_info'}}; + } + $l->configure(-width => 1, -height => $w->height) unless $l->IsMapped; + + my $new_rootx = $w->rootx + $w->{'reqwidth'}/2 + $dx; + $new_rootx = $min_rootx if $new_rootx < $min_rootx; + $new_rootx = $max_rootx if $new_rootx > $max_rootx; + my $placex = $new_rootx - $t->rootx - $t_border; + my $placey = $w->rooty - $t->rooty - $t_border; + $l->place(-in => $t, -anchor => 'n', '-x' => $placex, '-y' => $placey); + my $this = $w->containing($new_rootx, $w->rooty + 1); + $l->raise($this) if $this && $this ne $t; +} + +sub delta_width +{ + my ($w,$dx) = @_; + my $l = $w->{'lin'}; + $l->placeForget; + my $s = $w->slave; + if ($s) + { + my $m = $w->{'master'}; + my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); + my $w_width = $w->{'reqwidth'}; + my $m_width = $m->width; + my $s_width = $s->width; + my $max_width = $m_width - $w_width; + my $max_s_width; + if ($w->cget('-side') eq 'right') + { + $dx = -$dx; + $max_s_width = $max_width - + ($m->rootx + $m_width - ($s->rootx+$s_width)) - $m_border; + } + else + { + $max_s_width = $max_width - ($s->rootx - $m->rootx) - $m_border; + } + my $new_width = $s_width+$dx; + $new_width = $max_s_width if $new_width > $max_s_width; + $new_width = 0 if $new_width < 0; + $s->GeometryRequest($new_width, $s->height); + } +} + +sub delta_height_bar +{ + my ($w,$dy) = @_; + my $l = $w->{'lin'}; + my $r = $w->{'sep'}; + my $t = $w->toplevel; + my $m = $w->{'master'}; + my $s = $w->slave; + my ($min_rooty, $max_rooty, $t_border); + if (! $w->{'lin_info'}) + { + my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); + $t_border = $t->cget('-bd') + $t->cget('-highlightthickness'); + if ($w->cget('-side') eq 'bottom') + { + $min_rooty = $m->rooty + $m_border; + $max_rooty = $s->rooty + $s->height - 1; + } + else + { + $min_rooty = $s->rooty; + $max_rooty = $m->rooty + $m->height - $m_border - 1; + } + $w->{'lin_info'} = [$min_rooty, $max_rooty, $t_border]; + } + else + { + ($min_rooty, $max_rooty, $t_border) = @{$w->{'lin_info'}}; + } + $l->configure(-height => 1, -width => $w->width) unless $l->IsMapped; + + my $new_rooty = $w->rooty + $w->{'reqheight'}/2 + $dy; + $new_rooty = $min_rooty if $new_rooty < $min_rooty; + $new_rooty = $max_rooty if $new_rooty > $max_rooty; + my $placey = $new_rooty - $t->rooty - $t_border; + my $placex = $w->rootx - $t->rootx - $t_border; + $l->place(-in => $t, -anchor => 'w', '-x' => $placex, '-y' => $placey); + my $this = $w->containing($w->rootx + 1, $new_rooty); + $l->raise($this) if $this && $this ne $t; +} + +sub delta_height +{ + my ($w,$dy) = @_; + my $l = $w->{'lin'}; + $l->placeForget; + my $s = $w->slave; + if ($s) + { + my $m = $w->{'master'}; + my $m_border = $m->cget('-bd') + $m->cget('-highlightthickness'); + my $w_height = $w->{'reqheight'}; + my $m_height = $m->height; + my $s_height = $s->height; + my $max_height = $m_height - $w_height; + my $max_s_height; + if ($w->cget('-side') eq 'bottom') + { + $dy = -$dy; + $max_s_height = $max_height - + ($m->rooty + $m_height - ($s->rooty+$s_height)) - $m_border; + } + else + { + $max_s_height = $max_height - ($s->rooty - $m->rooty) - $m_border; + } + my $new_height = $s_height+$dy; + + $new_height = $max_s_height if $new_height > $max_s_height; + $new_height = 0 if $new_height < 0; + $s->GeometryRequest($s->width, $new_height); + } +} + +# Turn off expansion in the slave. +# This is done only if necessary, as calls to pack/gridConfigure cause +# repacking. +# Before call to pack/gridConfigure, the reqwidth/reqheight is set to the +# current width/height. This is because the geometry managers use +# the requested values, not the actual, to calculate the new geometry. +sub slave_expand_off +{ + my $w = shift; + my $s = $w->slave; + return if ! $s; + + my $manager = $s->manager; + if ($manager eq 'pack') + { + my %info = $s->packInfo; + my $expand = $info{'-expand'}; + if ($expand) + { + $s->GeometryRequest($s->width, $s->height); + $s->packConfigure(-expand => 0); + } + } + elsif ($manager eq 'grid') + { + my %info = $s->gridInfo; + my $master = $info{'-in'}; + if ($w->vert) + { + my $col = $info{'-column'}; + my $expand = $master->gridColumnconfigure($col, '-weight'); + if ($expand) + { + $s->GeometryRequest($s->width, $s->height); + $master->gridColumnconfigure($col, -weight => 0); + } + } + else + { + my $row = $info{'-row'}; + my $expand = $master->gridRowconfigure($row, '-weight'); + if ($expand) + { + $s->GeometryRequest($s->width, $s->height); + $master->gridRowconfigure($row, -weight => 0); + } + } + } +} + +1; + +__END__ + +=cut #' emacs hilighting... diff --git a/Master/perltl/site/lib/Tk/After.pm b/Master/perltl/site/lib/Tk/After.pm new file mode 100644 index 00000000000..e5eac8b20a8 --- /dev/null +++ b/Master/perltl/site/lib/Tk/After.pm @@ -0,0 +1,88 @@ +# Copyright (c) 1995-1999 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::After; +use Carp; + +use vars qw($VERSION); +$VERSION = '3.015'; # $Id: //depot/Tk8/Tk/After.pm#15 $ + +sub _cancelAll +{ + my $w = shift; + my $h = delete $w->{_After_}; + foreach my $obj (values %$h) + { + # carp "Auto cancel ".$obj->[1]." for ".$obj->[0]->PathName; + $obj->cancel; + } +} + +sub submit +{ + my $obj = shift; + my $w = $obj->[0]; + my $id = $obj->[1]; + my $t = $obj->[2]; + my $method = $obj->[3]; + delete($w->{_After_}{$id}) if (defined $id); + $id = $w->Tk::after($t,[$method => $obj]); + unless (exists $w->{_After_}) + { + $w->{_After_} = {}; + $w->OnDestroy([\&_cancelAll, $w]); + } + $w->{_After_}{$id} = $obj; + $obj->[1] = $id; + return $obj; +} + +sub DESTROY +{ + my $obj = shift; + @{$obj} = (); +} + +sub new +{ + my ($class,$w,$t,$method,@cb) = @_; + my $cb = (@cb == 1) ? shift(@cb) : [@cb]; + my $obj = bless [$w,undef,$t,$method,Tk::Callback->new($cb)],$class; + return $obj->submit; +} + +sub cancel +{ + my $obj = shift; + my $id = $obj->[1]; + my $w = $obj->[0]; + if ($id) + { + $w->Tk::after('cancel'=> $id); + delete $w->{_After_}{$id} if exists $w->{_After_}; + $obj->[1] = undef; + } + return $obj; +} + +sub repeat +{ + my $obj = shift; + $obj->submit; + local $Tk::widget = $obj->[0]; + $obj->[4]->Call; +} + +sub once +{ + my $obj = shift; + my $w = $obj->[0]; + my $id = $obj->[1]; + delete $w->{_After_}{$id}; + local $Tk::widget = $w; + $obj->[4]->Call; +} + +1; +__END__ + diff --git a/Master/perltl/site/lib/Tk/Bitmap.pm b/Master/perltl/site/lib/Tk/Bitmap.pm new file mode 100644 index 00000000000..da563ffa6cb --- /dev/null +++ b/Master/perltl/site/lib/Tk/Bitmap.pm @@ -0,0 +1,18 @@ +package Tk::Bitmap; +require Tk; +import Tk qw($XS_VERSION); +require Tk::Image; + +use vars qw($VERSION); +$VERSION = '3.010'; # $Id: //depot/Tk8/Bitmap/Bitmap.pm#10 $ + +use base qw(Tk::Image); + +Construct Tk::Image 'Bitmap'; + +bootstrap Tk::Bitmap; + +sub Tk_image { 'bitmap' } + +1; +__END__ diff --git a/Master/perltl/site/lib/Tk/Button.pm b/Master/perltl/site/lib/Tk/Button.pm new file mode 100644 index 00000000000..b0983ead7c3 --- /dev/null +++ b/Master/perltl/site/lib/Tk/Button.pm @@ -0,0 +1,148 @@ +package Tk::Button; +# Conversion from Tk4.0 button.tcl competed. +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + +use vars qw($VERSION); +$VERSION = '3.014'; # $Id: //depot/Tk8/Tk/Button.pm#14 $ + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +use strict; + +require Tk::Widget; +use base qw(Tk::Widget); + +use vars qw($buttonWindow $relief); + +Tk::Methods('deselect','flash','invoke','select','toggle'); + +sub Tk_cmd { \&Tk::button } + +Construct Tk::Widget 'Button'; + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'', 'Enter'); + $mw->bind($class,'', 'Leave'); + $mw->bind($class,'<1>', 'butDown'); + $mw->bind($class,'', 'butUp'); + $mw->bind($class,'', 'Invoke'); + $mw->bind($class,'', 'Invoke'); + return $class; +} + +# tkButtonEnter -- +# The procedure below is invoked when the mouse pointer enters a +# button widget. It records the button we're in and changes the +# state of the button to active unless the button is disabled. +# +# Arguments: +# w - The name of the widget. + +sub Enter +{ + my $w = shift; + my $E = shift; + if ($w->cget('-state') ne 'disabled') + { + $w->configure('-state' => 'active'); + $w->configure('-state' => 'active', '-relief' => 'sunken') if (defined($buttonWindow) && $w == $buttonWindow) + } + $Tk::window = $w; +} + +# tkButtonLeave -- +# The procedure below is invoked when the mouse pointer leaves a +# button widget. It changes the state of the button back to +# inactive. If we're leaving the button window with a mouse button +# pressed (tkPriv(buttonWindow) == $w), restore the relief of the +# button too. +# +# Arguments: +# w - The name of the widget. +sub Leave +{ + my $w = shift; + $w->configure('-state'=>'normal') if ($w->cget('-state') ne 'disabled'); + $w->configure('-relief' => $relief) if (defined($buttonWindow) && $w == $buttonWindow); + undef $Tk::window; +} + +# tkButtonDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. +sub butDown +{ + my $w = shift; + $relief = $w->cget('-relief'); + if ($w->cget('-state') ne 'disabled') + { + $buttonWindow = $w; + $w->configure('-relief' => 'sunken') + } +} + +# tkButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. +# +# Arguments: +# w - The name of the widget. +sub butUp +{ + my $w = shift; + if (defined($buttonWindow) && $buttonWindow == $w) + { + undef $buttonWindow; + $w->configure('-relief' => $relief); + if ($w->IS($Tk::window) && $w->cget('-state') ne 'disabled') + { + $w->invoke; + } + } +} + +# tkButtonInvoke -- +# The procedure below is called when a button is invoked through +# the keyboard. It simulate a press of the button via the mouse. +# +# Arguments: +# w - The name of the widget. +sub Invoke +{ + my $w = shift; + if ($w->cget('-state') ne 'disabled') + { + my $oldRelief = $w->cget('-relief'); + my $oldState = $w->cget('-state'); + $w->configure('-state' => 'active', '-relief' => 'sunken'); + $w->idletasks; + $w->after(100); + $w->configure('-state' => $oldState, '-relief' => $oldRelief); + $w->invoke; + } +} + + + +1; + +__END__ + + + + + diff --git a/Master/perltl/site/lib/Tk/Camel.xpm b/Master/perltl/site/lib/Tk/Camel.xpm new file mode 100644 index 00000000000..ba33c0149ec --- /dev/null +++ b/Master/perltl/site/lib/Tk/Camel.xpm @@ -0,0 +1,41 @@ +/* XPM */ +static char *Camel[] = { +/* width height num_colors chars_per_pixel */ +" 32 32 2 1", +/* colors */ +". c #ffffff", +"# c #7f7f00", +/* pixels */ +"................................", +"................................", +"...................###..........", +".......####......######.........", +"....####.##.....########........", +"....########....#########.......", +"......######..###########.......", +"......#####..#############......", +".....######.##############......", +".....######.###############.....", +".....######################.....", +".....#######################....", +".....#######################....", +"......#######################...", +".......####################.#...", +"........###################.#...", +"........###############.###.#...", +"............#######.###.###.#...", +"............###.###.##...##.....", +"............###.###..#...##.....", +"............##.####..#....#.....", +"............##.###...#....#.....", +"............##.##...#.....#.....", +"............#...#...#.....#.....", +"............#....#..#.....#.....", +"............#.....#.#.....#.....", +"............#.....###.....#.....", +"...........##....##.#....#......", +"...........#..............#.....", +".........###.............#......" +"................................", +"................................", +}; diff --git a/Master/perltl/site/lib/Tk/Canvas.pm b/Master/perltl/site/lib/Tk/Canvas.pm new file mode 100644 index 00000000000..e1ce78b6a93 --- /dev/null +++ b/Master/perltl/site/lib/Tk/Canvas.pm @@ -0,0 +1,60 @@ +package Tk::Canvas; +use vars qw($VERSION); +$VERSION = '3.018'; # $Id: //depot/Tk8/Canvas/Canvas.pm#18 $ + +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; + } +} + + + +1; + diff --git a/Master/perltl/site/lib/Tk/Checkbutton.pm b/Master/perltl/site/lib/Tk/Checkbutton.pm new file mode 100644 index 00000000000..e5c43f15f24 --- /dev/null +++ b/Master/perltl/site/lib/Tk/Checkbutton.pm @@ -0,0 +1,42 @@ +package Tk::Checkbutton; +# Conversion from Tk4.0 button.tcl competed. +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or + + +use vars qw($VERSION); +$VERSION = '3.011'; # $Id: //depot/Tk8/Tk/Checkbutton.pm#11 $ + +# modify it under the same terms as Perl itself, subject +# to additional disclaimer in license.terms due to partial +# derivation from Tk4.0 sources. + +require Tk::Widget; +require Tk::Button; + +use base qw(Tk::Button); + +Construct Tk::Widget 'Checkbutton'; + +sub Tk_cmd { \&Tk::checkbutton } + + +sub ClassInit +{ + my ($class,$mw) = @_; + $mw->bind($class,'', 'Enter'); + $mw->bind($class,'', 'Leave'); + $mw->bind($class,'<1>', 'Invoke'); + $mw->bind($class,'', 'Invoke'); + return $class; +} + +sub Invoke +{ + my $w = shift; + $w->invoke() unless($w->cget('-state') eq 'disabled'); +} + +1; diff --git a/Master/perltl/site/lib/Tk/Clipboard.pm b/Master/perltl/site/lib/Tk/Clipboard.pm new file mode 100644 index 00000000000..6990b371f58 --- /dev/null +++ b/Master/perltl/site/lib/Tk/Clipboard.pm @@ -0,0 +1,110 @@ +# Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. +package Tk::Clipboard; +use strict; + +use vars qw($VERSION); +$VERSION = '3.016'; # $Id: //depot/Tk8/Tk/Clipboard.pm#16 $ + +use AutoLoader qw(AUTOLOAD); +use Tk qw(catch); + +sub clipEvents +{ + return qw[Copy Cut Paste]; +} + +sub ClassInit +{ + my ($class,$mw) = @_; + foreach my $op ($class->clipEvents) + { + $mw->Tk::bind($class,"<<$op>>","clipboard$op"); + } + return $class; +} + +sub clipboardSet +{ + my $w = shift; + $w->clipboardClear; + $w->clipboardAppend(@_); +} + +sub clipboardCopy +{ + my $w = shift; + my $val = $w->getSelected; + if (defined $val) + { + $w->clipboardSet('--',$val); + } + return $val; +} + +sub clipboardCut +{ + my $w = shift; + my $val = $w->clipboardCopy; + if (defined $val) + { + $w->deleteSelected; + } + return $val; +} + +sub clipboardGet +{ + my $w = shift; + $w->SelectionGet('-selection','CLIPBOARD',@_); +} + +sub clipboardPaste +{ + my $w = shift; + local $@; + catch { $w->insert('insert',$w->clipboardGet)}; +} + +sub clipboardOperations +{ + my @class = (); + my $mw = shift; + if (ref $mw) + { + $mw = $mw->DelegateFor('bind'); + } + else + { + push(@class,$mw); + $mw = shift; + } + while (@_) + { + my $op = shift; + $mw->Tk::bind(@class,"<<$op>>","clipboard$op"); + } +} + +# These methods work for Entry and Text +# and can be overridden where they don't work + +sub deleteSelected +{ + my $w = shift; + catch { $w->delete('sel.first','sel.last') }; +} + + +1; +__END__ + +sub getSelected +{ + my $w = shift; + my $val = Tk::catch { $w->get('sel.first','sel.last') }; + return $val; +} + + diff --git a/Master/perltl/site/lib/Tk/CmdLine.pm b/Master/perltl/site/lib/Tk/CmdLine.pm new file mode 100644 index 00000000000..09d4da9c41d --- /dev/null +++ b/Master/perltl/site/lib/Tk/CmdLine.pm @@ -0,0 +1,954 @@ +package Tk::CmdLine; # -*-Perl-*- + +#/----------------------------------------------------------------------------// +#/ Module: Tk/CmdLine.pm +#/ +#/ Purpose: +#/ +#/ Process standard X11 command line options and set initial resources. +#/ +#/ Author: ???? Date: ???? +#/ +#/ History: SEE POD +#/----------------------------------------------------------------------------// + +use vars qw($VERSION); +$VERSION = '3.030'; # $Id: //depot/Tk8/Tk/CmdLine.pm#30 $ + +use 5.004; + +use strict; + +use Config; + +my $OBJECT = undef; # define the current object + +#/----------------------------------------------------------------------------// +#/ Constructor +#/ Returns the object reference. +#/----------------------------------------------------------------------------// + +sub new # Tk::CmdLine::new() +{ + my $this = shift(@_); + my $class = ref($this) || $this; + + my $name = 'pTk'; + $name = $1 if (($0 =~ m/(?:^|[\/\\])([\w-]+)(?:\.\w+)?$/) && ($1 ne '-e')); + + my $self = { + name => $name, + config => { -name => $name }, + options => {}, + methods => {}, + command => [], + synchronous => 0, + iconic => 0, + motif => ($Tk::strictMotif || 0), + resources => {} }; + + return bless($self, $class); +} + +#/----------------------------------------------------------------------------// +#/ Process the arguments in a given array or in @ARGV. +#/ Returns the object reference. +#/----------------------------------------------------------------------------// + +sub Argument_ # Tk::CmdLine::Argument_($flag) # private method +{ + my $self = shift(@_); + my $flag = shift(@_); + unless ($self->{offset} < @{$self->{argv}}) + { + die 'Usage: ', $self->{name}, ' ... ', $flag, " ...\n"; + } + return splice(@{$self->{argv}}, $self->{offset}, 1); +} + +sub Config_ # Tk::CmdLine::Config_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + push(@{$self->{command}}, $flag, $val); + $self->{config}->{"-$name"} = $val; +} + +sub Flag_ # Tk::CmdLine::Flag_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + push(@{$self->{command}}, $flag); + $self->{$name} = 1; +} + +sub Option_ # Tk::CmdLine::Option_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + push(@{$self->{command}}, $flag, $val); + $self->{options}->{"*$name"} = $val; +} + +sub Method_ # Tk::CmdLine::Method_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + push(@{$self->{command}}, $flag, $val); + $self->{methods}->{$name} = $val; +} + +sub Resource_ # Tk::CmdLine::Resource_($flag, $name) # private method +{ + my $self = shift(@_); + my ($flag, $name) = @_; + my $val = $self->Argument_($flag); + if ($val =~ /^([^!:\s]+)*\s*:\s*(.*)$/) + { + push(@{$self->{command}}, $flag, $val); + $self->{options}->{$1} = $2; + } +} + +my %Method = ( + background => 'Option_', + bg => 'background', # alias + class => 'Config_', + display => 'screen', # alias + fg => 'foreground', # alias + fn => 'font', # alias + font => 'Option_', + foreground => 'Option_', + geometry => 'Method_', + iconic => 'Flag_', + iconposition => 'Method_', + motif => 'Flag_', + name => 'Config_', + screen => 'Config_', + synchronous => 'Flag_', + title => 'Config_', + xrm => 'Resource_' +); + +sub SetArguments # Tk::CmdLine::SetArguments([@argument]) +{ + my $self = (@_ # define the object as necessary + ? ((ref($_[0]) eq __PACKAGE__) + ? shift(@_) + : (($_[0] eq __PACKAGE__) ? shift(@_) : 1) && ($OBJECT ||= __PACKAGE__->new())) + : ($OBJECT ||= __PACKAGE__->new())); + $OBJECT = $self; # update the current object + $self->{argv} = (@_ ? [ @_ ] : \@ARGV); + $self->{offset} = 0; # its existence will denote that this method has been called + + my @option = (); + + while ($self->{offset} < @{$self->{argv}}) + { + last if ($self->{argv}->[$self->{offset}] eq '--'); + unless ( + (($self->{argv}->[$self->{offset}] =~ /^-{1,2}(\w+)$/) && (@option = $1)) || + (($self->{argv}->[$self->{offset}] =~ /^--(\w+)=(.*)$/) && (@option = ($1, $2)))) + { + ++$self->{offset}; + next; + } + + next if (!exists($Method{$option[0]}) && ++$self->{offset}); + + $option[0] = $Method{$option[0]} if exists($Method{$Method{$option[0]}}); + + my $method = $Method{$option[0]}; + + if (@option > 1) # replace --