APPROVE COMMIT Norbert! This is good to go. NOTE: This patch has been committed. xwem patch: ChangeLog files diff command: cvs -q diff -U 0 Files affected: ChangeLog Source files diff command: cvs -q diff -uN Files affected: man/xwem.texi man/xwem-version.texi lisp/xwem-xfig.el lisp/xwem-worklog.el lisp/xwem-win.el lisp/xwem-weather.el lisp/xwem-transient.el lisp/xwem-theme.el lisp/xwem-tabbing.el lisp/xwem-strokes.el lisp/xwem-special.el lisp/xwem-sound.el lisp/xwem-selections.el lisp/xwem-rooticon.el lisp/xwem-root.el lisp/xwem-register.el lisp/xwem-pager.el lisp/xwem-osd.el lisp/xwem-netwm.el lisp/xwem-mouse.el lisp/xwem-modes.el lisp/xwem-minibuffer.el lisp/xwem-manage.el lisp/xwem-main.el lisp/xwem-load.el lisp/xwem-keytt.el lisp/xwem-keymacro.el lisp/xwem-keydefs.el lisp/xwem-keyboard.el lisp/xwem-interactive.el lisp/xwem-icons.el lisp/xwem-holer.el lisp/xwem-help.el lisp/xwem-frametrans.el lisp/xwem-framei.el lisp/xwem-frame.el lisp/xwem-focus.el lisp/xwem-faces.el lisp/xwem-events.el lisp/xwem-edprops.el lisp/xwem-edmacro.el lisp/xwem-diagram.el lisp/xwem-desktop.el lisp/xwem-compat.el lisp/xwem-clswi.el lisp/xwem-clients.el lisp/xwem-clgen.el lisp/xwem-battery.el lisp/xwem-appcollect.el lisp/ixwem.el icons/mini-xv.xpm icons/mini-graph.xpm icons/mini-display.xpm icons/README package-info.in Makefile ChangeLog.upstream Index: ChangeLog =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/ChangeLog,v retrieving revision 1.74 diff -u -U0 -r1.74 ChangeLog --- ChangeLog 16 Dec 2004 08:07:47 -0000 1.74 +++ ChangeLog 1 Jan 2005 04:41:39 -0000 ＠＠ -0,0 +1,8 ＠＠ +2005-01-01 Steve Youngs <steve(a)youngs.au.com&gt; + + * Makefile (AUTHOR_VERSION): Bump. + (REQUIRES): Add elib, ilisp, and mail-lib. + + This is the version 2.0 release. For details see + ChangeLog.upstream. + Index: ChangeLog.upstream =================================================================== RCS file: ChangeLog.upstream diff -N ChangeLog.upstream --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ ChangeLog.upstream 1 Jan 2005 04:41:09 -0000 ＠＠ -0,0 +1,730 ＠＠ +# do not edit -- automatically generated by arch changelog +# non-id: automatic-ChangeLog--lg(a)xwem.org--2004/xwem--main--2.0 +# + +2005-01-01 02:30:16 GMT Zajcev Evgeny <lg(a)xwem.org&gt; version-0 + + Summary: + Version 2.0 is released + Revision: + xwem--main--2.0--version-0 + + + new files: + .arch-ids/README.id README + + +2004-12-29 22:32:15 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-19 + + Summary: + xparent problem kind of fix, dedicated problem kind of fix + Revision: + xwem--main--2.0--patch-19 + + * lisp/xwem-clgen.el (on-kill): [fix?] Do not do XDestroyWindow + + * lisp/xwem-clients.el (xwem-clded-disassociate-frame): [fix] check + xwem-cl-win for validity before operating on it. + + + + modified files: + lisp/xwem-clgen.el lisp/xwem-clients.el + + +2004-12-23 22:26:45 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-18 + + Summary: + very tiny fixes + Revision: + xwem--main--2.0--patch-18 + + * lisp/xwem-icons.el (xwem-icons-list): [fix] Removed redundant .* + + * lisp/xwem-keymacro.el (xwem-misc): [addon] Require xwem-misc + + * lisp/xwem-manage.el (xwem-applications-alist): [fix] xemacs to match + GNU Emacs, XEmacs and SXEmacs. + + + + + modified files: + lisp/xwem-icons.el lisp/xwem-keymacro.el lisp/xwem-manage.el + + +2004-12-20 21:03:40 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-17 + + Summary: + Merged with 2004-w + Revision: + xwem--main--2.0--patch-17 + + Patches applied: + + * dev(a)xwem.org--2004-w/xwem--dev--2.0--patch-3 + Merged with main, some fixes + + + modified files: + Makefile lisp/xwem-keymacro.el lisp/xwem-minibuffer.el + lisp/xwem-misc.el man/Makefile + + new patches: + dev(a)xwem.org--2004-w/xwem--dev--2.0--patch-3 + + +2004-12-19 22:45:44 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-16 + + Summary: + xwem tray fixes to support dockapp's map/unmap, osd fix + Revision: + xwem--main--2.0--patch-16 + + * lisp/xwem-keyboard.el (xwem-kbd-quit): [typo] + + * lisp/xwem-tray.el (xwem-tray-remove-dapp): [fix] check dapp state. + + * lisp/xwem-tray.el (xwem-tray-hide-dapp): [new] + + * lisp/xwem-tray.el (xwem-tray-show-dapp): [new] + + * lisp/xwem-tray.el (xwem-tray-get-proper-position): [fix] check dapp's + state. + + * lisp/xwem-tray.el (xwem-tray-new-dapp): [fix] change dapp's state after + XMapWindow. + + * lisp/xwem-tray.el (xwem-tray-init): [fix] Handle MapNotify/UnmapNotify + events. + + * lisp/xwem-tray.el (xwem-tray-handle-xevent): [fix] Handle + MapNotify/UnmapNotify events. + + * utils/xwem-osd.el (xwem-osd-rect-add): [Sem] Optional FILL-P argument + added. + + modified files: + lisp/xwem-keyboard.el lisp/xwem-tray.el utils/xwem-osd.el + + +2004-12-19 01:40:32 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-15 + + Summary: + compile custom-load.el + Revision: + xwem--main--2.0--patch-15 + + * Makefile (EXTRA_OBJ): [addon] custom-load.elc + + * Makefile (distclean): [addon] remove .elc files expilicitely. + + modified files: + Makefile + + +2004- + + modified files: + Makefile lisp/xwem-frame.el lisp/xwem-minibuffer.el + lisp/xwem-misc.el lisp/xwem-tabbing.el lisp/xwem-theme.el + lisp/xwem-win.el lpath.el man/Makefile + + +2004-12-11 21:22:18 GMT Evgeny Zajcev <lg(a)xwem.org&gt; patch-5 + + Summary: + hot fix + Revision: + xwem--main--2.0--patch-5 + + + modified files: + Makefile lisp/xwem-clients.el lisp/xwem-main.el + lisp/xwem-minibuffer.el lisp/xwem-root.el + + +2004-12-11 20:33:02 GMT Evgeny Zajcev <lg(a)xwem.org&gt; patch-4 + + Summary: + Sync with CVS, some fixes. + Revision: + xwem--main--2.0--patch-4 + + lisp/xwem-clgen.el (xwem-withdraw-generic): [rem] Evil things removed to + avoid BadWindow X errors. + + lisp/xwem-keyboard.el (modifiers): [sch] Modifiers handling changed. Alt + key should work, however not checked. + + lisp/xwem-clients.el (xwem-client-apply-state): [fix] Handle change to + withdrawn state specially to avoid BadWindow X errors. + + lisp/xwem-root.el (xwem-root-events-handler): [addon] X-MappingNotify + handler added. + + lisp/xwem-events.el (xwem-ev-reconfig): [fix] Do things more safely, + should fix opera issue. + + lisp/xwem-win.el (xwem-frame-set-win-config-frame-params): [fix] use + `xwem-frame-apply-xgeom-1'. + + + modified files: + lisp/xwem-clgen.el lisp/xwem-clients.el lisp/xwem-events.el + lisp/xwem-keyboard.el lisp/xwem-main.el lisp/xwem-root.el + lisp/xwem-win.el + + +2004-12-10 23:29:27 GMT Evgeny Zajcev <lg(a)xwem.org&gt; patch-3 + + Summary: + merge from steve (build cleanup) + Revision: + xwem--main--2.0--patch-3 + + Patches applied: + + * steve(a)eicq.org--2004/xwem--steve--2.0--patch-4 + sync to lg + + * steve(a)eicq.org--2004/xwem--steve--2.0--patch-5 + fix some function foo not known to be defined warnings + + + modified files: + lpath.el + + new patches: + steve(a)eicq.org--2004/xwem--steve--2.0--patch-4 + steve(a)eicq.org--2004/xwem--steve--2.0--patch-5 + + +2004-12-10 22:46:33 GMT Evgeny Zajcev <lg(a)xwem.org&gt; patch-2 + + Summary: + makefile changes + Revision: + xwem--main--2.0--patch-2 + + + modified files: + Makefile + + +2004-12-10 21:51:10 GMT Evgeny Zajcev <lg(a)xwem.org&gt; patch-1 + + Summary: + merge from steve + Revision: + xwem--main--2.0--patch-1 + + Patches applied: + + * steve(a)eicq.org--2004/xwem--steve--2.0--base-0 + tag of lg(a)xwem.org--2004/xwem--main--2.0--base-0 + + * steve(a)eicq.org--2004/xwem--steve--2.0--patch-1 + Add some missing files to the repo + + * steve(a)eicq.org--2004/xwem--steve--2.0--patch-2 + Introduce a tla-stlye version string, clean up the build + + * steve(a)eicq.org--2004/xwem--steve--2.0--patch-3 + emergancy build fix + + + new files: + .arch-ids/Makefile.id .arch-ids/xwem-loaddefs-gen.el.id + Makefile battery/.arch-ids/=id battery/.arch-ids/Makefile.id + battery/.arch-ids/battery.c.id battery/Makefile + battery/battery.c dockapp/.arch-ids/.arch-inventory.id + dockapp/.arch-ids/=id dockapp/.arch-ids/xwem-battery.el.id + dockapp/.arch-ids/xwem-framei.el.id + dockapp/.arch-ids/xwem-pager.el.id + dockapp/.arch-ids/xwem-time.el.id + dockapp/.arch-ids/xwem-weather.el.id dockapp/.arch-inventory + dockapp/xwem-battery.el dockapp/xwem-framei.el + dockapp/xwem-pager.el dockapp/xwem-time.el + dockapp/xwem-weather.el extra/.arch-ids/.arch-inventory.id + extra/.arch-ids/=id extra/.arch-ids/ixwem.el.id + extra/.arch-ids/xwem-edprops.el.id + extra/.arch-ids/xwem-frametrans.el.id + extra/.arch-ids/xwem-recover.el.id + extra/.arch-ids/xwem-smartmods.el.id + extra/.arch-ids/xwem-vert.el.id extra/.arch-inventory + extra/ixwem.el extra/xwem-edprops.el extra/xwem-frametrans.el + extra/xwem-recover.el extra/xwem-smartmods.el + extra/xwem-vert.el icons/.arch-ids/=id + icons/.arch-ids/README.id icons/.arch-ids/mini-acroread.xpm.id + icon + icons/mini-xchat1.xpm icons/mini-xdvi.xpm + icons/mini-xemacs.xpm icons/mini-xemacs1.xpm + icons/mini-xemacsC.xpm icons/mini-xemacsgnus.xpm + icons/mini-xemacsinfo.xpm icons/mini-xemacspy.xpm + icons/mini-xemacstex.xpm icons/mini-xfig.xpm + icons/mini-xkeycaps.xpm icons/mini-xterm.xpm + icons/mini-xterm1.xpm icons/mini-xv.xpm icons/mini-xv1.xpm + icons/mini-xwem.xpm icons/mini-zoom.xpm + icons/mini32x32-help.xpm icons/root-icon.xpm + lisp/.arch-ids/.arch-inventory.id lisp/.arch-ids/=id + lisp/.arch-ids/xwem-clgen.el.id + lisp/.arch-ids/xwem-clients.el.id + lisp/.arch-ids/xwem-clswi.el.id + lisp/.arch-ids/xwem-compat.el.id + lisp/.arch-ids/xwem-desktop.el.id + lisp/.arch-ids/xwem-edmacro.el.id + lisp/.arch-ids/xwem-events.el.id + lisp/.arch-ids/xwem-faces.el.id + lisp/.arch-ids/xwem-focus.el.id + lisp/.arch-ids/xwem-frame.el.id + lisp/.arch-ids/xwem-gamma.el.id lisp/.arch-ids/xwem-help.el.id + lisp/.arch-ids/xwem-icons.el.id + lisp/.arch-ids/xwem-interactive.el.id + lisp/.arch-ids/xwem-keyboard.el.id + lisp/.arch-ids/xwem-keydefs.el.id + lisp/.arch-ids/xwem-keymacro.el.id + lisp/.arch-ids/xwem-launcher.el.id + lisp/.arch-ids/xwem-load.el.id lisp/.arch-ids/xwem-main.el.id + lisp/.arch-ids/xwem-manage.el.id + lisp/.arch-ids/xwem-minibuffer.el.id + lisp/.arch-ids/xwem-misc.el.id lisp/.arch-ids/xwem-modes.el.id + lisp/.arch-ids/xwem-mouse.el.id + lisp/.arch-ids/xwem-netwm.el.id + lisp/.arch-ids/xwem-ratanot.el.id + lisp/.arch-ids/xwem-register.el.id + lisp/.arch-ids/xwem-report.el.id + lisp/.arch-ids/xwem-root.el.id + lisp/.arch-ids/xwem-rooter.el.id + lisp/.arch-ids/xwem-rooticon.el.id + lisp/.arch-ids/xwem-selections.el.id + lisp/.arch-ids/xwem-sound.el.id + lisp/.arch-ids/xwem-special.el.id + lisp/.arch-ids/xwem-strokes.el.id + lisp/.arch-ids/xwem-struct.el.id + lisp/.arch-ids/xwem-tabbing.el.id + lisp/.arch-ids/xwem-theme.el.id + lisp/.arch-ids/xwem-transient.el.id + lisp/.arch-ids/xwem-tray.el.id lisp/.arch-ids/xwem-win.el.id + lisp/.arch-inventory lisp/xwem-clgen.el lisp/xwem-clients.el + lisp/xwem-clswi.el lisp/xwem-compat.el lisp/xwem-desktop.el + lisp/xwem-edmacro.el lisp/xwem-events.el lisp/xwem-faces.el + lisp/xwem-focus.el lisp/xwem-frame.el lisp/xwem-gamma.el + lisp/xwem-help.el lisp/xwem-icons.el lisp/xwem-interactive.el + lisp/xwem-keyboard.el lisp/xwem-keydefs.el + lisp/xwem-keymacro.el lisp/xwem-launcher.el lisp/xwem-load.el + lisp/xwem-main.el lisp/xwem-manage.el lisp/xwem-minibuffer.el + lisp/xwem-misc.el lisp/xwem-modes.el lisp/xwem-mouse.el + lisp/xwem-netwm.el lisp/xwem-ratanot.el lisp/xwem-register.el + lisp/xwem-report.el lisp/xwem-root.el lisp/xwem-rooter.el + lisp/xwem-rooticon.el lisp/xwem-selections.el + lisp/xwem-sound.el lisp/xwem-special.el lisp/xwem-strokes.el + lisp/xwem-struct.el lisp/xwem-tabbing.el lisp/xwem-theme.el + lisp/xwem-transient.el lisp/xwem-tray.el lisp/xwem-win.el + man/.arch-ids/.arch-inventory.id man/.arch-ids/=id + man/.arch-ids/Makefile.id man/.arch-ids/addons.texi.id + man/.arch-ids/client.texi.id man/.arch-ids/frame.texi.id + man/.arch-ids/help.texi.id man/.arch-ids/hooking.texi.id + man/.arch-ids/logging.texi.id man/.arch-ids/manda.texi.id + man/.arch-ids/minibuf.texi.id man/.arch-ids/overview.texi.id + man/.arch-ids/primitives.texi.id man/.arch-ids/start.texi.id + man/.arch-ids/subsystems.texi.id + man/.arch-ids/textspec.texi.id man/.arch-ids/tray.texi.id + man/.arch-ids/win.texi.id man/.arch-ids/xwem.texi.id + man/.arch-inventory man/Makefile man/addons.texi + man/client.texi man/frame.texi man/help.texi man/hooking.texi + man/logging.texi man/manda.texi man/minibuf.texi + man/overview.texi man/primitives.texi man/start.texi + man/subsystems.texi man/textspec.texi man/tray.texi + man/win.texi man/xwem.texi utils/.arch-ids/.arch-inventory.id + utils/.arch-ids/=id utils/.arch-ids/xwem-appcollect.el.id + utils/.arch-ids/xwem-diagram.el.id + utils/.arch-ids/xwem-holer.el.id + utils/.arch-ids/xwem-osd.el.id + utils/.arch-ids/xwem-worklog.el.id + utils/.arch-ids/xwem-xfig.el.id utils/.arch-inventory + utils/xwem-appcollect.el utils/xwem-diagram.el + utils/xwem-holer.el utils/xwem-osd.el utils/xwem-worklog.el + utils/xwem-xfig.el xwem-loaddefs-gen.el + + modified files: + lpath.el package-info.in + + renamed files: + .arch-ids/Makefile.id + ==> .arch-ids/Makfile.CVS.id + Makefile + ==> Makfile.CVS + + new directories: + battery battery/.arch-ids dockapp dockapp/.arch-ids extra + extra/.arch-ids icons icons/.arch-ids lisp lisp/.arch-ids man + man/.arch-ids utils utils/.arch-ids + + new patches: + steve(a)eicq.org--2004/xwem--steve--2.0--base-0 + steve(a)eicq.org--2004/xwem--steve--2.0--patch-1 + steve(a)eicq.org--2004/xwem--steve--2.0--patch-2 + steve(a)eicq.org--2004/xwem--steve--2.0--patch-3 + + +2004-12-08 19:22:14 GMT Evgeny Zajcev <lg(a)xwem.org&gt; base-0 + + Summary: + Initial import of xwem sources. + Revision: + xwem--main--2.0--base-0 + + + new files: + ChangeLog.CVS Makefile TODO logo.xpm lpath.el package-info.in + + Index: Makefile =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/Makefile,v retrieving revision 1.29 diff -u -u -r1.29 Makefile --- Makefile 16 Dec 2004 08:07:47 -0000 1.29 +++ Makefile 1 Jan 2005 04:41:09 -0000 ＠＠ -18,11 +18,12 ＠＠ # Boston, MA 02111-1307, USA. VERSION = 1.18 -AUTHOR_VERSION = 0.2 +AUTHOR_VERSION = lg(a)xwem.org--2004/xwem--main--2.0--version-0 MAINTAINER = Zajcev Evgeny <zevlg(a)yandex.ru&gt; PACKAGE = xwem PKG_TYPE = regular -REQUIRES = xwem xemacs-base xlib strokes edit-utils text-modes time slider +REQUIRES = xwem xemacs-base xlib strokes edit-utils text-modes time slider \ + elib ilisp mail-lib CATEGORY = standard DONTCOMPILE = lisp/_pkg.el lisp/auto-autoloads.el lisp/custom-load.el Index: package-info.in =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/package-info.in,v retrieving revision 1.4 diff -u -u -r1.4 package-info.in --- package-info.in 16 Dec 2004 08:07:48 -0000 1.4 +++ package-info.in 1 Jan 2005 04:41:09 -0000 ＠＠ -13,17 +13,21 ＠＠ filename FILENAME md5sum MD5SUM size SIZE - provides (xwem-clients xwem-compat xwem-events xwem-faces - xwem-focus xwem-frame xwem-help xwem-icons - xwem-interactive xwem-keyboard xwem-keydefs - xwem-keymacro xwem-launcher xwem-load xwem-macros - xwem-main xwem-manage xwem-minibuffer xwem-misc - xwem-mouse xwem-root xwem-sound xwem-special - xwem-strokes xwem-tabbing xwem-tray xwem-win - xwem-clswi xwem-diagram xwem-edmacro xwem-framei - xwem-gamma xwem-holer xwem-osd xwem-register - xwem-rooter xwem-smartmods xwem-time xwem-worklog - xwem-xfig xwem-keytt) + provides (ixwem xwem-appcollect xwem-battery xwem-clgen + xwem-clients xwem-clswi xwem-compat xwem-desktop + xwem-diagram xwem-edmacro xwem-edprops xwem-events + xwem-faces xwem-focus xwem-frame xwem-framei + xwem-frametrans xwem-gamma xwem-help xwem-holer + xwem-icons xwem-interactive xwem-keyboard xwem-keydefs + xwem-keymacro xwem-keytt xwem-launcher xwem-load + xwem-loaddefs xwem-macros xwem-main xwem-manage + xwem-minibuffer xwem-misc xwem-modes xwem-mouse + xwem-netwm xwem-osd xwem-pager xwem-ratanot xwem-recover + xwem-register xwem-report xwem-root xwem-rooter + xwem-rooticon xwem-selections xwem-smartmods xwem-sound + xwem-special xwem-strokes xwem-struct xwem-tabbing + xwem-theme xwem-time xwem-transient xwem-tray xwem-version + xwem-vert xwem-weather xwem-win xwem-worklog xwem-xfig) requires (REQUIRES) type regular )) Index: icons/README =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/icons/README,v retrieving revision 1.3 diff -u -u -r1.3 README --- icons/README 16 Dec 2004 08:07:58 -0000 1.3 +++ icons/README 1 Jan 2005 04:41:09 -0000 ＠＠ -37,6 +37,10 ＠＠ * "};" must be on its own line at the end of file. * ' ' must be used for None color. + + * Do not use ',' character to denote color. + + * No trailing spaces in any line. Recommended, but not required: Index: icons/mini-display.xpm =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/icons/mini-display.xpm,v retrieving revision 1.3 diff -u -u -r1.3 mini-display.xpm --- icons/mini-display.xpm 16 Dec 2004 08:07:58 -0000 1.3 +++ icons/mini-display.xpm 1 Jan 2005 04:41:09 -0000 ＠＠ -1,28 +1,27 ＠＠ /* XPM */ static char *mini_display_xpm[] = { /* columns rows colors chars-per-pixel */ -"16 16 6 1", +"16 16 5 1", " c None", ". c gray50", "X c white", "o c black", "O c blue", -"+ c gray85", /* pixels */ -" ", -" ............ ", -" .XXXXXXXXXXXXo ", -" .Xooooooooo.Xo ", -" .XoOOOOOOOO.Xo ", -" .XoOXOOOOOO.Xo ", -" .XoOOOOOOOO.Xo ", -" .XoOOOOOOOO.Xo ", -" .XoOOOOOOOO.Xo ", -" .XoOOOOOOOO.Xo ", -" .Xo.........Xo ", -" .XXXXXXXXXXXXo ", -" oooooooooooo ", -" .XXXX+.o ", -" oooooooooooo ", -" " +" ", +" ............ ", +" .XXXXXXXXXXXXo ", +" .Xooooooooo.Xo ", +" .XoOOOOOOOO.Xo ", +" .XoOXXOOOOO.Xo ", +" .XoOOOOOOOO.Xo ", +" .XoOOOOOOOO.Xo ", +" .XoOOOOOOOO.Xo ", +" .XoOOOOOOOO.Xo ", +" .Xo.........Xo ", +" .XXXXXXXXXXXXo ", +" oooooooooooo ", +" .XXXX..o ", +" oooooooooooo ", +" " }; Index: icons/mini-graph.xpm =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/icons/mini-graph.xpm,v retrieving revision 1.3 diff -u -u -r1.3 mini-graph.xpm --- icons/mini-graph.xpm 16 Dec 2004 08:07:58 -0000 1.3 +++ icons/mini-graph.xpm 1 Jan 2005 04:41:09 -0000 ＠＠ -10,6 +10,7 ＠＠ "r c red", "＠ c #808080", /* pixels */ +" ", " ### ", " mm# ", " mm# ", ＠＠ -24,8 +25,5 ＠＠ " gg# bb# mm# rr#", " gg# bb# mm# rr#", "################", -" ＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠", -" " -}; - - \ No newline at end of file +" ＠＠＠＠＠＠＠＠＠＠＠＠＠＠＠" +}; Index: icons/mini-xv.xpm =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/icons/mini-xv.xpm,v retrieving revision 1.3 diff -u -u -r1.3 mini-xv.xpm --- icons/mini-xv.xpm 16 Dec 2004 08:07:58 -0000 1.3 +++ icons/mini-xv.xpm 1 Jan 2005 04:41:09 -0000 ＠＠ -3,9 +3,9 ＠＠ /* width height num_colors chars_per_pixel */ "16 16 4 1", " c None", -"# c black", -"r c red", -". c white", +"# c black s xblack", +"r c red s xred", +". c white s xwhite", /* pixels */ " ", " ", Index: lisp/ixwem.el =================================================================== RCS file: lisp/ixwem.el diff -N lisp/ixwem.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/ixwem.el 1 Jan 2005 04:41:09 -0000 ＠＠ -0,0 +1,150 ＠＠ +;;; ixwem.el --- + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Created: Sat Sep 11 21:38:13 GMT 2004 +;; Keywords: xwem +;; X-CVS: $Id: ixwem.el,v 1.2 2004/12/05 05:52:26 youngs Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; + +;;; Code: + + +;; Highlighting. +;; TODO: +;; - font lock faces +;; - +(require 'xwem-load) + +(defgroup ixwem nil + "Group to customize IXWEM." +:prefix "ixwem-" +:group 'xwem) + +(defcustom ixwem-name-length 32 + "*Maximum length of xwem client name to display." +:type 'number +:group 'ixwem) + +;;; Internal variables + +(defvar ixwem-header-line + (concat " IMD Manda Client Size Frame Uptime\n" + " --- ----- ------ ---- ----- ------\n")) + +(defvar ixwem-local-map + (let ((map (make-sparse-keymap))) + (define-key map ?q 'ixwem-quit) + map) + "Keymap used when in ixwem mode.") + + +(defun ixwem-client-format (cl) + (format (format " %%.%ds\n" ixwem-name-length) + (xwem-client-name cl))) + +(defun ixwem-draw-tree (buf) + "Draw clients tree in buffer BUF." + (with-current-buffer buf + (erase-buffer buf) + + (insert (concat " Name" (make-string (- ixwem-name-length 3) ?\x20) + "Size " "Uptime " "Recency\n")) + (insert (concat " ----" (make-string (- ixwem-name-length 3) ?\x20) + "---- " "------ " "-------\n")) + (mapc (lambda (ma) + (insert (format "[%S]\n" (xwem-manda-name ma))) + (cond ((eq (xwem-manda-name ma) 'generic) + (mapc (lambda (fr) + (insert (format " {F%d: %s}\n" + (xwem-frame-num fr) (xwem-frame-name fr))) + (mapc (lambda (cl) + (when (and (eq (xwem-cl-frame cl) fr) + (eq (xwem-cl-manda cl) ma)) + (insert (ixwem-client-format cl)))) + xwem-clients)) + xwem-frames-list)) + (t (mapc (lambda (cl) + (when (eq (xwem-cl-manda cl) ma) + (insert (ixwem-client-format cl)))) + xwem-clients)))) + xwem-manda-list) + )) + +(defun ixwem-list-clients (buf) + "List xwem clients in BUF buffer." + (with-current-buffer buf + (erase-buffer) + + ;; Display header + (insert ixwem-header-line) + + ;; Display clients tree + (mapcar (lambda (cl) + (let ((bstr (make-string 40 ?\x20))) + (insert + (format " *# %.9s %.24s %.8s %.8s %.20s\n" + (concat (symbol-name (xwem-manda-name (xwem-cl-manda cl))) bstr) + (concat (xwem-client-name cl) bstr) + (concat (let ((gg (xwem-cl-get-usize cl))) + (format "%dx%d" (car gg) (cdr gg))) + bstr) + (if (xwem-cl-frame cl) + (concat (xwem-frame-name (xwem-cl-frame cl)) bstr) + bstr) + (concat (xwem-cl-get-uptime cl) bstr))))) + xwem-clients) + )) + +(defun ixwem-mode () + "Enter ixwem mode." + (setq major-mode 'ixwem) + (setq mode-name "IXWEM") + (use-local-map ixwem-local-map) + ) + +;;;###autoload(autoload 'ixwem "ixwem" "" t) +(define-xwem-command ixwem () + "Interactive xwem clients browsing." + (xwem-interactive) + + (let ((buf (get-buffer-create "*ixwem*"))) + (switch-to-buffer buf) + (ixwem-draw-tree buf) +; (ixwem-list-clients buf) + (ixwem-mode) + )) + +(defun ixwem-quit () + "Quit IXWEM." + (interactive) + + (bury-buffer)) + + +(provide 'ixwem) + +;;; ixwem.el ends here Index: lisp/xwem-appcollect.el =================================================================== RCS file: lisp/xwem-appcollect.el diff -N lisp/xwem-appcollect.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-appcollect.el 1 Jan 2005 04:41:09 -0000 ＠＠ -0,0 +1,105 ＠＠ +;;; xwem-appcollect.el --- + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Created: Fri Oct 29 04:35:18 MSD 2004 +;; Keywords: xwem +;; X-CVS: $Id: xwem-appcollect.el,v 1.1 2004/11/29 20:42:25 lg Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; Helpfull util to create `xwem-applications-alist'. +;; Usage: +;; +;; (xwem-appcollect '("xterm" "mozilla")) + +;; (xwem-appcollect '("xterm" "mozilla") '(name class) 'or) + +;; (xwem-appcollect '("xterm" "mozilla") '(command) 'or) + +;;; Code: + +(require 'xwem-load) +(require 'xwem-manage) +(require 'xwem-launcher) + +(define-xwem-method manage appcollect (cl) + "Manage method when collecting info about applications." + (declare (special xwem-app-collection)) + (declare (special xwem-app-collect-wait)) + + (let ((app-name (xwem-cl-get-prop cl 'xwem-appcollect-app-name)) + (op (xwem-cl-get-prop cl 'xwem-appcollect-op)) + (params (xwem-cl-get-prop cl 'xwem-appcollect-params)) + mspec) + + (setq mspec (list op)) + (mapc (lambda (par) + (cond ((eq par 'class) + (push `(and (class-inst ,(concat "^" (car (xwem-hints-wm-class (xwem-cl-hints cl))) "$")) + (class-name ,(concat "^" (cdr (xwem-hints-wm-class (xwem-cl-hints cl))) "$"))) + mspec)) + ((eq par 'name) + (push `(name ,(concat "^" (xwem-hints-wm-name (xwem-cl-hints cl)) "$")) + mspec)) + ((eq par 'command) + (push `(command ,(concat "^" (xwem-hints-wm-command (xwem-cl-hints cl)) "$")) + mspec)))) + params) + (setq mspec (nreverse mspec)) + + (setq xwem-app-collection (put-alist app-name (list mspec) xwem-app-collection)) + (xwem-client-kill cl t) + (setq xwem-app-collect-wait nil))) + +;;;###xwem-autoload(autoload 'xwem-appcollect "xwem-appcollect" nil nil) +(defun xwem-appcollect (app-names &optional params operation) + "Collect and return applications manage specs. +APP-NAMES is a list of applications to collect. + +PARAMS is a list of elements where each element is one of: + `class' - Include class-inst/class-name into mspec. + `name' - Include app name into mspec. + `command' - Include command into mspec." + (let ((xwem-app-collection nil)) + (declare (special xwem-app-collection)) + + (mapc (lambda (app) + (let ((cmd (xwem-launcher-normalize-cmd app)) + (xwem-app-collect-wait t)) + (declare (special xwem-app-collect-wait)) + (xwem-manda-add-expectance + `(appcollect (xwem-appcollect-op ,(or operation 'and) xwem-appcollect-params ,(or params '(class)) + xwem-appcollect-app-name ,app) + (eval t)) 120) + (xwem-execute-program cmd) + (while xwem-app-collect-wait + (dispatch-event (next-event))))) + app-names) + + (nreverse xwem-app-collection))) + + +(provide 'xwem-appcollect) + +;;; xwem-appcollect.el ends here Index: lisp/xwem-battery.el =================================================================== RCS file: lisp/xwem-battery.el diff -N lisp/xwem-battery.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-battery.el 1 Jan 2005 04:41:09 -0000 ＠＠ -0,0 +1,292 ＠＠ +;;; xwem-battery.el --- Dockapp APM battery monitor for XWEM. + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; +;; Created: Thu Sep 2 01:14:36 GMT 2004 +;; Keywords: xwem +;; X + X-ButtonPress X-ButtonRelease)) + + (xwem-XTrayInit (xwem-dpy) bxwin dockip dockgroup dockalign) + + (X-Win-put-prop bxwin 'xwem-batt-timer + (start-itimer "xwem-batt" + `(lambda () (xwem-batt-win-update ,bxwin)) + xwem-batt-update-interval xwem-batt-update-interval)) + 'started)) + + +;;;; In case there is no battery.ell +(unless (fboundp 'apm-battery) + (defvar apm-program "apm") + (defvar apm-state-percent-arguments "-bl") + (defvar apm-status-alist + '((0 . high) (1 . low) (2 . critical) (3 . charging))) + + (defun apm-battery () + "Return battery status." + (let (state percents) + (with-temp-buffer + (call-process apm-program nil (current-buffer) + nil apm-state-percent-arguments) + (goto-char (point-min)) + (setq state (cdr (assq (string-to-int + (buffer-substring (point-at-bol) + (point-at-eol))) + apm-status-alist))) + (forward-line) + (setq percents (string-to-int + (buffer-substring (point-at-bol) + (point-at-eol))))) + (list (eq state 'charging) state percents)))) + + +(provide 'xwem-battery) + +;;; xwem-battery.el ends here Index: lisp/xwem-clgen.el =================================================================== RCS file: lisp/xwem-clgen.el diff -N lisp/xwem-clgen.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-clgen.el 1 Jan 2005 04:41:10 -0000 ＠＠ -0,0 +1,408 ＠＠ +;;; xwem-clgen.el --- Generic model to manage clients. + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; +;; Created: Sat Aug 28 14:31:39 MSD 2004 +;; Keywords: xwem +;; X-CVS: $Id: xwem-clgen.el,v 1.3 2004/12/05 22:37:32 lg Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; Generic managing model. + +;;; Code: + +(require 'xwem-load) +(require 'xwem-manage) + +;;; Customisation +(defgroup xwem-clgen nil + "Group to customise management of generic clients." +:prefix "xwem-clgen-" +:group 'xwem-modes) + +(defcustom xwem-clgen-other-strategy 'samewin + "*Strategy used when searching for other client in window. +Possible values are: + + `samewin' - Search for client managed in window. + + `sameframe-nonactive' - Search for nonactive client managed + in window's frame. + + `sameframe-any' - Search for any client managed in window's + frame. + + `samemanda-nonactive' - Search for any nonactive client with same + manage entry as other client. + + `any-nonactive' - Search for any nonactive client." +:type '(choice (const :tag "Same Window" samewin) + (const :tag "Inactive in same frame" sameframe-nonactive) + (const :tag "Any in same frame" sameframe-any) + (const :tag "Inactive with same manda" samemanda-nonactive) + (const :tag "Any inactive" any-nonactive)) +:group 'xwem-clgen) + +(defcustom xwem-clgen-other-on-split t + "*Non-nil mean activate c +;;; xwem-clgen.el ends here Index: lisp/xwem-clients.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-clients.el,v retrieving revision 1.13 diff -u -u -r1.13 xwem-clients.el --- lisp/xwem-clients.el 16 Dec 2004 08:08:04 -0000 1.13 +++ lisp/xwem-clients.el 1 Jan 2005 04:41:10 -0000 ＠＠ -3,9 +3,11 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; +;; Richard Klinda <ignotus(a)hixsplit.hu&gt; ;; Created: 2 Mar 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xwem-clients.el,v 1.13 2004/12/16 08:08:04 youngs Exp $ +;; X-CVS: $Id: xwem-clients.el,v 1.12 2004/12/05 22:37:32 lg Exp $ ;; This file is part of XWEM. ＠＠ -32,15 +34,11 ＠＠ ;; ;; Client state(`xwem-cl-state') is one of: ;; -;; 'managed - Client has `xwem-cl-win' and in WIN's clients list, but -;; not current in WIN. +;; 'active - Client managed and activated. ;; -;; 'managed-current - As 'managed, but CL aslo current in WIN. +;; 'inactive - CL managed, but not viewable. ;; -;; 'demanaged - CL may have valid `xwem-cl-win', but not in WIN's -;; clients list and not current in any window. -;; -;; 'iconified - Same as 'demanaged +;; 'iconified - CL iconified, not viewable. ;; ;; 'destroyed - CL's x window destroyed. ;; ＠＠ -56,23 +54,32 ＠＠ ;; `xwem-cl-state-change-hook' - Called when CL changes state to one ;; described above. ;; -;; `xwem-cl-manage-hook' - Called when CL just managed in some -;; window. +;; `xwem-cl-manage-hook' - Called when CL just managed. +;; +;; `xwem-cl-activate-hook' - Called when CL is activated in its context. ;; -;; `xwem-cl-demanage-hook' - Called when CL just demanaged from some -;; window. +;; `xwem-cl-deactivate-hook' - Called when CL is deactivated in its context. +;; +;; `xwem-cl-withdraw-hook' - Called when CL is about to move to withdrawn state. ;; -;; `xwem-cl-mark-hook' - Called when CL marked or unmarked. + +;; +;; Supported client properties: +;; +;; `noselect' - Non-nil to make client non-selectable. + ;;; Code:  (eval-when-compile ;; Shutup compiler - (require 'xlib-xwin) - (require 'xwem-macros) - (require 'iswitchb) + (autoload 'subtract-time "time-date") + (defvar xwem-frame-ev-mask) ) -(require 'xwem-frame) + +(require 'xwem-load) +(require 'xwem-manage) +(require 'xwem-misc) ;;; Variables (defgroup xwem-cl nil ＠＠ -80,12 +87,28 ＠＠ :prefix "xwem-cl-" :group 'xwem) +(defgroup xwem-modes nil + "Group to customize XWEM managing modes." +:prefix "xwem-" +:group 'xwem) + (defcustom xwem-cl-use-parent-xwin t "*Non-nil mean that CL will use some X window, where it(CL) lowered. -This is need to fullish some X applications, which accuire clients in such evil manner." +This is need to fullish some X applications, which accuire clients in +such evil manner." :type 'boolean :group 'xwem-cl) +(defcustom xwem-cl-noname-name "<noname>" + "*Name for clients which does not have name." +:type 'string +:group 'xwem-cl) + +(defcustom xwem-cl-noicon-name "<noname>" + "*Icon name for clients which does not have their own." +:type 'string +:group 'xwem-cl) + (defcustom xwem-cl-other-strategy 'samewin "*Strategy to be used to select other CL. One of 'any 'samewin 'sameframe. ＠＠ -95,21 +118,74 ＠＠ (const :tag "Any" any)) :group 'xwem-cl) -(defcustom xwem-cl-other-on-split t - "Non-nil mean manage other client when split occurs in new window. -Minor mode." +(defcustom xwem-frame-iresize-mode 'normal + "*Default type of drawing outlines when resizing frame interactively. +It is not recommeded to use 'opaque resize mode." +:type '(choice (const :tag "Normal border" normal) + (const :tag "Contiguous borders" contiguous) + (const :tag "Outline Corners" corners) + -:type 'hook -:group 'xwem-hooks) - -(defcustom xwem-cl-wmname-change-hooks nil - "Hooks to be called when WM_NAME changes." +;;;###autoload +(defcustom xwem-client-select-hook nil + "*Hooks called when new client just selected. +It is pretty guarantied that `xwem-selected-client' is valid xwem-cl +structure at time of hook execution." :type 'hook :group 'xwem-hooks) -(defcustom xwem-cl-wmcommand-chage-hooks nil - "Hooks to be called when WM_COMMAND changes." +;;;###autoload +(defcustom xwem-client-deselect-hook nil + "Hooks called with one arg - cl, when cl deselected. +It is pretty guarantied that `xwem-selected-client' is valid xwem-cl +structure at time of hook execution." :type 'hook :group 'xwem-hooks) -(defcustom xwem-cl-wmclass-change-hooks nil - "Hooks to be called when WM_CLASS changes." -:type 'hook -:group 'xwem-hooks) +;;; Internal variables -(defcustom xwem-cl-wmh-change-hooks nil - "Hooks to be called when WM_HINTS changes." -:type 'hook -:group 'xwem-hooks) + +(defconst xwem-client-ev-mask + (Xmask-or XM-ColormapChange XM-PropertyChange + XM-FocusChange XM-EnterWindow XM-LeaveWindow + XM-StructureNotify XM-ResizeRedirect) + "Event mask for xwem's client.") -;;;###autoload -(defvar xwem-clients nil "Clients Windows list") +;;;###xwem-autoload +(defvar xwem-clients nil + "List of all managed clients.") + +;;;###xwem-autoload +(defvar xwem-current-cl nil + "Internal variable. +Use `xwem-cl-selected' to get selected client.") + +;;;###xwem-autoload +(defvar xwem-last-cl nil + "Last selected client. +Use `(xwem-last-client)' to get last selected client.") ;;;###autoload (defvar xwem-cl-mark-ring nil "The list of marked clients.") -;;;###autoload -(defstruct xwem-hints - ;; TODO: add more - wm-normal-hints - wm-hints - wm-class - wm-command - wm-name - wm-transient-for - wm-protocols) - -(defconst xwem-client-ev-mask (Xmask-or XM-ColormapChange XM-PropertyChange - XM-FocusChange XM-EnterWindow XM-LeaveWindow - XM-StructureNotify XM-ResizeRedirect) - "Event mask for xwem's client.") +;;;###xwem-autoload +(defmacro xwem-cl-marked-p (cl) + "Return non-nil if client CL is marked, i.e. in `xwem-cl-mark-ring' list." + `(memq ,cl xwem-cl-mark-ring)) -;;;###autoload -(defstruct (xwem-cl (:predicate xwem-iscl-p)) - xwin ; X-Win - saved-name ; saved WM_NAME - xgeom ; X-Geom etry for cl - xattrs ; X-Attr ibutes +;;; Client properties +;;;###xwem-autoload +(defvar xwem-supported-client-properties nil + "List of supported client's properties definitions. +Property definition is list in form: +\(NAME . (MANAGE-TYPE (KEYWORD VAL ...) ...)). + +Valid KEYWORD are: + + `:type' - Same as for `defcustom'. eval composite type added. + + `:set' - Function to call when setting this property. Default is + `xwem-cl-put-prop'. Function called with three + arguments - CL PROP VAL. + + `:get' - Function to call in order to fetch property value. Default + is `xwem-cl-get-prop'. Function called with two + arguments - CL PROP. +") + +;;;###xwem-autoload +(defmacro define-xwem-client-property (name manage-type doc &rest keys-vals) + "Define new xwem client property NAME." + `(xwem-support-cl-property (quote ,name) (quote ,manage-type) + (list :doc ,doc ,＠keys-vals))) + +;;;###xwem-autoload +(defun xwem-property-supported-p (prop) + "Return non-nil if client property PROP is supported." + (assq prop xwem-supported-client-properties)) + +;;;###xwem-autoload +(defun xwem-support-cl-property (prop-name manage-type keys-val) + "Add supported client property." + (let ((pdef (assq prop-name xwem-supported-client-properties))) + (unless pdef + (setq pdef (cons prop-name nil)) + (setq xwem-supported-client-properties + (cons pdef xwem-supported-client-properties))) + + (setcdr pdef (plist-put (cdr pdef) manage-type keys-val)))) + +;;;###xwem-autoload +(defun xwem-unsupport-cl-property (prop-name manage-type) + "Remove PROP-NAME from supported property for MANAGE-TYPE." + (let ((pdef (assq prop-name xwem-supported-client-properties))) + (when pdef + (setcdr pdef (plist-remprop (cdr pdef) manage-type)) + (when (null (cdr pdef)) + (setq xwem-supported-client-properties + (delq pdef xwem-supported-client-properties)))))) + +(defun xwem-clprop-get-keyword (cl prop keyword &optional default) + "Return CL's property KEYWORD value. +If no KEYWORD for such CL, return default KEYWORD value. +Return DEFAULT if KEYWORD not found." + (let ((prop-def (assq prop xwem-supported-client-properties))) + (or (plist-get (plist-get (cdr prop-def) (xwem-cl-manage-type cl)) keyword) + (plist-get (plist-get (cdr prop-def) nil) keyword default)))) - win ; xwem-win dow - hints ; xwem-hints - manda ; xwem-manda entry - transient-for ; non-nil if client is transient for window - (ev-mask xwem-client-ev-mask) ; event mask for certain client - - (state 'unknown) ; state of client, 'managed, 'iconified, 'unknown, etc - start-time ; start-time - recency ; last time when CL was active - translist ; list of transient-for windows for this client +;;;###xwem-autoload +(defun xwem-client-set-property (cl prop val) + "Set client property." + (funcall (xwem-clprop-get-keyword cl prop :set 'xwem-cl-put-prop) + cl prop val)) + +;;;###xwem-autoload +(defun xwem-client-property (cl prop) + "Return CL's property PROP." + (funcall (xwem-clprop-get-keyword cl prop :get 'xwem-cl-get-prop) + cl prop)) + +(defun xwem-client-properties (cl) + "Return CL's properties list." + (let ((cplist (xwem-cl-plist cl)) + (rplist nil)) + (while cplist + (when (xwem-property-supported-p (car cplist)) + (setq rplist (plist-put rplist (car cplist) (cadr cplist)))) + (setq cplist (cddr cplist))) + rplist)) - plist ; user defined plist - ) +(define-xwem-client-property x-border-width nil + "CL's xwin border width." +:type 'number +:set 'xwem-client-set-x-border-width) + +(define-xwem-client-property x-border-color nil + "CL's xwin border color." +:type 'color +:set 'xwem-client-set-x-border-color) + +(define-xwem-client-property noselect nil + "Non-nil mean CL can't be selected." +:type 'boolean) + +(define-xwem-client-property skip-deselect nil + "CL skips deselecting." +:type 'boolean) + +(define-xwem-client-property override-skip-deselect nil + "CL overrides skip-deselect property of selected client." +:type 'boolean) + +(define-xwem-client-property skip-initial-state nil + "Non-nil mean skip CL's initial state hint." +:type 'boolean)  ;;; Functions -;;;###autoload -(defun xwem-cl-p (cl &optional sig) - "Returns t if CL is XWEM client window." - (let ((iscl (xwem-iscl-p cl))) - (if (and (not iscl) sig) - (signal 'wrong-type-argument (list sig 'xwem-cl-p cl)) - iscl))) +(defun xwem-client-set-x-border-width (cl bprop width) + "Change CL's border with to WIDTH. +Default WIDTH is 0." + (xwem-cl-put-prop cl bprop width) ; save it in props + + (unless (numberp width) + (setq width 0)) ; XXX + + (setf (xwem-cl-new-xgeom cl) (make-X-Geom :border-width width)) + (xwem-refit cl)) + +(defun xwem-client-set-x-border-color (cl bprop col) + "Change CL's border color to COL." + (xwem-cl-put-prop cl bprop col) ; save it in props + + (unless col + (setq col "black")) ; XXX + + (XSetWindowBorder (xwem-dpy) (xwem-cl-xwin cl) + (XAllocColor (xwem-dpy) (XDefaultColormap (xwem-dpy)) + (xwem-make-color col)))) + +(defun xwem-cl-focus-selected () + "If CL is selected, set focus on it. +Used in `xwem-post-deffering-hook'." + (xwem-focus-set (xwem-cl-selected))) + +;;;###xwem-autoload +(defun xwem-cl-select (cl) + "Set CL to be current cl." + (xwem-client-local-variables-import (xwem-cl-selected)) + + ;; Set CL to be current client + (setf (xwem-last-client) (xwem-cl-selected)) + (setf (xwem-cl-selected) cl) + + (xwem-client-local-vari + (t t))))))))))) + +;;;###xwem-autoload +(defun xwem-cl-other (cl &optional clients-list also-active no-sort) + "Return xwem client other then CL selecting from CLIENTS-LIST. +Default CLIENTS-LIST is what is returned by `xwem-clients-list'. +Deactivated clients are preferred to activated, unless ALSO-ACTIVE is non-nil. Special clients excluded. -If CL is not actually xwem client, nil returned." - (if (xwem-cl-p cl) - (let ((cll (cond ((eq xwem-cl-other-strategy 'any) xwem-clients) - - ((eq xwem-cl-other-strategy 'samewin) - (xwem-win-make-cl-list-sort-by-recency (xwem-cl-win cl))) - - ((eq xwem-cl-other-strategy 'sameframe) - (xwem-frame-make-cl-list (xwem-cl-frame cl))) - - (t xwem-clients))) - (rcl nil) - (notgoodcl nil)) ;not so good candidate as rcl - - (while cll - (when (not (eq (car cll) cl)) ;skip ourself - (if (and (not (xwem-cl-exclude-p (car cll))) - (or visible (not (xwem-win-cl-current-p (car cll))))) - (progn - (setq rcl (car cll)) - (setq cll nil)) - - (when (and visible (null notgoodcl)) - (setq notgoodcl (car cll))))) - (setq cll (cdr cll))) +Use `(xwem-cl-other cl nil t)' form to fetch most recent +client, other then CL. + +CLIENTS-LIST is sorted by recency unless NO-SORT is non-nil." + (unless clients-list + (setq clients-list (xwem-clients-list))) + + (unless no-sort + (setq clients-list + (xwem-cl-list-sort-by-recency clients-list))) + + (let ((rcl nil) + (notgoodcl nil)) ;not so good candidate as rcl + + (while clients-list + (when (and (xwem-cl-p (car clients-list)) ; skip non-clients + (not (eq (car clients-list) cl)) ; skip ourself + (not (eq (xwem-cl-state (car clients-list)) 'iconified))) ; skip iconified + (if (or also-active (not (eq (xwem-cl-state (car clients-list)) 'active))) + ;; Found pretty good candidate + (setq rcl (car clients-list) + clients-list nil) + + (when (and also-active (null notgoodcl)) + (setq notgoodcl (car clients-list))))) + (setq clients-list (cdr clients-list))) - (or rcl notgoodcl)) + ;; Return + (or rcl notgoodcl))) - ;; [else] invalid CL - nil)) +;;;###xwem-autoload +(defun xwem-select-some-client () + (unless (and (xwem-cl-alive-p (xwem-cl-selected)) + (eq (xwem-cl-state (xwem-cl-selected)) 'active)) + (xwem-select-client nil))) + +;;;###xwem-autoload +(defun xwem-select-last-or-other-client (cl &optional force allow-dummy) + "Select last or other client according to CL. +New client selected only if CL is current selected or FORCE is non-nil +or dummy client currently selected. -(defun xwem-cl-bury (cl) - "Put CL to the and of clients list. -Maybe used in `xwem-cl-manage-hook' or `xwem-cl-demanage-hook'." - (setq xwem-clients - (nconc (delete cl xwem-clients) (list cl))) - nil) ; continue hooks processing +`xwem-select-last-or-other-client' tries to avoid selecting dummy +clients, unless ALLOW-DUMMY is non-nil." + (when (or force + (xwem-cl-selected-p cl) + (xwem-cl-selected-p (xwem-dummy-client))) + (if (and (xwem-cl-alive-p (xwem-last-client)) + (not (eq (xwem-last-client) cl)) + (or allow-dummy + (not (xwem-dummy-client-p (xwem-last-client))))) + (xwem-select-client (xwem-last-client)) + (xwem-select-client (xwem-cl-other cl nil t)))))  -;;; Manda functions begin -;;;###autoload +;;;###xwem-autoload (defun xwem-cl-correct-size-for-size (cl new-geom &optional x-type y-type) "Make CL's geometry as close to NEW-GEOM as possible. X-TYPE is one of 'center 'left or 'right, default is 'center. Y-TYPE is one of 'center 'top or 'bottom, default is 'center." - (let* ((hthi (X-Geom-border-width new-geom)) + (let* ((hthi (or (X-Geom-border-width new-geom) 0)) + (he (X-Geom-height new-geom)) + (wi (X-Geom-width new-geom)) (clgmt (xwem-cl-xgeom cl)) + (wmnh (xwem-hints-wm-normal-h +When used with prefix ARG, then focus to that other window." (xwem-interactive "cXWEM-CL Other: \nP") - (let ((wn (xwem-win-next (xwem-win-selected))) - (xwem-cl-manage-hook nil)) ; skip setup hooks - - (when cl - (when (xwem-win-only-one-p (xwem-win-selected)) - (xwem-frame-split-vert nil) - (setq wn (xwem-win-next (xwem-win-selected)))) - - (when wn - (xwem-manda-manage cl wn) - - (when arg - (xwem-window-select wn))) - ))) + (let (nwin) + (when (xwem-win-only-one-p (xwem-win-selected)) + (xwem-window-split-vertically nil)) ; XXX + (setq nwin (xwem-win-next (xwem-win-selected))) + + (xwem-win-set-cl nwin cl) + (when arg + (xwem-select-window nwin)))) ;;;###autoload(autoload 'xwem-cl-switch-other-frame "xwem-clients" "" t) (define-xwem-command xwem-cl-switch-other-frame (cl &optional arg) "Switch to CL in other XWEM frame. When used with prefix ARG, then create embedded frame, if creation is needed at all." - (xwem-interactive "cXWEM-CL Other frame: \nP") + (xwem-interactive + (list (xwem-read-client + "XWEM-CL Other frame: " + (xwem-cl-list-sort-by-recency + (xwem-clients-list + (lambda (cl) + (xwem-manage-property (xwem-cl-manage-type cl) 'win-support))))) + xwem-prefix-arg)) (let ((ofr (or (xwem-frame-other (xwem-frame-selected)) - (xwem-make-frame-1 arg nil nil t)))) + (xwem-make-frame-1 (or (and arg 'embedded) 'desktop) +:noselect t)))) - (xwem-manda-manage cl (xwem-frame-selwin ofr)) - (xwem-frame-select ofr)) - ) + (xwem-cl-change-window cl (xwem-frame-selwin ofr)) + (xwem-select-client cl))) ;;;###autoload(autoload 'xwem-cl-switch-to-other "xwem-clients" "" t) -(define-xwem-command xwem-cl-switch-to-other (n &optional window) - "Switch to other client." - (xwem-interactive "p") +(define-xwem-command xwem-cl-switch-to-other (cl &optional n) + "Switch to xwem client other then CL. +Default CL is selected client. +If prefix argument N is specified, switch to N's other client." + (xwem-interactive (list (xwem-cl-selected) + (prefix-numeric-value xwem-prefix-arg))) + + (while (> n 0) + (setq cl (xwem-method-other-client cl)) + (decf n)) - (let* ((win (or window (xwem-win-selected))) - (ocl (xwem-win-cl win))) - (while (> n 0) - (setq ocl (xwem-cl-other ocl)) - (setq n (- n 1))) - (if (xwem-cl-p ocl) - (xwem-manda-manage ocl win) - (xwem-message 'note "No other client available.")))) + (unless (xwem-cl-alive-p cl) + (error 'xwem-error "No other client available")) + + (xwem-select-client cl)) ;;;###autoload(autoload 'xwem-cl-switch-to-other-in-other-win "xwem-clients" "" t) (define-xwem-command xwem-cl-switch-to-other-in-other-win (n) - "Like `xwem-cl-switch-to-other', but in other window." + "Switch to other client in other window then selected," (xwem-interactive "p") - (xwem-cl-switch-to-other n (xwem-window-other 1))) + (when (xwem-win-only-one-p) + (error 'xwem-error "Only one window")) + + (let* ((win (xwem-window-other 1)) + (cl (xwem-win-cl win))) + (while (> n 0) + (setq cl (xwem-cl-other cl (xwem-win-clients win))) + (decf n)) + + (unless (xwem-cl-alive-p cl) + (error 'xwem-error "Invalid client")) + + (xwem-activate cl))) ;;;###autoload(autoload 'xwem-kill-cl-and-window "xwem-clients" "" t) -(define-xwem-command xwem-kill-cl-and-window (arg) - "Kill selected client and window. +(define-xwem-command xwem-kill-cl-and-window (window &optional arg) + "Kill WINDOW an client currently activated in it. If used with prefix ARG then kill client in other window and other window (not implemented)." - (xwem-interactive "P") + (xwem-interactive (list (xwem-win-selected) + xwem-prefix-arg)) - (let* ((win (if arg (xwem-window-other 1) (xwem-win-selected))) + (let* ((win (if arg (xwem-window-other 1 window) window)) (cl (xwem-win-cl win))) + ;; kill client (when (xwem-cl-p cl) - ;; Deassociate CL from WIN so no client will be managed when we - ;; kill CL. - (setf (xwem-cl-win cl) nil) - (setf (xwem-win-cl win) nil) - (xwem-client-kill t cl) - - ;; Make sure CL is removed from clients list - (xwem-remove-client cl)) - - (xwem-window-delete win) - (xwem-frame-redraw (xwem-win-frame win)) - )) + (xwem-client-kill cl)) + + ;; kill window + (xwem-window-delete win))) ;;;###autoload(autoload 'xwem-cl-transpose "xwem-clients" "" t) -(define-xwem-command xwem-cl-transpose (arg &optional cl) +(define-xwem-command xwem-cl-transpose (cl &optional arg) "Transpose CL with client at right in CL's WIN. If ARG is non-nil transpose with left client. If CL is ommited than selected client will be used." - (xwem-interactive "P") - - (let* ((cl (or cl (xwem-cl-selected))) - (sw (xwem-cl-win cl)) - (tai (cadr (member cl (funcall (if arg 'reverse 'identity) (xwem-win-make-cl-list sw)))))) - (when (not (xwem-cl-p tai)) - (setq tai (cadr (member cl (funcall (if arg 'identity 'reverse) (xwem-win-make-cl-list sw)))))) - - (when (and (xwem-cl-p cl) (xwem-cl-p tai)) - (xwem-list-exchange-els xwem-clients cl tai) + (xwem-interactive (list (xwem-cl-selected) + xwem-prefix-arg)) - (run-hook-with-args 'xwem-win-clients-change-hook sw)) - )) - -(defun xwem-client-rearrange-top (cl) - "Move CL on top of `xwem-clients'." - (when (xwem-win-selected-p (xwem-cl-win cl)) - (setq xwem-clients (cons cl (delete cl xwem-clients)))) - - nil) ;continue hooks processing + (when (xwem-cl-p cl) + (let* ((sw (xwem-cl-win cl)) + (tai (cadr (memq cl (funcall (if arg 'reverse 'identity) + (xwem-win-clients sw)))))) + (unless (xwem-cl-p tai) + (setq tai (cadr (memq cl (funcall (if arg 'identity 'reverse) + (xwem-win-clients sw)))))) + + (when (xwem-cl-p tai) + (xwem-list-exchange-els (xwem-win-clients sw) cl tai) + (run-hook-with-args 'xwem-win-clients-change-hook sw)) + ))) +(put 'xwem-cl-transpose 'xwem-frame-command t) -;;;###autoload -(defun xwem-init-clients () +(defun xwem-clients-init () "Clients part initializer" - (xwem-message 'msg "Initializing clients ... wait") + (xwem-message 'init "Initializing clients ...") (setq xwem-clients nil) - ;; Gentle handling of window splitting - (add-hook 'xwem-win-after-split-hook 'xwem-cl-other-on-split) + ;; Add default select/deselect hooks + (add-hook 'xwem-client-select-hook 'xwem-client-default-select-hook t) + (add-hook 'xwem-client-deselect-hook 'xwem-client-default-deselect-hook t) - (when xwem-cl-use-set-focus - (add-hook 'xwem-cl-manage-hook 'xwem-client-focus)) + ;; Initialise dummy client + (xwem-dummy-client-init) - (when xwem-cl-use-recent-cl-on-top - (add-hook 'xwem-cl-manage-hook 'xwem-client-rearrange-top)) -; (add-hook 'xwem-cl-demanage-hook 'xwem-cl-bury)) - - ;; Setup - (when xwem-cl-use-parent-xwin - (add-hook 'xwem-cl-create-hook 'xwem-cl-parent-on-creation) - (add-hook 'xwem-cl-destroy-hook 'xwem-cl-parent-on-destroy) - (add-hook 'xwem-cl-state-change-hook 'xwem-cl-parent-on-change-state)) - ) + (xwem-message 'init "Initializing clients ... done")) -;;;###autoload +;;;###xwem-autoload (defun xwem-client-sendmsg-atom (cl atom &optional time) "Send Client message to client CL." (XSendEvent (xwem-dpy) (xwem-cl-xwin cl) nil 0 - (X-Create-message - (list [1 X-ClientMessage] ;type - [1 32] ;format - [2 1000] ;XXX seq - [4 (X-Win-id (xwem-cl-xwin cl))] ; window - [4 (X-Atom-id (X-Atom-find-by-name (xwem-dpy) "WM_PROTOCOLS"))] - [4 (X-Atom-id atom)] - [4 (or time X-CurrentTime)] - [4 nil])))) + (X-Create-message + (list [1 X-ClientMessage] ; type + [1 X-format-32] ; format + [2 1000] ; XXX seq + [4 (X-Win-id (xwem-cl-xwin cl))] ; wind - (xwem-frame-selwin fr))) - xwem-frames-list))) - - ;; Setup focus mode - (xwem-focus-mode-set new-cl xwem-default-focus-mode) - - ;; Run new client hook - (run-hook-with-args 'xwem-cl-create-hook new-cl) - - ;; Finnally manage new client - (if (xwem-win-p dwin) - (xwem-manda-manage new-cl dwin) - (xwem-manda-manage new-cl))) - ))) - )) + (setf (xwem-cl-initial-xattrs new-cl) + (XGetWindowAttributes (xwem-dpy) xwin)) + (setf (xwem-cl-initial-xgeom new-cl) + (XGetGeometry (xwem-dpy) xwin)) + (setf (xwem-cl-xgeom new-cl) + (copy-X-Geom (xwem-cl-initial-xgeom new-cl))) + (setf (xwem-cl-start-time new-cl) + (current-time)) + + ;; Apply properties + (xwem-cl-apply-plist new-cl props) + + new-cl))) + +(defun xwem-unmake-client (cl) + "Unmake client CL." + ;; If unmaking selected client, then select dummy client + (when (xwem-cl-selected-p cl) + (xwem-select-client nil)) + + (X-Win-rem-prop (xwem-cl-xwin cl) 'xwem-cl) + (X-Win-EventHandler-rem (xwem-cl-xwin cl) 'xwem-cl-events-handler) + + ;; Make sure CL not in xwem-clients + (setq xwem-clients (delq cl xwem-clients)) + + (X-invalidate-cl-struct cl)) + +(defun xwem-client-first-manage (cl) + "Manage client CL for the first time. +Return non-nil if CL successfully managed." + ;; Find match spec for CL + (let ((mspec (xwem-manda-find-match cl))) + (when mspec + ;; Add CL to clients list + (pushnew cl xwem-clients :test 'eq) + + ;; Apply plist before setting managing model, becase seting + ;; properties may depend on it and will fail because client is + ;; not yet managed by this managing model. + + ;; On the other hand not seting managing model before applying + ;; properties may cause seting property to fail, for example + ;; 'expect-win property, which only set for 'generic managing + ;; model. + (setf (xwem-cl-manage-spec cl) mspec) + (xwem-cl-apply-plist cl (cadr mspec)) + + (xwem-debug 'xwem-cl "Managing model: %S selected" '(xwem-cl-manage-type cl)) + + ;; Setup focus mode if not already setuped + (unless (xwem-client-property cl 'xwem-focus-mode) + (xwem-focus-mode-set cl)) + + (xwem-debug 'xwem-cl "Focus model: %S selected" + '(xwem-client-property cl 'xwem-focus-mode)) + + ;; Run manage method + (xwem-manage cl) + + ;; Unmark CL as it was expected in case `xwem-manda-find-match' + ;; marked it. + (xwem-cl-was-expected cl nil) + + ;; Run new client hook + (when (xwem-cl-alive-p cl) + (run-hook-with-args 'xwem-cl-create-hook cl)) + cl))) + +;;;###xwem-autoload +(defun xwem-xwin-try-to-manage (xwin) + "Try to manage X window XWIN. +Return managed client, or nil if client wasnt managed." + (unless (xwem-xwin-cl xwin) + (let ((cl (xwem-make-client xwin xwem-client-default-properties))) + (when (xwem-cl-p cl) + (unless (xwem-client-first-manage cl) + (xwem-unmake-client cl))) + (and (xwem-cl-p cl) cl)))) + +;;;###xwem-autoload +(defun xwem-cl-destroy (cl) + "Tottally destroy CL." + (setf (xwem-cl-state cl) 'destroyed) + + (xwem-method-on-kill cl) + (run-hook-with-args 'xwem-cl-destroy-hook cl) + + (xwem-select-some-client) + (xwem-deffered-funcall 'xwem-unmake-client cl)) + +;;;###xwem-autoload +(defun xwem-cl-apply-plist (cl nplist) + "Set plist's properties in CL." + (while nplist + (unless (eq (cadr nplist) (xwem-client-property cl (car nplist))) + (xwem-client-set-property cl (car nplist) (cadr nplist))) + (setq nplist (cdr (cdr nplist))))) + +;;;###xwem-autoload +(defun xwem-cl-apply-new-xgeom (cl &optional correct-including-border hold-size) + "Apply entries in `xwem-cl-new-xgeom' to CL's x geometry. +When CORRECT-INCLUDING-BORDER is non-nil, then +`xwem-cl-correct-size-for-size' will correct size reguarding new +border +(define-xwem-command xwem-client-run-copy (cl &optional arg) "Run the same command as selected CL. -With prefix arg run it in other window. -With double prefix arg run in other window and select. -With numeric prefix arg run ARG copies." - (xwem-interactive "P") +Prefix ARG specifies how many copies to run." + (xwem-interactive (list (xwem-cl-selected) + (prefix-numeric-value xwem-prefix-arg))) - (let* ((cl (or cl (xwem-cl-selected))) - (nw (and (xwem-cl-p cl) (xwem-cl-win cl)))) - - (if (not (xwem-cl-p cl)) - (xwem-message 'warn "No client selected to copy.") + (unless (xwem-cl-alive-p cl) + (error 'xwem-error "Invalid client")) - (let ((cmd (xwem-hints-wm-command (xwem-cl-hints cl))) - (cnt (if (numberp arg) arg 1)) ;how many clients to start - (i 0)) - (if (or (not (stringp cmd)) (string= cmd "")) - (xwem-message 'warn "Invalid cmd: \"%s\"" cmd) - - (when (and (listp arg) (not (null arg))) - (setq nw (xwem-win-next nw)) - (when (not (xwem-win-p nw)) - ;; Create window - (xwem-frame-split-vert nil) - (setq nw (xwem-win-next (xwem-win-selected)))) - - (when (xwem-win-p nw) - (when (= (prefix-numeric-value arg) 4) - (xwem-win-expt-inc nw cmd cnt)) - - (when (= (prefix-numeric-value arg) 16) - (xwem-window-select-maybe-redraw nw)))) - - (when (xwem-win-p nw) - (while (< i cnt) - (xwem-execute-program cmd) - (setq i (1+ i)))) - ))))) + (let* ((cmd (xwem-hints-wm-command (xwem-cl-hints cl))) + (mspec (xwem-cl-manage-spec cl)) + (mtype (car mspec)) + (mplist (copy-list (cadr mspec)))) + + ;; Check command for validity + (when (or (not (stringp cmd)) (string= cmd "")) + (error 'xwem-error "Invalid command: " cmd)) + + ;; XXX Adjust plist + (setq mplist (plist-put mplist 'expect-win (xwem-cl-win cl))) + + (setq mspec (list mtype mplist (list 'command cmd))) + ;; Execute copies using expectances + (while (> arg 0) + +q (xwem-manda-add-expectance mspec) + (xwem-execute-program cmd) + (setq arg (1- arg))))) ;;;###autoload(autoload 'xwem-client-run-copy-other-win "xwem-clients" "" t) (define-xwem-command xwem-client-run-copy-other-win (arg &optional cl) ＠＠ -1131,11 +1331,10 ＠＠ (xwem-interactive "P") (let ((cl (or cl (xwem-cl-selected))) - (xwem-win-after-split-hook nil) ; prevent hooks cmd own) (when (or (not (xwem-cl-p cl)) (not (xwem-win-p (xwem-cl-win cl)))) - (error "Can't run copy of invalid client")) + (error 'xwem-error "Can't run copy of invalid client")) (setq cmd (xwem-hints-wm-command (xwem-cl-hints cl))) (setq own (xwem-window-other 1 (xwem-cl-win cl))) ＠＠ -1144,12 +1343,13 ＠＠ ;; Check is there split needed (when (eq own (xwem-win-selected)) (if arg - (xwem-frame-split-horiz 0) - (xwem-frame-split-vert 0)) + (xwem-window-split-horizontally 0) + (xwem-window-split-vertically 0)) (setq own (xwem-win-next (xwem-win-selected)))) - ;; Install expectance - (xwem-win-expt-inc own cmd) + ;; Install expectance in hope it will be managed by generic + ;; manage type, or some other type that suppors expectances. + (xwem-manda-add-expectance `(nil (expect-win ,own) (command ,cmd))) ;; Finnaly run command (xwem-execute-program cmd)) ＠＠ -1167,56 +1367,68 ＠＠ (when (or (not (xwem-cl-p cl)) (not (xwem-frame-p (xwem-cl-frame cl)))) - (error "Can't run copy of invalide client")) + (error 'xwem-error "Can't run copy of invalid client")) (setq cmd (xwem-hints-wm-command (xwem-cl-hints cl))) (setq ofr (xwem-frame-other (xwem-cl-frame cl))) (when cmd (unless (xwem-frame-p ofr) - (setq ofr (xwem-make-frame-1 arg nil nil t))) + (setq ofr (xwem-make-frame-1 (or (and arg 'embedded) 'desktop) +:noselect t))) ;; Setup expectance - (xwem-win-expt-inc (xwem-frame-selwin ofr) cmd) - - ( + (setf (xwem-cl-state cl) 'unknown)) (setq xwem-clients (cdr xwem-clients)))) -;;;###autoload -(defun xwem-client-hide (cl &optional new-state) - "Hide CL's window. Optionally you may specify NEW-STATE." - ;; Just move off the screen - (XMoveWindow (xwem-dpy) (xwem-cl-xwin cl) - (X-Geom-width (xwem-rootgeom)) - (X-Geom-height (xwem-rootgeom))) - - (XUnmapWindow (xwem-dpy) (xwem-cl-xwin cl)) - (xwem-client-change-state cl (or new-state 'iconified)) - ) - -;;;###autoload -(defun xwem-client-show (cl &optional new-state) - "Show xwem client CL." - ;; Make sure CL's frame is CL's parent - (XReparentWindow (xwem-dpy) (xwem-cl-xwin cl) - (xwem-frame-xwin (xwem-cl-frame cl)) - (X-Geom-width (xwem-rootgeom)) (X-Geom-height (xwem-rootgeom))) - - (if (xwem-cl-transient-for cl) - (XRaiseWindow (xwem-dpy) (xwem-cl-xwin cl)) - - ;; Must be lowered - (XLowerWindow (xwem-dpy) (xwem-cl-xwin cl))) - - (XMoveWindow (xwem-dpy) (xwem-cl-xwin cl) - (X-Geom-x (xwem-cl-xgeom cl)) - (X-Geom-y (xwem-cl-xgeom cl))) - - (XMapWindow (xwem-dpy) (xwem-cl-xwin cl)) - (xwem-client-change-state cl (or new-state 'managed-current)) - ) -  ;;; Events handling for client windows (defun xwem-cl-hproperty (cl xev) ＠＠ -1452,150 +1646,670 ＠＠ rhook) ;; Some CL's property changed - (X-Dpy-log (xwem-dpy) "CLIENT .. PropertyNotify: Atom-id = %d\n" 'atom-id) + (xwem-debug 'xwem-cl "CLIENT .. PropertyNotify: Atom-id = %d" 'atom-id) - (cond - ((and (= atom-id (X-Atom-id XA-wm-normal-hints)) (= state X-PropertyNewValue)) - (setf (xwem-hints-wm-normal-hints (xwem-cl-hints cl)) (XGetWMNormalHints (xwem-dpy) xwin)) - (setq rhook 'xwem-cl-wmnh-change-hooks)) - - ((and (= atom-id (X-Atom-id XA-wm-hints)) (= state X-PropertyNewValue)) - (setf (xwem-hints-wm-hints (xwem-cl-hints cl)) (XGetWMHints (xwem-dpy) xwin)) - (setq rhook 'xwem-cl-wmh-change-hooks)) - - ((and (= atom-id (X-Atom-id XA-wm-class)) (= state X-PropertyNewValue)) - (setf (xwem-hints-wm-class (xwem-cl-hints cl)) (XGetWMClass (xwem-dpy) xwin)) - (setq rhook 'xwem-cl-wmclass-change-hooks)) - - ((and (= atom-id (X-Atom-id XA-wm-command)) (= state X-PropertyNewValue)) - (setf (xwem-hints-wm-command (xwem-cl-hints cl)) (XGetWMCommand (xwem-dpy) xwin)) - (setq rhook 'xwem-cl-wmcommand-chage-hooks)) - - ((and (= atom-id (X-Atom-id XA-wm-name)) (= state X-PropertyNewValue)) - (setf (xwem-hints-wm-name (xwem-cl-hints cl)) (XGetWMName (xwem-dpy) xwin)) - (unless (equal (xwem-hints-wm-name (xwem-cl-hints cl)) (xwem-cl-saved-name cl)) - (setf (xwem-cl-saved-name cl) (xwem-hints-wm-name (xwem-cl-hints cl))) - (setq rhook 'xwem-cl-wmname-change-hooks))) - ) + (cond ((and (= atom-id (X-Atom-id XA-wm-normal-hints)) + (= state X-PropertyNewValue)) + ;; WM_NORMAL_HINTS changed + (setf (xwem-cl-wm-normal-hints cl) + (XGetWMNormalHints (xwem-dpy) xwin)) + (setq rhook t)) + + ((and (= atom-id (X-Atom-id XA-wm-hints)) + (= state X-PropertyNewValue)) + ;; WM_HINTS changed + (setf (xwem-cl-wm-hints cl) (XGetWMHints (xwem-dpy) xwin)) + (setq rhook t)) + + ((and (= atom-id (X-Atom-id XA-wm-class)) + (= state X-PropertyNewValue)) + ;; WM_CLASS changed + (multiple-value-bind (ci cn) + (values-list (XGetWMClass (xwem-dpy) xwin)) + (setf (xwem-cl-wm-class cl) (cons ci cn))) + (setq rhook t)) + + ((and (= atom-id (X-Atom-id XA-wm-command)) + (= state X-PropertyNewValue)) + ;; WM_COMMAND changed + (setf (xwem-cl-wm-command cl) (XGetWMCommand (xwem-dpy) xwin)) + (setq rhook t)) + + ((and (= atom-id (X-Atom-id XA-wm-name)) + (= state X-PropertyNewValue)) + ;; WM_NAME changed + (setf (xwem-cl-wm-name cl) (XG + + `deactivate' - Client must be deactivate. + + `deselect' - Client is deselecting. + +Default TYPE is `deactivate'." + (unless type + (setq type 'deactivate)) + + (cond ((eq type 'deselect) + (xwem-method-deactivate cl type)) + + ((eq (xwem-cl-state cl) 'active) + (xwem-client-change-state cl 'inactive) + (xwem-method-deactivate cl type) + (xwem-select-some-client)) + + ((not (eq (xwem-cl-state cl) 'inactive)) + (xwem-method-deactivate cl type) + (xwem-select-some-client)))) + +;;;###xwem-autoload +(defun xwem-iconify (cl) + "Function to iconify client CL. +ARGS - arguments." + (unless (eq (xwem-cl-state cl) 'iconified) + (xwem-client-change-state cl 'iconified) + (xwem-method-iconify cl)) + + (xwem-select-some-client)) + +;;;###xwem-autoload +(defun xwem-refit (cl) + "Function to refit client CL. +ARGS - arguments." + ;; Reguard border width change + (when (and (xwem-cl-new-xgeom cl) + (xwem-manage-property (xwem-cl-manage-type cl) 'reguard-x-border-width) + (X-Geom-border-width (xwem-cl-new-xgeom cl))) + (setf (X-Geom-border-width (xwem-cl-xgeom cl)) + (X-Geom-border-width (xwem-cl-new-xgeom cl)))) + + (xwem-method-refit cl) + + ;; Apply (new) CL geometry to life + (xwem-cl-apply-xgeom cl) + + ;; Finally run hooks + (run-hook-with-args 'xwem-cl-refit-hook cl)) + +;;;###xwem-autoload +(defun xwem-withdraw (cl) + "Withdraw client CL." + (xwem-client-change-state cl 'withdrawn) + (xwem-method-withdraw cl) + + (xwem-select-some-client) + (run-hook-with-args 'xwem-cl-withdraw-hook cl)) + +;;;; ---- Default manage methods ---- + +(define-xwem-deffered xwem-default-apply-state (cl) + "Apply CL's state to life." + (cond ((eq (xwem-cl-state cl) 'active) + (XMapWindow (xwem-dpy) (xwem-cl-xwin cl))) + ((memq (xwem-cl-state cl) '(inactive iconified)) + (XUnmapWindow (xwem-dpy) (xwem-cl-xwin cl))))) + +(define-xwem-method activate default (cl &optional type) + "Default method to activate client CL." + (cond ((eq type 'select) + (xwem-deffered-funcall 'XRaiseWindow (xwem-dpy) (xwem-cl-xwin cl))) + ((eq type 'activate) + (xwem-default-apply-state cl)))) + +(define-xwem-method deactivate default (cl &optional type) + "Default method to deactivate client CL." + (cond ((eq type 'deactivate) + (xwem-default-apply-state cl)))) + +(define-xwem-method iconify default (cl) + "Default method to iconify CL." + (xwem-default-apply-state cl)) + +(define-xwem-method refit default (cl) + "Default method to refit CL." + (xwem-cl-apply-new-xgeom cl) + (xwem-cl-apply-xgeom cl)) + +;; New method to select other client +(defun xwem-method-other-client (cl) + "Return xwem client other then CL." + (xwem-execute-method 'other-client (xwem-cl-manage-type cl) cl)) + +(define-xwem-method other-client default (cl) + "Default other-client method." + (xwem-cl-other cl nil t)) + + +;;; Dummy client, used, when selecting `nil' client. +(defvar xwem-dummy-client nil + "Internal variable.") + +(define-xwem-client-property dummy-client-p nil + "Non-nil for dummy clients." +:type 'boolean) + +;;;###xwem-autoload +(defun xwem-dummy-client-p (cl) + "Return non-nil if CL is dummy client." + (xwem-client-property cl 'dummy-client-p)) + +;;;###xwem-autoload +(defun xwem-non-dummy-client-p (cl) + "Opposit to `xwem-dummy-client-p'." + (not (xwem-dummy-client-p cl))) + +;;;###xwem-autoload +(defun xwem-dummy-client () + "Return dummy client." + (or xwem-dummy-client + (progn (xwem-dummy-client-init) xwem-dummy-client))) + +(defun xwem-dummy-client-init () + "Create dummy client" + (unless xwem-dummy-client + (setq xwem-dummy-client + (xwem-make-client (XCreateWindow (xwem-dpy) nil 0 0 1 1 0 nil nil nil + (make-X-Attr :override-redirect t)) + '(dummy-client-p t ignore-has-input-p t))) + + (XSelectInput (xwem-dpy) (xwem-cl-xwin xwem-dummy-client) + (Xmask-or X + +;;;###xwem-autoload +(defun xwem-client-local-variable-value (client variable) + "Return CLINEN's local VARIABLE value. +Or global VARIABLE value if CLIENT does not have local value." + (let ((lval (assq variable (xwem-cl-local-variables client)))) + (if lval + (cdr lval) + (get variable 'xwem-default-value)))) + +(defun xwem-client-local-variables-import (cl) + "Set client local variables in CL." + (when (xwem-cl-p cl) + (setf (xwem-cl-local-variables cl) + (mapcar (lambda (var) + (cons var (symbol-value var))) + xwem-client-local-variables)))) + +(defun xwem-client-local-variables-export (cl) + "Set variables using CL's client local variables." + (when (xwem-cl-p cl) + (mapc (lambda (var) + (let ((val (assq var (xwem-cl-local-variables cl)))) + (if val + (set var (cdr val)) + (set var (get var 'xwem-default-value))))) + xwem-client-local-variables))) + +;;; Clients configurations +(defun xwem-client-configuration () + "Return current clients configuration." + ) -(defun xwem-cl-parent-on-destroy (cl) - "CL is about to be destroyed." - (let ((pwin (xwem-cl-get-prop cl 'parent-xwin))) - (when (X-Win-p pwin) - (XDestroyWindow (xwem-dpy) pwin)))) +(defun xwem-set-client-configuration (config) + "Set client configuration to CONFIG." + )  (provide 'xwem-clients) + +;;;; On-load actions: +;; Define dummy manage type +(define-xwem-manage-model dummy + "Managing model for dummy clients. +Dummy client is client which can't do anything." +:match-spec '(function (lambda (cl) (xwem-client-property cl 'dummy-client-p)))) + +(if xwem-started + (xwem-clients-init) + (add-hook 'xwem-before-init-wins-hook 'xwem-clients-init)) ;;; xwem-clients.el ends here Index: lisp/xwem-clswi.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-clswi.el,v retrieving revision 1.6 diff -u -u -r1.6 xwem-clswi.el --- lisp/xwem-clswi.el 16 Dec 2004 08:08:04 -0000 1.6 +++ lisp/xwem-clswi.el 1 Jan 2005 04:41:10 -0000 ＠＠ -1,10 +1,11 ＠＠ -;;; xwem-clswi.el --- Client switching package. +;;; xwem-clswi.el --- Simple clients switching. ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Keywords: xwem -;; X-CVS: $Id: xwem-clswi.el,v 1.6 2004/12/16 08:08:04 youngs Exp $ +;; X-CVS: $Id: xwem-clswi.el,v 1.5 2004/12/05 22:37:33 lg Exp $ ;; This file is NOT part of XEmacs. ＠＠ -27,106 +28,121 ＠＠ ;;; Commentary: -;; To use this package add something like: -;; -;; (autoload 'xwem-clswi-enable "xwem-clswi" "Enable client switching." t) -;; (add-hook 'xwem-load-hook 'xwem-clswi-enable) -;; -;; to your xwemrc.el. It will install new bindings `H-]' for -;; switching to next client and `H-[' for switching to previous -;; client. +;; Included as default bindings, `H-[', `H-]', `H-{', `H-}'. + +;; If current client supports windowing, than next/prev client in its +;; window is selected. If client does not support windowing (for +;; example fullscreen client) next/prev client of same manage type is +;; selected. ;;; Code:  +(require 'xwem-clients) + (defgroup xwem-clswi nil "Group to customize clients switcher." :prefix "xwem-clswi-" :group 'xwem) -(defcustom xwem-clswi-beep-on-error nil +(defcustom xwem-clswi-beep-on-error t "*Non-nil mean beep on any error." :type 'boolean :group 'xwem-clswi) (defcustom xwem-clswi-show-info nil - "*Non-nil mean show info about client in xwem minibuffer after switch." -:type 'boolean + "*Non-nil mean show info about client in xwem minibuffer after switch. +It also can be a function which accepts one argument - client and +return non-nil to show info." +:type '(restricted-sexp :match-alternatives (functionp boolean-p)) :group 'xwem-clswi) -(defvar xwem-clswi-enabled nil - "Non-nil means that xwem-clswi is enabled. -Do not ch + (xwem-interactive (list (xwem-cl-selected) + (prefix-numeric-value xwem-prefix-arg))) - (xwem-message (if xwem-clswi-beep-on-error 'warn 'warn-nobeep) - "No clients to switch.")))) + (xwem-clswi-next cl (- arg))) -(define-xwem-command xwem-clswi-prev (arg &optional win) - "Switch to ARG previous client in WIN. -If WIN is ommited then in selected window." +;;;###autoload(autoload 'xwem-clswi-next-other-window "xwem-clswi" nil t) +(define-xwem-command xwem-clswi-next-other-window (arg) + "Switch next ARG client in other window." (xwem-interactive "p") - (xwem-clswi-next (- arg) win)) + (let ((win (xwem-window-other 1 (xwem-win-selected)))) + (when (and (xwem-win-p win) + (not (eq win (xwem-win-selected)))) + (xwem-clswi-next (xwem-win-cl win) arg)))) + +;;;###autoload(autoload 'xwem-clswi-prev-other-window "xwem-clswi" nil t) +(define-xwem-command xwem-clswi-prev-other-window (arg) + "Switch previous ARG client in other window." + (xwem-interactive "p") + (xwem-clswi-next-other-window (- arg)))  (provide 'xwem-clswi) Index: lisp/xwem-compat.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-compat.el,v retrieving revision 1.5 diff -u -u -r1.5 xwem-compat.el --- lisp/xwem-compat.el 16 Dec 2004 08:08:04 -0000 1.5 +++ lisp/xwem-compat.el 1 Jan 2005 04:41:10 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Fri Dec 12 15:51:10 MSK 2003 ;; Keywords: xwem, xlib -;; X-CVS: $Id: xwem-compat.el,v 1.5 2004/12/16 08:08:04 youngs Exp $ +;; X-CVS: $Id: xwem-compat.el,v 1.4 2004/11/29 20:41:47 lg Exp $ ;; This file is part of XWEM. ＠＠ -33,11 +33,10 ＠＠ ;;; Code:  -;;;###autoload + (defvar xwem-gnuemacs-p (string-match "GNU Emacs" emacs-version) "Non-nil when running under GNU Emacs.") -;;;###autoload (defun xwem-define-prefix-command (name &optional mapvar) "Compat version for `define-prefix-command'." (if xwem-gnuemacs-p Index: lisp/xwem-desktop.el =================================================================== RCS file: lisp/xwem-desktop.el diff -N lisp/xwem-desktop.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-desktop.el 1 Jan 2005 04:41:10 -0000 ＠＠ -0,0 +1,160 ＠＠ +;;; xwem-desktop.el --- + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; +;; Created: Wed Jul 14 10:16:20 MSD 2004 +;; Keywords: xwem, desktop +;; X-CVS: $Id: xwem-desktop.el,v 1.4 2004/12/05 22:37:33 lg Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; To start using, add something like: + +;; (add-hook 'xwem-exit-hook 'xwem-desktop-save) +;; (xwem-desktop-load) + +;; to your xwemrc. + +;;; TODO: + +;; * Save registers betwean sessions, maybe by using expectances. + +;;; Code: + +(require 'xwem-load) +(require 'xwem-frame) + +;;; Customisation +(defgroup xwem-desktop nil + "Group to customize xwem desktop." +:prefix "xwem-desktop-" +:group 'xwem) + +(defcustom xwem-desktop-goals + '(frames-config + (keymap . xwem-user-macros-prefix) + (xwem-launcher-history . 100) + (xwem-read-expression-history . 100)) + "*List of variables to save. +Each element is eather symbol or cons cell in form. +\(symbol . maxsize\)." +:type '(repeat (choice (const :tag "Frames configuration" frames-config) + (cons :tag "Keymap goal" + (const :tag "Keymap" keymap) + (symbol :tag "Keymap prefix")) + (cons :tag "History" + (choice (const :tag "Launcher history" xwem-launcher-history) + (const :tag "Expression history" xwem-read-expression-history) + (symbol :tag "Custom history")) + (number :tag "Max Size")))) +:group 'xwem-desktop) + +;;; Internal variables + +(defun xwem-desktop-save-element (el &optional buffer) + "Save element EL. +EL is one of that occurs in `xwem-desktop-goals'." + (unless buffer + (setq buffer (current-buffer))) + (cond ((eq el 'frames-config) + ;; Store frames configuration here + (xwem-frame-config-dump1 (xwem-frame-configuration) buffer t)) + + ((symbolp el) + (princ "\n;; Symbol value\n" buffer) + (princ (concat "(setq " (symbol-name el) " " + (if (listp (symbol-value el)) + (concat "(quote " (prin1-to-string (symbol-value el)) ")") + (prin1-to-string (symbol-value el))) + ")\n") + buffer)) + + ((and (consp el) (numberp (cdr el))) + (princ "\n;; List\n" buffer) + (let ((result nil) + (clist (symbol-value (car el))) + (limit (cdr el))) + (while (and clist (> limit 0)) + (unless (member (car clist) result) + (setq result (cons (car clist) result)) + (decf limit)) + (setq clist (cdr clist))) + (setq result (nreverse result)) + (princ (concat "(setq " (symbol-name (car el)) " " + "(quote " (prin1-to-string result) ")" + ")\n") + buffer))) + + ((and (consp el) (eq (car el) 'keymap)) + (let* ((kmap (xwem-kbd-fixup-keymap (cdr el))) + (kmap-name (keymap-name kmap))) + (princ (format "\n;; Keymap (%s)\n" kmap-name) buffer) + (map-keymap (lambda (kseq fbind) + (princ (concat "(define-key (quote " (prin1-to-string kmap-name) ") " + "(quote " (prin1-to-string kseq) ") " + "(quote " (prin1-to-string fbind) ")" + ")\n") + buffer)) + kmap))) + + (t (xwem-message 'warning "Strange el: `%S', skiping .." el)))) + +;;;###autoload(autoload 'xwem-desktop-save "xwem-desktop" nil t) +(define-xwem-command xwem-desktop-save (&optional file) + "Save things described in `xwem-desktop-goals' into FILE. +Defaultly FILE is ~/.xwem/xwem-desktop.el" + (xwem-interactive "FSave xwem desktop to: ") + (unless file + (setq file (expand-file-name "xwem-desktop.el" xwem-dir))) + + (with-temp-buffer + (erase-buffer) + (insert + (format ";;; %s --- Desktop configuration for XWEM.\n" + (file-name-nondirectory file)) + "\n;; NOTE: This file is automatically generated by xwem-desktop\n\n") + + ;; Set print-XX to nil to make full printing of objects + (let ((print-length nil) + (print-level nil)) + (mapc 'xwem-desktop-save-element xwem-desktop-goals)) + + (insert (format "\n;;; %s ends here\n" (file-name-nondirectory file))) + (write-region (point-min) (point-max) file))) + +;;;###autoload(autoload 'xwem-desktop-load "xwem-desktop" nil t) +(define-xwem-command xwem-desktop-load (&optional file) + "Load saved desktop from FILE. +Default FILE is ~/.xwem/xwem-desktop.el." + (xwem-interactive "FLoad xwem desktop from: ") + + (unless file + (setq file (expand-file-name "xwem-desktop.el" xwem-dir))) + + (load-file file)) + + +(provide 'xwem-desktop) + +;;; xwem-desktop.el ends here Index: lisp/xwem-diagram.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-diagram.el,v retrieving revision 1.4 diff -u -u -r1.4 xwem-diagram.el --- lisp/xwem-diagram.el 16 Dec 2004 08:08:05 -0000 1.4 +++ lisp/xwem-diagram.el 1 Jan 2005 04:41:11 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Sat Mar 6 17:09:58 MSK 2004 ;; Keywords: xwem -;; X-CVS: $Id: xwem-diagram.el,v 1.4 2004/12/16 08:08:05 youngs Exp $ +;; X-CVS: $Id: xwem-diagram.el,v 1.3 2004/12/03 19:43:36 lg Exp $ ;; This file is part of XWEM. ＠＠ -39,6 +39,11 ＠＠ ;;; Code:  +(require 'xlib-xlib) + +(require 'xwem-faces) + + (defun xwem-diag-dot-distance (dot1 dot2) "Return distance betwean DOT1 and DOT2." (let ((w (abs (- (X-Point-x dot1) (X-Point-x dot2)))) ＠＠ -351,7 +356,6 ＠＠ (list d1 dd1 dd2 dd3 d3 d4 d1 d2 d3 d2 dd2)) )) -;;;###autoload (defun xwem-diag-draw-percentage (type spec d edge-gc x y width height &optional sector-width label-factor label-font) "Draw percentage sector of TYPE. TYPE is one of 'plain or '3d. ＠＠ -378,10 +382,10 ＠＠ ;; Validate spec ; (when (> (apply '+ (mapcar (lambda (el) (aref el 0)) spec)) 100) -; (error "Invalid spec" spec)) +; (error "XWEM Invalid spec" spec)) (let ((draw-sector (lambda (sel angbeg angle) - (xwem-face-set-foreground temp-fill-face (aref sel 2)) + (xwem-set-face-foreground temp-fill-face (aref sel 2)) (let ((xint-off 0) (yint-off 0)) ＠＠ -411,7 +415,8 ＠＠ (gc edge-gc) (text (if (stringp (aref sel 1)) (aref sel 1) (format "%d%%" (aref sel 0))))) (XDrawString xdpy d gc - (- (X-Point-x (nth 2 cd)) (/ (X-Text-width xdpy (X-Gc-font gc) text) 2)) + (- (X-Point-x (nth 2 cd)) + (/ (X-Text-width xdpy (X-Gc-font gc) text) 2)) (+ (/ (X-Text-height xdpy (X-Gc-font gc) text) 2) (X-Point-y (nth 2 cd))) text))) ＠＠ -463,7 +468,6 ＠＠ ))) -;;;###autoload (defun xwem-diag-plot-coordinates (d gc x y w h x-step y-step &rest params) "Draw coordinates system." (let ((notch-len (or (plist-get params :notch-len) 4)) ＠＠ -483,12 +487,18 ＠＠ (setq noff (% center-x x-step)) (while (< noff w) - (setq x-notches (cons (cons (cons (+ x noff) (- y center-y)) (cons (+ x noff) (- y center-y notch-len))) x-notches)) + (setq x-notches (cons (cons (cons (+ x noff) + (- y center-y)) + (cons (+ x noff) (- y center-y notch-len))) + x-notches)) (setq noff (+ noff x-step))) (setq noff (% center-y y-step)) (while (< noff h) - (setq y-notches (cons (cons (cons (+ x center-x) (- y noff)) (cons (+ x center-x notch-len) (- y noff))) y-notches)) + (setq y-notches (cons (cons (cons (+ x center-x) + (- y noff)) + (cons (+ x center-x notch-len) (- y noff))) + y-notches)) (setq noff (+ noff y-step))) ;; Set dashes ＠＠ -496,19 +506,21 ＠＠ (setq sls (X-Gc-line-style gc)) (setf (X-Gc-line-style gc) X-LineOnOffDash) (XChangeGC xdpy gc) - (XSetDashes xdpy gc 0 (list grid-dash-even grid-dash-odd grid-dash-even grid-dash-odd)) + (XSetDashes xdpy gc 0 (list grid-dash-even grid-dash-odd + grid-dash-even grid-dash-odd)) (unwind-protect (progn - (XDrawSegments xdpy d gc (mapcar (lam + (apply 'nconc (mapcar* (lambda (d dn) + (if dn + (list d (cons (X-Point-x d) (X-Point-y dn))) + (list d))) + dots (nconc (cdr dots) (list nil)))))) ((eq type 'histeps) ;; TODO: write me ＠＠ -625,7 +652,6 ＠＠ )) )) -;;;###autoload (defun xwem-diag-read-data-file (file &optional using x-scale y-scale) "Read data FILE and return list of dots lists. USING is cons cell that specifies which columns to use. Index: lisp/xwem-edmacro.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-edmacro.el,v retrieving revision 1.7 diff -u -u -r1.7 xwem-edmacro.el --- lisp/xwem-edmacro.el 16 Dec 2004 08:08:05 -0000 1.7 +++ lisp/xwem-edmacro.el 1 Jan 2005 04:41:11 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: Fri Dec 12 11:19:50 MSK 2003 ;; Keywords: xwem, xlib -;; X-CVS: $Id: xwem-edmacro.el,v 1.7 2004/12/16 08:08:05 youngs Exp $ +;; X-CVS: $Id: xwem-edmacro.el,v 1.6 2004/12/05 22:37:33 lg Exp $ ;; This file is part of XWEM. ＠＠ -37,11 +38,12 ＠＠ ;;; Code:  - (eval-and-compile - (require 'xwem-macros) (require 'edmacro)) +(require 'xwem-load) + +;;; Customization (defgroup xwem-edmacro nil "Group to customize `xwem-edmacro' addon." :prefix "xwem-edmacro-" ＠＠ -59,6 +61,8 ＠＠ :type 'boolean :group 'xwem-edmacro) +;;; Internal variables + ;; Variables (defvar xwem-edmacro-prefix-arg nil "Value of prefix argument. ＠＠ -81,8 +85,17 ＠＠ ;; redefine key in user macros map (define-key xwem-global-map xwem-edmacro-store-place mac))) - (setq xwem-edmacro-store-place nil) - ) + (setq xwem-edmacro-store-place nil)) + +(defun xwem-edmacro-finish (frame) + "Called when edmacro finishes. +FRAME is special emacs frame where macro editing occurs. +Keep selected buffer to be selected even after FRAME deleted." + (let ((buf (current-buffer))) + (if (frame-live-p frame) + (delete-frame frame t) + (xwem-special-revert-focus nil)) + (set-buffer buf))) ;;;###autoload(autoload 'xwem-edmacro-edit-kbd-macro "xwem-edmacro" "" t) (define-xwem-command xwem-edmacro-edit-kbd-macro (xwem-keys &optional arg) ＠＠ -92,18 +105,18 ＠＠ (list (xwem-read-key-sequence (substitute-command-keys - (concat "Enter \\<xwem-global-map>\\[xwem-keymacro-play-last] " - "or one of \\<xwem-global-map>\\[xwem-user-keymacros-prefix] XXX: "))) + (concat "Enter `\\<xwem-global-map>\\[xwem-keymacro-play-last]' " + "or one of `\\<xwem-global-map>\\[xwem-user-macros-prefix] XXX': "))) (prefix-numeric-value xwem-prefix-arg))) (xwem-kbd-stop-grabbing) - (let ((xwem-cmd (xwem-kbd-key-binding xwem-keys)) - xwem-evs) + (let ((xwem-cmd (xwem-kbd-get-binding xwem-keys)) + xwem-evs frame) (setq xwem-evs (cond ((eq xwem-cmd 'xwem-keymacro-play-last) (setq xwem-edmacro-store-place 'xwem-keymacro-last-kbd-macro) - xwem-keymacro-last-kbd-macro) + (or xwem-keymacro-last-kbd-macro [])) ((vectorp xwem-cmd) (setq xwem-edmacro-store-place xwem-keys) ＠＠ -120,19 +133,19 ＠＠ (t nil))) (if (null xwem-evs) - (cond ((and (null xwem-edmacro-can-edit-unbinded) (null xwem-cmd)) - (xwem-message 'warn (concat "Dissalowed to edit unbinded key " - (key-description xwem-keys) - " by `xwem-edmacro-can-edit-unbinded'"))) - ((null xwem-edmacro-can-edit-nonmacro) - (xwem-message 'warn (concat "Dissalowed to edit non-macro key " - (key-description xwem-keys) - " by `xwem-edmacro-can-edit-nonmacro'."))) - (t (xwem-message 'warn "Invalid keyboard macro given."))) + (cond ((and (not xwem-edmacro-can-edit-unbinded) (null xwem-cmd)) + (xwem-message 'warning (concat "Dissalowed to edit unbinded key " + (key-description xwem-keys) + " by `xwem-edmacro-can-edit-unbinded'"))) + ((not xwem-edmacro-can-edit-nonmacro) + (xwem-message 'warning (concat "Dissalowed to edit non-macro key " + (key-description xwem-keys) + " by `xwem-edmacro-can-edit-nonmacro'."))) + (t (xwem-message 'warning "Invalid keyboard macro given."))) ;; XXX (when xwem-edmacro-store-place - (xwem-special-popup-frame (get-buffer-create "*Edit Macro*") t) + (setq frame (xwem-special-popup-frame (get-buffer-create "*Edit Macro*") t)) ;; Add some info in *Edit Macro* buffer (let ((edmacro-format-hook ＠＠ -159,7 +172,10 ＠＠ (mapvector (lambda (k) (if (and (listp k) (= (length k) 1)) (car k) k)) xwem-evs)) - (edit-kbd-macro xwem-evs arg 'xwem-special-revert-focus 'xwem-edmacro-store))) + ;; Start edmacro + (edit-kbd-macro xwem-evs arg + `(lambda () (xwem-edmacro-finish ,frame)) + 'xwem-edmacro-store))) )))  Index: lisp/xwem-edprops.el =================================================================== RCS file: lisp/xwem-edprops.el diff -N lisp/xwem-edprops.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-edprops.el 1 Jan 2005 04:41:11 -0000 ＠＠ -0,0 +1,154 ＠＠ +;;; xwem-edprops.el --- Interactively edit xwem client's properties. + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Created: Wed Oct 27 11:15:39 MSD 2004 +;; Keywords: xwem, edit +;; X-CVS: $Id: xwem-edprops.el,v 1.1 2004/11/29 20:41:30 lg Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; Mode to edit xwem client's properties. + +;;; Code: +(require 'xwem-load) + + +;; Various stuff +(defvar xwem-edprops-mode-hook nil + "*Hooks to call when entering xwem edprops mode.") + +(defvar xwem-edprops-client nil) +(make-variable-buffer-local 'xwem-client-edprops-client) + +(defvar xwem-edprops-mode nil + "Non-nil mean xwem edprops mode is enabled.") +(make-variable-buffer-local 'xwem-edprops-mode) +(set-default 'xwem-edprops-mode nil) + +(defvar xwem-edprops-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-c" 'xwem-edprops-finish) + (define-key map "\C-c\C-q" 'xwem-edprops-quit) + map) + "Keymap when editing client properties.") + +(or (assq 'xwem-edprops-mode minor-mode-alist) + (setq minor-mode-alist + (cons (list 'xwem-edprops-mode + " XWEM-edprops") + minor-mode-alist))) + +(or (assq 'xwem-edprops-mode minor-mode-map-alist) + (setq minor-mode-map-alist + (cons (cons 'xwem-edprops-mode + xwem-edprops-map) + minor-mode-map-alist))) + + +(defun xwem-edprops-quit (cl) + "Quit editing properties for CL discarding changes." + (interactive (list xwem-edprops-client)) + + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))) + +(defun xwem-edprops-finish (cl) + "Finish editing properties for CL, saving changes." + (interactive (list xwem-edprops-client)) + + (set-buffer-modified-p nil) + (let ((nplist (read (buffer-string))) + (oplist (xwem-cl-plist cl))) + (kill-buffer (current-buffer)) + + ;; Remove all supported properties that not in NPLIST + (while oplist + (when (and (xwem-property-supported-p (car oplist)) + (not (plist-get nplist (car oplist)))) + (xwem-message 'info "Removing property %S ..\n" (car oplist)) + (xwem-client-set-property cl (car oplist) nil)) + (setq oplist (cddr oplist))) + + (xwem-cl-apply-plist cl nplist))) + +(defun xwem-edprops-mode () + "Enable xwem-edprops mode in current buffer." + (setq xwem-edprops-mode t) + + (run-hooks 'xwem-edprops-mode-hook)) + +;;;###autoload(autoload 'xwem-edit-client-properties "xwem-edprops" "Interactively edit client's properties." t) +(define-xwem-command xwem-edit-client-properties (cl) + "Interactive edit CL's properties." + (xwem-interactive (list (xwem-cl-selected))) + + (when (eq cl (xwem-dummy-client)) + (error "XWEM Can't edit properties for dummy client")) + + (with-current-buffer (get-buffer-create " *CL-PROPS*") + (kill-all-local-variables) + (setq xwem-edprops-client cl) + + (emacs-lisp-mode) + (setq xwem-edprops-mode t) ; enable edprops mode + + (erase-buffer) + (insert ";; Bindings:\n") + (insert ";; ") (where-is 'xwem-edprops-finish t) (insert "\n") + (insert ";; ") (where-is 'xwem-edprops-quit t) (insert "\n") + + (insert + "\n" + ";; XWEM Client\n\n" + (format ";; Manage mode: %s\n" (upcase (symbol-name (xwem-cl-manage-type cl)))) + (format ";; Name: %s\n" (xwem-client-name cl)) + (format ";; Class: %S\n" (xwem-hints-wm-class (xwem-cl-hints cl))) + (format ";; Command: %S\n" (xwem-hints-wm-command (xwem-cl-hints cl))) + "(\n\n") + (save-excursion + (mapc (lambda (kv) + (when (or (numberp (cdr kv)) + (symbolp (cdr kv)) + (stringp (cdr kv))) + (insert (format "%S %S\n" (car kv) (cdr kv))))) + (plist-to-alist (xwem-cl-plist cl))) + + (insert "\n\n;;; Supported properties:\n") + (let ((print-level 4)) ; Restrict huge output + (mapc (lambda (sp) + (unless (memq (car sp) (xwem-cl-plist cl)) + (insert (format "; %S %S\n" (car sp) (xwem-client-property cl (car sp)))))) + xwem-supported-client-properties)) + (insert "\n)")) + + ;; Enter editing properties mode + (xwem-edprops-mode) + + (xwem-special-popup-frame (current-buffer)) + )) + + +(provide 'xwem-edprops) + +;;; xwem-edprops.el ends here Index: lisp/xwem-events.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-events.el,v retrieving revision 1.9 diff -u -u -r1.9 xwem-events.el --- lisp/xwem-events.el 16 Dec 2004 08:08:05 -0000 1.9 +++ lisp/xwem-events.el 1 Jan 2005 04:41:11 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: 21 Mar 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xwem-events.el,v 1.9 2004/12/16 08:08:05 youngs Exp $ +;; X-CVS: $Id: xwem-events.el,v 1.6 2004/12/05 22:37:33 lg Exp $ ;; This file is part of XWEM. ＠＠ -33,199 +34,239 ＠＠ ;; ;;; Code  -(eval-when-compile - (require 'xlib-xwin)) - -(defun xwem-ev-defhnd (xdpy win xev) - "Default X-Events handler." - - (X-Event-CASE xev -; (:X-ClientMessage (xwem-ev-clnmsg xdpy win xev)) -; (:X-PropertyNotify (xwem-ev-property xdpy win xev)) - (:X-ConfigureRequest (xwem-ev-reconfig xdpy win xev)) - (:X-MapRequest (xwem-ev-remap xdpy win xev)) - (:X-DestroyNotify (xwem-ev-destroy xdpy win xev)) - (:X-ResizeRequest (xwem-ev-reresize xdpy win xev))) - ) +(require 'xwem-load) +;;;###xwem-autoload (defun xwem-ev-reconfig (xdpy win xev) "Common ConfigureRequest handler." (let* ((win (X-Event-xconfigurerequest-wind + ;; Remember some information about command invocation + (setq xwem-last-xevent x-ev + xwem-event-client (xwem-event-client x-ev) + xwem-last-event e-ev + xwem-this-command-keys (vconcat (and (not (xwem-kbd-global-map-current-p)) + xwem-this-command-keys) + (vector e-ev)))) + + +;;;###xwem-autoload +(defun xwem-next-command-event (&optional prompt) + "Return next command event. +Actually return cons cell where car is Emacs event and cdr is X Event." + (let (eev cev xev) + ;; Normal + (when prompt + (xwem-message 'prompt prompt)) + + ;; Process while interesting event occur + (while (and (setq eev (next-event)) + (not (cond ((and (eval-event-p eev) + (X-Event-p (setq xev (event-object eev))) + (memq (X-Event-type xev) + (list X-KeyPress X-ButtonPress + X-ButtonRelease X-MotionNotify)) + (setq cev (car (xwem-xevents->emacs-events (list xev) t)))) + (X-Event-put-property xev 'emacs-event cev) + 'break) + + ((and (eval-event-p eev) + (eventp (setq cev (event-object eev))) + (eq (event-function eev) 'xwem-dispatch-command-event)) + ;; Unread command event + (setq xev nil) + 'break)))) + (dispatch-event eev)) + + (when prompt + (xwem-clear-message)) + + (xwem-event-as-command cev xev) + (cons cev xev))) + +;;;###xwem-autoload +(defun xwem-dispatch-command-event (eev &optional xev) + "Dispatch command Emacs event EEV." + (let* ((ecl (xwem-event-client xev)) + (bind (or (xwem-lookup-key ecl (vector eev)) + ;; Then check for quit key + (and (equal xwem-quit-key (events-to-keys (vector eev))) + xwem-quit-command) + ;; Then accept even default bindings + (xwem-lookup-key ecl (vector eev) t)))) + ;; If some button press/release does not have binding - ignore it + (unless (and (null bind) (button-event-p eev)) + (xwem-event-as-command eev xev) + (xwem-kbd-dispatch-binding bind)))) + +;;;###xwem-autoload +(defun xwem-dispatch-command-xevent (xev) + "Dispatch command event XEV." + ;; If we are grabbing keyboard now and modifier pressed do nothing. + (unless (or (= (X-Event-type xev) X-KeyRelease) + (and (= (X-Event-type xev) X-KeyPress) + (xwem-kbd-kcode-modifier-p (X-Event-xkey-keycode xev)))) + (setf (xwem-xevent-emacs-event xev) + (car (xwem-xevents->emacs-events (list xev) t))) + (xwem-dispatch-command-event + (xwem-xevent-emacs-event xev) xev))) + +;;; Unread command events support +;;;###xwem-autoload +(defun xwem-unread-command-event (eev-or-xev) + "Make event EV to be readed by `xwem-next-command-event' later, +or to be executed by `xwem-dispatch-command-event'. +Event EV can be either Emacs event, or X-Event." + (enqueue-eval-event (if (X-Event-p eev-or-xev) + 'xwem-dispatch-command-xevent + 'xwem-dispatch-command-event) + eev-or-xev)) + + (provide 'xwem-events) ;;; xwem-events.el ends here Index: lisp/xwem-faces.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-faces.el,v retrieving revision 1.10 diff -u -u -r1.10 xwem-faces.el --- lisp/xwem-faces.el 16 Dec 2004 08:08:05 -0000 1.10 +++ lisp/xwem-faces.el 1 Jan 2005 04:41:11 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: Mon Dec 29 12:04:19 MSK 2003 ;; Keywords: xwem -;; X-CVS: $Id: xwem-faces.el,v 1.10 2004/12/16 08:08:05 + (setq spec (specifier-spec-list spec nil tag-set t)) + (cdr (car (cdr (car spec))))))) + +;; Getters +(defsubst xwem-face-foreground (face &optional tag-set domain) + "Return FACE foreground color in TAG-SET." + (or (xwem-face-generic-specifier face 'foreground tag-set domain) + (xwem-face-generic-specifier face 'foreground) + (face-foreground-name face))) +(defsubst xwem-face-background (face &optional tag-set domain) + "Return FACE background color in TAG-SET." + (or (xwem-face-generic-specifier face 'background tag-set domain) + (xwem-face-generic-specifier face 'background) + (face-background-name face))) +(defsubst xwem-face-font (face &optional tag-set domain) + "Return FACE font in TAG-SET." + (or (xwem-face-generic-specifier face 'font tag-set domain) + (xwem-face-generic-specifier face 'font) + (face-font-name face))) +(defsubst xwem-face-line-style (face &optional tag-set domain) + "Return FACE's line style in TAG-SET." + (or (xwem-face-generic-specifier face 'line-style tag-set domain) + (xwem-face-generic-specifier face 'line-style))) +(defsubst xwem-face-line-width (face &optional tag-set domain) + "Return FACE's line width TAG-SET." + (or (xwem-face-generic-specifier face 'line-width tag-set domain) + (xwem-face-generic-specifier face 'line-width))) +(defsubst xwem-face-cap-style (face &optional tag-set domain) + "Return FACE's cap style in TAG-SET." + (or (xwem-face-generic-specifier face 'cap-style tag-set domain) + (xwem-face-generic-specifier face 'cap-style))) +(defsubst xwem-face-join-style (face &optional tag-set domain) + "Return FACE's join style in TAG-SET." + (or (xwem-face-generic-specifier face 'join-style tag-set domain) + (xwem-face-generic-specifier face 'join-style))) +(defsubst xwem-face-function (face &optional tag-set domain) + "Return FACE's function in TAG-SET." + (or (xwem-face-generic-specifier face 'function tag-set domain) + (xwem-face-generic-specifier face 'function))) +(defsubst xwem-face-subwindow-mode (face &optional tag-set domain) + "Return FACE's cap style in TAG-SET." + (or (xwem-face-generic-specifier face 'subwindow-mode tag-set domain) + (xwem-face-generic-specifier face 'subwindow-mode))) +(defsubst xwem-face-graphics-exposures (face &optional tag-set domain) + "Return FACE's graphics exposures in TAG-SET." + (or (xwem-face-generic-specifier face 'graphics-exposures tag-set domain) + (xwem-face-generic-specifier face 'graphics-exposures) + X-False)) + +(defsubst xwem-face-x-gc (face &optional tag-set domain) + "Return FACE's X-Gc in TAG-SET." + (or (face-property face (xwem-face-generic-specifier face 'x-gc tag-set domain)) + (face-property face 'xwem-x-gc))) + +;; Setters +(defun xwem-face-set-domain-face (face &optional domain) + (cond ((null domain) (xwem-face-get-domain-face face)) + ((xwem-cl-p domain) + (or (cdr (assq face (xwem-cl-get-sys-prop domain 'domain-faces))) + (let ((nface (intern (symbol-name (gensym "xwem-cl-domain-face"))))) + (xwem-cl-put-sys-prop domain 'domain-faces + (cons (cons face (xwem-copy-face face nface)) + (xwem-cl-get-sys-prop domain 'domain-faces))) + nface))) + ((xwem-win-p domain) + (or (cdr (assq face (xwem-win-get-prop domain 'domain-faces))) + (let ((nface (intern (symbol-name (gensym "xwem-win-domain-face"))))) + (xwem-win-put-prop domain 'domain-faces + (cons (cons face (xwem-copy-face face nface)) + (xwem-win-get-prop domain 'domain-faces))) + nface))) + ((xwem-frame-p domain) + (or (cdr (assq face (xwem-frame-get-prop domain 'domain-faces))) + (let ((nface (intern (symbol-name (gensym "xwem-frame-domain-face"))))) + (xwem-frame-put-prop domain 'domain-faces + (cons (cons face (xwem-copy-face face nface)) + (xwem-frame-get-prop domain 'domain-faces))) + + (XDefaultRootWindow xdpy)) + (make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy) +:line-style (xwem-face-line-style face tag-set 'nodomain) +:line-width (xwem-face-line-width face tag-set 'nodomain) +:cap-style (xwem-face-cap-style face tag-set 'nodomain) +:join-style (xwem-face-join-style face tag-set 'nodomain) +:function (xwem-face-function face tag-set 'nodomain) +:subwindow-mode (xwem-face-subwindow-mode face tag-set 'nodomain) +:graphics-exposures (xwem-face-graphics-exposures face tag-set 'nodomain) +:foreground (let ((fc (xwem-face-foreground face tag-set 'nodomain))) + (if (stringp fc) + (XAllocColor xdpy cmap (xwem-make-color fc)) + fc)) +:background (let ((bc (xwem-face-background face tag-set 'nodomain))) + (if (stringp bc) + (XAllocColor xdpy cmap (xwem-make-color bc)) + bc)) +:font (X-Font-get xdpy (xwem-face-font face tag-set 'nodomain)))))) + (xwem-set-face-x-gc face gc tag-set 'nodomain) + gc))) - (let ((xdpy (xwem-dpy)) - (gc (xwem-face-get-gc face)) - (fgcol (xwem-misc-colorspec->rgb-vector-safe (face-foreground-name face) [0 0 0]))) - (setf (X-Gc-foreground gc) (XAllocColor xdpy (XDefaultColormap xdpy) - (make-X-Color :red (aref fgcol 0) -:green (aref fgcol 1) -:blue (aref fgcol 2)))) - (XChangeGC xdpy gc))) +(put 'xwem-face-get-gc 'lisp-indent-function 1)  (provide 'xwem-faces) Index: lisp/xwem-focus.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-focus.el,v retrieving revision 1.8 diff -u -u -r1.8 xwem-focus.el --- lisp/xwem-focus.el 16 Dec 2004 08:08:06 -0000 1.8 +++ lisp/xwem-focus.el 1 Jan 2005 04:41:11 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: Fri Dec 19 13:25:30 MSK 2003 ;; Keywords: xwem, xlib -;; X-CVS: $Id: xwem-focus.el,v 1.8 2004/12/16 08:08:06 youngs Exp $ +;; X-CVS: $Id: xwem-focus.el,v 1.7 2004/12/05 22:37:33 lg Exp $ ;; This file is part of XWEM. ＠＠ -32,174 +33,246 ＠＠ ;;; Code:  -(eval-when-compile - (require 'xlib-xwin) - (require 'xwem-clients)) +(require 'xwem-load) ;;;###autoload +(defcustom xwem-default-focus-mode 'generic + "*Default CL's focus mode." +:type '(choice (const :tag "Generic mode" generic) + (const :tag "Click to focus" click-focus) + (const :tag "Follow mouse" follow-mouse)) +:group 'xwem) + +;;; Internal variables + (defvar xwem-focus-stack nil "Last thing that has focus. Internal variable, do not modify.")  -;;;###autoload +;;;###xwem-autoload (defun xwem-focus-xcurrent () "Return current focus." (let ((cf (XGetInputFocus (xwem-dpy)))) cf)) -;;;###autoload (defun xwem-focus-push (&optional xwin) "Push current focus or XWIN to `xwem-focus-stack'." (push (or xwin (xwem-focus-xcurrent)) xwem-focus-stack)) -;;;###autoload +;;;###xwem-autoload (defun xwem-focus-pop () "Pop value from `xwem-focus-stack'." (pop xwem-focus-stack)) -;;;###autoload (defun xwem-focus-push-set (xwin) "Push current focus to `xwem-focus-stack' and set focus to XWIN." (xwem-focus-push) (XSetInputFocus (xwem-dpy) xwin X-RevertToParent)) -;;;###autoload (defun xwem-focus-pop-set () "Pop from `xwem-focus-stack' and s +(define-xwem-client-property xwem-focus-mode nil + "Client focus model." +:type '(eval (list 'choice xwem-focus-mode-names)) +:set 'xwem-focus-set-focus-mode) + +(defun xwem-focus-set-focus-mode (cl prop mode) + "Set CL focus mode property PROP to MODE." + (xwem-focus-mode-invoke cl 'before-mode-change) + (xwem-cl-put-prop cl prop (or mode xwem-default-focus-mode)) + (xwem-focus-mode-invoke cl 'after-mode-change)) -(defun xwem-focus-mode-define (name fun) +(defmacro define-xwem-focus-mode (name args &optional docstring &rest body) "Define new focus mode named by NAME. FUN specifies function to call when focus changes." - (add-to-list 'xwem-focus-modes (cons name fun)) - (put name 'xwem-focus-mode fun)) + (let ((fun (or (and (functionp args) `(function ,args)) + `(lambda ,args + ,docstring + ,＠body)))) + `(progn + (put (quote ,name) 'xwem-focus-mode ,fun) + (add-to-list 'xwem-focus-mode-names + (cons (list 'const :tag ,docstring (quote ,name)) (quote ,fun)))))) +(put 'define-xwem-focus-mode 'lisp-indent-function 'defun) -;;;###autoload +;;;###xwem-autoload (defun xwem-focus-mode-invoke (cl &rest args) - "Invoke CL's focus mode function with ARGS." + "Invoke CL's focus mode function with ARGS. +Invoke focus mode, car of ARGS normally type of invocation. +Built-in invocation types are: + + 'before-mode-change - Called before focus mode changed. + 'after-mode-change - Called after focus mode has been changed. + 'focus-in - When CL receives focus. + 'focus-out - When CL looses focus. + 'enter - When CL enters. + 'leave - When CL leaves. + 'before-keymap-change - Before CL's local map changed. + 'after-keymap-change - After CL's local map changed. +" (when (xwem-cl-p cl) - (let* ((mode (xwem-cl-get-prop cl 'xwem-focus-mode)) + (let* ((mode (xwem-client-property cl 'xwem-focus-mode)) (fun (get mode 'xwem-focus-mode))) (when fun (apply fun cl args))))) -;;;###autoload -(defun xwem-focus-mode-set (cl mode) - "For CL window set focus mode to MODE." - (unless (eq (xwem-cl-get-prop cl 'xwem-focus-mode) mode) - (xwem-focus-mode-invoke cl 'before-mode-change) - (xwem-cl-put-prop cl 'xwem-focus-mode mode) - (xwem-focus-mode-invoke cl 'after-mode-change))) +;;;###xwem-autoload +(defun xwem-focus-mode-set (cl &optional mode) + "For CL window set focus mode to MODE. +If MODE is ommited, `xwem-default-focus-mode' is used." + (xwem-focus-set-focus-mode cl 'xwem-focus-mode mode)) ;; Some built-in focus modes -(xwem-focus-mode-define 'generic - (lambda (cl action &optional xev) - nil)) - -(xwem-focus-mode-define 'follow-mouse - (lambda (cl action &optional xev) - (cond ((and (eq action 'enter) - (eq (X-Event-xcrossing-mode xev) X-NotifyNormal)) - (xwem-cl-pop-to-client cl)) - ))) +(define-xwem-focus-mode generic ignore "Generic mode") +(define-xwem-focus-mode follow-mouse (cl action &optional xev) + "Focus follow mouse" + (cond ((and (eq action 'enter) + (eq (X-Event-xcrossing-mode xev) X-NotifyNormal)) + (xwem-select-client cl)) + )) + +;;; Click to focus model +(defvar xwem-focus-click-to-focus-map + (let ((map (make-sparse-keymap))) + (define-key map [button1] 'xwem-focus-click-on) + (define-key map [button2] 'xwem-focus-click-on) + (define-key map [button3] 'xwem-focus-click-on) + map) + "Keymap used for click to focus model.") + +(defvar xwem-focus-click-minor-mode nil + "*Non-nil mean `xwem-focus-click-to-focus-map' is enabled.") +(xwem-make-variable-client-local 'xwem-focus-click-minor-mode) + +(defun xwem-turn-on-focus-click-mode (cl) + "On CL, turn on click to focus minor mode." + (unless (xwem-client-local-variable-value cl 'xwem-focus-click-minor-mode) + (xwem-kbd-install-grab xwem-focus-click-to-focus-map (xwem-cl-xwin cl) X-GrabModeSync) + (xwem-client-local-variable-set cl 'xwem-focus-click-minor-mode t))) + +(defun xwem-turn-off-focus-click-mode (cl) + "On CL, turn off click to focus minor mode." + (when (xwem-client-local-variable-value cl 'xwem-focus-click-minor-mode) + (XAllowEvents (xwem-dpy) X-ReplayPointer) + (xwem-kbd-uninstall-grab xwem-focus-click-to-focus-map (xwem-cl-xwin cl)) + (xwem-client-local-variable-set cl 'xwem-focus-click-minor-mode nil))) + +(defun xwem-focus-click-mode (cl) + "On CL, toggle click to focus minor mode." + (if (xwem-client-local-variable-value cl 'xwem-focus-click-minor-mode) + (xwem-turn-off-focus-click-mode cl) + (xwem-turn-on-focus-click-mode cl))) + +;;;###autoload(autoload 'xwem-focus-click-on "xwem-focus" nil t) (define-xwem-command xwem-focus-click-on () "Command used by `click-focus' focus mode." (xwem-interactive) - (let* ((xev xwem-last-xevent) - (cl (xwem-find-client (X-Event-win xev)))) - (when (xwem-cl-p cl) - (xwem-cl-pop-to-client cl)))) - -(xwem-focus-mode-define 'click-focus - (lambda (cl action &optional xev) - (cond ((and (eq action 'focus-in) - (or (eq (X-Event-xfocus-mode xev) X-NotifyNormal) - (eq (X-Event-xfocus-mode xev) X-NotifyWhileGrabbed))) - ;; Remove button1 from local keymap and ungrab it - (xwem-message 'info "focus in")) - - ((and (eq action 'focus-out) - (or (eq (X-Event-xfocus-mode xev) X-NotifyNormal) - (eq (X-Event-xfocus-mode xev) X-NotifyWhileGrabbed))) - ;; Add button1 to local keymap and grab for it - (xwem-local-set-key [button1] 'xwem-focus-click-on cl) - (xwem-message 'info "focus out")) - - ((eq action 'before-mode-change) - ;; Remove button1 from local keymap and ungrab it - ) - ))) - -(put 'xwem-focus-mode-define 'lisp-indent-function 1) + (when (xwem-cl-p xwem-event-client) + (xwem-select-client xwem-event-client)) + + ;; Pass the click + (XAllowEvents (xwem-dpy) X-ReplayPointer)) + +(define-xwem-focus-mode click-focus (cl action &optional xev) + "Click to focus" + (cond ((and (eq action 'focus-in) + (or (eq (X-Event-xfocus-mode xev) X-NotifyNormal) + (eq (X-Event-xfocus-mode xev) X-NotifyWhileGrabbed))) + ;; Remove button[123] from local keymap and ungrab it + (xwem-turn-off-focus-click-mode cl)) + + ((and (eq action 'focus-out) + (or (eq (X-Event-xfocus-mode xev) X-NotifyNormal) + (eq (X-Event-xfocus-mode xev) X-NotifyWhileGrabbed))) + ;; Add button[123] to local keymap and grab for it + (xwem-turn-on-focus-click-mode cl)) + + ((memq action '(after-mode-change after-keymap-change)) + ;; Start grabing button1 in sync mode + (unless (xwem-cl-selected-p cl) + (xwem-turn-on-focus-click-mode cl))) + + ((memq action '(before-mode-change before-keymap-change)) + ;; Remove button1 from local keymap and ungrab it + (xwem-turn-off-focus-click-mode cl)) + )) + +;; Register minor mode +(xwem-add-minor-mode 'xwem-focus-click-minor-mode + 'xwem-focus-click-minor-mode + xwem-focus-click-to-focus-map)  (provide 'xwem-focus) Index: lisp/xwem-frame.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-frame.el,v retrieving revision 1.13 diff -u -u -r1.13 xwem-frame.el --- lisp/xwem-frame.el 16 Dec 2004 08:08:06 -0000 1.13 +++ lisp/xwem-frame.el 1 Jan 2005 04:41:12 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: 21 Mar 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xwem-frame.el,v 1.13 2004/12/16 08:08:06 youngs Exp $ +;; X-CVS: $Id: xwem-frame.el,v 1.12 2004/12/05 22:37:33 lg Exp $ ;; This file is part of XWEM. ＠＠ -32,13 +33,13 ＠＠ ;; ;;; Code -  -(eval-when-compile - (require 'xlib-xlib) - (require 'xwem-misc)) +(require 'xlib-xlib) (require 'xlib-xinerama) +(require 'xwem-load) +(require 'xwem-misc) + ;;; Variables (defgroup xwem-frame nil "Group + (setf (xwem-frame-link-prev ,frame2) pf))) + +(defmacro xwem-frame-link-remove (frame) + "Remove FRAME from linkage." + `(let ((nfr (xwem-frame-link-next ,frame)) + (pfr (xwem-frame-link-prev ,frame))) + (when (xwem-frame-p pfr) + (setf (xwem-frame-link-next pfr) nfr)) + (when (xwem-frame-p nfr) + (setf (xwem-frame-link-prev nfr) pfr)))) + +(defmacro xwem-frame-link-head (frame) + "Returns head frame of FRAME's linkage." + `(let ((fr ,frame)) + (while (xwem-frame-p (xwem-frame-link-prev fr)) + (setq fr (xwem-frame-link-prev fr))) + fr)) + +(defmacro xwem-frame-linkage-map (frame fn) + "Call FN for each frame in FRAME's linkage. +FN called with one argument - frame." + ;; TODO: avoid infinit recursion + `(let ((fr (xwem-frame-link-head ,frame))) + + (while (xwem-frame-p fr) + (funcall ,fn fr) + (setq fr (xwem-frame-link-next fr))))) +;;; Functions +(define-xwem-deffered xwem-frame-apply-state (frame) + "Apply FRAME's state to life." + (cond ((eq (xwem-frame-state frame) 'mapped) + (XMapWindow (xwem-dpy) (xwem-frame-xwin frame))) + ((eq (xwem-frame-state frame) 'unmapped) + (XUnmapWindow (xwem-dpy) (xwem-frame-xwin frame))))) + (defun xwem-frame-unmap (frame) "Unmap frame FRAME." - (when (xwem-frame-mapped-p frame) - (XSelectInput (xwem-dpy) (xwem-frame-xwin frame) 0) - (XUnmapWindow (xwem-dpy) (xwem-frame-xwin frame)) - (setf (xwem-frame-state frame) 'unmapped))) + (setf (xwem-frame-state frame) 'unmapped) + (xwem-frame-apply-state frame)) +;;;###xwem-autoload (defun xwem-frame-map (frame) "Map frame FRAME." - (unless (xwem-frame-mapped-p frame) - (XSelectInput (xwem-dpy) (xwem-frame-xwin frame) xwem-frame-ev-mask) + (setf (xwem-frame-state frame) 'mapped) + (xwem-frame-apply-state frame)) - (XMapWindow (xwem-dpy) (xwem-frame-xwin frame)) - (setf (xwem-frame-state frame) 'mapped))) +(define-xwem-deffered xwem-frame-apply-raise-lower (frame) + "Apply FRAME's raise/lower state to life." + (let ((rl (xwem-frame-get-prop frame 'raise-lower-state))) + (cond ((eq rl 'raise) + (XRaiseWindow (xwem-dpy) (xwem-frame-xwin frame))) + ((eq rl 'lower) + (XLowerWindow (xwem-dpy) (xwem-frame-xwin frame)))))) -;;;###autoload -(defun xwem-frame-selected () - "Return selected frame." - xwem-current-frame) +;;;###autoload(autoload 'xwem-frame-lower "xwem-frame" "" t) +(define-xwem-command xwem-frame-lower (frame) + "Lower FRAME's window." + (xwem-interactive (list (xwem-frame-selected))) -;;;###autoload -(defun xwem-frame-selected-p (frame) - "Return non-nil if FRAME is selected." - (eq frame (xwem-frame-selected))) + (xwem-frame-put-prop frame 'raise-lower-state 'lower) + (xwem-frame-apply-raise-lower frame)) +(put 'xwem-frame-lower 'xwem-frame-command t) + +;;;###autoload(autoload 'xwem-frame-raise "xwem-frame" "" t) +(define-xwem-command xwem-frame-raise (frame) + "Raise FRAME's window." + (xwem-interactive (list (xwem-frame-selected))) + + (xwem-frame-map frame) ; make sure frame is mapped + (xwem-frame-put-prop frame 'raise-lower-state 'raise) + (xwem-frame-apply-raise-lower frame)) +(put 'xwem-frame-raise 'xwem-frame-command t) (defun xwem-frame-embedded-for-frame (frame) "Return XWEM frame for which FRAME is embedded." (let* ((cl (and (xwem-frame-p frame) - (xwem-find-client (xwem-frame-xwin frame)))) + (xwem-frame-get-prop frame 'xwem-embedded-cl))) (rv (and (xwem-cl-p cl) (xwem-cl-frame cl)))) rv)) -(defun xwem-frame-embedded-pop (frame) - "Pop embedded FRAME, see also `xwem-cl-pop-to-client'." - (let* ((cl (xwem-find-client (xwem-frame-xwin frame))) - (clfr (and (xwem-cl-p cl) (xwem-cl-frame cl))) - (clw (and (xwem-cl-p cl) (xwem-cl-win cl)))) - - (when (null clfr) - (setq clfr (xwem-frame-selected))) - (when (null clw) - (setq clw (xwem-win-selected))) - - ;; Raise frame in which we are embedded. - (when (not (xwem-frame-selected-p clfr)) - (if (xwem-frame-embedded-p clfr) - (xwem-frame-embedded-pop clfr) - (xwem-frame-raise clfr))) - - (when (not (xwem-win-selected-p clw)) - (xwem-window-select clw)) - - (xwem-manda-manage cl clw))) - -(defun xwem-frame-unembedd (frame) +(defun xwem-frame-unembedd (frame &optional new-type) "Unembedd FRAME." (when (xwem-frame-embedded-p frame) - (let* ((cl (xwem-find-client (xwem-frame-xwin frame))) - (ngeom (nthcdr 4 (XTranslateCoordinates (xwem-dpy) (xwem-frame-xwin frame) - (xwem-rootwin) (xwem-frame-x frame) - (xwem-frame-y frame))))) + (let* ((cl (xwem-frame-get-prop frame 'xwem-embedded-cl)) + (tpnt (car (XTranslateCoordinates (xwem-dpy) (xwem-frame-xwin frame) + (xwem-rootwin) (xwem-frame-x frame) + (xwem-frame-y frame))))) ;; Remove clients stuff - (X-Win-EventHandler-rem (xwem-cl-xwin cl) 'xwem-cl-events-handler) - (xwem-cl-hdestroy-notify cl nil) + (xwem-cl-destroy cl) + + ;; Unmark FRAME as embedded + (xwem-cl-rem-prop cl 'xwem-embedded-frame) + (xwem-frame-rem-prop frame 'xwem-embedded-cl) + + ;; Set new frame TYPE + (setf (xwem-frame-type frame) (or new-type 'desktop)) (XReparentWindow (xwem-dpy) (xwem-frame-xwin frame) (xwem-rootwin) - (car ngeom) (cadr ngeom)) - (setf (xwem-frame-embedded-p frame) nil) - (xwem-frame-set-pos frame (car ngeom) (cadr ngeom)) + (X-Point-x tpnt) (X-Point-y tpnt)) + (xwem-frame-set-pos frame (X-Point-x tpnt) (X-Point-y tpnt)) + (xwem-frame-apply-state frame) ))) -;;;###autoload -(defun xwem-frame-select (frame &optional dnr-hooks) - "Set FRAME as selected frame. -If DNR-HOOKS is non-nil, than do not run hooks." - - (let ((ofr (xwem-frame-selected)) - (nfr frame)) - ;; If FRAME is embedded frame we should raise frame in whose - ;; window FRAME is embedded. - (when (xwem-frame-embedded-p frame) - (xwem-frame-embedded-pop frame)) +;;;###xwem-autoload +(defun xwem-select-frame (frame) + "Set FRAME to be selected frame. +Actually all the work done in `xwem-select-window'." + (or (xwem-frame-alive-p frame) + (error 'xwem-error "Selecting dead frame")) + (xwem-select-window (xwem-frame-selwin frame))) + +(defun xwem-frame-autoiconify-on-deselect () + "Maybe iconify FRAME, when deselecting FRAME." + (when (eq xwem-frame-autoiconify-mode 'always) + ;; NOTE: double deffering + (xwem-deffered-funcall 'xwem-frame-unmap (xwem-frame-selected)))) + +(defun xwem-frame-autoiconify-on-select () + "Maybe iconify some frames when selecting FRAME." + (when (eq xwem-frame-autoiconify-mode 'intersect) + (let ((nfr-rect (X-Geom-to-X-Rect (xwem-frame-xgeom (xwem-frame-selected)))) + (frames (xwem-frames-list))) + (while frames + (when (and (not (eq (xwem-frame-selected) (car frames))) + (xwem-frame-mapped-p (car frames)) + (X-Rect-intersect-p nfr-rect (X-Geom-to-X-Rect (xwem-frame-xgeom (car frames))))) + ;; NOTE: double deffering + (xwem-deffered-funcall 'xwem-frame-unmap (car frames))) + (setq frames (cdr frames)))))) - (setq xwem-current-frame frame) - - ;; Now raise and set input focus to FRAME - (xwem-frame-raise nfr) - (xwem-focus-set frame) - - (when (not dnr-hooks) - (run-hook-with-args 'xwem-frame-switch-hook ofr nfr)))) - -(defun xwem-frame-maybe-autoiconify (ofr nfr) - "This function aimed to be used in `xwem-frame-switch-hook'. -According to `xwem-frame-autoiconify-mode' it possible iconfies OFR -frame." - (when (and xwem-frame-autoiconify-mode (not (eq ofr nfr)) - (or (eq xwem-frame-autoiconify-mode 'always) - (and (eq xwem-frame-autoiconify-mode 'intersect) (xwem-frame-p nfr) - (X-Rect-intersect-p (X-Geom-to-X-Rect (xwem-frame-xgeom nfr)) - (X-Geom-to-X-Rect (xwem-frame-xgeom ofr)))))) - (xwem-frame-unmap ofr))) - -(defun xwem-frame-select-defhook (ofr nfr) - "Default hook for `xwem-frame-switch-hook'. -NOT USED." - ;; Here is OFR may be invisible, but we redraw it in case it is - ;; visible. - (X-Dpy-send-excursion (xwem-dpy) - (when (and (xwem-frame-p ofr) - (xwem-frame-alive-p ofr)) - (xwem-frame-redraw ofr)) - - (when (and (xwem-frame-p nfr) - (xwem-frame-alive-p nfr)) - (xwem-frame-redraw nfr)) - )) - -;;;###autoload -(defun xwem-make-frame-1 (&optional embedded-p params props non-select) +;;;###xwem-autoload(autoload 'xwem-make-frame-1 "xwem-frame") +(defun* xwem-make-frame-1 (type &key params props noselect) "Create new frame with optional frame properties PROPS. If EMBEDDED-p is non-nil than create embedded frame. -If NON-SELECT is non-nil then do not select newly created frame to be +If NOSELECT is non-nil then do not select newly created frame to be current." - (let* ((fplist (copy-sequence xwem-frame-defprops)) - (frame (apply 'make-xwem-frame params))) - - (setf (xwem-frame-embedded-p frame) embedded-p) - - ;; setup properties - (while props - (setq fplist (plist-put fplist (car props) (cadr props))) - (setq props (cddr props))) - (setf (xwem-frame-props frame) fplist) + (let* ((fplist (copy-list xwem-frame-default-properties)) + (frame (apply 'make-xwem-frame params)) + fwin parwin) + + (setf (xwem-frame-type frame) type) + (setf (xwem-frame-state frame) 'unmapped) + ;;; Initialise FRAME's geometry (unless (xwem-frame-xgeom frame) (setf (xwem-frame-xgeom frame) (make-X-Geom))) ＠＠ -459,111 +449,92 ＠＠ (X-Geom-height (xwem-minib-xgeom xwem-minibuffer)) 0)))) - ;; We should not process events before frame's window events - ;; handler installed - (setf (xwem-frame-xwin frame) - (XCreateWindow - (xwem-dpy) nil - (xwem-frame-x frame) - (xwem-frame-y frame) - (xwem-frame-width frame) - (xwem-frame-height frame) - (xwem-frame-get-prop frame 'inner-border-width) - nil ;DefaultDepth - nil ;CopyFromParent - nil ;CopyFromParent - (make-X-Attr :override-redirect 0 - :background-pixel (XAllocNamedColor - (xwem-dpy) (XDefaultColormap (xwem-dpy)) - xwem-frame-background) - :border-pixel (XBlackPixel (xwem-dpy)) -:backing-store X-WhenMapped - :cursor xwem-frame-cursor - :event-mask xwem-frame-ev-mask))) - - (let ((fwin (xwem-frame-xwin frame)) - parwin) - (X-Win-put-prop fwin 'xwem-frame frame) - - ;; Setup events handlers - (X-Win-EventHandler-add-new fwin 'xwem-frame-events-handler 200) - (X-Win-EventHandler-add-new fwin 'xwem-ev-reconfig 90 (list X-ConfigureRequest)) - - ;; XXX Setup WM_XXX stuff - (XSetWMProtocols (xwem-dpy) fwin - (list (X-Atom-find-by-name (xwem-dpy) "WM_DELETE_WINDOW"))) - - (XSetWMClass (xwem-dpy) fwin - '("xwem-frame" "xwem-frame")) - (XSetWMName (xwem-dpy) fwin - (format "xwem-frame[%d]" (length xwem-frames-list))) - - ;; Initialize root window - (setq parwin (xwem-win-new (list :frame frame) nil)) - - (setf (xwem-win-x parwin) - (xwem-frame-get-prop frame 'otter-border-width)) - (setf (xwem-win-y parwin) - (+ (xwem-frame-get-prop frame 'title-height) - (xwem-frame-get-prop frame 'otter-border-width))) - (setf (xwem-win-width parwin) - (- (xwem-frame-width frame) - (* 2 (xwem-frame-get-prop frame 'otter-border-width)))) - (setf (xwem-win-height parwin) - (- (xwem-frame-height frame) - (xwem-frame-get-prop frame 'title-height) - (* 2 (xwem-frame-get-prop frame 'otter-border-width)))) - - (setf (xwem-frame-selwin frame) parwin) - (setf (xwem-frame-rootwin frame) parwin) - - ;; Add to the end of frames list - (if xwem-frames-list - (setcdr (last xwem-frames-list) (list frame)) - (setq xwem-frames-list (list frame))) - - ;; Handle as client, i.e. make frame to be embedded - (when embedded-p - (xwem-make-client (xwem-frame-xwin frame))) - - ;; Finally map and maybe select newly created frame - (xwem-frame-map frame) - - ;; TODO: - ;; Actually here we should wait for an Expose event, according to - ;; some standard. -; (unless embedded-p -; ;; Not for embedded frames -; (XIfEvent (xwem-dpy) -; (lambda (xev) -; (and (= (X-Event-type xev) X-Expose) -; (= (X-Win-id (X-Event-win xev)) (X-Win-id fwin)))))) - - ;; Install grabbing - (unless embedded-p - (xwem-kbd-install-grab xwem-global-map fwin)) - - (unless non-select - (xwem-frame-select frame)) + ;;; Initialize FRAME's X window + (setq fwin (XCreateWindow + (xwem-dpy) nil + (xwem-frame-x frame) + (xwem-frame-y frame) + (xwem-frame-width frame) + (xwem-frame-height frame) + 0 ; border width + nil ;DefaultDepth + nil ;CopyFromParent + nil ;CopyFromParent + (make-X-Attr :override-redirect (not (xwem-frame-embedded-p frame)) +:backing-store X-Always +:cursor xwem-frame-cursor +:event-mask xwem-frame-ev-mask))) + (X-Win-put-prop fwin 'xwem-frame frame) + (setf (xwem-frame-xwin frame) fwin) + + ;; Install events handlers + (X-Win-EventHandler-add-new fwin 'xwem-frame-events-handler 150) + (X-Win-EventHandler-add-new fwin 'xwem-ev-reconfig 40 (list X-ConfigureRequest)) + + ;; XXX Setup WM_XXX stuff + (XSetWMProtocols (xwem-dpy) fwin + (list (X-Atom-find-by-name (xwem-dpy) "WM_DELETE_WINDOW") + (X-Atom-find-by-name (xwem-dpy) "WM_TAKE_FOCUS"))) + (XSetWMClass (xwem-dpy) fwin + (list (symbol-name (xwem-frame-type frame)) + "xwem-frame")) + (XSetWMName (xwem-dpy) fwin "xwem-frame") + + ;; Install grabbing + (xwem-kbd-install-grab 'xwem-frame-prefix fwin) + + ;;; Initialise FRAME properties + ;; Adjust frame properties in case FRAME is embedded or dedicated + ;; frame. + (setq fplist (xwem-misc-merge-plists + fplist + (cond ((xwem-frame-embedded-p frame) + xwem-embedded-frame-default-properties) + ((xwem-frame-dedicated-p frame) + xwem-dedicated-frame-defalut-properties)))) + + ;;; Initialize FRAME's root window + (setq parwin (xwem-win-new (list :frame frame) nil)) + (setf (xwem-frame-selwin frame) parwin) + (setf (xwem-frame-rootwin frame) parwin) + + ;; Set FRAME properties + (xwem-frame-set-properties frame (xwem-misc-merge-plists fplist props)) + + ;; Setup rootwin's geometry + (xwem-frame-setup-root-win frame) + + ;; Add to the end of frames list + (setq xwem-frames-list + (append xwem-frames-list (list frame))) + + ;; Handle as client, i.e. make frame to be embedded + (when (xwem-frame-embedded-p frame) + (let ((ecl (xwem-xwin-try-to-manage (xwem-frame-xwin frame)))) + (when (xwem-cl-p ecl) + (xwem-frame-put-prop frame 'xwem-embedded-cl ecl) + (xwem-cl-put-sys-prop ecl 'xwem-embedded-frame frame)))) + + ;; Finally map and maybe select newly created frame + (unless (xwem-frame-property frame 'initially-unmapped) + (xwem-frame-map frame)) - ;; Now draw frames contents. -; (unless embedded-p -; (xwem-frame-draw frame nil)) - ) + (unless noselect + (xwem-select-frame frame)) ;; Now run on-create hooks (run-hook-with-args 'xwem-frame-creation-hook frame) - frame)) (defun xwem-init-frame-at-rect (xrect) "Create frame to fit in XRECT rectangle." (let ((xmrect (make-X-Rect :x 0 :y 0 :width (X-Geom-width (xwem-rootgeom)) - :height - (if (xwem-minib-frame xwem-minibuffer) - (+ (* 2 (frame-property (xwem-minib-frame xwem-minibuffer) 'border-width)) - (frame-pixel-height (xwem-minib-frame xwem-minibuffer))) - 0)))) + :height (if (xwem-minib-xgeom xwem-minibuffer) + (X-Geom-height (xwem-minib-xgeom xwem-minibuffer)) + (+ (* 2 xwem-minibuffer-border-width) + (frame-pixel-height (xwem-minib-frame xwem-minibuffer)) + xwem-minibuffer-outer-border-width + xwem-minibuffer-outer-border-width))))) (when (X-Rect-intersect-p xmrect xrect) ;; Take into account this intersection ＠＠ -571,17 +542,24 ＠＠ (- (X-Rect-height xrect) (X-Rect-height xmrect)))) - (xwem-make-frame-1 nil (list :xgeom (X-Rect-to-X-Geom xrect)) nil t))) + (xwem-make-frame-1 'desktop +:params (list :xgeom (X-Rect-to-X-Geom xrect)) +:noselect t))) (defun xwem-frame-adjust-geom (frame new-rect) "Adjust FRAME geom according to NEW-RECT and xwem-minibuffer geom." (let ((mrect (X-Geom-to-X-Rect (xwem-minib-xgeom xwem-minibuffer))) + (brd (X-Geom-border-width (xwem-minib-xgeom xwem-minibuffer))) ngeom) - - (when (X-Rect-intersect-p new-rect mrect) - (setf (X-Rect-height new-rect) - (- (X-Rect-height new-rect) - (X-Rect-height mrect)))) + (when (eq (xwem-cl-state (xwem-minib-cl xwem-minibuffer)) 'active) + (when brd + (incf (X-Rect-width mrect) (+ brd brd)) + (incf (X-Rect-height mrect) (+ brd brd))) + + (when (X-Rect-intersect-p new-rect mrect) + (setf (X-Rect-height new-rect) + (- (X-Rect-height new-rect) + (X-Rect-height mrect))))) (setq ngeom (X-Rect-to-X-Geom new-rect)) (setf (X-Geom-border-width ngeom) ＠＠ -589,72 +567,85 ＠＠ (setf (xwem-frame-xgeom frame) ngeom))) -;;;###autoload -(defun xwem-init-frames () - "xwem frames initializer." - (xwem-message 'msg "Initializing frames ... wait") - (setq xwem-frames-list nil) - (setq xwem-current-frame nil) - - ;; Create cursor used while pointer is over xwem frame - (setq xwem-frame-cursor (xwem-make-cursor (eval xwem-frame-cursor-shape) - xwem-frame-cursor-foreground-color - xwem-frame-cursor-background-color)) - - ;; Default swich hook - (add-hook 'xwem-frame-switch-hook 'xwem-frame-select-defhook) - ;; Add autoiconifier hook - (add-hook 'xwem-frame-switch-hook 'xwem-frame-maybe-autoiconify) +(defun xwem-frame-default-select-hook () + "Do various default things when frame selected. +To be used in `xwem-frame-select-hook'." + (xwem-frame-autoiconify-on-select) + (xwem-frame-deffered-redraw-inner-border (xwem-frame-selected))) + +(defun xwem-frame-default-deselect-hook () + "Do various default things when frame deselected. +To be used in `xwem-frame-deselect-hook'." + (xwem-frame-autoiconify-on-deselect) + (xwem-frame-deffered-redraw-inner-border (xwem-frame-selected))) + +(defun xwem-frame-create-initial () + "Create initial frames." + (if xwem-frame-dumped-config + ;; Create frames from saved configuration + (xwem-frame-config-restore1) - (unless xwem-frame-omit-init-frame ;; Xinerama stuff - (let ((xin (X-XIneramaQueryScreens (xwem-dpy)))) + (let ((xin (X-XIneramaQueryScreens (xwem-dpy))) + frame frame-old) (if (car xin) - ;; XInerama enabled + ;; XInerama enabled, so construct frames linkage (while (setq xin (cdr xin)) - (xwem-init-frame-at-rect (car xin))) + (setq frame (xwem-init-frame-at-rect (car xin))) + (when frame-old + (xwem-frame-link-insert-after frame-old frame)) + (setq frame-old frame)) - ;; No XInerama + ;; No XInerama, crate just one frame (xwem-init-frame-at-rect (X-Geom-to-X-Rect (xwem-rootgeom))))) ;; Select very first frame - (xwem-frame-select (car xwem-frames-list))) - ) + (xwem-select-frame (car (xwem-frames-list))))) -;;;###autoload -(define-xwem-command xwem-frame-split-horiz (arg &optional frame) - "Split FRAME horizontally. -Prefix argument specifies how many pixels splitted window will be after split." - (xwem-interactive "p") - - (let* ((sp-frame (or frame (xwem-frame-selected)))) - (when (xwem-frame-dedicated-p sp-frame) - (error "Can't split dedicated frame.")) - - (xwem-win-split (xwem-frame-selwin sp-frame) 'horizontal arg) - (xwem-frame-redraw sp-frame) - )) - -;;;###autoload(autoload 'xwem-frame-split-vert "xwem-frame" "" t) -(define-xwem-command xwem-frame-split-vert (arg &optional frame) - "Split FRAME vertically. -Prefix argument specifies how many pixels splitted window will be after split." - (xwem-interactive "p") - - (let* ((sp-frame (or frame (xwem-frame-selected)))) - (when (xwem-frame-dedicated-p sp-frame) - (error "Can't split dedicated frame.")) - (xwem-win-split (xwem-frame-selwin sp-frame) 'vertical arg) - (xwem-frame-redraw sp-frame) - )) - -;;;###autoload(autoload 'xwem-frame-win-enlarge-hor "xwem-frame" "" t) -(define-xwem-command xwem-frame-win-enlarge-hor (n &optional win) - "Enlarge WIN or selected window N pixels horizontaly." - (xwem-interactive "p") - - (xwem-window-enlarge n nil (or win (xwem-win-selected))) - (xwem-frame-draw (xwem-win-frame (or win (xwem-win-selected))) nil)) - -;;;###autoload(autoload 'xwem-frame-win-enlarge-ver "xwem-frame" "" t) -(define-xwem-command xwem-frame-win-enlarge-ver (n &optional win) - "Enlarge WIN or selected window N pixels horizontaly." - (xwem-interactive "p") - - (xwem-window-enlarge n t (or win (xwem-win-selected))) - (xwem-frame-draw (xwem-win-frame (or win (xwem-win-selected))) nil)) + (xwem-frame-total-remove frame))) +(put 'xwem-frame-destroy 'xwem-frame-command t) (defun xwem-frame-goto (n direction &optional frame) "Goto window at DIRECTION on FRAME N times. DIRECTION is one of 'next, 'prev, 'next-vert, ..." (let* ((gframe (or frame (xwem-frame-selected))) (cwin (xwem-frame-selwin gframe))) + + ;; Adjust N and DIRECTION if needed + (when (and (eq direction 'next) + (< n 0)) + (setq n (- n) + direction 'prev)) + (while (> n 0) (cond ((eq direction 'next) (setq cwin (xwem-window-next cwin))) ＠＠ -1330,12 +1225,11 ＠＠ (setq cwin (xwem-window-prev cwin))) ((eq direction 'next-vert) (setq cwin (xwem-window-next-vertical cwin))) - (t (error "Bad DIRECTION in xwem-frame-goto, should be one of 'next or 'prev"))) + (t (error 'xwem-error "Bad DIRECTION in `xwem-frame-goto', should be one of 'next or 'prev"))) (setq n (1- n))) - (xwem-window-select cwin) - (xwem-frame-redraw gframe)) - ) + (xwem-select-window cwin) + )) ;;;###autoload(autoload 'xwem-frame-goto-next "xwem-frame" "" t) (define-xwem-command xwem-frame-goto-next (arg) ＠＠ -1402,7 +1296,7 ＠＠ xoff yoff) (when (xwem-frame-embedded-p frm) - (error "Can't split embedded frame")) + (error 'xwem-error "Can't split embedded frame")) (if vertp (progn ＠＠ -1425,14 +1319,13 ＠＠ (samey (xwem-frame-y frm))) (while (> n 0) (setq nframe - (xwem-make-frame-1 nil - (list :xgeom - (make-X-Geom :x (if vertp samex (+ samex xoff)) - :y (if vertp (+ samey yoff) samey) - :width nwi - :height nhe)) - nil - t)) + (xwem-make-frame-1 (xwem-frame-type frm) + :params (list :xgeom + (make-X-Geom :x (if vertp samex (+ samex xoff)) +:y (if vertp (+ samey yoff) samey) +:width nwi +:height nhe)) +:noselect t)) ;; Now setup linkage (xwem-frame-link-insert-after oframe nframe) (setq oframe nframe) ＠＠ -1448,19 +1341,21 ＠＠ "Make horizontal sbs split N times for selected frame." (xwem-interactive "p") (xwem-frame-sp + + (:X-MotionNotify + ;; Update curr-xrect + (setf (X-Rect-x curr-xrect) + (+ (X-Rect-x curr-xrect) (- (X-Event-xmotion-root-x xev) sx))) + (setq sx (X-Event-xmotion-root-x xev)) + (setf (X-Rect-y curr-xrect) + (+ (X-Rect-y curr-xrect) (- (X-Event-xmotion-root-y xev) sy))) + (setq sy (X-Event-xmotion-root-y xev)) + + (when (or (> (abs (- (X-Rect-x curr-xrect) (X-Rect-x last-xrect))) step) + (> (abs (- (X-Rect-y curr-xrect) (X-Rect-y last-xrect))) step)) + (unless (eq imove-mode 'opaque) + (xwem-misc-outline last-xrect imove-mode)) + + (setf (X-Rect-x last-xrect) (X-Rect-x curr-xrect)) + (setf (X-Rect-y last-xrect) (X-Rect-y curr-xrect)) + (if (eq imove-mode 'opaque) + (xwem-frame-set-pos frame (X-Rect-x last-xrect) (X-Rect-y last-xrect)) + (xwem-misc-outline last-xrect imove-mode)))))) + + (xwem-mouse-ungrab) + (unless (eq imove-mode 'opaque) + (xwem-misc-outline last-xrect imove-mode)) + + ;; Apply changes + (xwem-frame-set-pos frame (X-Rect-x last-xrect) (X-Rect-y last-xrect))) + ;; Dispatch map requests + (mapc 'X-Dpy-event-dispatch pevs))) + ;;;###autoload(autoload 'xwem-frame-imove "xwem-frame" "" t) -(define-xwem-command xwem-frame-imove (&optional step) +(define-xwem-command xwem-frame-imove () "Interactively move FRAME." (xwem-interactive) (unless (or (interactive-p) (= (X-Event-type xwem-last-xevent) X-ButtonPress)) - (error "xwem-frame-imove must be binded to mouse event")) + (error 'xwem-error "`xwem-frame-imove'' must be binded to mouse event")) (let* ((srx (X-Event-xbutton-root-x xwem-last-xevent)) (sry (X-Event-xbutton-root-y xwem-last-xevent)) - (frame (or (xwem-frame-find 'xwin (X-Event-win xwem-last-xevent)) - (xwem-frame-at srx sry))) - (imove-mode (funcall xwem-frame-imoveresize-mode-function frame 'move)) - (last-xrect (X-Geom-to-X-Rect (xwem-frame-xgeom frame))) - (curr-xrect (copy-sequence last-xrect)) - moving done xev) - - (if (not (xwem-frame-p frame)) - (error "Click on non-XWEM frame") + (frame (or (xwem-xwin-frame (X-Event-xbutton-event xwem-last-xevent)) + (xwem-frame-at srx sry)))) - (unless step - (setq step 1)) ; XXX + (unless (xwem-frame-p frame) + (error 'xwem-error "`xwem-frame-imove' on non-frame")) - (xwem-mouse-grab xwem-cursor-move (xwem-frame-xwin frame) - (Xmask-or XM-ButtonRelease XM-ButtonMotion)) - (unwind-protect - (while (not done) - (setq xev (xwem-next-event)) - (X-Event-CASE xev - (:X-ButtonRelease - (setq done t)) - - (:X-MotionNotify - ;; Update curr-xrect - (setf (X-Rect-x curr-xrect) - (+ (X-Rect-x curr-xrect) (- (X-Event-xmotion-root-x xev) srx))) - (setq srx (X-Event-xmotion-root-x xev)) - (setf (X-Rect-y curr-xrect) - (+ (X-Rect-y curr-xrect) (- (X-Event-xmotion-root-y xev) sry))) - (setq sry (X-Event-xmotion-root-y xev)) - - (when (or (> (abs (- (X-Rect-x curr-xrect) (X-Rect-x last-xrect))) step) - (> (abs (- (X-Rect-y curr-xrect) (X-Rect-y last-xrect))) step)) - (if moving - (unless (eq imove-mode 'opaque) - (XGrabServer (xwem-dpy)) - (xwem-misc-outline last-xrect imove-mode)) - (setq moving t)) - - (setf (X-Rect-x last-xrect) (X-Rect-x curr-xrect)) - (setf (X-Rect-y last-xrect) (X-Rect-y curr-xrect)) - (if (eq imove-mode 'opaque) - (xwem-frame-set-pos frame (X-Rect-x last-xrec + +(defun xwem-frame-set-showing-mode (frame prop val) + "Set FRAME's showing mode PROP to VAL." + (xwem-frame-put-prop frame prop val) + (if val + (xwem-frame-enter-showing-mode frame) + (xwem-frame-leave-showing-mode frame))) -;;;###autoload -(defun xwem-frame-make-cl-list (frame) - "Make list of all clients FRAME holds." - (let ((rcls nil)) - (xwem-win-map (lambda (win) - (setq rcls (nconc rcls (xwem-win-make-cl-list win)))) - (xwem-window-next (xwem-frame-selwin frame))) - rcls)) +(define-xwem-frame-property showing-mode + "Frame's showing mode." +:type 'boolean +:set 'xwem-frame-set-showing-mode)  (provide 'xwem-frame) Index: lisp/xwem-framei.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-framei.el,v retrieving revision 1.6 diff -u -u -r1.6 xwem-framei.el --- lisp/xwem-framei.el 16 Dec 2004 08:08:07 -0000 1.6 +++ lisp/xwem-framei.el 1 Jan 2005 04:41:12 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2004 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: Tue Jan 27 08:01:43 MSK 2004 ;; Keywords: xwem -;; X-CVS: $Id: xwem-framei.el,v 1.6 2004/12/16 08:08:07 youngs Exp $ +;; X-CVS: $Id: xwem-framei.el,v 1.4 2004/12/05 22:37:28 lg Exp $ ;; This file is part of XWEM. ＠＠ -33,15 +34,20 ＠＠ ;; Add something like this to your xwemrc.el to start using frame ;; indicator: ;; -;; (autoload 'xwem-framei-init "xwem-framei") ;; (add-hook 'xwem-after-init-hook 'xwem-framei-init) ;; +;; To use framei dockapp add: + +;; (add-hook 'xwem-after-init-hook 'xwem-framei-dockapp) + ;;; Code:  -(require 'xwem-compat) +(require 'xwem-load) +(require 'xwem-frame) (require 'xwem-osd) +;;; Customisation (defgroup xwem-framei nil "*Group to customize xwem frame indicator." :prefix "xwem-framei-" ＠＠ -62,13 +68,16 ＠＠ :type 'number :group 'xwem-framei) -(defcustom xwem-framei-show-frame-name t - "*Non-nil mean show frame name aswell as frame number." -:type 'boolean -:group 'xwem-framei) - -(defface xwem-framei-face - `((t (:foreground "green2" :size 128 :family "helvetica"))) +(define-xwem-face xwem-framei-face + `(((background dark desktop) (:foreground "magenta" :size 34 :family "helvetica")) + ((background desktop light) (:foreground "darkmagenta" :size 34 :family "helvetica")) + ((background dark embedded) (:foreground "magenta" :size 24 :family "helvetica")) + ((background embedded light) (:foreground "darkmagenta" :size 24 :family "helvetica")) + ((background dark embedded-desktop) (:foreground "magenta" :size 24 :family "helvetica")) + ((background embedded-desktop light) (:foreground "darkmagenta" :size 24:family "helvetica")) + ((background dark dedicated) (:foreground "magenta" :size 20 :family "fixed")) + ((background dedicated light) (:foreground "darkmagenta" :size 20 :family "fixed")) + (t (:foreground "green2" :size 24 :family "helvetica"))) "*Face used to draw frame number." :group 'xwem-framei) ＠＠ -86,6 +95,37 ＠＠ :type 'function :group 'xwem-framei) +(defcustom xwem-framei-format-function 'xwem-framei-default-format + "Function passed with one arg - frame, should return string to display." +:type 'funtion +:group 'xwem-framei) + +(define-xwem-face xwem-framei-dockapp-face + `(((desktop) (:foreground "magenta4" :bold t)) + ((embedded-desktop) (:foreground "magenta4")) + ((dedicated) (:foreground "yellowgreen")) + (t (:foreground "magenta4" :bold t))) + "Face used to draw in framei dockapp." +:group 'xwem-faces) + +(defcustom xwem-framei-dockapp-format-function 'xwem-framei-dockapp-default-format + "Function passed with one arg - frame, should return string to display." +:type 'funtion +:group 'xwem-framei) + +;;; Internal variables + +(defun xwem-framei-default-format (frame) + "Default function used in `xwem-framei-format-function'. +Return string in form \"NUM: NAME\"" + (case (xwem-frame-type frame) + (when (xwem-osd-p xwem-framei-dockapp-osd) - (xwem-osd-destroy xwem-framei-dockapp-osd)) - ) + (xwem-osd-destroy xwem-framei-dockapp-osd))) -;; commands -(define-xwem-command xwem-framei-dockapp-frames-menu () +;;;###autoload +(defun xwem-framei-dockapp (&optional dockid dockgroup dockalign) + "Start frame indicator dockapp." + (unless (xwem-osd-p xwem-framei-dockapp-osd) + (let ((width (* (face-width 'xwem-framei-dockapp-face) 8)) + (height (face-height 'xwem-framei-dockapp-face))) + + (setq xwem-framei-dockapp-osd + (xwem-osd-create-dock (xwem-dpy) width height + (list 'keymap xwem-framei-dockapp-keymap))) + + ;; Try to display current frame + (xwem-framei-dockapp-update) + + ;; Add frame hooks + (add-hook 'xwem-frame-select-hook 'xwem-framei-dockapp-update) + (add-hook 'xwem-frame-change-hook 'xwem-framei-dockapp-update)))) + +;; Commands +;;;###autoload(autoload 'xwem-framei-dockapp-popup-menu "xwem-framei" nil t) +(define-xwem-command xwem-framei-dockapp-popup-menu () "Popup frames menu." (xwem-interactive) - (xwem-popup-menu (list "XWEM Frames" :filter - (lambda (not-used) - (mapcar (lambda (el) - (let ((fn (xwem-frame-num el))) - (vector - (concat "Frame " (int-to-string fn) ": " (xwem-frame-name el)) - `(xwem-frame-switch-nth ,fn)))) - xwem-frames-list)))) - ) + (xwem-popup-menu + (list "XWEM Frames" :filter + (lambda (not-used) + (nconc + (mapcar (lambda (frame) + (vector + (case (xwem-frame-type frame) + (dedicated + (if (xwem-frame-cl frame) + (format "D[%d]: %s" (xwem-frame-num frame) + (xwem-client-name (xwem-frame-cl frame))) + (format "D[%d]: <none>" (xwem-frame-num frame)))) + (t (format "%s %d: %s" + (capitalize (symbol-name (xwem-frame-type frame))) + (xwem-frame-num frame) (xwem-frame-name frame)))) + `(xwem-select-frame ,frame))) + xwem-frames-list) + (list "---" + (vector "Destroy" 'xwem-framei-stop-dockapp))))))) + +;;;###autoload(autoload 'xwem-framei-dockapp-popup-alt-menu "xwem-framei" nil t) +(define-xwem-command xwem-framei-dockapp-popup-alt-menu () + "Popup alternative menu." + (xwem-interactive) + + (xwem-popup-menu + (nconc '("XWEM Frames") + (mapcar (lambda (type) + (nconc (list (capitalize (symbol-name type))) + (mapcar (lambda (frame) + (vector + (format "%d: %s" + (xwem-frame-num frame) + (case (xwem-frame-type frame) + (dedicated + (if (xwem-frame-cl frame) + (xwem-client-name (xwem-frame-cl frame)) + "<none>")) + (t (xwem-frame-name frame)))) + `(xwem-select-frame ,frame))) + (xwem-frames-list type)))) + xwem-frame-types) + '("---" ["Destroy" xwem-framei-stop-dockapp]))))  (provide 'xwem-framei) Index: lisp/xwem-frametrans.el =================================================================== RCS file: lisp/xwem-frametrans.el diff -N lisp/xwem-frametrans.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-frametrans.el +(require 'xwem-load) +(require 'xwem-misc) + (defface xwem-gamma-face `((t (:foreground "#1a1a1a" :background "black"))) "Face used to adjust gamma.") ＠＠ -60,6 +64,7 ＠＠ (gg (+ 0.1 (* k (cadr clist)))) (bg (+ 0.1 (* k (caddr clist))))) (X-XF86VidModeSetGamma xwem-gamma-display rg gg bg xwem-gamma-screen) + (XFlush xwem-gamma-display) (xwem-message 'nolog "New gamma: r=%f g=%f b=%f" rg gg bg))) (defun xwem-gamma-widget (xdpy &optional screen-num) Index: lisp/xwem-help.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-help.el,v retrieving revision 1.6 diff -u -u -r1.6 xwem-help.el --- lisp/xwem-help.el 16 Dec 2004 08:08:07 -0000 1.6 +++ lisp/xwem-help.el 1 Jan 2005 04:41:12 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: 1 Sep 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xwem-help.el,v 1.6 2004/12/16 08:08:07 youngs Exp $ +;; X-CVS: $Id: xwem-help.el,v 1.5 2004/12/05 22:37:34 lg Exp $ ;; This file is part of XWEM. ＠＠ -32,8 +32,21 ＠＠ ;;; Code:  +(require 'xwem-load) +(require 'xwem-misc) + +(defmacro xwem-help-display (title &rest forms) + "Evaluate FORMS in special emacs frame and xwem help buffer." + `(let ((temp-buffer-show-function 'xwem-special-popup-frame)) + (with-displaying-help-buffer + (lambda () + (set-buffer standard-output) + ,＠forms) + (format "xwem %s" (or ,title ""))))) +(put 'xwem-help-display 'lisp-indent-function 'defun) + ;;; Some help stuff -;;;###autoload +;;;###xwem-autoload (defun xwem-logo-string () "Return textified XWEM's logo string." (concat (xwem-str-with-faces "X" (list 'bold-italic)) ＠＠ -46,128 +59,157 ＠＠ "Display some help info." (xwem-interactive) - (xwem-help-display - (progn - (insert "Hello, this is help for ") - (insert (xwem-logo-string)) - (insert "\n\n")) - (progn - (insert "TODO: here is some description for ") - (insert (xwem-logo-string)) - (insert " stuff.\n")) - (insert "\n") - ;; Frames config - (progn - (insert "---=== Frames Info ===---\n\n") - (insert (format "You have %d frames now and [%d] frame is selected.\n" - (length xwem-frames-list) (xwem-frame-num (xwem-frame-selected)))) - (insert "\n")) - - ;; Clients - ;; Maybe use tree-widget package to display this info? - (let ((curr-classn "") - (curr-classi "")) - (insert "---=== Clients Info ===---\n") - (mapc - (lambda (el) - (let ((clclass (xwem-hints-wm-class (xwem-cl-hints el))) - (clgeom (xwem-cl-xgeom el))) - (when (not (string= curr-classn (cadr clclass))) - (setq curr-classn (cadr clclass)) - (insert (format "\n= Begin for class name: <%s> =\n" curr-classn))) - (when (not (string= curr-classi (car clclass))) - (setq curr-classi (car clclass)) - (insert (format "\n- Class instance: <%s> -\n" curr-classi))) - (insert (format "WM-NAME: <%s>, Geom: %dx%d+%d+%d\n" - (xwem-hints-wm-name (xwem-cl-hints el)) - (X-Geom-width clgeom) - (X-Geom-height clgeom) - (X-Geom-x clgeom) - (X-Geom-y clgeom))))) - (sort (copy-list xwem-clients) - (lambda (el1 el2) (let ((cl1-clas (xwem-hints-wm-class (xwem-cl-hints el1))) - (cl1-name (xwem-hints-wm-name (xwem-cl-hints el1))) - (cl2-clas (xwem-hints-wm-class (xwem-cl-hints el2))) - (cl2-name (xwem-hints-wm-name (xwem-cl-hints el2)))) - ;; Sort by class name, than by class - ;; instance, than by wm-name. - (or (string-lessp (cadr cl1-clas) (cadr cl2-clas)) - (and (string= (cadr cl1-clas) (cadr cl2-clas)) - (string-lessp (car cl1-clas) (car cl2-clas))) - (and (string= (car cl1-clas) (car cl2-clas)) - (string-lessp cl1-name cl2-name)))))) - ) - (insert "\n")) - - (progn - (insert "---=== Bindings for `") - (insert (xwem-str-with-faces "xwem-global-map" 'font-lock-keyword-face)) - (insert "' ===---\n")) - (des + (xwem-message 'todo "`xwem-help-clients' is not written yet.") ) ;;;###autoload(autoload 'xwem-help-where-is "xwem-help" "" t) Index: lisp/xwem-holer.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-holer.el,v retrieving revision 1.5 diff -u -u -r1.5 xwem-holer.el --- lisp/xwem-holer.el 16 Dec 2004 08:08:07 -0000 1.5 +++ lisp/xwem-holer.el 1 Jan 2005 04:41:12 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Thu Jan 15 12:39:04 MSK 2004 ;; Keywords: xwem -;; X-CVS: $Id: xwem-holer.el,v 1.5 2004/12/16 08:08:07 youngs Exp $ +;; X-CVS: $Id: xwem-holer.el,v 1.2 2004/12/05 05:52:34 youngs Exp $ ;; This file is part of XWEM. ＠＠ -33,21 +33,21 ＠＠ ;; ;; Add something following to your ~/.xwem/xwemrc.el to start using ;; holer: - -;; ;; Making holes in frames -;; (require 'xwem-holer) +;; ;; (define-key xwem-global-map (xwem-kbd "H-x h") 'xwem-holer-prefix) +;; +;; Note: in xwem2.0-rc2 binded by default to `H-x h' ;;; BUGS: ;; -;; - You can create/manipulate holes only on selected frame. +;; - You can create/manipulate holes only on selected frame. ;;; Code: -(require 'xlib-xshape) -(eval-when-compile - (require 'xlib-xlib) - (require 'xwem-misc))  +(require 'xlib-xshape) + +(require 'xwem-load) +(require 'xwem-compat) (defgroup xwem-holer nil "Group to customize xwem holer." ＠＠ -61,7 +61,7 ＠＠ (defcustom xwem-holer-outline-color "blue2" "*Color of holer outliner." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color :group 'xwem-holer) (defcustom xwem-holer-move-cursor-shape 'X-XC-fleur ＠＠ -71,22 +71,22 ＠＠ (defcustom xwem-holer-move-cursor-foreground "#0000AA" "*Cursor's foreground when moving holer." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color :group 'xwem-holer) (defcustom xwem-holer-move-cursor-background "#000088" "*Cursor's background when moving holer." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color :group 'xwem-holer) (defcustom xwem-holer-resize-cursor-foreground "#0000AA" "*Cursor's foreground when resizing holer." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color :group 'xwem-holer) (defcustom xwem-holer-resize-cursor-background "#000088" "*Cursor's background when resizing holer." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color :group 'xwem-holer) (defcustom xwem-holer-min-pixels 10 ＠＠ -95,8 +95,11 ＠＠ :type 'number :group 'xwem-holer) +;;; Internal variables +  ;;; Define holer prefix map +;;;###autoload(autoload 'xwem-holer-prefix "xwem-holer" nil nil 'keymap) (xwem-define-prefix-command 'xwem-holer-prefix t) (defvar xwem-holer-map (symbol-function 'xwem-holer-prefix) "Keymap for holer (\\<xwem-global-map>\\[xwem-holer-prefix]) commands. ＠＠ -400,21 +403,19 ＠＠ (when (= (X-Event-type xev) X-ButtonPress) (let* ((xdpy (X-Event-dpy xev)) (frame (xwem-holer-find-frame xev)) - (xt (and (xwem-frame-p frame) - (XTranslateCoordinates xdpy (XDefaultRootWindow xdpy) - (xwem-frame-xwin frame) - (X-Event-xbutton-root-x xev) - (X-Event-xbutton-root-y xev)))) - (chw (nth 3 xt)) + (chw (and (xwem-frame-p frame) + (cdr (XTranslateCoordinates xdpy (XDefaultRootWindow xdpy) + (xwem-frame-xwin frame) + (X-Event-xbutton-root-x xev) + (X-Event-xbutton-root-y xev))))) (hl (and (X-Win-p chw) (X-Win-get-prop chw 'xwem-holer)))) (when (xwem-holer-p hl) - (let ((hlxt (XTranslateCoordinates - xdpy (XDefaultRootWindow xdpy) - (xwem-holer-outliner-win hl) - (X-Event-xbutton-root-x xev) (X-Event-xbutton-root-y xev)))) - (setf (xwem-holer-click-xoff hl) (nth 4 hlxt)) - (setf (xwem-holer-click-yoff hl) (nth 5 hlxt)) - + (let ((tpnt (car (XTranslateCoordinates + xdpy (XDefaultRootWindow xdpy) + (xwem-holer-outliner-win hl) + (X-Event-xbutton-root-x xev) (X-Event-xbutton-root-y xev))))) + (setf (xwem-holer-click-xoff hl) (X-Point-x tpnt)) + (setf (xwem-holer-click-yoff hl) (X-Point-y tpnt)) hl))))) (define-xwem-command xwem-holer-imove () ＠＠ -487,6 +488,8 ＠＠ (truncate (Xmask-or XM-ButtonPress XM-ButtonRelease XM-ButtonMotion)) cursor) (X-Win-EventHandler-add-new (xwem-holer-outliner-win hl) 'xwem-holer-event-handler) + (while (xwem-holer-mode hl) + (dispatch-event (next-event))) )))) (define-xwem-command xwem-holer-idestroy () Index: lisp/xwem-icons.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-icons.el,v retrieving revision 1.8 diff -u -u -r1.8 xwem-icons.el --- lisp/xwem-icons.el 16 Dec 2004 08:08:08 -0000 1.8 +++ lisp/xwem-icons.el 1 Jan 2005 04:41:12 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: Sat Dec 27 15:38:24 MSK 2003 ;; Keywords: xwem -;; X-CVS: $Id: xwem-icons.el,v 1.8 2004/12/16 08:08:08 youngs Exp $ +;; X-CVS: $Id: xwem-icons.el,v 1.7 2004/12/05 22:37:34 lg Exp $ ;; This file is part of XWEM. ＠＠ -30,93 +31,246 ＠＠ ;; Icons support. -;;; Code: +;; Supports client properties: + +;; `xwem-tab-face' - Face to draw tabber item (overrides `xwem-tabber-face' +;; `xwem-icon-name' - Name of icon to use (overrides `xwem-icons-alist') -(eval-when-compile - (require 'xlib-xlib)) +;;; Code: + (require 'xlib-xpm) -(defvar xwem-icons-dir (locate-data-directory "xwem") - "Directory where icons for use by XWEM lies.") +(require 'xwem-load) -(defvar xwem-icons-list nil - "List of already loaded icons.") +;;;###autoload +(defcustom xwem-icons-dir (locate-data-directory "xwem") + "Directory where icons for use by XWEM lies." +:type 'directory +:group 'xwem) ;;;###autoload -(defvar xwem-icons-alist - ;; [ wm-name wm-class-name wm-class-instance ] . icon-name - '(([".*" ".term" ".Term"] . "mini-term.xpm") - ([".*" "xclock" "XClock"] . "mini-clock.xpm") - ([".*" "xload" "XLoad"] . "mini-measure.xpm") - ([".*" "xcalc" "XCalc"] . "mini-calc.xpm") - - ([".*" "xkeycaps" "XKeyCaps"] . "mini-xkeycaps.xpm") - ([".*" "xdvi" "XDvi"] . "mini-xdvi.xpm") - ([".*" "xv" "XV.*"] . "mini-xv.xpm") - ([".*" ".*" "AcroRead"] . "mini-acroread.xpm") - ([".*" ".*" "Xpdf"] . "mini-acroread.xpm") - ([".*" ".*" "Xman"] . "mini-info.xpm") - - ([".*" "Mozilla" ".*"] . "mini-mozilla.xpm") - ([".*" "gv" "GV"] . "mini-gv.xpm") - ([".*" "ghostview" "Ghostview"] . "mini-gv.xpm") - ([".*" "xfig" "Fig"] . "mini-xfig.xpm") - ([".*" "ethereal" "Ethereal"] . "mini-ethereal.xpm") - ([".*" "xfd" "Xfd"] . "mini-font.xpm") - ([".*" "xfontsel" "XFontSel"] . "mini-font.xpm") - ([".*" "xconsole" "XConsole"] . "mini-sh1.xpm") - ([".*" "xcolors" "Xcolors"] . "mini-colors.xpm") - ([".*" ".*" "X-Chat"] . "mini-xchat.xpm") - - ;; Match by WM_NAME since WM_CLASS is not setuped - (["Lupe" ".*" ".*"] . "mini-zoom.xpm") - (["xcmap" "" ".*"] . "mini-colors.xpm") - +(defcustom xwem-icons-list + '(("mini-display.xpm" (class-inst "^Terminal$") (class-name "^Terminal$")) + ("mini-clock.xpm" (application "xclock")) + ("mini-measure.xpm" (application "xload")) + ("mini-calc.xpm" + (or (buffer-major-mode calc-mode) + (class-name "[cC]alc"))) + + ("mini-xkeycaps.xpm" (application "xkeycaps")) + ("mini-xv.xpm" (application "xv")) + ("mini-imagemagic.xpm" (application "display")) + + ("mini-xdvi.xpm" (class-inst "^xdvi$") (class-name "^XDvi$")) + ("mini-acroread.xpm" (class-name "^AcroRead\\|Xpdf$")) + ("min + (pm (and (nth 3 kw) (make-X-Pixmap :dpy (xwem-dpy) :id (nth 3 kw)))) + (gg nil)) + (if (not (and pp pm)) + (xwem-cl-put-sys-prop cl 'kwm-win-icon 'no-kwm-win-icon) + + (setq gg (XGetGeometry (xwem-dpy) pp)) + (setf (X-Pixmap-width pp) (X-Geom-width gg)) + (setf (X-Pixmap-height pp) (X-Geom-height gg)) + + (setq gg (XGetGeometry (xwem-dpy) pm)) + (setf (X-Pixmap-width pm) (X-Geom-width gg)) + (setf (X-Pixmap-height pm) (X-Geom-height gg)) + + (xwem-cl-put-sys-prop cl 'kwm-win-icon (setq gg (cons pp pm)))) + gg)) + (t kwi)))) + +;;;###xwem-autoload +(defun xwem-icons-cl-icon (cl &optional tag-set) + "Get X-Image of CL's icon. +Return cons cell where car is X-Pixmap of icon and cdr is X-Pixmap +where mask for icon is stored. + +TAG-SET specifies environment list for which icon is created." + (or (xwem-icons-cl-kwm-win-icon cl tag-set) + (xwem-icons-cl-buildin-icon cl tag-set)))  (provide 'xwem-icons) Index: lisp/xwem-interactive.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-interactive.el,v retrieving revision 1.11 diff -u -u -r1.11 xwem-interactive.el --- lisp/xwem-interactive.el 16 Dec 2004 08:08:08 -0000 1.11 +++ lisp/xwem-interactive.el 1 Jan 2005 04:41:13 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: Thu Dec 18 05:49:52 MSK 2003 ;; Keywords: xwem, xlib -;; X-CVS: $Id: xwem-interactive.el,v 1.11 2004/12/16 08:08:08 youngs Exp $ +;; X-CVS: $Id: xwem-interactive.el,v 1.10 2004/12/05 22:37:34 lg Exp $ ;; This file is part of XWEM. ＠＠ -35,126 +36,183 ＠＠ (eval-when-compile ;; Shutup compiler (defvar iswitchb-buflist nil) - (autoload 'iswitchb-read-buffer "iswitchb")) + (autoload 'iswitchb-read-buffer "iswitchb") + ) + +(require 'xlib-xlib) + +(require 'xwem-struct) +(require 'xwem-loaddefs) + + +(defcustom xwem-completing-read-type 'iswitchb + "*Type of interactive client reading. +Possible values are `iswitchb', requires iswitchb package, or +`complete' uses standard `completing-read'." +:type '(choice (const :tag "Iswitchb" iswitchb) + (const :tag "Standard" complete)) +:group 'xwem-misc) + +;;; Internal variables -;;;###autoload (defvar xwem-interactively nil "Non-nil when xwem in interactive mode. -Internal variable, do not modify.") +Internal variabel, do not modify.") + +;; Save read-from-minibuffer for further use +(eval-and-compile + (define-function 'read-from-minibuffer-for-xwem + (symbol-function 'read-from-minibuffer))) + +(defmacro xwem-interactive (&rest ispec) + "Just like `interactive', but accepts xwem specific arguments. +Code letters available are: +s -- String. +k -- Single key. +K -- Key sequence that executes command. +c -- Client. +f -- Existing file. +F -- Possible non-existing file. +p -- Prefix argument as number. +P -- Prefix argument in raw form. +C -- Command. +e -- External command." + (let ((is (cond ((and (= (length ispec) 1) + (stringp (car ispec))) + (setq ispec (car ispec)) + (split-string ispec "\n")) + + (t ispec)))) + + (if (not (stringp ispec)) + `(interactive (let ((xwem-interactively t)) + (prog1 (progn ,＠ispec) + (setq xwem-prefix-arg nil)))) + + `(interactive (prog1 (xwem-interactive-ilist (quote ,is)) + (setq xwem-prefix-arg nil)))) + )) -(defalias 'read-from-minibuffer-for-xwem (symbol-function 'read-from-minibuffer)) +(defmacro define-xwem-command (funsym args docstring inter &rest body) + "Same as `xwem-defun', but make FUNSYM to be interactive command. +INTER is actually a for of `xwem-interactive'." + `(defun ,funsym ,args + ,docstring + ,(macroexpand inter) + ;; Maybe run command without GCing (xwem-kbd-wait-key-release (X-Event-xkey-keycode xwem-last-xevent))) ;; Remove ?* from first element in SPEC ＠＠ -198,6 +257,7 ＠＠ ((eq code ?e) (xwem-read-external-command prompt)) ))) spec))) +  (provide 'xwem-interactive) Index: lisp/xwem-keyboard.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-keyboard.el,v retrieving revision 1.14 diff -u -u -r1.14 xwem-keyboard.el --- lisp/xwem-keyboard.el 16 Dec 2004 08:08:08 -0000 1.14 +++ lisp/xwem-keyboard.el 1 Jan 2005 04:41:13 -0000 ＠＠ -3,10 +3,11 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Authors: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Alex Ott <ottalex(a)narod.ru&gt; ;; Created: 21 Mar 2003 ;; Keywords: xwem, xlib -;; X-CVS: $Id: xwem-keyboard.el,v 1.14 2004/12/16 08:08:08 youngs Exp $ +;; X-CVS: $Id: xwem-keyboard.el,v 1.13 2004/12/08 08:30:55 youngs Exp $ ;; This file is part of XWEM. ＠＠ -36,11 +37,12 ＠＠ ;;; Code:  - -(eval-when-compile - (require 'xwem-clients)) +(require 'xlib-xlib) (require 'xlib-xtest) -(require 'xwem-compat) +(require 'xlib-keysymdb) + +(require 'xwem-load) +(require 'xwem-misc) ;;{{{ [-] Custamizable xwem-keyboard group ＠＠ -50,6 +52,7 ＠＠ :prefix "xwem-" :group 'xwem) +;;;###autoload (defcustom xwem-pre-command-hook nil "*Hooks to run just before executing command. This may examine `xwem-this-command' variable to find out which ＠＠ -59,15 +62,17 ＠＠ :group 'xwem-keyboard :group 'xwem-hooks) +;;;###autoload (defcustom xwem-post-command-hook nil "*Hooks to run after command execution." :type 'hook :group 'xwem-keyboard :group 'xwem-hooks) -(defcustom xwem-keyboard-echo-keystrokes t - "*If non-nil than echo unfinished commands in echo area." -:type 'boolean +;;;###autoload +(defcustom xwem-keyboard-echo-keystrokes 1 + "*If non-nil than echo unfinished commands in echo area after this many seconds of pause." +:type 'number :group 'xwem-keyboard) (defcustom xwem-hyper-modifier 'hyper ＠＠ -75,7 +80,8 ＠＠ :type '(choice (const :tag "Meta" meta) (const :tag "Control" control) (const :tag "Super" super) - (const :tag "Hyper" hyper)) + (const :tag "Hyper" hyper) + (const :tag "Alt" alt)) :group 'xwem-keyboard) (defcustom xwem-meta-modifier 'meta ＠＠ -83,7 +89,8 ＠＠ :type '(choice (const :tag "Meta" meta) (const :tag "Control" control) (const :tag "Super" super) - (const :tag "Hyper" hyper)) + (const :tag "Hyper" hyper) + (const :tag "Alt" alt)) :group 'xwem-keyboard) (defcustom xwem-control-modifier 'control ＠＠ -91,7 +98,8 ＠＠ :type '(choice (const :tag "Meta" meta) (const :tag "Control" control) (const :tag "Super" super) - (const :tag "Hyper" hyper)) + (const :tag "Hyper" hyper) + (const :tag "Alt" alt)) :group 'xwem-keyboard) (defcustom xwem-kbd-evillocks (list XK-NumLock XK-Caps-Lock) ＠＠ -106,31 +114,37 ＠＠ "List of evil masks. Internal variable, DO NOT MODIFY.") +;;;###autoload (defcustom xwem-quit-key [(hyper ?g)] "Quit command key." :type 'sexp :group 'xwem-keyboard) +;;;###autoload (defcustom xwem-quit-command 'xwem-keyboard-quit "Default command to be called when `xwem-quit-key' pressed." :type 'function :group 'xwem-keyboard) +;;;###autoload (defcustom xwem-help-key [(hyper ?h)] "Help command key." :type 'sexp :group 'xwem-keyboard) +;;;###autoload (defcustom xwem-prefix-help-command 'xwem-describe-prefix-bindings "Default command to be called when `xwem-help-key' pressed." :type 'function :group 'xwem-keys) +;;;###autoload (defcustom xwem-universal-key [(hyper ?u)] "Key for universal argument commands." :type 'sexp :group 'xwem-keyboard) +;;;###autoload (defcustom xwem-kbd-quit-hook nil "*Hooks to be runned when KBD exits. Runned only on \\<xwem-global-map>\\[xwem-kbd-quit], but not on ＠＠ -139,23 +153,33 + ;; Create new local keymap for client if needed + (unless (keymapp (xwem-local-map cl)) + (setf (xwem-local-map cl) (make-sparse-keymap))) + + (xwem-define-key (xwem-cl-xwin cl) (xwem-local-map cl) key command pgrab-mode kgrab-mode)) + +;;;###xwem-autoload +(defun xwem-use-local-map (keymap &optional cl) + "Select KEYMAP as local CL's keymap." + (unless cl + (setq cl (xwem-cl-selected))) + + (setf (xwem-local-map cl) keymap)) ;;}}} ＠＠ -349,23 +406,20 ＠＠ (define-xwem-command xwem-undefined-command () "Called when key is not binded." (xwem-interactive) - (xwem-message 'warn "Command undefined for key %S." xwem-last-event)) + (signal 'undefined-keystroke-sequence xwem-this-command-keys)) ;;;###autoload(autoload 'xwem-self-insert-or-undefined "xwem-keyboard" "" t) (define-xwem-command xwem-self-insert-or-undefined (arg) "Self insert or undefined command. Prefix ARG specifies how many characters to insert." - (xwem-interactive "*_p") - - (let ((lev xwem-last-event)) - ;; TODO: - ;; * Check is LEV is actually self insertable event - (if arg - (xwem-key-send-ekeys (make-vector arg lev)) - - (xwem-message 'warn "%s is not defined, prefix arg is %S." - (key-description xwem-this-command-keys) arg) - ))) + (xwem-interactive "*_P") + + (if (= (length xwem-this-command-keys) 1) + ;; Self insert command allowed only for normal clients + (unless (xwem-dummy-client-p (xwem-cl-selected)) + (xwem-key-send-ekeys + (make-vector (prefix-numeric-value arg) xwem-last-event))) + (error 'xwem-error (format "%s is undefined" (key-description xwem-this-command-keys))))) ;;}}} ＠＠ -376,8 +430,11 ＠＠ "Send quit signal." (xwem-interactive) + (setq xwem-override-map nil) (signal 'quit '(xwem)) - (xwem-message 'info "quit.")) + + ;; NOT REACHED + (xwem-message 'error "quit.")) ;;;###autoload(autoload 'xwem-kbd-quit "xwem-keyboard" "" t) (define-xwem-command xwem-kbd-quit () ＠＠ -387,85 +444,9 ＠＠ (xwem-kbd-stop-grabbing) (setq xwem-kbd-private-prefix-map nil) (XSetInputFocus (xwem-dpy) X-PointerRoot X-RevertToPointerRoot X-CurrentTime) - (xwem-message 'note "[kbd-quit] InputFocus is PonterRoot, prfxmap is nil.") + (xwem-message 'note "[kbd-quit] InputFocus set PointerRoot") - (run-hooks 'xwem-kbd-quit-hook) - ) - -;;}}} - -;;{{{ [-] Initializators - -(defun xwem-kbd-initialize-private-modifiers () - "Create internal modifier representation to speedup futher work. -Also update `xwem-kbd-evilmasks' if `xwem-kbd-evillocks' is non-nil." - (setq xwem-kbd-private-modifiers (make-vector 7 nil)) - (let* ((ctrls (list (car (xwem-kbd-xksym->xkcode XK-Control-L)) - (car (xwem-kbd-xksym->xkcode XK-Control-R)))) - (locks (list (car (xwem-kbd-xksym->xkcode XK-Caps-Lock)))) - (shifts (list (car (xwem-kbd-xksym->xkcode XK-Shift-L)) - (car (xwem-kbd-xksym->xkcode XK-Shift-R)))) - (metas (list (car (xwem-kbd-xksym->xkcode XK-Meta-L)) - (car (xwem-kbd-xksym->xkcode XK-Meta-R)))) - (hypers (list (car (xwem-kbd-xksym->xkcode XK-Hyper-L)) - (car (xwem-kbd-xksym->xkcode XK-Hyper-R)))) - (supers (list (car (xwem-kbd-xksym->xkcode XK-Super-L)) - (car (xwem-kbd-xksym->xkcode XK-Super-R)))) - (numlocks (list (car (xwem-kbd-xksym->xkcode XK-NumLock)))) - (evils (mapcar (lambda (ks) - (car (xwem-kbd-xksym->xkcode ks))) xwem-kbd-evillocks)) - (mlist (mapcar 'truncate (list X-Shift X-Lock X-Control X-Mod1 X-Mod2 - X-Mod3 X-Mod4 X-Mod5))) - (slist (car (last xwem-xmods-mapping)))) - - (while slist - ;; Update some private modifier mask - (when (intersection (car slist) shifts) - (aset xwem-kbd-private-modifiers 0 (cons (car mlist) (aref xwem-kbd-private-modifiers 0)))) - (when (intersection (car slist) locks) - (aset xwem-kbd-private-modifiers 1 (cons (car mlist) (aref xwem-kbd-private-modifiers 1)))) - (when (intersection (car slist) ctrls) - (aset xwem-kbd-private-modifiers 2 (cons (car mlist) (aref xwem-kbd-private-modifiers 2)))) - (when (intersection (car slist) metas) - (aset xwem-kbd-private-modifiers 3 (cons (car mlist) (aref xwem-kbd-private-modifiers 3)))) - (when (intersection (car slist) hypers) - (aset xwem-kbd-private-modifiers 4 (cons (car mlist) (aref xwem-kbd-private-modifiers 4)))) - (when (intersection (car slist) supers) - (aset xwem-kbd-private-modifiers 5 (cons (car mlist) (aref xwem-kbd-private-modifiers 5)))) - (when (intersection (car slist) numlocks) - (aset xwem-kbd-private-modifiers 6 (cons (car mlist) (aref xwem-kbd-private-modifiers 6)))) - - ;; Update Evil locks - (when (intersection (car slist) evils) - (push (car mlist) xwem-kbd-evilmasks)) - - (setq slist (cdr slist)) - (setq mlist (cdr mlist))))) - -;;;###autoload -(defun xwem-kbd-init () - "Init part for keys. -Fetches KeyboardMapping from the X server and stores it in -`xwem-xkeys-mapping'" - (xwem-message 'msg "Initializing keyboard ... wait") - (xwem-kbd-set-current-prefix-keymap nil) - - ;; Hmm FSFmacs issued "invalid instraction" in `XGetKeyboardMapping' - (setq xwem-xkeys-mapping - (XGetKeyboardMapping (xwem-dpy) - (X-Dpy-min-keycode (xwem-dpy)) - (- (X-Dpy-max-keycode (xwem-dpy)) - (X-Dpy-min-keycode (xwem-dpy))))) - - (setq xwem-xmods-mapping - (XGetModifierMapping (xwem-dpy))) - - ;; Initialize `xwem-kbd-private-modifiers' - (xwem-kbd-initialize-private-modifiers) - - ;; Initialize keyboard macrosing - (xwem-keymacro-init) - ) + (run-hooks 'xwem-kbd-quit-hook)) ;;}}} ＠＠ -502,6 +483,9 ＠＠ ((= ksym XK-Insert) 'insert) ((= ksym XK-Pause) 'pause) ((= ksym XK-Space) 'space) + + ((= ksym XK-Next) 'next) + ((= ksym XK-Prior) 'prior) ;; TODO: add more ((= ksym XK-F1) 'f1) ＠＠ -519,7 +503,8 ＠＠ ((= ksym 0) nil) - (t (XCharacter ksym)))) ;nil or proper character + (t (or (X-XKeysymDB-keysym->sym ksym) + (XCharacter ksym))))) ;nil or proper character (defun xwem-kbd-emacs->xksym (ksym) "Convert back from Emacs key symbol KSYM to proper X key symbol." ＠＠ -547,6 +532,9 ＠＠ ((string= symname "insert") XK-Insert) ((string= symname "pause") XK-Pause) + ((string= symname "next") XK-Next) + ((string= symname "prior") XK-Prior) + ;; Mouse buttons ((string= symname "button1") (list X-XButton1)) ((string= symname "button2") (list X-XButton2)) ＠＠ -555,14 +543,15 ＠＠ ((string= symname "button5") (list X-XButton5)) ;; Functional keys - ((string-match "[fF]\\([0-9]+\\)" symname) + ((string-match "^[fF]\\([0-9]+\\)$" symname) (symbol-value (intern (concat "XK-F" (substring symname (match-beginning 1) (match-end 1)))))) - (t (Xforcenum (string-to-char osymname)))))) + (t (or (X-XKeysymDB-sym->keysym ksym) + (Xforcenum (string-to-char osymname))))))) ((characterp ksym) (Xforcenum ksym)) ;Should not be there ＠＠ -570,27 +559,16 ＠＠ (defun xwem-kbd-emods->xmodmask (emods) "Convert Emacs modifiers list EMODS to X modifers mask." - (Xmask-or - (if (member 'control emods) (xwem-kbd-controlmask) 0) - (if (member 'shift emods) (xwem-kbd-shiftmask) 0) - (if (member 'meta emods) (xwem-kbd-metamask) 0) - (if (member 'hyper emods) (xwem-kbd-hypermask) 0) - (if (member 'super emods) (xwem-kbd-supermask) 0))) + (apply 'Xmask-or 0 (mapcar (lambda (mod) + (or (get mod 'x-mod-mask) 0)) + emods))) (defun xwem-kbd-xmodmask->emods (mmask) "Convert X modifiers mask MMASK to Emacs modifiers list." - (let (rmods) - (when (Xtest mmask (xwem-kbd-controlmask)) - (push 'control rmods)) - (when (Xtest mmask (xwem-kbd-shiftmask)) - (push 'shift rmods)) - (when (Xtest mmask (xwem-kbd-hypermask)) - (push 'hyper rmods)) - (when (Xtest mmask (xwem-kbd-metamask)) - (push 'meta rmods)) - (when (Xtest mmask (xwem-kbd-supermask)) - (push 'super rmods)) - rmods)) + (delq nil (mapcar (lambda (mod) + (and (Xtest mmask (or (get mod 'x-mod-mask) 0)) + mod)) + '(shift control alt meta hyper super)))) ;; keysyms and keycodes converters (defun xwem-kbd-xksym->xkcode (ksym) ＠＠ -598,25 +576,24 ＠＠ Convert keysym to cons cell where car is keycode and cdr is modifiers list, using `xwem-xkeys-mapping' list. NOTE: only 'shift modifier supported." - (setq ksym (float ksym)) ; for sure - (let ((kslist (car (last xwem-xkeys-mapping))) - (kcode (X-Dpy-min-keycode (xwem-dpy))) - (kmods nil) - kel) - + (let* ((kcode (X-Dpy-min-keycode (xwem-dpy))) + (kslist (car (last xwem-xkeys-mapping))) + (ksyms-per-kcode (length (car kslist))) + (ksym-off 0) + (kmods nil)) (while kslist - (setq kel (car kslist)) - (if (member ksym kel) - (progn - (cond ((= ksym (nth 0 kel)) nil) - ((= ksym (nth 1 kel)) - (setq kmods (cons 'shift kmods))) - (t nil)) - (setq kslist nil)) - - (setq kslist (cdr kslist)) - (setq kcode (1+ kcode)) - )) + (cond ((= ksym (nth ksym-off (car kslist))) + (setq kslist nil)) + ((= ksym (nth (1+ ksym-off) (car kslist))) + (setq kslist nil + kmods (cons 'shift kmods))) + (t (setq kslist (cdr kslist) + kcode (1+ kcode)) + (when (and (null kslist) + (setq ksym-off (+ 2 ksym-off)) + (< ksym-off ksyms-per-kcode)) + (setq kslist (car (last xwem-xkeys-mapping)) + kcode (X-Dpy-min-keycode (xwem-dpy))))))) (cons kcode kmods))) (defun xwem-kbd-xkcode->xksym (kcode) ＠＠ -626,40 +603,21 ＠＠ ) ;;; Various subroutines -;;;###autoload (defun xwem-kbd-emod->kcode (emod &optional any) "Convert Emacs modifier EMOD to X keycode. Behaviour is undefined If ANY argument is supplied. DO NOT RELY ON THIS FUNCTION." - (let* ((mods (car (last xwem-xmods-mapping))) - (rmod (cond ((eq emod 'shift) (nth 0 mods)) - ;; locks skiped - ((eq emod 'control) (nth 2 mods)) - ((eq emod 'meta) (nth 3 mods)) - ;; numlock skiped - ((eq emod 'hyper) (nth 5 mods)) - ((eq emod 'super) (nth 6 mods)) - (t (error (format "Bad modifier `%S'" emod)))))) - (if any - rmod - (car rmod)))) + (funcall (if any 'identity 'car) (get emod 'x-key-codes))) -;;;###autoload (defun xwem-kbd-kcode->emod (kcode) "Convert key code KCODE to Emacs modifier, if KCODE is actually a modifier. See also `xwem-kbd-kcode-modifier-p'." - (let* ((mods (car (last xwem-xmods-mapping))) - (rmod (cond ((member kcode (nth 0 mods)) 'shift) - ;; locks skiped - ((member kcode (nth 2 mods)) 'control) - ((member kcode (nth 3 mods)) 'meta) - ;; numlock skiped - ((member kcode (nth 5 mods)) 'hyper) - ((member kcode (nth 6 mods)) 'super) - (t nil)))) - rmod)) + (let ((emods '(shift control alt meta super hyper))) + (while (and emods (not (member kcode (get (car emods) 'x-key-codes)))) + (setq emods (cdr emods))) + (car emods))) -;;;###autoload +;;;###xwem-autoload (defun xwem-kbd-kcode-modifier-p (kcode) "Return non-nil if key code KCODE is modifier." (let ((mods (car (last xwem-xmods-mapping)))) ＠＠ -686,8 +644,27 ＠＠ modifiers)) -;;;###autoload -(defun xwem-kbd-xevents->emacs-events (xevs &optional trust-modbits) +(defun xwem-kbd-hack-mouse (xev) + "Return (X . Y) to be used in mouse Emacs event." + (let ((cl (xwem-misc-find-cl-by-emacs-frame (last-nonminibuf-frame))) + xpnt x y) + + (if (member (X-Event-type xev) (list X-ButtonPress X-ButtonRelease)) + (setq x (X-Event-xbutton-root-x xev) + y (X-Event-xbutton-root-y xev)) + (setq x (X-Event-xmotion-root-x xev) + y (X-Event-xmotion-root-y xev))) + + (when cl + (setq xpnt (car (XTranslateCoordinates (xwem-dpy) (xwem-cl-xwin cl) (xwem-rootwin) 0 0)))) + + (when xpnt + (setq x (- x (X-Point-x xpnt))) + (setq y (- y (X-Point-y xpnt)))) + (cons x y))) + +;;;###xwem-autoload +(defun xwem-xevents->emacs-events (xevs &optional trust-modbits) "Convert X-Events XEVS to Emacs events. If TRUST-MODBITS is non-nil than we can trust modifier bits in ＠＠ -710,7 +687,7 ＠＠ (setq xevtype (X-Event-type xev)) (unless (member xevtype (list X-KeyPress X-KeyRelease X-ButtonPress X-ButtonRelease X-MotionNotify)) - (error "Invalid event type: %s" (X-Event-name xev))) + (error 'xwem-error "Invalid event type: %s" (X-Event-name xev))) (setq kcode nil mbutton nil) ＠＠ -738,25 +715,20 ＠＠ (X-Event-xbutton-state xev)) ((eq xevtype X-MotionNotify) (X-Event-xmotion-state xev)))))) - (make-event (cond ((eq xevtype X-KeyPress) 'key-press) - ((eq xevtype X-ButtonPress) 'button-press) - ((eq xevtype X-ButtonRelease) 'button-release) - ((eq xevtype X-MotionNotify) 'motion) - (t (error "Unknown event: %s" (X-Event-name xev)))) - (nconc (when (member xevtype (list X-ButtonPress X-ButtonRelease X-MotionNotify)) - (list 'x (cond ((member xevtype (list X-ButtonPress X-ButtonRelease)) - (X-Event-xbutton-root-x xev)) ; XXX what about 'channel? - (t (X-Event-xmotion-root-x xev))) - 'y (cond ((member xevtype (list X-ButtonPress X-ButtonRelease)) - (X-Event-xbutton-root-y xev)) ; XXX what about 'channel? - (t (X-Event-xmotion-root-y xev))))) - (list 'modifiers (xwem-kbd-adjust-modifiers kcode current-modifiers)) - (when (eq xevtype X-KeyPress) - (list 'key (xwem-kbd-xksym->emacs - (xwem-kbd-adjust-keycode kcode current-modifiers)))) - (when (member xevtype (list X-ButtonPress X-ButtonRelease)) - (list 'button mbutton))))) - )) + (make-event (cond ((eq xevtype X-KeyPress) 'key-press) + ((eq xevtype X-ButtonPress) 'button-press) + ((eq xevtype X-ButtonRelease) 'button-release) + ((eq xevtype X-MotionNotify) 'motion) + (t (error 'xwem-error "Unknown event: %s" (X-Event-name xev)))) + (nconc (when (member xevtype (list X-ButtonPress X-ButtonRelease X-MotionNotify)) + (let ((xm (xwem-kbd-hack-mouse xev))) + (list 'x (car xm) 'y (cdr xm)))) + (list 'modifiers (xwem-kbd-adjust-modifiers kcode current-modifiers)) + (when (eq xevtype X-KeyPress) + (list 'key (xwem-kbd-xksym->emacs + (xwem-kbd-adjust-keycode kcode current-modifiers)))) + (when (member xevtype (list X-ButtonPress X-ButtonRelease)) + (list 'button mbutton))))))) rxevs)) ;; Remove non-events from list ＠＠ -767,7 +739,6 ＠＠ "Convert Emacs EVENTS list to X events list." ) -;;;###autoload (defun xwem-kbd-ekeys->eevents (ekeys) "Convert Emacs keys sequence EKEYS to Emacs events vector." (mapvector (lambda (key) ＠＠ -787,25 +758,37 ＠＠ ;;{{{ [-] Sending +(defvar xwem-private-xtest-keycode-sequence nil) + ;; Sending(using XTEST) +(defun xwem-key-sendseq-1 (&optional keycode-seq) + "Emulate key presses/releases of KEYCODE-SEQ sequence using XTEST extension." + (unless keycode-seq + (setq keycode-seq xwem-private-xtest-keycode-sequence )) + (mapc (lambda (ksel) + (let ((ktype (car ksel)) + (kcode nil) + (ktime nil)) + (cond ((vectorp (cdr ksel)) + (setq kcode (aref (cdr ksel) 0)) + (setq ktime (aref (cdr ksel) 1))) + (t (setq kcode (cdr ksel)) + (setq ktime X-CurrentTime))) + (X-XTest-FakeInput (xwem-dpy) ktype kcode X-None 0 0 ktime))) + keycode-seq) + + (when (eq keycode-seq xwem-private-xtest-keycode-sequence) + (setq xwem-private-xtest-keycode-sequence nil))) + (defun xwem-key-sendseq (keycode-seq) "Emulate KEYCODE-SEQ. KEYCODE-SEQ is list of cons cells where car is event type and cdr is keycode. Supported event types are `X-Xtest-KeyPress' and `X-Xtest-KeyRelease'." - (mapc (lambda (ksel) - (let ((ktype (car ksel)) - (kcode nil) - (ktime nil)) - (cond ((vectorp (cdr ksel)) - (setq kcode (aref (cdr ksel) 0)) - (setq ktime (aref (cdr ksel) 1))) - (t - (setq kcode (cdr ksel)) - (setq ktime X-CurrentTime))) - (X-XTest-FakeInput (xwem-dpy) ktype kcode X-None 0 0 ktime))) - keycode-seq)) + (setq xwem-private-xtest-keycode-sequence + (append xwem-private-xtest-keycode-sequence keycode-seq)) + (xwem-add-hook-post-deffering 'xwem-key-sendseq-1 t)) -;;;###autoload +;;;###xwem-autoload (defun xwem-key-send-ekeys (keys) "Send Emacs key sequence KEYS using XTEST extension." (let (lseq) ＠＠ -837,38 +820,44 ＠＠ (setq lseq (nreverse lseq)) (xwem-key-sendseq lseq))) -;;;###autoload +;;;###xwem-autoload (defun xwem-kbd-wait-key-release (keycode) "Wait for key with KEYCODE for release." (unless xwem-executing-kbd-macro - ;; Increase events queue protecs so no events will be - ;; processed inside `XIfEvent'. - (incf (X-Dpy-evq-protects (xwem-dpy))) - - ;; Wait for a keyrelease - (unwind-protect - (XIfEvent (xwem-dpy) - (lambda (xev) + ;; Now wait key release event + (XNextEvent (xwem-dpy) nil + (lambda (xev) (and (= (X-Event-type xev) X-KeyRelease) (= (X-Event-xkey-keycode xev) keycode)))) + )) +; ;; Increase events queue protecs so no events will be +; ;; processed inside `XIfEvent'. +; (incf (X-Dpy-evq-protects (xwem-dpy))) + +; ;; Wait for a keyrelease +; (unwind-protect +; (XIfEvent (xwem-dpy) +; (lambda (xev) +; (and (= (X-Event-type xev) X-KeyRelease) +; (= (X-Event-xkey-keycode xev) keycode)))) - ;; Allow later events processing - (decf (X-Dpy-evq-protects (xwem-dpy)))))) +; ;; Allow later events processing +; (decf (X-Dpy-evq-protects (xwem-dpy))))) + -;;;###autoload +;;;###xwem-autoload (defun xwem-kbd-force-mods-release () "Force release of some modifiers." (let* ((xmods (car (last xwem-xmods-mapping))) - (mods (list (car (nth 0 xmods)) ; shift - (car (nth 2 xmods)) ; control - (car (nth 3 xmods)) ; meta - (car (nth 5 xmods)) ; hyper - (car (nth 6 xmods))))) ; super - (mapc (lambda (mod) - (X-XTest-FakeInput (xwem-dpy) X-Xtest-KeyRelease mod (xwem-rootwin) 0 0)) - (delete 0 mods)) - )) + (mods (list (nth 0 xmods) ; shift + (nth 2 xmods) ; control + (nth 3 xmods) ; meta + (nth 5 xmods) ; hyper + (nth 6 xmods)))) ; super + (xwem-key-sendseq-1 + (mapcar (lambda (el) (cons X-Xtest-KeyRelease el)) + (delete 0 (mapcar 'car mods)))))) (defun xwem-kbd-wait-button-release (button) "Wait for BUTTON for release." ＠＠ -878,49 +867,121 ＠＠ ;;{{{ [-] keypress/KeyRelease processing -(defun xwem-kbd-echolastkey () - "Echo key sequence already pressed in xwem minibuffer." - (when xwem-keyboard-echo-keystrokes - ;; XXX if there message from XWEM in minibuffer than add, otherwise - (if (xwem-interactive-p) - (append-message 'command (concat (single-key-description xwem-last-event) " ")) +;;;###xwem-autoload +(defun xwem-kbd-add-default-keymap (keymap) + "Add KEYMAP to default keymaps. +KEYMAP MUST NOT HAS PARENTS!" + (unless (memq keymap (keymap-parents xwem-default-parent-map)) + (set-keymap-parents xwem-default-parent-map + (cons keymap (keymap-parents xwem-default-parent-map))))) + +;;; Keys echoing +(defvar xwem-kbd-echoing-keys nil "Non-nil mean we are echoing command keys.") +(defvar xwem-kbd-scheduled-keys [] "Keys scheduled for echoing.") +(defvar xwem-kbd-scheduled-timer nil) + +(+ (and (lookup-key (xwem-kbd-fixup-keymap xwem-global-map) + keys accept-default) + xwem-global-map))))))) + +;;;###xwem-autoload +(defun xwem-global-key-binding (cl keys &optional accept-default) + "Return global binding for KEYS." + (lookup-key xwem-global-map keys accept-default)) -(defun xwem-kbd-process-after-lookup (lkm) - "Process keymap or command entry LKM after `lookup-key'." - (X-Dpy-log (xwem-dpy) "lkm = %S\n" 'lkm) - - (let ((slkm lkm) ;save lkm - (prfx-plist (when (and xwem-kbd-private-prefix-map - (symbolp xwem-kbd-private-prefix-map)) - (symbol-plist xwem-kbd-private-prefix-map))) - (splist (when (symbolp lkm) (symbol-plist lkm)))) - - (when (and (symbolp lkm) - (functionp lkm) - (keymapp (symbol-function lkm))) - (setq lkm (symbol-function lkm))) - - (X-Dpy-log (xwem-dpy) "PRFX-PLIST = %S, SPLIST = %S\n" 'prfx-plist 'splist) - - ;; Check for special mode, when we just reading single keystroke - (when xwem-kbd-reading-key - (xwem-read-keys-stop nil)) - - ;; Last chance to try default command - (when (null lkm) - (setq lkm (keymap-default-binding (xwem-kbd-current-map))) - (setq splist (and (symbolp lkm) (symbol-plist lkm)))) - - ;; Check is there need for prefix help or quit command - (when (and (null lkm) - xwem-kbd-now-grabbing) - (setq lkm - (let ((etk (events-to-keys (vector xwem-last-event)))) - (cond ((equal etk xwem-help-key) xwem-prefix-help-command) - ((equal etk xwem-quit-key) xwem-quit-command) - (t nil))))) - - ;; Now take a look at lkm - (cond ((null lkm) - ;; Check are we reading keysequence now - (when xwem-kbd-reading-keyseq - (xwem-read-keys-stop t)) - - (unless (eq (event-type xwem-last-event) 'button-release) - (xwem-play-sound 'undefined-key) - (xwem-message 'info "%s not binded." (key-description xwem-this-command-keys))) - - (xwem-kbd-stop-grabbing) - (xwem-kbd-set-current-prefix-keymap nil) - (setq xwem-this-command-keys []) - (setq xwem-kbd-reading-key nil) - (setq xwem-kbd-reading-keyseq nil) - - (let ((ex-fun (plist-get prfx-plist 'exit-fun))) - (when ex-fun (funcall ex-fun))) - ) - - ;; Prefix map - ((keymapp lkm) - - (xwem-kbd-set-current-prefix-keymap slkm) - (let ((enter-fun (plist-get splist 'enter-fun))) - (when enter-fun (funcall enter-fun))) - - (xwem-kbd-start-grabbing)) - - ;; Binded command or something else - (t - - ;; Check are we reading keysequence now - (when xwem-kbd-reading-keyseq - (xwem-read-keys-stop t)) - - ;; Reset privat keymap prefix - (xwem-kbd-set-current-prefix-keymap nil) - - ;; Now run command or keyboard macro - (unwind-protect - (condition-case err - (cond ((vectorp lkm) - ;; Keyboard macro. - ;; Wait for keyrelease, ungrab keyboard, than play it. - (when (= (X-Event-type xwem-last-xevent) X-KeyPress) - (xwem-kbd-wait-key-release (X-Event-xkey-keycode xwem-last-xevent))) - (xwem-kbd-stop-grabbing) - (xwem-keymacro-internal-play lkm (prefix-numeric-value xwem-prefix-arg))) - - ((commandp lkm) - ;; Execute command - (setq xwem-this-command lkm) - (run-hooks 'xwem-pre-command-hook) - - (call-interactively xwem-this-command) - - (setq xwem-last-command xwem-this-command)) - - (t (error "Unknown lkm %S" lkm))) - - (error - (xwem-play-sound 'command-fail) - (xwem-message 'err-nobeep "In cmd(%S): %s" lkm (error-message-string err))) - - (quit - (if (and (boundp 'xwem-bypass-quit) - (symbol-value 'xwem-bypass-quit)) - (signal 'quit (list 'xwem-bypass-quit (symbol-value 'xwem-bypass-quit))) - - (xwem-play-sound 'quit) - (xwem-message 'info "Quit: %s" err)))) - - ;; XXX Generic post command processing - (when (xwem-kbd-global-map-current-p) +;;;###xwem-autoload +(defun xwem-local-key-binding (cl keys &optional accept-default) + "Return local binding for KEYS." + (let ((lkmap (xwem-local-map cl))) + (and (keymapp lkmap) + (lookup-key lkmap keys accept-default)))) + +;;;###xwem-autoload +(defun xwem-minor-mode-key-binding (cl keys &optional accept-default) + "Return CL's minor mode binding for KEYS. +Retun cons cell in form `(MODENAME . BINDING)'." + (let ((mlist xwem-minor-mode-map-alist) + (bind nil)) + ;; Scan minor modes for binding + (while (and mlist (not bind)) + (when (xwem-client-local-variable-value cl (car (car mlist))) + (setq bind (lookup-key (xwem-kbd-fixup-keymap (cdr (car mlist))) + keys accept-default))) + (unless bind + (setq mlist (cdr mlist)))) + (when bind + (cons (car (car mlist)) bind)))) + +;;;###xwem-autoload +(defun xwem-lookup-key (client keys &optional accept-default) + "In CLIENT's context, lookup for KEYS binding. +`xwem-lookup-key' omits default binding unless ACCEPT-DEFAULT is +non-nil." + (unless client + (setq client (xwem-cl-selected))) + + (let (lkmap) + (if (setq lkmap (or (and (= (length keys) 1) + xwem-kbd-private-prefix-map) + xwem-override-map + xwem-override-local-map)) + (lookup-key (xwem-kbd-fixup-keymap lkmap) keys accept-default) + + ;; Try looking up in next order: + ;; - Minor modes map + ;; - Local map + ;; - Default parent map + ;; - Global map + (or (cdr (xwem-minor-mode-key-binding client keys accept-default)) + (xwem-local-key-binding client keys accept-default) + (xwem-global-key-binding client keys accept-default))))) + +;;;###xwem-autoload +(defun xwem-kbd-get-binding (keys &optional client) + "Get binding value for KEYS." + (xwem-lookup-key client keys t)) + +(defun xwem-kbd-fixate-current-lkm (lkm) + "In case LKM is not usable, fixate it. +Return fixated LKM." + (when (null lkm) + (let ((etk (events-to-keys (vector xwem-last-event)))) + (cond ((equal etk xwem-help-key) + (setq lkm xwem-prefix-help-command)) + ((equal etk xwem-quit-key) + (setq lkm xwem-quit-command)) + + ;; Last chance in re-lookup command keys + (t (setq lkm (or (xwem-lookup-key xwem-event-client xwem-this-command-keys) + (xwem-lookup-key xwem-event-client xwem-this-command-keys t))))))) + lkm) + +;;;###xwem-autoload +(defun xwem-kbd-dispatch-binding (lkm) + "Process keymap or command entry LKM after `lookup-key'. +Return non-nil if some action was performed." + ;; Check for special mode, when we just reading single keystroke + (when xwem-kbd-reading-key + (xwem-read-keys-stop nil)) + + ;; Fixate LKM, if it is bad + (setq lkm (xwem-kbd-fixate-current-lkm lkm)) + + (xwem-debug 'xwem-event "KBD Dispatcher: %S, lkm = %S" + 'xwem-this-command-keys 'lkm) + + (if (keymapp (xwem-kbd-fixup-keymap lkm)) + (progn + ;; Subkeymap + (xwem-kbd-set-current-prefix-keymap lkm) + (xwem-kbd-start-grabbing (eval (plist-get (xwem-kbd-keymap-plist lkm) 'cursor))) + + ;; Show keymap's prompt + (let ((prompt (or (eval (plist-get (xwem-kbd-keymap-plist lkm) 'prompt)) + (keymap-prompt lkm)))) + (if prompt + (xwem-message 'prompt prompt) + (xwem-kbd-schedule-command-keys-echoing)))) + + ;; Check are we reading keysequence now + (when xwem-kbd-reading-keyseq + (xwem-read-keys-stop t)) + + ;; Reset privat keymap prefix + (xwem-kbd-set-current-prefix-keymap nil) + + ;; Now run command or keyboard macro + (xwem-unwind-protect + (cond ((or (vectorp lkm) (stringp lkm)) + ;; Keyboard macro. + ;; Wait for keyrelease, ungrab keyboard, than play it. + (when (= (X-Event-type xwem-last-xevent) X-KeyPress) + (xwem-kbd-wait-key-release (X-Event-xkey-keycode xwem-last-xevent))) (xwem-kbd-stop-grabbing) - (setq xwem-this-command-keys [])) - ) + (xwem-keymacro-internal-play lkm (prefix-numeric-value xwem-prefix-arg))) - ;; Run post command hook - (run-hooks 'xwem-post-command-hook) - ) + ((commandp lkm) + ;; Fix LKM in case it is frame command + (when (and (symbolp lkm) + (get lkm 'xwem-frame-command) + (not (or (xwem-frame-p (xwem-cl-frame xwem-event-client)) + (eq (xwem-dummy-client) xwem-event-client)))) + (setq lkm 'ignore)) + + ;; Schedule it in hope that it will install prefix map + (xwem-kbd-schedule-command-keys-echoing) + + ;; Execute command + (setq xwem-this-command lkm) + (run-hooks 'xwem-pre-command-hook) + (call-interactively xwem-this-command) + (setq xwem-last-command xwem-this-command) + (run-hooks 'xwem-post-command-hook)) + + ((null lkm) + ;; Just echo key + (xwem-kbd-schedule-command-keys-echoing)) + + (t (error 'xwem-error (format "Unknown command: '%S'" lkm)))) + + ;; XXX Generic post command processing + (when (xwem-kbd-global-map-current-p) + (setq xwem-this-command-keys [])) + ;; Do it deffering, becase there maybe pending command events + ;; which need to be processed. + (xwem-deffered-funcall + (lambda () + (when (xwem-kbd-global-map-current-p) + (xwem-kbd-stop-command-keys-echoing) + (xwem-kbd-stop-grabbing))))) - (t (error - (format "Hm .. strange lkm=%S" lkm)))))) + (and lkm 'done))) ;;}}} ;;{{{ [-] Grabbing -(defun xwem-kbd-graugra-key (key win mode &optional button-mask) +;;;###xwem-autoload +(defun xwem-kbd-graugra-key (key win mode &optional button-mask pgrab-mode kgrab-mode) "Grab or Ungrab KEY on WIN. MODE is either 'grab or 'ungrab. BUTTON-MASK is mask passed to `XGrabButton' if MODE is 'grab and key is actually a mouse key." + (xwem-keyboard-init) ; make sure keyboard initialised + (let* ((key (aref (key-sequence-list-description key) 0)) (kmods (butlast key)) (ksyko (xwem-kbd-emacs->xksym (car (last key)))) ＠＠ -1141,109 +1214,195 ＠＠ (if mouse (if (eq mode 'grab) (XGrabButton (xwem-dpy) mouse (Xmask-or kmods m1 m2) win - (or button-mask (Xmask-or XM-ButtonPress XM-ButtonRelease)) nil t) + (or button-mask (Xmask-or XM-ButtonPress XM-ButtonRelease)) + nil t pgrab-mode kgrab-mode) (XUngrabButton (xwem-dpy) mouse (Xmask-or kmods m1 m2) win)) (if (eq mode 'grab) - (XGrabKey (xwem-dpy) ksyko (Xmask-or kmods m1 m2) win t) + (XGrabKey (xwem-dpy) ksyko (Xmask-or kmods m1 m2) win + t pgrab-mode kgrab-mode) (XUngrabKey (xwem-dpy) ksyko (Xmask-or kmods m1 m2) win)))) xwem-kbd-evilmasks)) xwem-kbd-evilmasks) )) -(defun xwem-kbd-grab-key (key win) +(defun xwem-kbd-grab-key (key win &optional pgrab kgrab) "Grab KEY on WIN." - (xwem-kbd-graugra-key key win 'grab)) + (xwem-kbd-graugra-key key win 'grab nil pgrab kgrab)) (defun xwem-kbd-ungrab-key (key win) "Stop grabbing KEY on WIN." (xwem-kbd-graugra-key key win 'ungrab)) -;;;###autoload -(defun xwem-kbd-install-grab (keymap win) +;;;###xwem-autoload +(defun xwem-kbd-install-grab (keymap win &optional pgrab kgrab) "Install KEYMAP grabs on X window WIN." - (map-keymap (lambda (key unused) - (xwem-kbd-grab-key key win)) - keymap)) + (map-keymap (lambda (key bind) + (unless (and (symbolp bind) (get bind 'xwem-no-grab)) + (xwem-kbd-grab-key key win pgrab kgrab))) + (xwem-kbd-fixup-keymap keymap)) + + ;; Also grab KEYMAP's parents + (mapc (lambda (pkeymap) + (xwem-kbd-install-grab pkeymap win pgrab kgrab)) + (keymap-parents (xwem-kbd-fixup-keymap keymap)))) + +;;;###xwem-autoload +(defun xwem-kbd-uninstall-grab (keymap win &optional predict) + "Uninstall KEYMAP grabs on X window WIN. + +Optionally you can specify PREDICT to decide for which keys grabbing +should be uinstalled. PREDICT must accept two arguments - KEY and +BINDING, and return non-nil if this KEY must be ungrabbed. + +By default all keys are ungrabbed." + (map-keymap (lambda (key bind) + (when (or (not predict) + (funcall predict key bind)) + (xwem-kbd-ungrab-key key win))) + (xwem-kbd-fixup-keymap keymap)) + + ;; Also ungrab KEYMAP's parents + (mapc (lambda (pkeymap) + (xwem-kbd-uninstall-grab pkeymap win predict)) + (keymap-parents (xwem-kbd-fixup-keymap keymap)))) -;;;###autoload -(defun xwem-kbd-uninstall-grab (keymap win) - "Uninstall KEYMAP grabs on X window WIN." - (map-keymap (lambda (key unused) - (xwem-kbd-ungrab-key key win)) - keymap)) - -;;;###autoload +(defun xwem-kbd-apply-grabbing () + "Start/stop grabbing according to `xwem-kbd-now-grabbing'." + (if xwem-kbd-now-grabbing + (unless xwem-executing-kbd-macro + (XGrabKeyboard (xwem-dpy) (or (xwem-focus-xcurrent) (xwem-rootwin)) nil) + (xwem-mouse-grab xwem-kbd-now-grabbing) + (XAllowEvents (xwem-dpy) X-SyncBoth)) + (unless xwem-executing-kbd-macro + (XUngrabKeyboard (xwem-dpy)) + (xwem-mouse-ungrab)))) + +;;;###xwem-autoload (defun xwem-kbd-start-grabbing (&optional cursor) "Begin grabbing keyboard (some key-prefix is entered). Optionally you can specify CURSOR to be used, while grabbing." (unless xwem-kbd-now-grabbing - (unless xwem-executing-kbd-macro - (XGrabKeyboard (xwem-dpy) (or (xwem-focus-xcurrent) (xwem-rootwin)) nil) - (xwem-mouse-grab (or cursor xwem-cursor-wait))) - - (setq xwem-kbd-now-grabbing t))) - -;;;###autoload -(defun xwem-kbd-start-grabbing-sync (&optional cursor) - "Same as `xwem-kbd-start-grabbing', but initiate grabs in Sync mode. -CURSOR argument is same is for `xwem-kbd-start-grabbing'." - (unless xwem-kbd-now-grabbing - (unless xwem-executing-kbd-macro - (XGrabKeyboard (xwem-dpy) (or (xwem-focus-xcurrent) (xwem-rootwin)) - nil X-GrabModeSync X-GrabModeSync) - (xwem-mouse-grab (or cursor xwem-cursor-wait)) - ) + (setq xwem-kbd-now-grabbing (or cursor xwem-cursor-wait)) + (xwem-kbd-apply-grabbing))) - (setq xwem-kbd-now-grabbing t))) - -;;;###autoload +;;;###xwem-autoload (defun xwem-kbd-stop-grabbing () "Stop grabbing keyboard." (when xwem-kbd-now-grabbing - (unless xwem-executing-kbd-macro - (XUngrabKeyboard (xwem-dpy)) - (xwem-mouse-ungrab)) + (setq xwem-kbd-now-grabbing nil) + (xwem-kbd-apply-grabbing))) - (setq xwem-kbd-now-grabbing nil))) +;;;###autoload(autoload 'xwem-kbd-quote-command "xwem-keyboard" "" t) +(define-xwem-command xwem-kbd-quote-command () + "Pass event EV to currently active window. +DOES NOT WORK." + (xwem-interactive "_") + + (let ((xwin (xwem-focus-xcurrent)) + xev) + (when (X-Win-p xwin) + (XGrabKeyboard (xwem-dpy) xwin nil X-GrabModeSync X-GrabModeSync) + (XGrabPointer (xwem-dpy) xwin (Xmask-or XM-ButtonPress XM-ButtonRelease) + xwem-cursor-quote nil X-GrabModeSync X-GrabModeSync) + (XAllowEvents (xwem-dpy) X-SyncBoth) + + (xwem-message 'prompt "[Quote key]") + (xwem-unwind-protect + (while (and (setq xev (xwem-next-event nil + (list X-KeyPress X-KeyRelease X-ButtonPress X-ButtonRelease))) + (not (xwem-xevents->emacs-events (list xev) t) )) + (XAllowEvents (xwem-dpy) X-SyncBoth)) + (XAllowEvents (xwem-dpy) X-ReplayKeyboard) + (XAllowEvents (xwem-dpy) X-ReplayPointer) + (XUngrabKeyboard (xwem-dpy)) + (XUngrabPointer (xwem-dpy)) + (xwem-clear-message))))) + +;;}}} -;;; FIXME: this does bad, naughty things. -;; ;;;###autoload(autoload 'xwem-kbd-quote-command "xwem-keyboard" "" t) -;; (define-xwem-command xwem-kbd-quote-command () -;; "Pass event EV to currently active window. -;; DOES NOT WORK." -;; (xwem-interactive "_") - -;; (let ((xwin (xwem-focus-xcurrent))) -;; (when (X-Win-p xwin) -;; (XGrabKeyboard (xwem-dpy) xwin nil X-GrabModeAsync X-GrabModeSync) -;; (XGrabPointer (xwem-dpy) xwin (Xmask-or XM-ButtonPress XM-ButtonRelease) -;; xwem-cursor-quote nil X-GrabModeSync) -;; (XAllowEvents (xwem-dpy) X-SyncBoth) - -;; (xwem-message 'info "[Quote key]") -;; (unwind-protect -;; (let ((done nil) -;; xev) -;; (while (not done) -;; (setq xev (xwem-next-event 1)) -;; (cond ((X-Event-p xev) -;; (if (and (member (X-Event-type xev) -;; (list X-KeyPress X-ButtonPress X-ButtonRelease)) -;; (xwem-kbd-xevents->emacs-events (list xev) t)) -;; (progn -;; (xwem-message 'info "here") -;; (XAllowEvents (xwem-dpy) X-ReplayKeyboard) -;; (XAllowEvents (xwem-dpy) X-ReplayPointer) -;; (xwem-clear-message) -;; (setq done t)) - -;; (XAllowEvents (X-Event-dpy xev) X-SyncBoth))) -;; (t (setq done t))))) - -;; (XUngrabKeyboard (xwem-dpy)) -;; (XUngrabPointer (xwem-dpy)) -;; )))) +;;{{{ [-] Initializators + +;;;###xwem-autoload +(defun xwem-kbd-initialize-modifiers () + "Create internal modifier representation to speedup futher work. +Also update `xwem-kbd-evilmasks' if `xwem-kbd-evillocks' is non-nil." + (setq xwem-xmods-mapping + (XGetModifierMapping (xwem-dpy))) + + (let* ((ctrls (list (car (xwem-kbd-xksym->xkcode XK-Control-L)) + (car (xwem-kbd-xksym->xkcode XK-Control-R)))) + (alts (list (car (xwem-kbd-xksym->xkcode XK-Alt-L)) + (car (xwem-kbd-xksym->xkcode XK-Alt-R)))) + (locks (list (car (xwem-kbd-xksym->xkcode XK-Caps-Lock)))) + (shifts (list (car (xwem-kbd-xksym->xkcode XK-Shift-L)) + (car (xwem-kbd-xksym->xkcode XK-Shift-R)))) + (metas (list (car (xwem-kbd-xksym->xkcode XK-Meta-L)) + (car (xwem-kbd-xksym->xkcode XK-Meta-R)))) + (hypers (list (car (xwem-kbd-xksym->xkcode XK-Hyper-L)) + (car (xwem-kbd-xksym->xkcode XK-Hyper-R)))) + (supers (list (car (xwem-kbd-xksym->xkcode XK-Super-L)) + (car (xwem-kbd-xksym->xkcode XK-Super-R)))) + (numlocks (list (car (xwem-kbd-xksym->xkcode XK-NumLock)))) + (evils (mapcar (lambda (ks) + (car (xwem-kbd-xksym->xkcode ks))) xwem-kbd-evillocks)) + (mlist (mapcar 'truncate (list X-Shift X-Lock X-Control X-Mod1 X-Mod2 + X-Mod3 X-Mod4 X-Mod5))) + (slist (car (last xwem-xmods-mapping)))) + + ;; Clear modifiers info + (mapc (lambda (mod-sym) + (put mod-sym 'x-key-codes nil) + (put mod-sym 'x-mod-mask nil)) + '(shift lock control alt meta hyper super numlock)) + + (while slist + ;; Update some private modifier mask + (mapc (lambda (mods mod-sym) + (when (intersection (car slist) mods) + (put mod-sym 'x-key-codes mods) + (put mod-sym 'x-mod-mask (Xmask-or (car mlist) + (or (get mod-sym 'x-mod-mask) 0))))) + (list shifts locks ctrls alts metas hypers supers numlocks) + '(shift lock control alt meta hyper super numlock)) + + ;; Update Evil locks + (when (intersection (car slist) evils) + (push (car mlist) xwem-kbd-evilmasks)) + + (setq slist (cdr slist)) + (setq mlist (cdr mlist))) + + ;; Hack over Alt-Meta problem + (when (eql (get 'alt 'x-mod-mask) (get 'meta 'x-mod-mask)) + (put 'alt 'x-mod-mask 0)))) + +(defun xwem-keyboard-init () + "Initialize xwem keyboard. +Fetches KeyboardMapping from the X server and stores it in +`xwem-xkeys-mapping'" + (unless (get 'xwem-keyboard 'initialized) + (xwem-message 'init "Initializing keyboard ...") + + (xwem-kbd-set-current-prefix-keymap nil) + + ;; Hmm FSFmacs issued "invalid instraction" in `XGetKeyboardMapping' + (setq xwem-xkeys-mapping + (XGetKeyboardMapping (xwem-dpy) + (X-Dpy-min-keycode (xwem-dpy)) + (- (X-Dpy-max-keycode (xwem-dpy)) + (X-Dpy-min-keycode (xwem-dpy))))) + + ;; Initialize modifiers + (xwem-kbd-initialize-modifiers) + + ;; Some messaging configuration + (add-to-list 'xwem-messages-ignore-labels 'keys) + (add-to-list 'xwem-messages-ignore-labels 'keys-continuator) + + (run-hooks 'xwem-keyboard-init-hook) + (put 'xwem-keyboard 'initialized t) + (xwem-message 'init "Initializing keyboard ... done"))) ;;}}} ＠＠ -1277,8 +1436,14 ＠＠ map) "Keymap used while processing \\<xwem-global-map>\\[xwem-universal-argument].") +(defvar xwem-universal-argument-num-events nil + "Number of argument-specifying events read by +`xwem-universal-argument'.") + (defun xwem-universal-common-begin () "Common begin for universal argument." + (setq xwem-universal-argument-num-events + (length xwem-this-command-keys)) (if xwem-kbd-now-grabbing (setq xwem-override-map xwem-universal-map) ＠＠ -1316,7 +1481,8 ＠＠ (setq xwem-prefix-arg (list (* 4 (car arg)))) (setq xwem-prefix-arg arg) - (setq xwem-override-map nil))) + (setq xwem-override-map nil)) + (setq xwem-universal-argument-num-events (length xwem-this-command-keys))) ;;;###autoload(autoload 'xwem-universal-minus "xwem-keyboard" "" t) (define-xwem-command xwem-universal-minus (arg) ＠＠ -1349,38 +1515,27 ＠＠ (xwem-universal-common-begin))) -(defun xwem-reset-this-command-lengths () - "For some documentation look at `reset-this-command-lengths'." - ;; This brokes some things, like H-1 H-2 H-3 will not be properly - ;; displayed in minibuffer, so i disabled it. - - ;; Also there is notice in event-stream.c to - ;; `reset-this-command-lengths': - ;; - ;; /* #### I don't understand this at all, so currently it does nothing. - ;; If there is ever a problem, maybe someone should investigate. */ - - ; (setq xwem-this-command-keys (vector xwem-last-event)) - ) - ;;;###autoload(autoload 'xwem-universal-command "xwem-keyboard" "" t) (define-xwem-command xwem-universal-command (arg) "Handle universal argument functionality." (xwem-interactive "P") (setq xwem-prefix-arg arg) - (xwem-reset-this-command-lengths) - (xwem-kbd-set-current-prefix-keymap nil) - (setq xwem-override-map nil) + (let ((keylist (append xwem-this-command-keys nil))) + (mapc 'xwem-unread-command-event + (nthcdr xwem-universal-argument-num-events keylist))) - (xwem-kbd-process-after-lookup - (xwem-kbd-key-binding-evs (vector xwem-last-event))) - ) + (setq xwem-override-map nil)) ;;}}}  (provide 'xwem-keyboard) + +;;;; On-load actions: +(if xwem-started + (xwem-keyboard-init) + (add-hook 'xwem-before-init-wins-hook 'xwem-keyboard-init)) ;;; xwem-keyboard.el ends here Index: lisp/xwem-keydefs.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-keydefs.el,v retrieving revision 1.10 diff -u -u -r1.10 xwem-keydefs.el --- lisp/xwem-keydefs.el 16 Dec 2004 08:08:08 -0000 1.10 +++ lisp/xwem-keydefs.el 1 Jan 2005 04:41:13 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created + +(define-key xwem-global-map (xwem-kbd "H-x b") 'xwem-switch-client) +(define-key xwem-global-map (xwem-kbd "H-x a") 'xwem-attach-client) +(define-key xwem-global-map (xwem-kbd "H-x H-b") 'xwem-ixwem) + (define-key xwem-global-map (xwem-kbd "H-x r") 'xwem-launch-program) (define-key xwem-global-map (xwem-kbd "H-:") 'xwem-eval-expression) (define-key xwem-global-map (xwem-kbd "H-!") 'xwem-shell-command) (define-key xwem-global-map (xwem-kbd "H-M-x") 'xwem-execute-extended-command) (define-key xwem-global-map (xwem-kbd "H-#") 'xwem-mini-calc) - -(define-key xwem-global-map (xwem-kbd "H-<") 'xwem-beginning-of-cl) -(define-key xwem-global-map (xwem-kbd "H->") 'xwem-end-of-cl) +(define-key xwem-global-map (xwem-kbd "H-TAB") 'xwem-minibuffer-activate) (define-key xwem-global-map (xwem-kbd "H-f12") 'xwem-misc-make-screenshot) (define-key xwem-global-map (xwem-kbd "H-z") 'xwem-misc-pause) (define-key xwem-global-map (xwem-kbd "H-pause") 'xwem-misc-pause) +;; Register commands +(define-key xwem-global-map (xwem-kbd "H-x 6") 'xwem-register-win-config) +(define-key xwem-global-map (xwem-kbd "H-x 8") 'xwem-register-frame-config) +(define-key xwem-global-map (xwem-kbd "H-x /") 'xwem-register-client) +(define-key xwem-global-map (xwem-kbd "H-x j") 'xwem-register-jump) + +;; Client switcher +(define-key xwem-global-map (xwem-kbd "H-f") 'xwem-forward-application) +(define-key xwem-global-map (xwem-kbd "H-b") 'xwem-backward-application) + +(define-key xwem-global-map (xwem-kbd "H-]") 'xwem-clswi-next) +(define-key xwem-global-map (xwem-kbd "H-[") 'xwem-clswi-prev) +(define-key xwem-global-map (xwem-kbd "H-}") 'xwem-clswi-next-other-window) +(define-key xwem-global-map (xwem-kbd "H-{") 'xwem-clswi-prev-other-window) + +;; Cutbuffers +(define-key xwem-global-map (xwem-kbd "H-w") 'xwem-copy-cutbuffer) +(define-key xwem-global-map (xwem-kbd "H-y") 'xwem-paste-cutbuffer) + +;;; Misc bindings +;; Making holer in frames +(define-key xwem-global-map (xwem-kbd "H-x h") 'xwem-holer-prefix) +;; Log your work +(define-key xwem-global-map (xwem-kbd "H-W") 'xwem-worklog-prefix) +;; Interactively edit client's property +(define-key xwem-global-map (xwem-kbd "H-c H-e") 'xwem-edit-client-properties) + ;; Compat layer, must move to xwem-compat.el (if xwem-gnuemacs-p (progn (define-key xwem-global-map [s-mouse-1] 'xwem-strokes-begin) (define-key xwem-global-map [h-mouse-1] 'xwem-strokes-cmplx-begin)) (progn - (define-key xwem-global-map (xwem-kbd "Sh-C-button1") 'xwem-frame-imove) - (define-key xwem-global-map (xwem-kbd "Sh-C-button3") 'xwem-frame-iresize) - - (define-key xwem-global-map (xwem-kbd "M-button1") 'xwem-strokes-begin) - (define-key xwem-global-map (xwem-kbd "H-button1") 'xwem-strokes-cmplx-begin))) + ;;; Root keymap + ;; No-need to grab button1/button3 + (define-key xwem-root-map (xwem-kbd "<button1>") 'xwem-popup-auto-menu) + (define-key xwem-root-map (xwem-kbd "<button3>") 'xwem-popup-clients-menu) + + ;;; Frame keymap + ;; No-need to grab button1/button3 + (define-key xwem-frame-map (xwem-kbd "<button1>") 'xwem-frame-on-delim-resize) + (put 'xwem-frame-on-delim-resize 'xwem-no-grab t) + (define-key xwem-frame-map (xwem-kbd "<button3>") 'xwem-frame-on-delim-menu) + (put 'xwem-frame-on-delim-menu 'xwem-no-grab t) + ;; Frame imove/iresize + (define-key xwem-frame-map (xwem-kbd "Sh-C-button1") 'xwem-frame-imove) + (define-key xwem-frame-map (xwem-kbd "Sh-C-button3") 'xwem-frame-iresize) + + ;; Strokes bindings + (define-key xwem-default-parent-map (xwem-kbd "M-<button1>") 'xwem-strokes-begin) + (define-key xwem-default-parent-map (xwem-kbd "H-<button1>") 'xwem-strokes-cmplx-begin) + ))  (provide 'xwem-keydefs) Index: lisp/xwem-keymacro.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-keymacro.el,v retrieving revision 1.9 diff -u -u -r1.9 xwem-keymacro.el --- lisp/xwem-keymacro.el 16 Dec 2004 08:08:08 -0000 1.9 +++ lisp/xwem-keymacro.el 1 Jan 2005 04:41:13 -0000 ＠＠ -1,11 +1,13 ＠＠ + ;;; xwem-keymacro.el --- Recording/playing keyboard macros. ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: Fri Dec 12 17:18:00 MSK 2003 ;; Keywords: xwem, xlib -;; X-CVS: $Id: xwem-keymacro.el,v 1.9 2004/12/16 08:08:08 youngs Exp $ +;; X-CVS: $Id: xwem-keymacro.el,v 1.8 2004/12/05 22:37:34 lg Exp $ ;; This file is part of XWEM. ＠＠ -68,17 +70,19 ＠＠ ;;; Code:  -(require 'xwem-compat) -(eval-and-compile - (require 'xlib-xtest) - (require 'xlib-xrecord)) + +(require 'xlib-xtest) +(require 'xlib-xrecord) + +(require 'xwem-load) +(require 'xwem-misc)  ;; Macros customization (defcustom xwem-keymacro-minib-bg "gray60" "*Background color for xwem's minibuffer while recording KBD macro. If nil - background will not change." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color :group 'xwem-keyboard) (defcustom xwem-keymacro-debug nil ＠＠ -96,20 +100,15 ＠＠ :type 'file :group 'xwem-keyboard) +;;; Internal variables +  ;;; Macros recording/playing internal variables -;;;###autoload +;;;###xwem-autoload (defvar xwem-executing-kbd-macro nil - "Non-nil when executing keyboard macro. -Actually Emacs keysequence(vector of keys) to be executed. -Internal variable, do not modify.") - -;;;###autoload -(defvar xwem-executing-kbd-macro-index nil - "Indexes current key in `xwem-excuting-kbd-macro' vector. -Internal variable, do not modify.") + "Non-nil when executing keyboard macro.") -;;;###autoload +;;;###xwem-autoload (defvar xwem-keymacro-last-kbd-macro nil "Last KBD macro.") (defvar xwem-keymacro-default-command 'xwem-keymacro-default ＠＠ -144,19 +143,20 ＠＠ "Non-nil when keyboard macrosing initialized. Internal variable, do not modify it directly.") -;;;###autoload (defun xwem-keymacro-init () "Initialize keyboard macrosing stuff." - ;; User xlib-xrecord extension to intercept KeyPress/KeyRelease + (pushnew '(macro "Macro") xwem-messages-label-prefixes) + + ;; Use xlib-xrecord extension to intercept KeyPress/KeyRelease ;; events. (let ((xrec-ext (X-XRecordQueryVersion (xwem-dpy))) (xtest-ext (XQueryExtension (xwem-dpy) "XTEST"))) (if (or (null (car xrec-ext)) (null (car xtest-ext))) - ;; Not XRECORD or XTEST extension support - (xwem-message 'warn "No XRECORD or XTEST extension on dpy, you can't use keyboard macros saving.") + ;; No XRECORD or XTEST extension support + (xwem-message 'warning "No XRECORD or XTEST extension on dpy, you can't use keyboard macros saving.") - ;; Dpy supports XRECORD extension + ;; (xwem-dpy) supports XRECORD extension (setq xwem-keymacro-rcontext (make-X-RecordContext :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy)))) (setq xwem-keymacro-rranges ;; We are only interested in KeyPrees/KeyRelease events ＠＠ -177,57 +177,45 ＠＠ (when xwem-keymacro-debug (setf (X-Dpy-log-buffer xwem-keymacro-dpy) "XREC.log")) - (setq xwem-keymacro-initialized t) - ))) + (setq xwem-keymacro-initialized t)))) (defun xwem-keymacro-extract (xevs &optional cutlen) "Extract keyboard macro from X-Events list XEVS. Return list of Emacs events. CUTLEN is how many events cut from the end (default is 1)." - (let ((evs (butlast (xwem-kbd-xevents->emacs-events xevs nil) + (let ((evs (butlast (xwem-xevents->emacs-events xevs nil) (or cutlen 1)))) (key-sequence-list-description (vconcat evs)))) -;;;###autoload +(defun xwem-keymacro-start-executing-keys (&rest args) + "Start executing keyboard macro." + (setq xwem-executing-kbd-macro t)) + +(defun xwem-keymacro-stop-executing-keys (&rest args) + "Stop executing keyboard macro." + (setq xwem-executing-kbd-macro nil)) + +;;;###xwem-autoload (defun xwem-keymacro-execute-keys (keys) "Execute keyboard macro KEYS." - (let ((xwem-executing-kbd-macro keys) - (xwem-executing-kbd-macro-index 0) - eev cmd) - - (while (< xwem-executing-kbd-macro-index - (length xwem-executing-kbd-macro)) - ;; Construct Emacs event - (setq eev (aref xwem-executing-kbd-macro xwem-executing-kbd-macro-index)) - (setq eev (make-event 'key-press (list 'modifiers (butlast eev) 'key (car (last eev))))) - - (setq cmd (xwem-kbd-key-binding-evs (vector eev))) - - ;; If current map is `xwem-global-map' and command not found, it - ;; is most possible that this is normal input, i.e. not an XWEM - ;; command. - (if (or cmd (not (xwem-kbd-global-map-current-p))) - (xwem-kbd-handle-keybutton-from-emacs eev) - - ;; Otherwise send fake event. Should we have default command - ;; in `xwem-global-map' to self-insert last command keys? - (xwem-key-send-ekeys eev)) + (enqueue-eval-event 'xwem-keymacro-start-executing-keys t) + (mapc 'xwem-unread-command-event keys) + (enqueue-eval-event 'xwem-keymacro-stop-executing-keys t) + ) - (incf xwem-executing-kbd-macro-index)))) - -;;;###autoload(autoload 'xwem-keymacro-begin "xwem-keymacro") +;;;###autoload(autoload 'xwem-keymacro-begin "xwem-keymacro" nil t) (define-xwem-command xwem-keymacro-begin (arg) "Start to record keyboard macro. If used with prefix ARG, then query for bind after macro define." (xwem-interactive "P") (when (not xwem-keymacro-initialized) - (error "Keyboard macros not initialized, use `xwem-keymacro-init'")) + (error 'xwem-error "Keyboard macros not initialized, use `xwem-keymacro-init'")) (if xwem-keymacro-saving - (xwem-message 'warn "Already defining macro...") + (xwem-message 'warning "Already defining macro...") - (xwem-message 'msg "Defining KBD macro ...") + (xwem-message 'macro "Defining KBD macro ...") ;; Clear events queue and enable context (setf (X-Dpy-evq xwem-keymacro-dpy) nil) ＠＠ -236,7 +224,7 ＠＠ ;; Change xwem's minibuffer background (when xwem-keymacro-minib-bg (setq xwem-keymacro-minib-old-bg - (face-background 'default (xwem-minib-frame xwem-minibuffer))) + (face-background-name 'default (xwem-minib-frame xwem-minibuffer))) (set-face-property 'default 'background xwem-keymacro-minib-bg (xwem-minib-frame xwem-minibuffer))) ＠＠ -244,21 +232,19 ＠＠ (setq xwem-keymacro-saving t) )) -;;;###autoload(autoload 'xwem-keymacro-end "xwem-keymacro") -(define-xwem-command xwem-keymacro-end (arg &optional key) +;;;###autoload(autoload 'xwem-keymacro-end "xwem-keymacro" nil t) +(define-xwem-command xwem-keymacro-end (arg) "Stop recording keyboard macro. -If recording done with prefix argument, then query for bind." - (xwem-interactive - (progn - (when (= (X-Event-type xwem-last-xevent) X-KeyPress) - (xwem-kbd-wait-key-release (X-Event-xkey-keycode xwem-last-xevent))) - - (list xwem-keymacro-prefix-arg - (when xwem-keymacro-prefix-arg - (xwem-read-key "Enter character to bind: "))))) +If recording done with prefix argument, then query for key to bind." + (xwem-interactive (list xwem-keymacro-prefix-arg)) (if (not xwem-keymacro-saving) - (xwem-message 'warn "Not recording KBD macro.") + (xwem-message 'warning "Not recording KBD macro.") + + ;; Wait last keyrelease, so `xwem-keymacro-extract' will cut keys + ;; properly. + (when (= (X-Event-type xwem-last-xevent) X-KeyPress) + (xwem-kbd-wait-key-release (X-Event-xkey-keycode xwem-last-xevent))) (X-XRecordDisableContext (xwem-dpy) xwem-keymacro-rcontext) (setq xwem-keymacro-saving nil) ＠＠ -274,12 +260,12 ＠＠ ;; Save last keyboard macro (setq xwem-keymacro-last-kbd-macro kmacro) - (define-key xwem-user-macros-map (events-to-keys (vector key)) kmacro))) + (let ((key (xwem-read-key "Enter character to bind: "))) + (define-key 'xwem-user-macros-prefix (events-to-keys (vector key)) kmacro)))) - (xwem-message 'msg "KBD macro defined.") - )) + (xwem-message 'macro "KBD macro defined."))) -;;;###autoload +;;;###xwem-autoload (defun xwem-keymacro-internal-play (keys &optional times) "Play Emacs KEYS TIMES times." (unless times ＠＠ -291,8 +277,7 ＠＠ (setq xwem-prefix-arg nil) (when xwem-keymacro-show-macro - (xwem-message 'info "Executing macro: '%s'" - (key-description keys))) + (xwem-message 'macro "Executing macro: '%s'" (key-description keys))) ;; Force release of modifiers (xwem-kbd-force-mods-release) ＠＠ -302,12 +287,12 ＠＠ (make-list times keys))) ;; Commands to be used in `xwem-keymacro-user-macros' -;;;###autoload(autoload 'xwem-keymacro-undefined "xwem-keymacro") +;;;###autoload(autoload 'xwem-keymacro-undefined "xwem-keymacro" nil t) (define-xwem-command xwem-keymacro-undefined () "Undefined macro command." (xwem-interactive) - (xwem-message 'warn "Macro key `%s' is not defined" (key-description xwem-this-command-keys))) + (xwem-message 'warning "Macro key `%s' is not defined" (key-description xwem-this-command-keys))) ;;;###autoload(autoload 'xwem-keymacro-play-last "xwem-keymacro") (define-xwem-command xwem-keymacro-play-last (arg) ＠＠ -315,15 +300,15 ＠＠ (xwem-interactive "*_p") (if xwem-keymacro-saving - (xwem-message 'warn "Can't play macro while recording.") + (xwem-message 'warning "Can't play macro while recording.") (if (not xwem-keymacro-last-kbd-macro) - (xwem-message 'warn "No KBD macros have been saved.") + (xwem-message 'macro "No KBD macros have been saved.") (xwem-keymacro-internal-play xwem-keymacro-last-kbd-macro arg)) )) -;;;###autoload(autoload 'xwem-keymacro-recursive-edit "xwem-keymacro") +;;;###autoload(autoload 'xwem-keymacro-recursive-edit "xwem-keymacro" nil t) (define-xwem-command xwem-keymacro-recursive-edit (arg) "Enter recursive edit. Using \\<xwem-global-map>\\[xwem-keymacro-recursive-edit] you can ＠＠ -335,7 +320,7 ＠＠ (or xwem-executing-kbd-macro xwem-keymacro-saving - (error "Not defining or executing keyboard macro")) + (error 'xwem-error "Not defining or executing keyboard macro")) (let ((xwem-this-command-keys []) (xwem-prefix-arg nil)) ＠＠ -349,7 +334,7 ＠＠ (X-XRecordEnableContext xwem-keymacro-dpy xwem-keymacro-rcontext)) )) -;;;###autoload(autoload 'xwem-keymacro-exit-recursive-edit "xwem-keymacro") +;;;###autoload(autoload 'xwem-keymacro-exit-recursive-edit "xwem-keymacro" nil t) (define-xwem-command xwem-keymacro-exit-recursive-edit () "Exit recursive edition." (xwem-interactive "*") ＠＠ -370,8 +355,8 ＠＠ (map-keymap (lambda (kseq fbind) (when (vectorp fbind) - (insert (format "(define-key xwem-user-macros-map '%S %S)\n" kseq fbind)))) - xwem-user-macros-map) + (insert (format "(define-key 'xwem-user-macros-prefix '%S %S)\n" kseq fbind)))) + (xwem-kbd-fixup-keymap 'xwem-user-macros-prefix)) (write-file (or file (expand-file-name xwem-keymacro-macrofile xwem-dir))) (kill-buffer buf)))) ＠＠ -385,4 +370,9 ＠＠  (provide 'xwem-keymacro) +;;; On-load actions +(if xwem-started + (xwem-keymacro-init) + (add-hook 'xwem-keyboard-init-hook 'xwem-keymacro-init)) + ;;; xwem-keymacro.el ends here Index: lisp/xwem-keytt.el =================================================================== RCS file: lisp/xwem-keytt.el diff -N lisp/xwem-keytt.el --- lisp/xwem-keytt.el 16 Dec 2004 08:08:08 -0000 1.3 +++ /dev/null 1 Jan 1970 00:00:00 -0000 ＠＠ -1,74 +0,0 ＠＠ -;;; xwem-keytt.el --- Keypress translation table. - -;; Copyright (C) 2003 by Free Software Foundation, Inc. - -;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; -;; Created: Fri Dec 12 19:33:35 MSK 2003 -;; Keywords: xwem, xlib -;; X-CVS: $Id: xwem-keytt.el,v 1.3 2004/12/16 08:08:08 youngs Exp $ - -;; This file is part of XWEM. - -;; XWEM is free software; you can redistribute it and/or modify it -;; under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; XWEM is distributed in the hope that it will be useful, but WITHOUT -;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -;; or FITNESS FOR A PARTICULAR PURPOSE. See t (xwem-launcher-join-cmd ncmd)))) -;;;###autoload +;;;###xwem-autoload (defun xwem-launcher-query (&optional prompt) "Query for command to launch using PROMPT." - (let ((cmd (xwem-launcher-read-command - (if prompt (concat prompt "XWEM-Run: ") "XWEM-Run: ")))) - + (let ((cmd (xwem-launcher-read-command (or prompt "XWEM-Run: ")))) (xwem-launcher-normalize-cmd cmd))) ;;;###autoload(autoload 'xwem-run-program "xwem-launcher" "" t) ＠＠ -223,6 +242,13 ＠＠ (xwem-execute-program command)) +(defun xwem-next-job-number () + "Return next job number for use by xwem." + (let ((job-number 1)) + (while (get-process (format "xwem-run-%d" job-number)) + (setq job-number (1+ job-number))) + job-number)) + ;;;###autoload (defun xwem-execute-program (command &optional buffer-name) "Execute COMMAND in buffer with BUFFER-NAME. ＠＠ -230,28 +256,41 ＠＠ (let* ((cmdargs (condition-case nil (split-string command " ") (t (list command)))) ; due to split-string args-out-of-range bug (prg (car cmdargs)) (args (cdr cmdargs)) - (job-number 1) - job-name) - (while (get-process (setq job-name (format "xwem-run-%d" job-number))) - (setq job-number (1+ job-number))) + (emacs-env (getenv "EMACS")) + (job-number (xwem-next-job-number)) + (job-name (format "xwem-run-%d" job-number)) + proc) - (or buffer-name - (setq buffer-name (format " *%s*" job-name))) + (unless buffer-name + (setq buffer-name (format " *%s*" job-name))) (with-current-buffer (get-buffer-create buffer-name) + ;; Sometimes `default-directory' became nil for some reason, I + ;; don't know why. Maybe XEmacs bug? --lg + (unless default-directory + (setq default-directory (expand-file-name "~/"))) + (erase-buffer) + (insert (format "--- Working directory: %S\n%% %S\n" default-directory command)) - (insert "--- working directory: %S" default-directory - "\n% " command ?\n) + ;; Set our EMACS environment variable so comint-exec doesn't do it + ;; for us. Note that if the environment is already set, we may + ;; not want to do it again. + (unless emacs-env + (setenv "EMACS" "xwem")) + + (setq proc (get-buffer-process + (comint-exec buffer-name job-name prg nil args))) + (comint-mode) + ;; COND because the proc may have died before the G-B-P is called. + (cond (proc (set-process-sentinel proc 'xwem-program-sentinel) + (xwem-message 'note "Job [%d] '%s' PID=%d" job-number command (process-id proc)))) + (setq mode-name "XWEM-Run") - (let ((proc (get-buffer-process - (comint-exec buffer-name job-name prg nil args)))) - (comint-mode) - ;; COND because the proc may have died before the G-B-P is called. - (cond (proc (set-process-sentinel proc 'xwem-program-sentinel) - (message "[%d] %d" job-number (process-id proc)))) - (setq mode-name "XWEM-Run") - proc)))) + ;; Restore our Emacs environment variable to its previous state. + (setenv "EMACS" emacs-env) + + proc))) (defun xwem-program-sentinel (process msg) "Called when PROCESS changed state to MSG." ＠＠ -265,9 +304,8 ＠＠ (substring msg 1 -1)))))) (when xwem-launcher-beep-done (xwem-play-sound 'ready)) - (xwem-message 'info "[%s] %s '%s'" (process-name process) - msg - (mapconcat 'identity (process-command process) " ")) + (xwem-message 'note "Job [%s] %s '%s'" (process-name process) + msg (mapconcat 'identity (process-command process) " ")) (if (null (buffer-name (process-buffer process))) (set-process-buffer process nil) ; WHY? Olin. ＠＠ -282,25 +320,48 ＠＠ (set-buffer-modified-p nil))))) (store-match-data ms)))) +;;;###xwem-autoload +(defun xwem-execute-cmd-expecting (cmd &optional manage-type cl-plist) + "Execute CMD expecting till client will be managed. +MANAGE-TYPE specifies which manage type to use in expectance. +CL-PLIST is properties for expected client. +Return managed client." + (setq cmd (XFreePixmap xdpy xpix-mask) + (X-Win-rem-prop xwin 'ladock-state) + (X-Win-rem-prop xwin 'ladock-action) + (X-Win-rem-prop xwin 'ladock-xgc) + (X-Win-rem-prop xwin 'ladock-xpix) + (X-Win-rem-prop xwin 'ladock-xpix-mask) + (when force (XDestroyWindow xdpy xwin)))) ;;;###autoload -(defun xwem-launch-button-start (xpm-file action &optional xdpy) +(defun xwem-launch-button-start (xpm-file action &optional dockid dockgroup dockalign) "Create new dockapp button with XPM-FILE image and doing ACTION on click. ACTION is cons cell wher car is one of 'elisp or 'cmd and cdr is string. For 'elisp car, cdr is real elisp expression, to evaluate on click. For 'cmd car, cdr is cmd to run on click." - (unless xdpy - (setq xdpy (xwem-dpy))) - (let (xwin xpix xpix-mask ximg xgc) - (setq xwin (XCreateWindow xdpy nil 0 0 xwem-launch-dock-width xwem-launch-dock-height 0 nil nil nil + (setq xwin (XCreateWindow (xwem-dpy) nil + 0 0 + xwem-launch-dock-width + xwem-launch-dock-height + 0 nil nil nil (make-X-Attr :override-redirect t -:backing-store X-WhenMapped -:background-pixel (XAllocNamedColor xdpy (XDefaultColormap xdpy) "gray50") -:border-pixel (XAllocNamedColor xdpy (XDefaultColormap xdpy) "gray80")) +:backing-store X-Always +:background-pixel (XAllocNamedColor (xwem-dpy) (XDefaultColormap (xwem-dpy)) "gray50") +:border-pixel (XAllocNamedColor (xwem-dpy) (XDefaultColormap (xwem-dpy)) "gray80")) )) ;; Create pixmap - (setq xpix (X:xpm-pixmap-from-file xdpy xwin xpm-file)) + (setq xpix (X:xpm-pixmap-from-file (xwem-dpy) xwin (expand-file-name xpm-file xwem-icons-dir))) (setq ximg (X-Pixmap-get-prop xpix 'ximg)) - (setq xpix-mask (X:xpm-pixmap-from-file xdpy xwin xpm-file t)) + (setq xpix-mask (X:xpm-pixmap-from-file (xwem-dpy) xwin (expand-file-name xpm-file xwem-icons-dir) t)) - (setq xgc (XCreateGC xdpy xpix - (make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy) + (setq xgc (XCreateGC (xwem-dpy) xpix + (make-X-Gc :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy)) :clip-x-origin (/ (- xwem-launch-dock-width (X-Image-width ximg)) 2) :clip-y-origin (/ (- xwem-launch-dock-height (X-Image-height ximg)) 2) :clip-mask xpix-mask))) ＠＠ -719,12 +790,11 ＠＠ (X-Win-put-prop xwin 'ladock-xpix xpix) (X-Win-put-prop xwin 'ladock-xpix-mask xpix-mask) - (XSelectInput xdpy xwin (Xmask-or XM-Exposure XM-StructureNotify XM-ButtonPress XM-ButtonRelease)) + (XSelectInput (xwem-dpy) xwin (Xmask-or XM-Exposure XM-StructureNotify XM-ButtonPress XM-ButtonRelease)) (X-Win-EventHandler-add xwin 'xwem-ladock-evhandler nil - (list X-Expose X-ButtonPress X-ButtonRelease X-DestroyNotify)) - - (XTrayInit xdpy xwin) + (list X-Expose X-MapNotify X-ButtonPress X-ButtonRelease X-DestroyNotify)) + (xwem-XTrayInit (xwem-dpy) xwin dockid dockgroup dockalign) xwin))  Index: lisp/xwem-load.el =================================================================== RCS file: lisp/xwem-load.el diff -N lisp/xwem-load.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-load.el 1 Jan 2005 04:41:14 -0000 ＠＠ -0,0 +1,46 ＠＠ +;;; xwem-load.el --- XWEM functionality loader. + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Created: Tue Aug 24 13:48:56 MSD 2004 +;; Keywords: xwem +;; X-CVS: $Id: xwem-load.el,v 1.4 2004/11/29 20:41:52 lg Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute i - (const :tag "Inverted Copy" X-GXCopyInverted) - (const :tag "Set" X-GXSet)))) - - -(provide 'xwem-macros) - -;;; xwem-macros.el ends here Index: lisp/xwem-main.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-main.el,v retrieving revision 1.16 diff -u -u -r1.16 xwem-main.el --- lisp/xwem-main.el 16 Dec 2004 08:08:09 -0000 1.16 +++ lisp/xwem-main.el 1 Jan 2005 04:41:14 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: 21 Mar 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xwem-main.el,v 1.16 2004/12/16 08:08:09 youngs Exp $ +;; X-CVS: $Id: xwem-main.el,v 1.14 2004/12/05 05:52:29 youngs Exp $ ;; This file is part of XWEM. ＠＠ -50,20 +50,28 ＠＠ ;; "\\|define-xwem-command" ;; "\\)\\s-+%s\\(\\s-\\|$\\)")) +;; XWEM core: +;; List of files XWEM can't live without. +;; +;; xwem-interactive.el - Interactive stuff +;; xwem-focus.el - Focuses +;; xwem-minibuffer.el - XWEM Minibuffer. +;; xwem-manage.el - Manage database. +;; xwem-keyboard.el - Keyboard stuff. +;; xwem-clients.el - Clients support. +;; xwem-win.el - Windows. +;; xwem-frames.el - Frames support. + ;;; Code:  (eval-when-compile - (require 'cl) ;last, intersection etc - (require 'xlib-xwin)) -(eval-when 'load - (load "xwem-keydefs") - (run-hooks 'xwem-load-hook)) -(require 'xwem-root) + (require 'cl)) ;last, intersection etc -;;;###autoload -(defconst xwem-version "xwem(xemacs-package): $Revision: 1.16 $") +(require 'xwem-load) +(require 'xwem-minibuffer) +(require 'xwem-version) (defgroup xwem nil "XWEM window manager." ＠＠ -82,13 +90,37 ＠＠ :type 'directory :group 'xwem) -;;;###autoload +(defcustom xwem-inhibit-startup-message nil + "*Non-nil mean, do not show message after successful XWEM start." +:type 'boolean +:group 'xwem) + (defcustom xwem-debug nil "*Non-nil mean run xlib and xwem in debugging mode." :type 'boolean :group 'xwem) ;;;###autoload +(defcustom xwem-debug-routines + '(xwem-cl xwem-event xwem-frame xwem-misc xwem-root xwem-deffered xwem-tray + ;; and X routines + x-misc x-event x-tray x-error x-record) + "Routines to debug on." +:type '(set (const :tag "XWEM CLients" xwem-cl) + (const :tag "XWEM Events" xwem-event) + (const :tag "XWEM Frames" xwem-frame) + (const :tag "XWEM Misc" xwem-misc) + (const :tag "XWEM Root" xwem-root) + (const :tag "XWEM Deffered calls" xwem-deffered) + (const :tag "XWEM Tray" xwem-tray) + (const :tag "X Misc" x-misc) + (const :tag "X Event" x-event) + (const :tag "X Tray" x-tray) + (const :tag "X Error" x-error) + (const :tag "X RECORD" x-record)) +:group 'xwem) + +;;;###xwem-autoload (defcustom xwem-commands-inhibit-gc t "*Non-nil mean that xwem interactive commands runs without GCing." :type 'boolean ＠＠ -96,24 +128,42 ＠＠ (defcustom xwem-custom-display nil ;"127.0.0.1:2" "*Custom display, mostly for debugging purposes." -:type '(restricted-sexp :match-alternatives (stringp null)) +:type '(choice (const :tag "No custom display" nil) + (const "127.0.0.1:2") + (string :tag "Custom display")) :group 'xwem) +;;;###autoload (defcustom xwem-load-hook nil "*Hooks to call after xwem was load." :type 'hook :group 'xwem-hooks) +;;;###autoload +(defcustom xwem-config-read-hook nil + "*Hooks to call after xwem read config file." +:type 'hook +:group 'xwem-hooks) + +;;;###autoload (defcustom xwem-before-init-wins-hook nil "Hooks called before `xwem-init-wins'." :type 'hook :group 'xwem-hooks) +;;;###autoload (defcustom xwem-after-init-wins-hook nil "Hooks called after `xwem-init-wins'." :type 'hook :group 'xwem-hooks) +;;;###autoload +(defcustom xwem-before-init-hook nil + "Hooks to be run before xwem initialization." +:type 'hook +:group 'xwem-hooks) + +;;;###autoload (defcustom xwem-after-init-hook nil "Hooks to be runned after xwem initialisation." :type 'hook ＠＠ -133,48 +183,37 ＠＠  ;;; Functions -(defun xwem-init-wins () - "Manage all mapped X windows." - (xwem-message 'msg "Initializing X windows ... wait") +(defun xwem-initial-manage () + "Manage all visible clients. +Even clients with override-redirect attribute set can be managed." + (xwem-message 'init "Initializing X windows ...") (run-hooks 'xwem-before-init-wins-hook) (let ((wins (XQueryTree (xwem-dpy) (xwem-rootwin))) - cln-wins attrs) + cln-wins) (setq wins (cdr (cdr (cdr (cdr wins))))) - (X-Dpy-log (xwem-dpy) "IN xwem-init-wins: wins length = %d\n" '(length wins)) + (xwem-debug 'xwem-misc "IN xwem-initial-manage: wins length = %d" '(length wins)) (while wins - (X-Dpy-log (xwem-dpy) "XGetWindowAttr BEGIN in xwem-init-wins\n") - (setq attrs (XGetWindowAttributes (xwem-dpy) (car wins))) - (X-Dpy-log (xwem-dpy) "XGetWindowAttr END in xwem-init-wins, as=%s\n" 'attrs) - - (when (and (not (X-Attr-override-redirect attrs)) - (= (X-Attr-mapstate attrs) X-Viewable) + (when (and (= (X-Attr-mapstate (XGetWindowAttributes (xwem-dpy) (car wins))) X-Viewable) (not (X-Win-get-prop (car wins) 'xwem-frame))) ;; X window visible and not an XWEM frame (setq cln-wins (cons (car wins) cln-wins))) - (setq wins (cdr wins))) ;; Manage all visible clients - (X-Dpy-log (xwem-dpy) "IN xwem-init-wins: managing wins length = %d\n" '(length shcfgl)) - (mapc 'xwem-make-client cln-wins) - ) + (mapc 'xwem-xwin-try-to-manage cln-wins)) (run-hooks 'xwem-after-init-wins-hook) - ) + (xwem-message 'init "Initializing X windows ... done")) (defun xwem-after-window-setup () "Function which will be added to `window-setup-hook'. Called after ~/.emacs file loaded and Emacs X window subsystems initialized." - ;; Create XWEM minibuffer - (xwem-minib-create) - - ;; revert back `menubar-visible-p' specifier - (set-specifier menubar-visible-p xwem-saved-menubar-visible-p) + (run-hooks 'xwem-before-init-hook) (let ((dfen (or xwem-custom-display (getenv "DISPLAY")))) (xwem-init-root ＠＠ -182,36 +221,27 ＠＠ (concat "127.0.0.1" dfen) dfen))) - ;; Select input on root window - (XSelectInput (xwem-dpy) (xwem-rootwin) xwem-root-ev-mask) - (X-Win-EventHandler-add-new (xwem-rootwin) 'xwem-root-events-handler 100) - - (xwem-init-cursors) - (xwem-init-faces) - (xwem-init-events) - (xwem-kbd-init) - (xwem-init-frames) - (xwem-init-win) - (xwem-init-misc) - - ;; Handle all X clients - (xwem-init-wins) + ;; Debugging? yes + (when xwem-debug + (setf (X-Dpy-log-buffer (xwem-dpy)) "*xwem-debug*") + (X-Dpy-set-log-routines (xwem-dpy) xwem-debug-routines)) - (when xwem-strokes-enabled - (xwem-strokes-init)) + (setq xwem-started t) - ;; Initialize xwem system tray - (when xwem-tray-enabled - (xwem-tray-startit (xwem-dpy))) + ;; Create initial frames + (xwem-frames-init) - (setq xwem-started t) + ;; Handle all X clients + (xwem-initial-manage) ;; Now xwem is fully intialized and it is time to run hooks (run-hooks 'xwem-after-init-hook) (XSync (xwem-dpy)) - (xwem-message 'asis (concat (xwem-logo-string) - " succesfully started. Start with `M-x xwem-help RET'.")) + (unless xwem-inhibit-startup-message + (xwem-message 'asis (concat (xwem-logo-string) + " succesfully started. Start with `" + (substitute-command-keys "\\<xwem-global-map>\\[xwem-help-prefix]") "'."))) ) (defcustom xwem-use-presetup t ＠＠ -219,50 +249,83 ＠＠ :type 'boolean :group 'xwem) +;;; Internal variables + ;;;###autoload (defun xwem-init () "Initialization of xwem subsystems." - (require 'xwem-keydefs) ; load keyboard difinitions - (setq inhibit-startup-message t) ; DO NOT REMOVE (when xwem-use-presetup - ;; default presetup - (setf allow-deletion-of-last-visible-frame t) + (setf allow-deletion-of-last-visible-frame t + auto-lower-frame t + + ;; Printing + ;print-level 2 + + ;; Yes, do it + max-specpdl-size 10000 + max-lisp-eval-depth 10000) + + ;; Destroy XEmacs frame when killing dedicated buffer (defadvice kill-buffer (before delete-dedicated-frame activate) "Work around dedicated frame problem." (let ((frame (buffer-dedicated-frame (get-buffer (or (ad-get-arg 0) (current-buffer)))))) (when (framep frame) (delete-frame frame)))) - (xwem-init-tabber)) + + ;; When XEmacs frame deselects, select xwem minibuffer + (add-hook 'deselect-frame-hook + (lambda () + (unless (eq (xwem-minib-frame xwem-minibuffer) + (selected-frame)) + (select-frame (xwem-minib-frame xwem-minibuffer))))) + + ;; Raise/lower minibuffer + (add-hook 'xwem-minibuffer-focusin-hook 'xwem-minib-focusin-autoraise) + (add-hook 'xwem-minibuffer-focusout-hook 'xwem-minib-focusout-autolower) + + ;; Generic managing model + (require 'xwem-clgen) + ;; Use nice tabber for frames + (require 'xwem-tabbing) + ;; Transient-for clients support + (require 'xwem-transient) + ;; Support netwm stuff + (require 'xwem-netwm)) + + ;; Load default keys definitions + (require 'xwem-keydefs) +; (load "xwem-keydefs") ;; read configuration (let ((cfg (expand-file-name "xwemrc.el" xwem-dir))) (if (file-exists-p cfg) (load cfg) - (xwem-message 'warn "Configuration file `%s' does not exists" cfg))) + (xwem-message 'warning "Configuration file `%s' does not exists" cfg))) - ;; Initialize various stuff that does not need display - (xwem-manda-init) + ;; Config just readed, so run hooks + (run-hooks 'xwem-config-read-hook) (add-hook 'window-setup-hook 'xwem-after-window-setup) (add-hook 'kill-emacs-hook 'xwem-fini t) ) -;;;###autoload -(defun xwem-fini () +;;;###autoload(autoload 'xwem-fini "xwem-main" nil t) +(define-xwem-command xwem-fini () "Fini all subsystems." - (xwem-kbd-quit) - (xwem-fini-events) - (xwem-fini-frames) - (xwem-fini-clients) - (when xwem-tray-enabled - (xwem-tray-fini)) - (xwem-fini-root) + (xwem-interactive) +; (xwem-kbd-quit) +; (xwem-frames-fini) +; (xwem-fini-clients) ;; Finally run exit hooks - (run-hooks 'xwem-exit-hook)) + (run-hooks 'xwem-exit-hook) + + ;; And close display + (xwem-fini-root) + )  (provide 'xwem-main) Index: lisp/xwem-manage.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-manage.el,v retrieving revision 1.9 diff -u -u -r1.9 xwem-manage.el --- lisp/xwem-manage.el 16 Dec 2004 08:08:09 -0000 1.9 +++ lisp/xwem-manage.el 1 Jan 2005 04:41:14 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Richard Klinda <ignotus(a)hixsplit.hu&gt; ;; Created: 21 Mar 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xwem-manage.el,v 1.9 2004/12/16 08:08:09 youngs Exp $ +;; X-CVS: $Id: xwem-manage.el,v 1.8 2004/12/05 22:37:34 lg Exp $ ;; This file is part of XWEM. ＠＠ -28,199 +29,523 ＠＠ ;;; Commentary: -;; +;; Manage database. Manage database is list of manda entries, which +;; are used to decide how to manage certain client. Every manda entry +;; has methods to operate on client. + +;;; Customization: + +;; Only one customisable variable is `xwem-manage-list' is a list +;; where each element is a list in form: + +;; \(MANAGE-TYPE CLIENT-PLIST MATCH-SPEC\) + +;; Configuration looks like this: + +;; (setq xwem-manage-list +;; '((fullscreen (ignore-has-input-p t fs-real-size t +;; x-border-width 2 x-border-color "brown4" +;; xwem-focus-mode follow-mouse) +;; (application "rdesktop")) +;; (rooter (dum - 'xwem-cl-iconify 'xwem-cl-refit) - - ;; Manda entry to handle xwem minibuffer - (define-xwem-manda 'xwem-minibuffer (xwem-class-matcher (concat "^" xwem-minibuffer-name "$")) - 0 t - 'xwem-minibuffer-init 'xwem-minib-manage nil nil 'xwem-minib-refit) - - ;; Manda entry to manage special Emacs frames - (define-xwem-manda 'xwem-special (xwem-class-matcher (concat "^" xwem-special-frame-name "$")) - 0 t - 'xwem-special-frame-init 'xwem-special-frame-manage - 'xwem-special-frame-demanage 'xwem-special-frame-iconify) - - ;; Manda entry to manage transient-for(dialogs) windows - (define-xwem-manda 'transient-for (lambda (cl) - (xwem-hints-wm-transient-for (xwem-cl-hints cl))) - 0 t - nil 'xwem-trans-for-manage 'xwem-trans-for-demanage - 'xwem-trans-for-demanage) - - ;; run init functions - (mapc (lambda (manel) - (xwem-manda-fun-run manel 'init)) - xwem-manda-list)) +(defvar xwem-manage-expectances nil + "List of expectances in `xwem-manage-list' format. +The difference from `xwem-manage-list' is that, when matching occurs +in `xwem-manage-expectances', matched entry removed from +`xwem-manage-expectances' list.") + +;;; Internal variables  -;; Transient for clients handling -(defcustom xwem-cl-transient-border-color "blue4" - "Border color for transient for windows." -:type '(restricted-sexp :match-alternatives (xwem-misc-colorspec-valid-p)) -:group 'xwem-cl) +;;; Matching -(defcustom xwem-cl-transient-border-width 2 - "Border width in pixels of transient for windows." -:type 'number -:group 'xwem-cl) +;;;###xwem-autoload +(defun xwem-class-match-p (cl cli-regex &optional cln-regex wmname-regex) + "Return non-nil if CL matches CLI-REGEX, CLN-REGEX, WMNAME-REGEX. +CLI-REGEX is regexp to match class instance name. +CLN-REGEX is regexp to match class name. +WMNAME-REGEX is regexp to match CL's WM_NAME." + (let* ((case-fold-search nil) + (hints (xwem-cl-hints cl)) + (class (xwem-hints-wm-class hints)) + (wmname (xwem-hints-wm-name hints))) + (and (or (null cli-regex) + (string-match cli-regex (or (car class) ""))) + (or (null cln-regex) + (string-match cln-regex (or (cdr class) ""))) + (or (null wmname-regex) + (string-match wmname-regex wmname))))) + +(defmacro define-xwem-class-matcher (cli-regex &optional cln-regex wmname-regex) + "Create and return new class matcher function. + +Result of this macro is function which is passed with on argument - CL. + +This function returns non-nil if CL's WM_CLASS matches +CLI-REGEX/CLN-REGEX and CL's WM_NAME matches WMNAME-REGEX. +If CLN-REGEX or WMNAME-REGEX ommited, then \".*\" expression will be +used (i.e. match everything)." + `(lambda (cl) + (xwem-class-match-p cl ,cli-regex ,cln-regex ,wmname-regex))) + +;;;###xwem-autoload +(defun xwem-cl-match-p (cl match-spec) + "Check whether CL matches MATCH-SPEC. +MATCH-SPEC format is a list in form + + (or (TYPE PARAM) ..) + +or + + (and (TYPE PARAM) ..). + +TYPE is one of: + + `class-name' - To match CL's class name (PARAM is regex). + + `class-inst' - To match CL's class instance name (PARAM is regex). -(defun xwem-trans-for-manage (cl &rest others) - "Manage CL that have transient-for flag." - ;; Map window for witch CL is transient and just map and raise CL - ;; over it - (let* ((xwin (xwem-cl-xwin cl)) - (tfwin (xwem-cl-transient-for cl)) - (trc (xwem-find-client tfwin))) - - (XChangeWindowAttributes (xwem-dpy) xwin - (make-X-Attr :border-pixel (XAllocNamedColor - (xwem-dpy) (XDefaultColormap (xwem-dpy)) - xwem-cl-transient-border-color))) - (XSetWindowBorderWidth (xwem-dpy) xwin xwem-cl-transient-border-width) - -; (XMoveWindow (xwem-dpy) xwin (X-Geom-x (xwem-cl-xgeom cl)) (X-Geom-y (xwem-cl-xgeom trc))) - - (XMapWindow (xwem-dpy) (xwem-cl-xwin cl)) - (XRaiseWindow (xwem-dpy) (xwem-cl-xwin cl)) - (XSelectInput (xwem-dpy) (xwem-cl-xwin cl) (Xmask-or XM-StructureNotify)) - - (when (xwem-cl-p trc) - + (let ((fun (get method-name manda-type))) + (when (or fun (setq fun (get method-name 'default))) + (apply fun args)))) + +(defsubst xwem-method-manage (cl) + (xwem-execute-method 'manage (xwem-cl-manage-type cl) cl)) + +(defsubst xwem-method-activate (cl &optional type) + "Activation method for CL. +For TYPE, see documentation for `xwem-activate'." + (xwem-execute-method 'activate (xwem-cl-manage-type cl) cl type)) + +(defsubst xwem-method-deactivate (cl &optional type) + (xwem-execute-method 'deactivate (xwem-cl-manage-type cl) cl type)) + +(defsubst xwem-method-refit (cl) + (xwem-execute-method 'refit (xwem-cl-manage-type cl) cl)) + +(defsubst xwem-method-iconify (cl) + (xwem-execute-method 'iconify (xwem-cl-manage-type cl) cl)) + +(defsubst xwem-method-withdraw (cl) + (xwem-execute-method 'withdraw (xwem-cl-manage-type cl) cl)) + +(defsubst xwem-method-on-kill (cl) + (xwem-execute-method 'on-kill (xwem-cl-manage-type cl) cl)) + +(defsubst xwem-method-on-type-change (cl &optional new-type) + (xwem-execute-method 'on-type-change (xwem-cl-manage-type cl) cl new-type)) + +(defmacro define-xwem-method (method-name manda-type arg-list &optional doc-string &rest forms) + "Define new method METHOD-NAME for MANDA-TYPE. +DOC-STRING is documentation. +FORMS - elisp forms to eval." + (let ((sym (intern (format "xwem:-%s-%s" manda-type method-name)))) + `(eval-and-compile + (defun ,sym ,arg-list + ,doc-string + ,＠forms) + (put (quote ,method-name) (quote ,manda-type) (quote ,sym)))))  (provide 'xwem-manage) Index: lisp/xwem-minibuffer.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-minibuffer.el,v retrieving revision 1.10 diff -u -u -r1.10 xwem-minibuffer.el --- lisp/xwem-minibuffer.el 16 Dec 2004 08:08:10 -0000 1.10 +++ lisp/xwem-minibuffer.el 1 Jan 2005 04:41:14 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Thu Dec 4 15:13:12 MSK 2003 ;; Keywords: xwem, xlib -;; X-CVS: $Id: xwem-minibuffer.el,v 1.10 2004/12/16 08:08:10 youngs Exp $ +;; X-CVS: $Id: xwem-minibuffer.el,v 1.9 2004/12/08 19:11:30 lg Exp $ ;; This file is part of XWEM. ＠＠ -33,41 +33,20 ＠＠ ;; such as messages displaying, system tray, etc. ;;; Code: -(eval-when-compile - (require 'xlib-xwin) - (require 'xwem-misc))  -;;;###autoload -(defstruct xwem-minib - frame ; Emacs frame - (evmask 0.0) ; events to select - cl - - plist ; User defined plist - ) - -;;;###autoload -(defmacro xwem-minib-xgeom (minb) - "Get MINB xgeom." - `(xwem-cl-xgeom (xwem-minib-cl ,minb))) - -(defmacro xwem-minib-xwin (minb) - "Get MINB xwin." - `(xwem-cl-xwin (xwem-minib-cl ,minb))) - -(defsetf xwem-minib-xgeom (minb) (xgeom) - `(setf (xwem-cl-xgeom (xwem-minib-cl ,minb)) ,xgeom)) +(require 'xwem-load) +(require 'xwem-focus) +(require 'xwem-manage) -(defsetf xwem-minib-xwin (minb) (xwin) - `(setf (xwem-cl-xwin (xwem-minib-cl ,minb)) ,xwin)) +(eval-when-compile + (defvar x-emacs-application-class nil)) ;; Customization (defgroup xwem-minibuffer nil "Group to customize XWEM minibuffer." :prefix "xwem-minibuffer-" -:group 'xwem) +:group 'xwem-modes) -;;;###autoload (defcustom xwem-minibuffer-name "xwem-minibuffer" "*Minibuffer name to be used by XWEM." :type 'string ＠＠ -75,10 +54,10 ＠＠ (defcustom xwem-minibuffer-bgcol "gray80" "*Background color to be used in `xwem-minib-frame'." -:type '(restricted-sexp :match-alternatives (xwem-misc-colorspec-valid-p)) +:type 'color :group 'xwem-minibuffer) -(defcustom xwem-minibuffer-font nil +(defcustom xwem-minibuffer-font (face-font-name 'default) "*Font to be used in `xwem-minib-frame'. May be nil or string." :type '(restricted-sexp :match-alternatives ('nil try-font-name)) :group 'xwem-minibuffer) ＠＠ -86,26 +65,75 ＠＠ (defcustom xwem-minibuffer-height 1 "Height of `xwem-minibuffer'." :type 'number +:set (lambda (sym val) + (set sym val) + ;; DO NOT RELY on `set-frame-height' + (let ((frame (and xwem-minibuffer (xwem-minib-frame xwem-minibuffer))) + (mcl (and xwem-minibuffer (xwem-minib-cl xwem-minibuffer)))) + (when (and frame mcl) + (setq st (/ (frame-pixel-height frame) (frame-height frame)) + nsz (* st xwem-minibuffer-height)) + (xwem-client-resize mcl nil nsz)))) +:initialize 'custom-initialize-default :group 'xwem-minibuffer) (defcustom xwem-minibuffer-width 80 "*Usable width of `xwem-minibuffer' frame." :type 'number +:set (lambda (sym val) + (set sym val) + ;; DO NOT RELY on `set-frame-width' + (let ((frame (and xwem-minibuffer (xwem-minib-frame xwem-minibuffer))) + (mcl (and xwem-minibuffer (xwem-minib-cl xwem-minibuffer)))) + (when (and frame mcl) + (setq st (/ (frame-pixel-width frame) (frame-width frame)) + nsz (* st xwem-minibuffer-width)) + (xwem-client-resize mcl nsz nil)))) +:initialize 'custom-initialize-default :group 'xwem-minibuffer) +;;;###xwem-autoload (defcustom xwem-minibuffer-border-width 3 "Border width for `xwem-minibuffer'." :type 'number +:set (lambda (sym val) + (set sym val) + (let ((cl (and xwem-minibuffer (xwem-minib-cl xwem-minibuffer)))) + (when (xwem-cl-p cl) + (xwem-client-set-property cl 'x-border-width xwem-minibuffer-border-width)))) +:initialize 'custom-initialize-default :group 'xwem-minibuffer) (defcustom xwem-minibuffer-passive-border-color "blue3" "Border color for `xwem-minibuffer'." -:type '(restricted-sexp :match-alternatives (xwem-misc-colorspec-valid-p)) +:type 'color +:set (lambda (sym val) + (set sym val) + (let ((cl (and xwem-minibuffer (xwem-minib-cl xwem-minibuffer)))) + (when (xwem-cl-p cl) + (xwem-set-face-foreground + 'x-border-face xwem-minibuffer-passive-border-color nil cl) + (xwem-client-set-property + cl 'x-border-color + (xwem-face-foreground + 'x-border-face (and (xwem-cl-selected-p cl) '(selected)) cl))))) +:initialize 'custom-initialize-default :group 'xwem-minibuffer) (defcustom xwem-minibuffer-active-border-color "blue" "Border color for `xwem-minibuffer' when it focused." -:type '(restricted-sexp :match-alternatives (xwem-misc-colorspec-valid-p)) +:type 'color +:set (lambda (sym val) + (set sym val) + (let ((cl (and xwem-minibuffer (xwem-minib-cl xwem-minibuffer)))) + (when (xwem-cl-p cl) + (xwem-set-face-foreground + 'x-border-face xwem-minibuffer-active-border-color '(selected) cl) + (xwem-client-set-property + cl 'x-border-color + (xwem-face-foreground + 'x-border-face (and (xwem-cl-selected-p cl) '(selected)) cl))))) +:initialize 'custom-initialize-default :group 'xwem-minibuffer) (defcustom xwem-minibuffer-hide-cursor-mode t ＠＠ -115,174 +143,373 ＠＠ :type 'boolean :group 'xwem-minibuffer) -(defcustom xwem-minibuffer-emacs-frames-has-minibuffer nil +(defcustom xwem-minibuffer-hide-show-parameter 0 + "*Animation delay parameter, when hiding/showing xwem minibuffer." +:type 'number +:group 'xwem-minibuffer) + +(defcustom xwem-minibuffer-autohide-timeout nil + "*Non-nil number, mean xwem minibuffer will be autohided, after that many seconds. +NOT YET IMPLEMENTED." +:type '(choice (const :tag "Disabled" nil) + (number :tag "Seconds")) +:set (lambda (sym value) + (set sym value) + (let ((mcl (xwem-minib-cl xwem-minibuffer))) + (when mcl + (if value + (xwem-minibuffer-enable-autohide-timer mcl) + (xwem-activate mcl) + (xwem-minibuffer-disable-autohide-timer mcl))))) +:initialize 'custom-initialize-default +:group 'xwem-minibuffer) + +(defcustom xwem-minibuffer-raise-when-active t + "*Non-nil mean xwem minibuffer is raised when activated." +:type 'boolean +:group 'xwem-minibuffer) + +(defcustom xwem-minibuffer-emacs-frames-has-minibuffer t "*Non-nil mean Emacs frames will have their own minibuffers." :type 'boolean :group 'xwem-minibuffer) -;; Variables +(defcustom xwem-minibuffer-set-default-minibuffer-frame t + "*Non-nil mean that xwem minibuffer frame will be set as `default-minibuffer-frame'." +:type 'boolean +:group 'xwem-minibuffer) + +;;;###xwem-autoload +(defcustom xwem-minibuffer-outer-border-width 1 + "*Outer border width for xwem minibuffer." +:type 'number +:group 'xwem-minibuffer) + +(defcustom xwem-minibuffer-outer-border-color "black" + "*Outer border color for xwem minibuffer." +:type 'color +:group 'xwem-minibuffer) + ;;;###autoload +(defcustom xwem-minibuffer-focusin-hook nil + "*Hooks called when xwem minibuffer got focus." +:type 'hook +:group 'xwem-minibuffer +:group 'xwem-hooks) + +;;;###autoload +(defcustom xwem-minibuffer-focusout-hook nil + "*Hooks called when xwem minibuffer lose focus." +:type 'hook +:group 'xwem-minibuffer +:group 'xwem-hooks) + +(defcustom xwem-minib-resize-exact t + "*If non-`nil', make minibuffer frame exactly the size needed to display all its contents. +Otherwise, the minibuffer frame can temporarily increase in size but +never get smaller while it is active." +:type 'boolean +:group 'xwem-minibuffer) + +(defcustom xwem-minib-specifiers + '((default-toolbar-visible-p . nil) + (menubar-visible-p . nil) + (horizontal-scrollbar-visible-p . nil) + ((face-font 'default) . xwem-minibuffer-font)) + "*Alist of specifiers to be set for xwem minibuffer." +:type '(repeat (cons (sexp :tag "Specifier sexp") + (sexp :tag "Specifier value sexp"))) +:set (lambda (sym value) + (set sym value) + (when (and xwem-minibuffer + (frame-live-p (xwem-minib-frame xwem-minibuffer))) + (xwem-minib-apply-specifiers (xwem-minib-frame xwem-minibuffer)))) +:group 'xwem-minibuffer) + +;;; Internal variables + +;; Variables +;;;###xwem-autoload (defvar xwem-minibuffer nil - "Internal variable, holds `xwem-minibuffer' structure.") + "Default xwem minibuffer.") + +(defvar xwem-minibuffer-map + (let ((map (make-sparse-keymap))) + (define-key map (xwem-kbd "H-g") 'minibuffer-keyboard-quit) + map) + "Keymap used while in xwem.")  -(defvar xwem-minib-after-creat-hooks nil - "Hooks to be called after xwem minibuffer created.") +(defun xwem-minib-apply-specifiers (frame) + "Apply `xwem-minib-specifiers' to FRAME." + (mapc (lambda (spc) + (set-specifier (eval (car spc)) (eval (cdr spc)) frame nil 'remove-locale)) + xwem-minib-specifiers)) -;;;###autoload (defun xwem-minib-create () "Create minibuffer that will be used by xwem, or use existen." (let ((mframe (xwem-misc-find-frame xwem-minibuffer-name))) - (when (null mframe) - ;; not yet created - (setq mframe (make-frame minibuffer-frame-plist))) + ;; xwem minib not yet created + (setq mframe (make-frame minibuffer-frame-plist (default-x-device)))) -; (setq default-minibuffer-frame mframe) (setf (xwem-minib-frame xwem-minibuffer) mframe) - ;; XXX - maybe move it to `xwem-minib-after-creat-hooks'? - (when xwem-minibuffer-font - (set-face-property 'default 'font xwem-minibuffer-font - (xwem-minib-frame xwem-minibuffer))) - (when xwem-minibuffer-bgcol - (set-face-property 'default 'background xwem-minibuffer-bgcol - (xwem-minib-frame xwem-minibuffer))) - - ;; TODO: run after create hooks - )) - -;; Manda functions -;;;###autoload -(defun xwem-minib-refit (cl &rest args) - "Refit xwem minibuffer. -CL is non-nil when `xwem-minib-refit' is called internally by xwem-minb-manage. -ARGS is additional arguments." - ;; Adjust geometry a little - (xwem-cl-correct-size-for-size cl (xwem-cl-xgeom cl) 'left 'bottom) - - (let ((mgeom (xwem-minib-xgeom xwem-minibuffer))) - (XMoveResizeWindow (xwem-dpy) (xwem-minib-xwin xwem-minibuffer) - (X-Geom-x mgeom) (X-Geom-y mgeom) (X-Geom-width mgeom) (X-Geom-height mgeom))) - ) - -;;;###autoload -(defun xwem-minibuffer-on-select () - "Function to be used in `select-frame-hook'." - (when (eq (xwem-minib-frame xwem-minibuffer) (selected-frame)) - (set-frame-property (xwem-minib-frame xwem-minibuffer) - 'border-color xwem-minibuffer-active-border-color) - (when xwem-minibuffer-hide-cursor-mode - (set-frame-property (xwem-minib-frame xwem-minibuffer) 'text-cursor-visible-p t)) - )) - -;;;###autoload -(defun xwem-minibuffer-on-deselect () - "Function to be used in `deselect-frame-hook'." - (set-frame-property (xwem-minib-frame xwem-minibuffer) - 'border-color xwem-minibuffer-passive-border-color) - (when xwem-minibuffer-hide-cursor-mode - (set-frame-property (xwem-minib-frame xwem-minibuffer) 'text-cursor-visible-p nil)) - ) + ;; Set specifiers values for MFRAME + (xwem-minib-apply-specifiers mframe) + (redraw-frame mframe t) ; KEEP THIS! + mframe)) + +(defmacro xwem-cl-minibuffer (cl) + `(xwem-cl-get-sys-prop ,cl 'xwem-minibuffer)) +(defsetf xwem-cl-minibuffer (cl) (minib) + `(xwem-cl-put-sys-prop ,cl 'xwem-minibuffer ,minib)) + +;;; Minibuffer focus model +(define-xwem-focus-mode minibuffer (cl action &optional xev) + "Focus mode for xwem minibuffer" + (let ((mb (xwem-cl-minibuffer cl))) + (when (and (xwem-minib-p mb) + (X-Event-p xev) + (not (member (X-Event-xfocus-mode xev) + (list X-NotifyVirtual X-NotifyNonlinearVirtual)))) + (cond ((eq action 'focus-in) + ;; XWEM Minibuffer activates + (run-hook-with-args 'xwem-minibuffer-focusin-hook mb)) + ((eq action 'focus-out) + ;; XWEM Minibuffer deactivates + (run-hook-with-args 'xwem-minibuffer-focusout-hook mb)))))) -;;;###autoload -(defun xwem-minib-manage (cl) - "Manage XWEM's minibuffer client CL." - (setf (xwem-minib-cl xwem-minibuffer) cl) - (setf (xwem-cl-xgeom cl) - (make-X-Geom :x 0 :y (- (X-Geom-height (xwem-rootgeom)) - (X-Geom-height (xwem-cl-xgeom cl))) - :width (X-Geom-width (xwem-rootgeom)) - :height (X-Geom-height (xwem-cl-xgeom cl)) - :border-width 0)) - - ;; Add these hooks instead of tracking X events -; (add-hook 'select-frame-hook 'xwem-minibuffer-on-select) -; (add-hook 'deselect-frame-hook 'xwem-minibuffer-on-deselect) - - ;; Install event handler for xwem minibuffer window. - (setf (xwem-minib-evmask xwem-minibuffer) - (Xmask-or (xwem-minib-evmask xwem-minibuffer) XM-FocusChange)) - (XSelectInput (xwem-dpy) (xwem-minib-xwin xwem-minibuffer) (xwem-minib-evmask xwem-minibuffer)) - (X-Win-EventHandler-add-new (xwem-minib-xwin xwem-minibuffer) 'xwem-minib-events-handler) - - ;; Install grabs - (xwem-kbd-install-grab xwem-global-map (xwem-minib-xwin xwem-minibuffer)) - - (xwem-minib-refit cl)) +;;;; ---- XWEM Minibuffer manage type ---- +(defun xwem-minibuffer-client-p (cl) + "Return non-nil if CL is minibuffer client." + (xwem-cl-minibuffer cl)) + +(defun xwem-manage-minibuffer (cl) + "Manage method for xwem minibuffers." + (let* ((xgeom (make-X-Geom :x 0 ; XXX +:y (X-Geom-height (xwem-rootgeom)) +:width (- (X-Geom-width (xwem-rootgeom)) + xwem-minibuffer-outer-border-width + xwem-minibuffer-outer-border-width) +:height (X-Geom-height-with-borders (xwem-cl-xgeom cl)) +:border-width xwem-minibuffer-outer-border-width)) + (minib (make-xwem-minib +:frame (xwem-misc-find-emacs-frame cl) +:cl cl +:xgeom xgeom))) + + (setf (xwem-minib-xwin minib) + (XCreateWindow (xwem-dpy) nil + (X-Geom-x xgeom) + (X-Geom-y xgeom) + (X-Geom-width xgeom) + (X-Geom-height xgeom) + (X-Geom-border-width xgeom) + nil nil nil + (make-X-Attr :override-redirect t +:background-pixel + (XAllocNamedColor + (xwem-dpy) (XDefaultColormap (xwem-dpy)) + xwem-minibuffer-bgcol)))) + ;; Setup window a little + (when xwem-minibuffer-outer-border-color + (XSetWindowBorder (xwem-dpy) (xwem-minib-xwin minib) + (XAllocNamedColor (xwem-dpy) (XDefaultColormap (xwem-dpy)) + xwem-minibuffer-outer-border-color))) + + ;; Save CL's minibuffer + (setf (xwem-cl-minibuffer cl) minib) + + ;; Setup x-border-face for minibuffer + (xwem-set-face-foreground 'x-border-face xwem-minibuffer-active-border-color + '(selected) cl) + (xwem-set-face-foreground 'x-border-face xwem-minibuffer-passive-border-color + nil cl) + (xwem-client-set-property cl 'x-border-width xwem-minibuffer-border-width) + (xwem-client-set-property cl 'x-border-color + (xwem-face-foreground 'x-border-face + (and (xwem-cl-selected-p cl) '(selected)) cl)) + + ;; Reparent xwem minib client to parent + ;; XXX XXX + (setf (X-Geom-x (xwem-cl-xgeom cl)) 0) + (setf (X-Geom-y (xwem-cl-xgeom cl)) 0) + (XReparentWindow (xwem-dpy) (xwem-minib-cl-xwin minib) + (xwem-minib-xwin minib) 0 0) + + ;; Set minibuffer focus model + (xwem-focus-mode-set cl 'minibuffer) + + ;; Install minibuffer local keymap + (xwem-use-local-map xwem-minibuffer-map cl) + + ;; Finnally refit cl and map parent + (xwem-refit cl) + (XMapWindow (xwem-dpy) (xwem-minib-xwin minib)) + + ;; Set default minibuffer, if not already set + (unless (xwem-cl-p (xwem-minib-cl xwem-minibuffer)) + (setq xwem-minibuffer minib) + (when xwem-minibuffer-set-default-minibuffer-frame + (setq default-minibuffer-frame (xwem-minib-frame xwem-minibuffer)))) + + ;; Now activate minibuffer + (xwem-activate cl))) + +(define-xwem-deffered xwem-minib-apply-pxgeom (minib) + "Apply MINIB's parent geometry to life." + (let ((pxgeom (xwem-minib-xgeom minib))) + (XMoveResizeWindow (xwem-dpy) + (xwem-minib-xwin minib) + (X-Geom-x pxgeom) + (X-Geom-y pxgeom) + (X-Geom-width pxgeom) + (X-Geom-height pxgeom)))) + +;; +;; Some bug here: + +;; Do `(xwem-refit (xwem-minib-cl xwem-minibuffer))' - xwem minib +;; will change its width. (ONLY when xwem-minib-resize-mode is on) + +(defun xwem-refit-minibuffer (cl) + "Refit xwem minibuffer client CL." + (xwem-debug 'xwem-minib "Refiting ..") + + (let ((cl-xgeom (xwem-cl-xgeom cl)) + (pxgeom (xwem-minib-xgeom (xwem-cl-minibuffer cl)))) + + ;; Adjust geometry a little to fill into xwem-minib-xwin and apply + ;; changes to life + (xwem-cl-apply-new-xgeom cl) + (xwem-cl-correct-size-for-size cl + (make-X-Geom :x 0 :y 0 +:width (X-Geom-width-with-borders cl-xgeom) +:height (X-Geom-height-with-borders cl-xgeom) +:border-width (X-Geom-border-width cl-xgeom)) + 'left 'top) + (xwem-cl-apply-xgeom cl) + + ;; Check maybe parent need to be resized/moved? + (unless (= (X-Geom-height-with-borders cl-xgeom) + (X-Geom-height pxgeom)) + (decf (X-Geom-y pxgeom) + (- (X-Geom-height-with-borders cl-xgeom) + (X-Geom-height pxgeom))) + (setf (X-Geom-height pxgeom) + (X-Geom-height-with-borders cl-xgeom)) + (xwem-minib-apply-pxgeom (xwem-cl-minibuffer cl))))) + +(defun xwem-minibuffer-autohide-timer (cl) + (when (and (numberp xwem-minibuffer-autohide-timeout) + +;; X-CVS: $Id: xwem-misc.el,v 1.15 2004/12/08 19:11:30 lg Exp $ ;; This file is part of XWEM. ＠＠ -40,47 +40,205 ＠＠ ;;; Code: ;;  -(require 'xlib-xwin) +(require 'xlib-xlib) +(require 'xlib-img) + +(require 'xwem-load) (eval-and-compile + (defvar iswitchb-buflist nil) ; shutup compiler + (defvar x-emacs-application-class nil) + (autoload 'iswitchb-read-buffer "iswitchb") ; shutup compiler + (defvar elp-function-list nil) ; shut up compiler (autoload 'elp-instrument-list "elp" nil t) (autoload 'elp-results "elp" nil t) (autoload 'calc-eval "calc")) +(defmacro xwem-gc-function-choice () + "Return choice dialog to select GC function." + `(`(choice (const :tag "None" nil) + (const :tag "Clear" X-GXClear) + (const :tag "And" X-GXAnd) + (const :tag "Reverse And" X-GXAndReverse) + (const :tag "Inverted And" X-GXAndInverted) + (const :tag "Xor" X-GXXor) + (const :tag "Or" X-GXOr) + (const :tag "Reverse Or" X-GXOrReverse) + (const :tag "Inverted Or" X-GXOrInverted) + (const :tag "Nor" X-GXNor) + (const :tag "Equive" X-GXEquiv) + (const :tag "Invert" X-GXInvert) + (const :tag "Copy" X-GXCopy) + (const :tag "Inverted Copy" X-GXCopyInverted) + (const :tag "Set" X-GXSet)))) + +(defmacro xwem-cursor-shape-choice () + "Return choice dialog to select cursor shape." + `(`(choice (const :tag "Left" X-XC-left_ptr) + (const :tag "Left w/mask" (X-XC-left_ptr)) + (const :tag "Right" X-XC-right_ptr ) + (const :tag "Right w/mask" (X-XC-right_ptr )) + (const :tag "Cross" X-XC-cross) + (const :tag "Cross w/mask" (X-XC-cross)) + (const :tag "Reverse Cross" X-XC-cross_reverse) + (const :tag "Reverse Cross w/mask" (X-XC-cross_reverse)) + (const :tag "Crosshair" X-XC-crosshair) + (const :tag "Crosshair w/mask" (X-XC-crosshair)) + (const :tag "Daimond cross" X-XC-diamond_cross) + (const :tag "Daimond cross w/mask" (X-XC-diamond_cross)) + ;; TODO: add more, take a look at Cursors section in + ;; xlib-const.el + (const :tag "Dot" X-XC-dot) + (const :tag "Dot w/mask" (X-XC-dot)) + (const :tag "Square Icon" X-XC-icon) + (const :tag "Square Icon w/mask" (X-XC-icon)) + (const :tag "Fluer" X-XC-fleur) + (const :tag "Fluer w/mask" (X-XC-fleur)) + + ;; Arrows + (const :tag "Down Arrow" X-XC-sb_down_arrow) + (const :tag "Down Arrow w/mask" (X-XC-sb_down_arrow)) + (const :tag "Question Arrow" X-XC-question_arrow) + (const :tag "Question Arrow w/mask" (X-XC-question_arrow)) + + (const :tag "TopLeft Arrow" X-XC-top_left_arrow) + (const :tag "TopLeft Arrow w/mask" (X-XC-top_left_arrow)) + (const :tag "Draft large" X-XC-draft_large) + (const :tag "Draft large w/mask" (X-XC-draft_large)) + (const :tag "Draft small" X-XC-draft_small) + (const :tag "Draft small w/mask" (X-XC-draft_small)) + + ;; Corners + (const :tag "Bottom Left corner" X-XC-bottom_left_corner) + (const :tag "Bottom Left corner w/mask" (X-XC-bottom_left_corner)) + (const :tag "Bottom Right corner" X-XC-bottom_right_corner) + (const :tag "Bottom Right corner w/mask" (X-XC-bottom_right_corner)) + (const :tag "Top Left corner" X-XC-top_left_corner) + (const :tag "Top Left corner w/mask" (X-XC-top_left_corner)) + (const :tag "Top Right corner" X-XC-top_right_corner) + (const :tag "Top Right corner w/mask" (X-XC-top_right_corner)) + + (const :tag "Gumby guy" X-XC-gumby) + (const :tag "Gumby guy w/mask" (X-XC-gumby)) + ))) + +(defmacro xwem-cus-set-cursor-foreground (cursor) + "Generate :set function to change CURSOR's foreground" + `(lambda (sym val) + (set sym val) + (when ,cursor + (xwem-cursor-recolorize ,cursor val)))) + +(defmacro xwem-cus-set-cursor-background (cursor) + "Generate :set function to change CURSOR's background" + `(lambda (sym val) + (set sym val) + (when ,cursor + (xwem-cursor-recolorize ,cursor nil val)))) + +(defmacro xwem-cus-set-cursor-shape (cursor &optional xwin) + "Generate :set function to change CURSOR's background" + `(lambda (sym val) + (set sym val) + (when ,cursor + (let ((ncur (copy-X-Cursor ,cursor)) + src-char msk-char) + (cond ((listp val) + (setq src-char (eval (car val)) + msk-char (1+ src-char))) + (t (setq src-char (eval val) + msk-char src-char))) + (setf (X-Cursor-id ncur) (X-Dpy-get-id (X-Cursor-dpy ,cursor))) + (setf (X-Cursor-src-char ncur) src-char) + (setf (X-Cursor-msk-char ncur) msk-char) + (XFreeCursor (X-Cursor-dpy ,cursor) ,cursor) + (XCreateGlyphCursor (X-Cursor-dpy ncur) ncur) + (setq ,cursor ncur))) + (if (listp ,xwin) + (mapc (lambda (xw) + (when (and xw (X-Win-p xw)) + (XSetWindowCursor (X-Win-dpy xw) xw ,cursor))) + ,xwin) + (when (and ,xwin (X-Win-p ,xwin)) + (XSetWindowCursor (X-Win-dpy ,xwin) ,xwin ,cursor))))) + (define-error 'xwem-internal-error "Internal XWEM error.") (defgroup xwem-misc nil "Group to customize miscellaneous options." -:prefix "xwem-misc-" +:prefix "xwem-" :group 'xwem) (defcustom xwem-messages-buffer-name " *xwem-messages*" "*Buffer name for xwem messages." :type 'string -:group 'xwem) +:group 'xwem-misc) (defcustom xwem-messages-buffer-lines 1000 "*Maximum lines in xwem messages buffer." :type 'number -:group 'xwem) +:group 'xwem-misc) + +(defconst xwem-messages-builtin-labels + '(info note error warning alarm todo prompt progress nolog asis) + "List of builtin labels.") + +;;;###autoload +(defcustom xwem-messages-ignore-labels + '(prompt progress nolog) + "*List of message labels to ignore putting them into xwem message log buffer." +:type '(repeat (choice (symbol :tag "Custom label") + (const :tag "Alarm" alarm) + (const :tag "Error" error) + (const :tag "Warning" warning) + (const :tag "Info" info) + (const :tag "Note" note) + (const :tag "TODO" todo) + (const :tag "Prompt" prompt) + (const :tag "Progress" progress) + (const :tag "NoLog" nolog))) +:group 'xwem-misc) -(defcustom xwem-misc-functions-to-profile - '(X-Create-message - X-Dpy-parse-message - string->int - string4->int - X-Dpy-grab-bytes - X-Dpy-filter - X-Dpy-parse-message-guess - accept-process-output - X-Text-width - X-Text-height - XImagePut) +(defcustom xwem-messages-beeps-alist + '((warning . warning) + (error . error) + (alarm . alarm)) + "*Alist in form (MSG-LABEL . SOUND). +Where SOUND is element of `xwem-sound-alist'." +:type `(repeat (cons (symbol :tag "Message Label") + ,(nconc '(choice) + (mapcar (lambda (ss) + (list 'const :tag (symbol-name (car ss)) (car ss))) + xwem-sound-alist) + '((symbol :tag "Sound type"))))) +:group 'xwem-misc) + +(defcustom xwem-messages-label-prefixes + '((warning "Warning" (red)) + (error "Erorr" (red bold)) + (alarm "Alarm" (red bold italic)) + (note "Note" (yellow)) + (info "Info" (default)) + (todo "TODO" (bold))) + "List of prefixes for certain labels. +CAR is label." +:type '(list (symbol :tag "Message label") string (repeat face)) +:group 'xwem-misc) + +(defcustom xwem-misc-functions-to-profile nil "List of functions to profile using xwem profiler." -:type '(repeat function) +:type (list 'repeat (cons 'choice + (delq nil + (mapcar (lambda (fun) + (and (symbolp fun) + (fboundp fun) + (> (length (symbol-name fun)) 4) + (string= "xwem" (substring (symbol-name fun) 0 4)) + (list 'function-item fun))) + obarray)))) :group 'xwem-misc) ;;; Cursors ＠＠ -93,137 +251,219 ＠＠ (defcustom xwem-cursor-default-shape 'X-XC-left_ptr "*Shape of default xwem cursor." :type (xwem-cursor-shape-choice) +:set (xwem-cus-set-cursor-shape xwem-cursor-default) +:initialize 'custom-initialize-default :group 'xwem-cursor) (defcustom xwem-cursor-default-foreground-color "#002800" "*Default cursor's foreground color." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-foreground xwem-cursor-default) +:initialize 'custom-initialize-default :group 'xwem-cursor) (defcustom xwem-cursor-default-background-color "#000000" "*Default cursor's background color." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-background xwem-cursor-default) +:initialize 'custom-initialize-default :group 'xwem-cursor) ;; wait cursor (defcustom xwem-cursor-wait-shape 'X-XC-icon "*Shape of cursor, when XWEM wait for something." :type (xwem-cursor-shape-choice) +:set (xwem-cus-set-cursor-shape xwem-cursor-wait) +:initialize 'custom-initialize-default :group 'xwem-cursor) (defcustom xwem-cursor-wait-foreground-color "#ea0000" "*Cursor's foreground color when XWEM wait for something." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-foreground xwem-cursor-wait) +:initialize 'custom-initialize-default :group 'xwem-cursor) -(defcustom xwem-cursor-wait-background-color nil;"#280000" +(defcustom xwem-cursor-wait-background-color "#280000" "*Cursor's background color when XWEM waiit for something." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-background xwem-cursor-wait) +:initialize 'custom-initialize-default :group 'xwem-cursor) ;; move cursor (defcustom xwem-cursor-move-shape 'X-XC-fleur "*Shape of cursor, when moving something." :type (xwem-cursor-shape-choice) +:set (xwem-cus-set-cursor-shape xwem-cursor-move) +:initialize 'custom-initialize-default :group 'xwem-cursor) (defcustom xwem-cursor-move-foreground-color "#777777" "*Cursor's foreground color when moving something." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-foreground xwem-cursor-move) +:initialize 'custom-initialize-default :group 'xwem-cursor) -(defcustom xwem-cursor-move-background-color nil;"#280000" +(defcustom xwem-cursor-move-background-color "#280000" "*Cursor's background color when moving something." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-background xwem-cursor-move) +:initialize 'custom-initialize-default +:group 'xwem-cursor) + +;; Resize cursor +(defcustom xwem-cursor-resize-shape 'X-XC-sizing + "*Shape of cursor, when resizing something." +:type (xwem-cursor-shape-choice) +:set (xwem-cus-set-cursor-shape xwem-cursor-resize) +:initialize 'custom-initialize-default +:group 'xwem-cursor) + +(defcustom xwem-cursor-resize-foreground-color "#777777" + "*Cursor's foreground color when resizing something." +:type 'color +:set (xwem-cus-set-cursor-foreground xwem-cursor-resize) +:initialize 'custom-initialize-default +:group 'xwem-cursor) + +(defcustom xwem-cursor-resize-background-color "#280000" + "*Cursor's background color when resizing something." +:type 'color +:set (xwem-cus-set-cursor-background xwem-cursor-resize) +:initialize 'custom-initialize-default :group 'xwem-cursor) ;; quote cursor (defcustom xwem-cursor-quote-shape 'X-XC-sb_down_arrow "*Shape of cursor, when XWEM quoting keyboard or mouse." :type (xwem-cursor-shape-choice) +:set (xwem-cus-set-cursor-shape xwem-cursor-quote) +:initialize 'custom-initialize-default :group 'xwem-cursor) (defcustom xwem-cursor-quote-foreground-color "#0000BB" "*Cursor's foreground color when XWEM quoting keyboard/mouse." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-foreground xwem-cursor-quote) +:initialize 'custom-initialize-default :group 'xwem-cursor) (defcustom xwem-cursor-quote-background-color "#000099" "*Cursor's background color when XWEM quoting keyboard/mouse." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-background xwem-cursor-quote) +:initialize 'custom-initialize-default :group 'xwem-cursor) ;; help cursor -(defcustom xwem-cursor-help-shape 'X-XC-question_arrow +(defcustom xwem-cursor-help-shape '(X-XC-question_arrow) "*Shape of cursor, when getting help with XWEM." :type (xwem-cursor-shape-choice) +:set (xwem-cus-set-cursor-shape xwem-cursor-help) +:initialize 'custom-initialize-default :group 'xwem-cursor) (defcustom xwem-cursor-help-foreground-color "#00BB00" "*Cursor's foreground color when quering XWEM for help." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-foreground xwem-cursor-help) +:initialize 'custom-initialize-default :group 'xwem-cursor) (defcustom xwem-cursor-help-background-color "#009900" "*Cursor's background color when quering XWEM for help." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-background xwem-cursor-help) +:initialize 'custom-initialize-default :group 'xwem-cursor) +;;; Internal variables + ;; cursor storages -;;;###autoload (defvar xwem-cursor-fnt nil "Font for \"cursor\" series.") -;;;###autoload (defvar xwem-cursor-default nil "Default cursor.") -;;;###autoload (defvar xwem-cursor-left nil "Left cursor.") -;;;###autoload (defvar xwem-cursor-right nil "Right cursor.") -;;;###autoload (defvar xwem-cursor-wait nil "Cursor when we are wait.") -;;;###autoload (defvar xwem-cursor-drag nil "Cursor when we drag. Drug is a bad idea.") -;;;###autoload (defvar xwem-cursor-move nil "Cursor when we move something.") -;;;###autoload +(defvar xwem-cursor-rsz-vert nil) +(defvar xwem-cursor-rsz-horz nil) (defvar xwem-cursor-resize nil "Cursor when we resize.") -;;;###autoload (defvar xwem-cursor-quote nil "Cursor when quoting key.") -;;;###autoload (defvar xwem-cursor-help nil "Cursor when in help mode.") +(defvar xwem-misc-mask-pixmap nil "Pixmap with depth 1.") +;;;###xwem-autoload +(defvar xwem-misc-mask-fgc nil "X-Gc with foreground 1.0 destination drawable has depth 1.") +;;;###xwem-autoload +(defvar xwem-misc-mask-bgc nil "X-Gc with foreground 1.0 destination drawable has depth 1.") + +;;; Macros +(defmacro xwem-xwin-frame (xwin) + "Return XWEM frame, which X window is XWIN." + `(X-Win-get-prop ,xwin 'xwem-frame)) + +;;;###xwem-autoload +(defmacro xwem-xwin-cl (xwin) + "Return CL, which X window is XWIN." + `(X-Win-get-prop ,xwin 'xwem-cl)) +(defsetf xwem-xwin-cl (xwin) (cl) + `(if (not ,cl) + (X-Win-rem-prop ,xwin 'xwem-cl) + (X-Win-put-prop ,xwin 'xwem-cl ,cl))) + ;;; Functions -(defsubst xwem-misc-colorspec->rgb-vector (colspec) +;;;###xwem-autoload +(defun xwem-misc-colorspec->rgb-vector (colspec) "Conver color specification COLSPEC to internal representation. COLSPEC maybe in form: #RRGGBB or name like 'green4'." (vconcat (color-instance-rgb-components (make-color-instance colspec)))) -(defsubst xwem-misc-colorspec->rgb-vector-safe (colspec &optional defret) +;;;###xwem-autoload +(defun xwem-misc-colorspec->rgb-vector-safe (colspec &optional defret) "Validate COLSPEC to be color specification in safe manner. Return DEFRET or [0 0 0] if there was error." (condition-case nil (xwem-misc-colorspec->rgb-vector colspec) (t (or defret [0 0 0])))) -(defsubst xwem-misc-colorspec-valid-p (colspec) +;;;###xwem-autoload +(defun xwem-misc-colorspec-valid-p (colspec) "Return non-nil if COLSPEC is valid color specification. Valid colorspecification is spec in form: #RRGGBB or name like 'green4'." (condition-case nil (xwem-misc-colorspec->rgb-vector colspec) (t nil))) -;;;###autoload +;;;###xwem-autoload +(defun xwem-make-color (colorspec &optional cmap) + "Create X-Color according to COLORSPEC." + (let ((ccol (xwem-misc-colorspec->rgb-vector-safe colorspec [0 0 0]))) + (make-X-Color :red (aref ccol 0) :green (aref ccol 1) :blue (aref ccol 2)))) + +;;;###xwem-autoload (defun xwem-make-cursor (type &optional fgcol bgcol) "Make new cursor of TYPE and store it in WHERE-STORE. BGCOL maybe nil, that mean masking will not be done." + (xwem-cursors-init) ; make sure cursor font loaded + (let ((fgc (xwem-misc-colorspec->rgb-vector-safe fgcol [0 0 0])) (bgc (xwem-misc-colorspec->rgb-vector-safe bgcol 'invalid-bgcol)) - cursor) + src-char msk-char cursor) + (cond ((listp type) + (setq src-char (eval (car type)) + msk-char (1+ src-char))) + (t (setq src-char (eval type) + msk-char src-char))) (setq cursor (make-X-Cursor :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy)) :source xwem-cursor-fnt :mask xwem-cursor-fnt -:src-char type -:msk-char (+ (if (eq bgc 'invalid-bgcol) 0 1) type) +:src-char src-char +:msk-char msk-char :fgred (aref fgc 0) :fggreen (aref fgc 1) :fgblue (aref fgc 2))) ＠＠ -235,48 +475,60 ＠＠ (XCreateGlyphCursor (xwem-dpy) cursor) cursor)) -;;;###autoload -(defun xwem-init-cursors () - "Initialize cursors." - ;; Make cursors - (xwem-message 'msg "Initializing cursors ... wait") - - (setq xwem-cursor-fnt (make-X-Font :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy)) -:name "cursor")) - (XOpenFont (xwem-dpy) xwem-cursor-fnt) +;;;###xwem-autoload +(defun xwem-cursor-recolorize (cursor new-fg &optional new-bg) + "Recolorize CURSOR to use NEW-FG foreground and NEW-BG background." + (let ((fgc (xwem-misc-colorspec->rgb-vector-safe + new-fg (vector (X-Cursor-fgred cursor) + (X-Cursor-fggreen cursor) + (X-Cursor-fgblue cursor)))) + (bgc (xwem-misc-colorspec->rgb-vector-safe + new-bg (vector (X-Cursor-bgred cursor) + (X-Cursor-bggreen cursor) + (X-Cursor-bgblue cursor))))) + (XRecolorCursor (xwem-dpy) cursor + (aref fgc 0) (aref fgc 1) (aref fgc 2) + (aref bgc 0) (aref bgc 1) (aref bgc 2)))) - (setq xwem-cursor-default (xwem-make-cursor (eval xwem-cursor-default-shape) +(defun xwem-cursors-init () + "Initialize cursors." + (unless xwem-cursor-fnt + ;; Make cursors + (xwem-message 'init "Initializing cursors ...") + + (setq xwem-cursor-fnt (make-X-Font :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy)) +:name "cursor")) + (XOpenFont (xwem-dpy) xwem-cursor-fnt) + + (setq xwem-cursor-default (xwem-make-cursor xwem-cursor-default-shape + xwem-cursor-default-foreground-color + xwem-cursor-default-background-color) + xwem-cursor-left (xwem-make-cursor X-XC-left_ptr + xwem-cursor-default-foreground-color + + "Clear xwem minibuffer's buffer." + (clear-message label (xwem-minib-frame xwem-minibuffer))) + +(defun xwem-message-insert (label msg &optional append-p) + "Insert message MSG into xwem minibuffer's buffer." + ;; Workaround XEmacs ''feature''. When minibuffer is activated, + ;; and someone uses echo are, XEmacs will wait 2 seconds, so we + ;; will got lag! (see DEFUN `command-loop-1' in cmdloop.c) --lg + ;; + ;; However in newer XEmacsen there is + ;; `minibuffer-echo-wait-function' variable, which controls + ;; behaviour. --lg + (when (zerop (minibuffer-depth)) + ;; Activate minibuffer, if not ignoring this label + (when (and xwem-minibuffer + (xwem-minib-cl xwem-minibuffer) + (not (memq label xwem-messages-ignore-labels))) + (xwem-activate (xwem-minib-cl xwem-minibuffer))) + (add-to-list 'log-message-ignore-labels label) ; avoid logging in *Messages* + (if append-p + (append-message label msg (and xwem-minibuffer (xwem-minib-frame xwem-minibuffer))) + (display-message label msg (and xwem-minibuffer (xwem-minib-frame xwem-minibuffer)))))) + +(defun xwem-message-label-prefix (label) + "Return prefix string, according to LABEL. +Return nil if no prefix required for label." + (let ((lp (assq label xwem-messages-label-prefixes))) + (when lp + (concat "XWEM" (if (and (stringp (cadr lp)) + (not (zerop (length (cadr lp))))) + "-" "") + (funcall 'xwem-str-with-faces (cadr lp) (caddr lp)) + ": ")))) + +(defun xwem-message-maybe-beep (label) + "If LABEL is beepable, then beep." + ;; Beep if needed + (let ((snd (assq label xwem-messages-beeps-alist))) + (when snd + (xwem-play-sound (cdr snd))))) + +(defun xwem-message-1 (label fmt append-p &rest args) + (let* ((print-level 3) ; XXX limit print level + (msg (if (eq label 'asis) fmt (apply 'format fmt args))) + (lp (xwem-message-label-prefix label))) + (when lp + (setq msg (concat lp msg))) + (xwem-message-log label msg) + (xwem-message-maybe-beep label) + + (xwem-message-insert label msg append-p))) + +(defun xwem-message-append (label fmt &rest args) + "Append message of LABEL type. +Message formatted using FTM and ARGS." + (apply 'xwem-message-1 label fmt t args)) + +;;;###xwem-autoload +(defun xwem-message (label fmt &rest args) + "Display xwem message of TYPE using FMT format." + (apply 'xwem-message-1 label fmt nil args)) -;;;###autoload(autoload 'xwem-show-message-log "xwem-misc") +;;;###autoload(autoload 'xwem-show-message-log "xwem-misc" nil t) (define-xwem-command xwem-show-message-log (arg) "Show `xwem-messages-buffer-name'. If prefix ARG is given, than behaviour is undefined." ＠＠ -519,10 +845,9 ＠＠ (with-current-buffer mbuf (setq mode-name "XWEM-log") (local-set-key (kbd "q") 'delete-frame) - (message "Press `q' to eliminate buffer.") + (xwem-message 'msg "Press `q' to eliminate buffer.") ))) -;;;###autoload (defun xwem-list-to-string (list len) "Convert LIST of characterters to string with length LEN." (let ((rstr "")) ＠＠ -533,15 +858,15 ＠＠ rstr)) ;;;; Misc commands. -;;;###autoload(autoload 'xwem-ignore-command "xwem-misc") -(define-xwem-command xwem-ignore-command () +;;;###autoload(autoload 'xwem-ignore-command "xwem-misc" nil t) +(define-xwem-command xwem-ignore-command (&rest args) "Generic ignore command." (xwem-interactive)) (defvar xwem-read-expression-history nil "*History of expressions evaled using `xwem-eval-expression'.") -;;;###autoload(autoload 'xwem-eval-expression "xwem-misc") +;;;###autoload(autoload 'xwem-eval-expression "xwem-misc" nil t) (define-xwem-command xwem-eval-expression (expr &optional arg) "Eval Lisp expression interactively. When used with prefix ARG, then insert the result into selected client." ＠＠ -557,21 +882,20 ＠＠ (if arg (xwem-key-send-ekeys (prin1-to-string (car values))) - (xwem-message 'info "%S => %S" expr (c -;;;###autoload (defun xwem-misc-linesp-height (linesp) "Return height of line spec LINESP." (apply 'max (mapcar (lambda (el) ＠＠ -777,7 +1105,6 ＠＠ (cdr el))) linesp))) -;;;###autoload (defun xwem-misc-linesp-show (xwin x y linesp &optional type default-background) "In x window XWIN at X and Y coordinates show line spec LINESP. TYPE is one of XImageString or XDrawString, default is XImageString." ＠＠ -796,7 +1123,6 ＠＠ (X-Gc-font (xwem-face-get-gc (car el))) (cdr el))))) linesp))) -;;;###autoload (defun xwem-misc-textsp-show (xwin x y textsp &optional type default-background) "In x window XWIN at X and Y coordinates show text spec TEXTSP. TYPE is one of XImageString or XDrawString, default is XImageString. ＠＠ -804,38 +1130,46 ＠＠ that have different than DEFAULT-BACKGROUND baground color are drawed using XImageString." (let ((yoff 0)) - (X-Dpy-send-excursion (X-Win-dpy xwin) - (mapc (lambda (el) - (xwem-misc-linesp-show xwin x (+ y yoff) el type default-background) - (setq yoff (+ yoff (xwem-misc-linesp-height el)))) - textsp) - ))) + (mapc (lambda (el) + (xwem-misc-linesp-show xwin x (+ y yoff) el type default-background) + (setq yoff (+ yoff (xwem-misc-linesp-height el)))) + textsp) + )) ;;; Outlining -(defface xwem-misc-outline-face1 - `((t (:foreground "white" :background "black" :function X-GXXor :subwindow-mode X-IncludeInferiors :line-width 4))) +(define-xwem-face xwem-misc-outline-face1 + `((t (:foreground "white" :background "black" +:function X-GXXor :subwindow-mode X-IncludeInferiors +:line-width 4))) "Face used to outline something." +:group 'xwem-misc :group 'xwem-faces) -(defface xwem-misc-outline-face2 - `((t (:foreground "white" :background "black" :function X-GXXor :subwindow-mode X-IncludeInferiors :line-width 2))) +(define-xwem-face xwem-misc-outline-face2 + `((t (:foreground "white" :background "black" +:function X-GXXor :subwindow-mode X-IncludeInferiors +:line-width 2))) "Face used to outline something." +:group 'xwem-misc :group 'xwem-faces) -;;;###autoload -(defun xwem-misc-outline (xrect how) - "Outline XRECT using HOW method. -Valid HOW is 'normal, ..." +(defun xwem-misc-outline (xrect how &optional xwin) + "Outline XRECT using HOW method in XWIN. +Valid HOW is 'normal, ... +If XWIN is not specified, X root window is used." + (unless xwin + (setq xwin (xwem-rootwin))) + (let ((x (X-Rect-x xrect)) (y (X-Rect-y xrect)) (w (X-Rect-width xrect)) (h (X-Rect-height xrect))) (cond ((eq how 'normal) - (XDrawRectangles (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face1) (list xrect))) + (XDrawRectangles (xwem-dpy) xwin (xwem-face-get-gc 'xwem-misc-outline-face1) (list xrect))) ((eq how 'contiguous) (xwem-misc-outline xrect 'normal) - (XDrawSegments (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face2) + (XDrawSegments (xwem-dpy) xwin (xwem-face-get-gc 'xwem-misc-outline-face2) (list (cons (cons x 0) (cons x (X-Geom-height (xwem-rootgeom)))) (cons (cons (+ x w) 0) ＠＠ -850,7 +1184,7 ＠＠ (let* ((cornw (/ w 8)) (cornh (/ h 8)) (crw (/ (+ cornh cornw) 2))) - (XDrawSegments (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face1) + (XDrawSegments (xwem-dpy) xwin (xwem-face-get-gc 'xwem-misc-outline-face1) (list ;; Top left (cons (cons x y) (cons (+ x cornw) y)) ＠＠ -875,7 +1209,7 ＠＠ ((eq how 'grid) (xwem-misc-outline xrect 'normal) - (XDrawSegments (xwem-dpy) (xwem-rootwin) (xwem-fa + (while (not (string= utf8-string "")) + (setq fc (aref utf8-string 0)) + (when (= (logand #xa0 fc) #xa0) + (error "unsupported utf8 character type %d" fc)) + (setq ulen (if (zerop (logand #x80 fc)) 1 2)) + + (if (= ulen 1) + (setq rstr (concat rstr (char-to-string fc)) + utf8-string (substring utf8-string 1)) + (setq rstr (concat rstr + (char-to-string + (xwem-misc-utf8-to-koi8-char + (logior (lsh (logand #xf fc) 6) + (logand #x3f (aref utf8-string 1)))))) + utf8-string (substring utf8-string 2)))) + rstr)) + +;;; Image rotator +(defun xwem-misc-rotidx-left (i w h depth) + (setq i (/ i depth)) + (let* ((y (/ i w)) + (x (% i w)) + (x1 y) + (y1 (- w x 1))) + (* (+ (* y1 h) x1) depth))) + +(defun xwem-misc-rotidx-right (i w h depth) + (setq i (/ i depth)) + (let* ((y (/ i w)) + (x (% i w)) + (x1 (- h y 1)) + (y1 x)) + (* (+ (* y1 h) x1) depth))) + +;;;###xwem-autoload +(defun xwem-misc-rotate-data (data w h depth &optional rotate) + "Rotate DATA obtained from XGetImage for use by XPutImage." + (unless (member depth '(8 16 24 32)) + (error 'xwem-error (format "Unsupported depth %d, use one of (8 16 24 32)" depth))) + (setq depth (truncate (/ depth 8))) + + (unless rotate + (setq rotate 'left)) + (setq rotate + (if (eq rotate 'left) + 'xwem-misc-rotidx-left + 'xwem-misc-rotidx-right)) + + (let* ((gc-cons-threshold most-positive-fixnum) ; inhibit GCing + (dstr (make-string (* w h depth) ?\x00)) + (dlen (length data)) + (i 0) + off j) + (while (< i dlen) + (setq off (funcall rotate i w h depth)) + (setq j 0) + (while (< j depth) + (aset dstr (+ off j) (aref data (+ i j))) + (incf j)) + (setq i (incf i depth))) + dstr)) + +;;;###xwem-autoload +(defun xwem-debug (routine fmt &rest fmt-args) + (let ((print-level 3)) ; XXX Restrict huge output + (apply 'X-Dpy-log (xwem-dpy) routine fmt fmt-args))) +  (provide 'xwem-misc) + +;;; On-load hooks: +; - Misc initialize +(if xwem-started + (xwem-misc-init) + (add-hook 'xwem-before-init-wins-hook 'xwem-misc-init)) ;;; xwem-misc.el ends here Index: lisp/xwem-modes.el =================================================================== RCS file: lisp/xwem-modes.el diff -N lisp/xwem-modes.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-modes.el 1 Jan 2005 04:41:15 -0000 ＠＠ -0,0 +1,89 ＠＠ +;;; xwem-modes.el --- + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Created: Mon Oct 18 22:36:23 MSD 2004 +;; Keywords: xwem +;; X-CVS: $Id: xwem-modes.el,v 1.1 2004/11/29 20:41:54 lg Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; + +;;; Code: + +(require 'xwem-load) + +;;;###xwem-autoload +(defvar xwem-minor-mode-alist nil + "Alist saying how to show minor modes. +Each element is a list which looks like (VAR STRING). +STRING is shown when VAR is non-nil.") + +;;;###xwem-autoload +(defvar xwem-minor-mode-map-alist nil + "Alist of keymaps for use of minor modes. +Each element looks like (VAR . KEYMAP).") + +;;;###xwem-autoload +(defun xwem-add-minor-mode (toggle name &optional keymap) + "Add a minor mode to `xwem-minor-mode-alist'. + +For TOGGLE, NAME, KEYMAP, usage take a look at `add-minor-mode'." + (setq xwem-minor-mode-alist + (put-alist toggle (list name) xwem-minor-mode-alist)) + (when (keymapp keymap) + (setq xwem-minor-mode-map-alist + (put-alist toggle keymap xwem-minor-mode-map-alist)))) + +;;;###xwem-autoload +(defun xwem-turn-on-minor-mode (cl mm-toggle) + "On CL, turn on minor mode MM-TOGGLE." + (unless (or (and (xwem-client-local-variable-p mm-toggle) + (xwem-client-local-variable-value cl mm-toggle)) + (symbol-value mm-toggle)) + (let ((kmap (assq mm-toggle xwem-minor-mode-map-alist))) + (when (keymapp (cdr kmap)) + (xwem-kbd-install-grab (cdr kmap) (xwem-cl-xwin cl)))) + + (if (xwem-client-local-variable-p mm-toggle) + (xwem-client-local-variable-set cl mm-toggle t) + (set-variable mm-toggle t)))) + +;;;###xwem-autoload +(defun xwem-turn-off-minor-mode (cl mm-toggle) + "On CL, turn off minor mode MM-TOGGLE." + (when (or (and (xwem-client-local-variable-p mm-toggle) + (xwem-client-local-variable-value cl mm-toggle)) + (symbol-value mm-toggle)) + (let ((kmap (assq mm-toggle xwem-minor-mode-map-alist))) + (when (keymapp (cdr kmap)) + (xwem-kbd-uninstall-grab (cdr kmap) (xwem-cl-xwin cl)))) + (if (xwem-client-local-variable-p mm-toggle) + (xwem-client-local-variable-set cl mm-toggle nil) + (set-variable mm-toggle nil)))) + + +(provide 'xwem-modes) + +;;; xwem-modes.el ends here Index: lisp/xwem-mouse.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-mouse.el,v retrieving revision 1.8 diff -u -u -r1.8 xwem-mouse.el --- lisp/xwem-mouse.el 16 Dec 2004 08:08:10 -0000 1.8 +++ lisp/xwem-mouse.el 1 Jan 2005 04:41:15 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: 21 Mar 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xwem-mouse.el,v 1.8 2004/12/16 08:08:10 youngs Exp $ +;; X-CVS: $Id: xwem-mouse.el,v 1.7 2004/12/05 05:52:29 youngs Exp $ ;; This file is part of XWEM. ＠＠ -32,6 +32,10 ＠＠ ;;; Code:  +(require 'xwem-load) +(require 'xwem-manage) + +;;; Customisation (defcustom xwem-popup-menu-function 'popup-menu "*Function used to popup menus. It is created for case when you change default `popup-menu' function, ＠＠ -39,6 +43,8 ＠＠ :type 'function :group 'xwem) +;;; Internal variables +  (defun xwem-mouse-change-cursor (cursor) "XXX. ＠＠ -65,47 +71,159 ＠＠ ) ;;; Menus +;;;###autoload +(defun xwem-popup-menu (menu &optional event) + "Popup MENU. +MENU and EVENT is same as for `popup-menu'." + (xwem-mouse-ungrab) + + (funcall xwem-popup-menu-function menu + (or event (and (member (event-type xwem-last-event) '(button-press button-release motion)) xwem-last-event)))) + (defvar xwem-applications-submenu '("Applications" - ["XEmacs" (make-frame)] - ["xterm" (xwem-execute-program "xterm")] - ["gv" (xwem-execute-program "gv")] - ["xfontsel" (xwem-execute-program "xfontsel")] - ) + ("XEmacs" + ["New frame" (make-frame nil (default-x-device))] + ["*scratch* frame" (with-selected-frame (make-frame nil (default-x-device)) + (switch-to-buffer "*scratch*"))]) + ("XTerm" + ["Default xterm" (xwem-launch-xterm nil)] + ["2 xterm" (xwem-launch-xterm 2)] + ["3 xterm" (xwem-launch-xterm 3)] + ["4 xterm" (xwem-launch-xterm 4)]) + ["Mozilla" (xwem-execute-program "mozilla")] + "--" + ["GhostView" (xwem-execute-program "gv")] + ["xfontsel" (xwem-execute-program "xfontsel")] + ["Lupe" (xwem-launch-lupe nil)] + ) "Submenu with applications.") -(defvar xwem-menu - (list "XWEM Menu" - xwem-applications-submenu - '("Windows" - ["Vertical Split" (xwem-frame-split-vert nil)] - ["Horizontal Split" (xwem-frame-split-horiz nil)] - ["Delete Window" (xwem-window-delete)] - ["Delete Others" (xwem-window-delete-others)] - ["Balance" (xwem-balance-windows (xwem-frame-selected))]) - ) - "Popup menu to be used by xwem." - ) +;;;###xwem-autoload +(defun xwem-generate-window-menu (title &optional win) + "Generate menu for WIN." + (unless title + (setq title "Window")) + (list title + (vector "Vertical Split" `(xwem-window-split-vertically nil ,win)) + (vector "Horizontal Split" `(xwem-window-split-horizontally nil ,win)) + (vector "Delete Window" `(xwem-window-delete ,win)) + (vector "Delete Others" `(xwem-window-delete-others ,win)) + (vector "Balance" `(xwem-balance-windows ,win)))) + +(defun xwem-generate-iconified-cl-menu (title &optional max-mwidth) + "Generate menu for iconified clients with TITLE. +MAX-MWIDTH specifies maximum menu width." + (list (xwem-misc-fixup-string title max-mwidth) +:filter + `(lambda (not-used) + (delq nil + (mapcar (lambda (cl) + (when (eq (xwem-cl-state cl) 'iconified) + (vector (xwem-misc-fixup-string (xwem-client-name cl) ,max-mwidth) + `(xwem-select-client ,cl) +:active (xwem-non-dummy-client-p cl)))) + xwem-clients))))) + +(defun xwem-generate-applications-cl-menu (title &optional max-mwidth) + "Generate menu for applications." + (list (xwem-misc-fixup-string title max-mwidth) +:filter `(lambda (not-used) + (mapcar (lambda (app-spec) + (list (xwem-misc-fixup-string (car app-spec) ,max-mwidth) +:filter `(lambda (not-used) + (delq nil + (mapcar (lambda (cl) + (when (xwem-cl-match-p cl (cdr (quote ,app-spec))) + (vector (xwem-misc-fixup-string (xwem-client-name cl) ,,max-mwidth) + `(xwem-select-client ,cl) +:active (xwem-non-dummy-client-p cl)))) + xwem-clients))))) + xwem-applications-alist)))) + +;;;###xwem-autoload +(defun xwem-generate-clients-menu (title &optional max-mwidth) + "Generate clients menu. +TITLE is menu title. +Optional MAX-MWIDTH argument specifies maximum width for menu items, +default is 42." + (unless max-mwidth + (setq max-mwidth 42)) + + (let (malist) + (mapc (lambda (cl) + (let ((kv (assq (xwem-cl-manage-type cl) malist))) + (if kv + (setcdr kv (cons cl (cdr kv))) + (setq malist (put-alist (xwem-cl-manage-type cl) (list cl) malist))))) + xwem-clients) + + (nconc (list (xwem-misc-fixup-string title max-mwidth)) + (mapcar (lambda (mc) + (list (xwem-misc-fixup-string (symbol-name (car mc)) max-mwidth) +:filter + `(lambda (not-used) + (mapcar (lambda (mccl) + (vector (xwem-misc-fixup-string (xwem-client-name mccl) ,max-mwidth) + `(xwem-select-client ,mccl) +:active (xwem-non-dummy-client-p mccl))) + (cdr (quote ,mc)))))) + malist) + + ;; Iconified + (list "==") + (list (xwem-generate-iconified-cl-menu "Iconified" max-mwidth)) + + ;; Applications + (list "--") + (list (xwem-generate-applications-cl-menu "Applications" max-mwidth)) + ))) -(defun xwem-menu-generate () +;;;###xwem-autoload +(defun xwem-generate-menu () "Generate xwem menu on fly." (list "XWEM Menu" - '("xwem-frames" :filter - (lambda (not-used) - (mapcar (lambda (el) - (let ((fn (xwem-frame-num el))) - (vector - (concat "Frame " (int-to-string fn) ": " (xwem-frame-name el)) - `(xwem-frame-switch-nth ,fn)))) - xwem-frames-list))) - - '("xwem-clients" :filter - (lambda (not-used) - (mapcar (lambda (el) - (let ((nam (xwem-hints-wm-name (xwem-cl-hints el)))) - (vector nam `(xwem-cl-pop-to-client ,el) -:active (if (xwem-cl-exclude-p el) nil t)))) - xwem-clients))) + (list "Minibuffer" + ["Hide" (xwem-iconify (xwem-minib-cl xwem-minibuffer)) +:active (eq (xwem-cl-state (xwem-minib-cl xwem-minibuffer)) 'active) ] + ["Show" (xwem-activate (xwem-minib-cl xwem-minibuffer)) +:active (not (eq (xwem-cl-state (xwem-minib-cl xwem-minibuffer)) 'active)) ] + ["Restore size" (xwem-minib-rsz-resize 1)]) + (xwem-generate-window-menu "Window" (xwem-win-selected)) + "--" + (list "Frames" :filter + (lambda (not-used) + (nconc + (list (list "Operations" + ["New Frame" (xwem-make-frame 'desktop)] + ["Next" (xwem-frame-next 1)] + ["Previous" (xwem-frame-previous 1)] + ["Iconify" (xwem-frame-hide (xwem-frame-selected))] + ["Transpose" (xwem-transpose-frames 1)] + "--" + ["Destroy" (xwem-frame-destroy (xwem-frame-selected))]) + (list "Side-by-side" + ["Vertical" (xwem-frame-sbs-vert-split 1)] + ["Horizontal" (xwem-frame-sbs-hor-split 1)]) + "--" + ["Show Root" (xwem-frame-showroot)] + ["Lower" (xwem-frame-lower (xwem-frame-selected))] + ["Raise" (xwem-frame-raise (xwem-frame-selected))] + ) + (list "==") + (mapcar (lambda (el) + (let ((fn (xwem-frame-num el))) + (vector + (concat "Frame " (int-to-string fn) ": " (xwem-frame-name el)) + `(xwem-frame-switch-nth ,fn)))) + xwem-frames-list)))) + + (list "Clients" :filter + (lambda (not-used) + (nconc + (cdr (xwem-generate-clients-menu nil)) + (list "==") + (and (xwem-cl-selected) (cdr (xwem-generate-cl-menu (xwem-cl-selected) 32)))))) "--" xwem-applications-submenu ＠＠ -117,24 +235,10 ＠＠ "Popup clients menu." (xwem-interactive) - (let ((menu (list "XWEM Clients" :filter - (lambda (not-used) - (mapcar (lambda (cl) - (let ((frame (xwem-cl-frame cl)) - (name (xwem-hints-wm-name (xwem-cl-hints cl)))) - (vector (if (xwem-frame-p frame) - (format "[%d](%s): %s" (xwem-frame-num (xwem-cl-frame cl)) - (xwem-frame-name (xwem-cl-frame cl)) - name) - name) - `(xwem-cl-pop-to-client ,cl) -:active (if (xwem-cl-exclude-p cl) nil t)))) - xwem-clients))))) + (xwem-popup-menu (xwem-generate-clients-menu "XWEM Clients"))) - (xwem-popup-menu menu))) - -;;;###autoload -(defun xwem-gen-cl-menu (cl &optional maxnlen) +;;;###xwem-autoload +(defun xwem-generate-cl-menu (cl &optional maxnlen) "Generate menu for CL. MAXNLEN - maximum menu width in characters." (unless maxnlen ＠＠ -149,46 +253,28 ＠＠ (vector "Info" `(xwem-client-info ,cl)) (vector "Iconify" `(xwem-client-iconify ,cl)) "--:singleDashedLine" - (vector "Transpose ==>" `(xwem-cl-transpose nil ,cl)) - (vector "Transpose <==" `(xwem-cl-transpose '(4) ,cl)) + (vector "Transpose ==>" `(xwem-cl-transpose ,cl)) + (vector "Transpose <==" `(xwem-cl-transpose ,cl '(4))) (vector "Mark client" `(if (xwem-cl-marked-p ,cl) (xwem-client-unset-mark ,cl) - (xwem-client-set-mark nil ,cl)) + (xwem-client-set-mark ,cl)) :style 'toggle :selected `(xwem-cl-marked-p ,cl)) "--:singleDashedLine" (vector "Run Copy" `(xwem-client-run-copy nil ,cl)) (vector "Run Copy other win" `(xwem-client-run-copy-other-win nil ,cl)) (vector "Run Copy other frame" `(xwem-client-run-copy-other-frame nil ,cl)) "--:doubleLine" - (vector "X Soft kill" `(xwem-client-kill nil ,cl)) - (vector "X Hard kill" `(xwem-client-kill '(4) ,cl)) + (vector "X Soft kill" `(xwem-client-kill ,cl)) + (vector "X Hard kill" `(xwem-client-kill ,cl '(4))) )) -;;;###autoload -(defun xwem-popup-menu (menu &optional event) - "Popup MENU. -MENU and EVENT is same as for `popup-menu'." - (xwem-mouse-ungrab) - - (funcall xwem-popup-menu-function menu event)) - -;;;###autoload(autoload 'xwem-popup-function-menu "xwem-mouse") -(define-xwem-command xwem-popup-function-menu (arg) - "Just popup `xwem-menu'. -ARG - Not used yet." - (xwem-interactive "_P") - - ;; TODO: - ;; * use ARG - (xwem-popup-menu xwem-menu)) - -;;;###autoload(autoload 'xwem-popup-auto-menu "xwem-mouse") +;;;###autoload(autoload 'xwem-popup-auto-menu "xwem-mouse" nil t) (define-xwem-command xwem-popup-auto-menu (arg) - "Popup menu generated by `xwem-menu-generate'. + "Popup menu generated by `xwem-generate-menu'. ARG - Not used yet." (xwem-interactive "_P") - (xwem-popup-menu (xwem-menu-generate))) + (xwem-popup-menu (xwem-generate-menu)))  (provide 'xwem-mouse) Index: lisp/xwem-netwm.el =================================================================== RCS file: lisp/xwem-netwm.el diff -N lisp/xwem-netwm.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-netwm.el 1 Jan 2005 04:41:15 -0000 ＠＠ -0,0 +1,582 ＠＠ +;;; xwem-netwm.el --- NETWM stuff. + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; +;; Created: Sat May 15 19:44:58 MSD 2004 +;; Keywords: xwem +;; X-CVS: $Id: xwem-netwm.el,v 1.3 2004/12/05 22:37:35 lg Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; Support for NETWM hints. See specification at: +;; http://www.freedesktop.org/standards/wm-spec/index.html. + +;;; Code: + +(require 'xlib-xlib) +(require 'xlib-xinerama) + +(require 'xwem-load) +(require 'xwem-manage) +(require 'xwem-version) + +(defgroup xwem-fullscreen nil + "Group to customize fullscreen managing + _NET_WM_STATE_BELOW _NET_WM_ALLOWED_ACTIONS _NET_WM_ACTION_MOVE + _NET_WM_ACTION_RESIZE _NET_WM_ACTION_MINIMIZE _NET_WM_ACTION_SHADE + _NET_WM_ACTION_STICK _NET_WM_ACTION_MAXIMIZE_HORZ + _NET_WM_ACTION_MAXIMIZE_VERT _NET_WM_ACTION_FULLSCREEN + _NET_WM_ACTION_CHANGE_DESKTOP _NET_WM_ACTION_CLOSE _NET_WM_STRUT + _NET_WM_ICON_GEOMETRY _NET_WM_ICON _NET_WM_PID _NET_WM_HANDLED_ICONS + _NET_WM_STRUT + + _NET_CURRENT_DESKTOP + _NET_SHOWING_DESKTOP + _NET_SUPPORTING_WM_CHECK + _NET_NUMBER_OF_DESKTOPS + _NET_DESKTOP_GEOMETRY + _NET_ACTIVE_WINDOW)) + +(defconst xwem-nwm-supported + (list _NET_WM_NAME _NET_CURRENT_DESKTOP + _NET_NUMBER_OF_DESKTOPS + _NET_DESKTOP_NAMES _NET_SHOWING_DESKTOP + _NET_WM_STATE _NET_WM_STATE_FULLSCREEN + _NET_CLIENT_LIST _NET_CLIENT_LIST_STACKING + _NET_ACTIVE_WINDOW + ) + ) + +(defun xwem-nwm-init () + "Initialize netwm stuff." + (xwem-message 'init "Initializing NET_WM support ...") + + (mapc (lambda (name) + (XInternAtom (xwem-dpy) name)) + xwem-nwm-atom-names) + + ;; Add client message handler on root window + (X-Win-EventHandler-add-new (xwem-rootwin) 'xwem-nwm-root-evhandler 100 + (list X-ClientMessage X-MapRequest)) + (X-Dpy-EventHandler-add (xwem-dpy) 'xwem-nwm-root-clnmsg 100 + (list X-ClientMessage)) +; ;; Update root event mask +; (setq xwem-root-ev-mask (Xmask-or xwem-root-ev-mask XM- +; (XSelectInput (xwem-dpy) + + ;; Add hooks + (add-hook 'xwem-frame-select-hook 'xwem-nwm-on-frame-select) + (add-hook 'xwem-frame-creation-hook 'xwem-nwm-set-number-of-desktops) + (add-hook 'xwem-frame-destroy-hook 'xwem-nwm-set-number-of-desktops) + + (add-hook 'xwem-cl-create-hook 'xwem-nwm-set-client-list) + (add-hook 'xwem-cl-destroy-hook 'xwem-nwm-set-client-list) + (add-hook 'xwem-client-select-hook 'xwem-nwm-set-active-window) + + ;; Set some properties + (xwem-nwm-set-supported) + (xwem-nwm-set-supporting-wm-check) + + (xwem-nwm-set-number-of-desktops) + (xwem-nwm-set-current-desk) + (xwem-nwm-set-desk-geometry) + + (xwem-nwm-set-client-list) + + (xwem-message 'init "Initializing NET_WM support ... done")) + +(defun xwem-nwm-on-frame-select () + "Called when frame switching occurs, i.e. member of `xwem-frame-select-hook'." + (xwem-nwm-set-current-desk (xwem-frame-selected))) + +(defun xwem-nwm-root-evhandler (xdpy xwin xev) + "Handle netwm's event" + (X-Event-CASE xev + (:X-ClientMessage + (xwem-nwm-root-clnmsg xdpy xwin xev)) + (:X-MapRequest + (xwem-nwm-root-mapreq xdpy xwin xev)))) + +(defun xwem-nwm-root-clnmsg (xdpy xwin xev) + "Dispatch ClientMessage event on root window." + (cond ((string= (X-Atom-name (X-Event-xclient-atom xev)) _NET_CURRENT_DESKTOP) + (let ((num (truncate (caar (X-Event-xclient-msg xev))))) + (xwem-frame-switch-nth num))) + + ((string= (X-Atom-name (X-Event-xclient-atom xev)) _NET_WM_STATE) + (xwem-debug 'xwem-misc "_NET_WM_STATE: -> %S" '(X-Event-xclient-msg xev)) + + (let ((vop (caar (X-Event-xclient-msg xev))) + (stype (caadr (X-Event-xclient-msg xev))) + (cl (xwem-xwin-cl xwin))) + ;; XXX Can handle only FULLSCREEN state + (when (= stype (X-Atom-id (XInternAtom (xwem-dpy) _NET_WM_STATE_FULLSCREEN))) + (cond ((= vop 0) + (xwem-toggle-fullscreen cl 'off)) + ((= vop 1) + (xwem-toggle-fullscreen cl 'on)))))) + )) + +(defun xwem-nwm-root-mapreq (xdpy xwin xev) + "Dispatch map request of XWIN to set _NET_WM_STATE property." + (XChangeProperty xdpy xwin + (XInternAtom xdpy _NET_WM_STATE) + XA-atom X-format-32 X-PropModeReplace + nil) + ) + +(defun xwem-nwm-set-state (xwin &optional state) + "Set XWIN's _NET_WM_STATE property to STATE. +If STATE is nil, then remove property." + (XChangeProperty (xwem-dpy) xwin + + (or (null force) (eq force 'on))) + (xwem-nwm-set-state xwin _NET_WM_STATE_FULLSCREEN) + (xwem-client-change-manage-type cl '(fullscreen)))))) + +;;;###autoload(autoload 'xwem-switch-to-fullscreen-cl "xwem-netwm" nil t) +(define-xwem-command xwem-switch-to-fullscreen-cl () + "Switch to client that in fullscreen mode." + (xwem-interactive) + + (let* ((fsclients (xwem-clients-list 'xwem-cl-fullscreen-p)) + (cl (and fsclients (xwem-read-client "Fullscreen CL: " fsclients)))) + + (unless (xwem-cl-alive-p cl) + (error 'xwem-error "No fullscreen clients")) + + (xwem-select-client cl))) + + +(provide 'xwem-netwm) +;;;; On-load actions + +;; Fullscreen manage type +(define-xwem-manage-model fullscreen + "Managing model to show client at fullscreen size." +:match-spec '(function xwem-netwm-fullscreen-p) + +:manage-method 'xwem-manage-fullscreen +:activate-method 'xwem-activate-fullscreen +:deactivate-method 'xwem-deactivate-fullscreen +:refit-method 'xwem-refit-fullscreen +:iconify-method 'xwem-iconify-fullscreen) + +(if xwem-started + (xwem-nwm-init) + (add-hook 'xwem-after-init-hook 'xwem-nwm-init)) + +;;; xwem-netwm.el ends here Index: lisp/xwem-osd.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-osd.el,v retrieving revision 1.5 diff -u -u -r1.5 xwem-osd.el --- lisp/xwem-osd.el 16 Dec 2004 08:08:11 -0000 1.5 +++ lisp/xwem-osd.el 1 Jan 2005 04:41:15 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Mon Jan 12 13:14:32 MSK 2004 ;; Keywords: xwem -;; X-CVS: $Id: xwem-osd.el,v 1.5 2004/12/16 08:08:11 youngs Exp $ +;; X-CVS: $Id: xwem-osd.el,v 1.4 2004/12/05 22:37:38 lg Exp $ ;; This file is part of XWEM. ＠＠ -79,11 +79,26 ＠＠ ;;; Code:  (eval-when-compile - (require 'cl) - (require 'xlib-xlib)) + (require 'cl)) + (require 'xlib-xshape) +(require 'xlib-tray) +(require 'xlib-xpm) + +(require 'xwem-diagram) -(defconst xwem-osd-instance-types '(text line dots arc rect) +(defcustom xwem-osd-default-font "fixed" + "Default font for text drawed in osd.") + +(defcustom xwem-osd-default-color "black" + "Default color used to draw.") + +(defcustom xwem-osd-always-ontop t + "*Non-nil mean that OSD's winow will be always on top.") + +;;; Internal variables + +(defconst xwem-osd-instance-types '(text line dots arc rect icon) "List of valid types of osd instance.")  ＠＠ -93,7 +108,24 ＠＠ (depth 0) ; depth xwin xmask - color) ; instance background color + color ; instance background color + + plist) ; User defined plist + +(defsubst xwem-osd-instance-put-prop (osin prop val) + "In OSD's instance OSIN properties list put property PROP with value VAL." + (setf (xwem-osd-instance-plist osin) + (plist-put (xwem-osd-instance-plist osin) prop val))) +(put 'xwem-osd-instance-put-prop 'lisp-indent-function 2) + +(defsubst xwem-osd-instance-get-prop (osin prop) + "Return OSD's instance OSIN property PROP." + (plist-get (xwem-osd-instance-plist osin) prop)) + +(defsubst xwem-osd-instance-rem-prop (osin prop) + "Remove OSD's instance OSIN property PROP." + (setf (xwem-osd-instance-plist osin) + (plist-remprop (xwem-osd-instance-plist osin) prop))) (defmacro xwem-osd-instance-xdpy (osin) "Return display of OSIN osd instance." ＠＠ -125,14 +157,10 ＠＠ "Return OSD's property PROP." (plist-get (xwem-osd-plist osd) prop)) -(defcustom xwem-osd-default-font "fixed" - "Default font for text drawed in osd.") - -(defcustom xwem-osd-default-color "black" - "Default color used to draw.") - -(defcustom xwem-osd-always-ontop t - "*Non-nil mean that OSD's winow will be always on top.") +(defsubst xwem-osd-rem-prop (osd prop) + "Remove OSD's property PROP." + (setf (xwem-osd-plist osd) + (plist-remprop (xwem-osd-plist osd) prop)))  ;;; Functions ＠＠ -140,7 +168,6 ＠＠ "On X display XDPY and window XWIN handle X Event XEV." x (+ y yoff) string) ＠＠ -480,7 +541,7 ＠＠ x (+ y yoff) string) (X-XShapeMask xdpy (xwem-osd-xwin osd) X-XShape-Bounding X-XShapeUnion 0 0 (xwem-osd-xmask osd)) - )) + osin)) (defun xwem-osd-set-line-width (osd new-line-width) "Set OSD's gc line width to NEW-LINE-WIDTH." ＠＠ -491,13 +552,13 ＠＠ (XChangeGC (xwem-osd-xdpy osd) (xwem-osd-mask-gc osd)) ) -(defun xwem-osd-line-add (osd x0 y0 x1 y1 &optional color) +(defun xwem-osd-line-add (osd x0 y0 x1 y1 &optional depth color) "In OSD's window add line." (let ((xdpy (xwem-osd-xdpy osd)) osin) ;; Create OSD line instance - (setq osin (xwem-osd-add-instance osd 0 color)) + (setq osin (xwem-osd-add-instance osd depth color)) (setf (xwem-osd-instance-type osin) 'line) (XDrawLine xdpy (xwem-osd-instance-xmask osin) (xwem-osd-mask-gc osd) x0 y0 x1 y1) ＠＠ -510,15 +571,15 ＠＠ x0 y0 x1 y1) (X-XShapeMask (xwem-osd-xdpy osd) (xwem-osd-xwin osd) X-XShape-Bounding X-XShapeUnion 0 0 (xwem-osd-xmask osd)) - )) + osin)) -(defun xwem-osd-dots-add (osd dots type &optional color) +(defun xwem-osd-dots-add (osd dots type &optional depth color) "In OSD's window add DOTS of TYPE." (let ((xdpy (xwem-osd-xdpy osd)) osin) ;; Create OSD dots instancne - (setq osin (xwem-osd-add-instance osd 0 color)) + (setq osin (xwem-osd-add-instance osd depth color)) (setf (xwem-osd-instance-type osin) 'dots) (xwem-diag-plot-dots type (xwem-osd-instance-xmask osin) (xwem-osd-mask-gc osd) 0 (xwem-osd-height osd) dots) ＠＠ -531,15 +592,15 ＠＠ 0 (xwem-osd-height osd) dots) (X-XShapeMask (xwem-osd-xdpy osd) (xwem-osd-xwin osd) X-XShape-Bounding X-XShapeUnion 0 0 (xwem-osd-xmask osd)) - )) + osin)) -(defun xwem-osd-arc-add (osd xarc &optional color) +(defun xwem-osd-arc-add (osd xarc &optional depth color) "In OSD's window draw arc specified by XARC." (let ((xdpy (xwem-osd-xdpy osd)) osin) ;; Create OSD arc instance - (setq osin (xwem-osd-add-instance osd 0 color)) + (setq osin (xwem-osd-add-instance osd depth color)) (setf (xwem-osd-instance-type osin) 'arc) (XDrawArcs xdpy (xwem-osd-instance-xmask osin) (xwem-osd-mask-gc osd) (list xarc)) ＠＠ -551,27 +612,89 ＠＠ (list xarc)) (X-XShapeMask (xwem-osd-xdpy osd) (xwem-osd-xwin osd) X-XShape-Bounding X-XShapeUnion 0 0 (xwem-osd-xmask osd)) - )) + osin)) -(defun xwem-osd-rect-add (osd x y width height &optional color) - "In OSD's window add rectangle specified by X Y WIDTH and HEIGHT." +(defun xwem-osd-rect-add (osd x y width height &optional depth color fill-p) + "In OSD's window add rectangle specified by X Y WIDTH and HEIGHT. +If FILL-P is non-nil, rectangle will be filled instead of outdrawing." (let ((xdpy (xwem-osd-xdpy osd)) osin) ;; Created OSD rect instance - (setq osin (xwem-osd-add-instance osd 0 color)) + (setq osin (xwem-osd-add-instance osd depth color)) (setf (xwem-osd-instance-type osin) 'rect) - (XDrawRectangle xdpy (xwem-osd-instance-xmask osin) (xwem-osd-mask-gc osd) - x y width height) + (XDrawRectangles xdpy (xwem-osd-instance-xmask osin) (xwem-osd-mask-gc osd) + (list (make-X-Rect :x x :y y :width width :height height)) + fill-p) (X-XShapeMask xdpy (xwem-osd-instance-xwin osin) X-XShape-Bounding X-XShapeSet 0 0 (xwem-osd-instance-xmask osin)) ;; Update OSD shape - (XDrawRectangle xdpy (xwem-osd-xmask osd) (xwem-osd-mask-gc osd) - x y width height) + (XDrawRectangles xdpy (xwem-osd-xmask osd) (xwem-osd-mask-gc osd) + (list (make-X-Rect :x x :y y :width width :height height)) + fill-p) (X-XShapeMask (xwem-osd-xdpy osd) (xwem-osd-xwin osd) X-XShape-Bounding X-XShapeUnion 0 0 (xwem-osd-xmask osd)) - )) + osin)) + +(defun xwem-osd-icon-data-add (osd xpm-data &optional x y depth) + "In OSD's window add icon. +X and Y specifies +;; (text (format-time-string "%a, %b %e")) +;; (width (+ 3 (X-Text-width +;; (xwem-dpy) +;; (X-Font-get (xwem-dpy) +;; (face-font-name face)) +;; text))) +;; (height (+ 3 (X-Text-height +;; (xwem-dpy) +;; (X-Font-get (xwem-dpy) +;; (face-font-name face)) +;; text)))) +;; (setq sy-osd-date (xwem-osd-create-dock +;; (xwem-dpy) +;; width +;; height +;; (list 'keymap sy-osd-date-keymap))) +;; (xwem-osd-set-color sy-osd-date (face-foreground-name face)) +;; (xwem-osd-set-font sy-osd-date (face-font-name face)) +;; (xwem-osd-text sy-osd-date text) +;; (xwem-osd-show sy-osd-date))) + +;; (defun sy-update-osd-date-maybe (&optional force) +;; "Update the OSD date at midnight. + +;; Optional Argument FORCE means to update the date now." +;; (let* ((now (decode-time)) +;; (cur-hour (nth 2 now)) +;; (cur-min (nth 1 now)) +;; (cur-comp-time (+ (* cur-hour 60) cur-min))) +;; (when (or force (= 0 cur-comp-time)) +;; (when (xwem-osd-p sy-osd-date) +;; (xwem-osd-text sy-osd-date (format-time-string "%a, %b %e")))))) + +;; (defun sy-update-osd-date () +;; "*Force update of the OSD date." +;; (interactive) +;; (when (xwem-osd-p sy-osd-date) +;; (sy-update-osd-date-maybe t))) + +;; (defun sy-delete-osd-date () +;; "*Delete the OSD date." +;; (interactive) +;; (when (xwem-osd-p sy-osd-date) +;; (when (itimerp "sy-osd-date-itimer") +;; (delete-itimer "sy-osd-date-itimer")) +;; (xwem-osd-destroy sy-osd-date))) + +;; (add-hook 'xwem-after-init-hook (lambda () +;; (progn +;; (sy-show-date-osd) +;; (start-itimer "sy-osd-date-itimer" +;; 'sy-update-osd-date-maybe +;; 60 60))))  Index: lisp/xwem-pager.el =================================================================== RCS file: lisp/xwem-pager.el diff -N lisp/xwem-pager.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-pager.el 1 Jan 2005 04:41:15 -0000 ＠＠ -0,0 +1,278 ＠＠ +;;; xwem-pager.el --- Simple frame pager. + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Richard Klinda <ignotus(a)hixsplit.hu&gt; +;; Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Created: Wed Aug 18 08:05:09 MSD 2004 +;; Keywords: xwem +;; X-CVS: $Id: xwem-pager.el,v 1.3 2004/12/05 22:50:13 lg Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; Simple dockapp to show xwem frames. Somekind of extension of +;; xwem-framei.el + +;;; Code: + +(require 'xwem-load) +(require 'xlib-xshape) + + +;; veryvery simple pager / 2d viewport support +;; the code works, do the following: +;; +;; add to XWEM-after-init-hook: +;; +;; (setq *pager-dockapp* (xwem-2dframes-start-dockapp)) +;; +;; ugly i know, that starts the dockapp +;; +;; (xwem-2dframes-make-frames) +;; +;; that will create the frames +;; +;; load this code, restart your XWEM and be happy. If you want to try it +;; out without restarting then MAKE SURE you have only 1 frame, load the +;; code then: +;; M-x xwem-2dframes-make-frames +;; +;; eval (setq *pager-dockapp* (xwem-2dframes-start-dockapp)) +;; +;; change viewports / frames somehow so the dockapp gets updated +;; +;; i know this code is hackis, but if you rename the variables / sturcture +;; the code like you wan +;; `xwem-recover-do-recover' command to force recovering. + +;;; Code: + +(require 'xwem-load) + +(defgroup xwem-recover nil + "Group to customize xwem recovering tool." +:prefix "xwem-recover-" +:group 'xwem) + +(defcustom xwem-recover-parameter '(12 . 3) + "*How many errors allowed without recovering. +car specifies number of errors, cdr specifies time in seconds." +:type '(cons number number) +:group 'xwem-recover) + +;;; Internal variables + +(defvar xwem-recover-mode nil + "Non-nil mean we are in recovering mode. +Use `xwem-recover-turn-on', `xwem-recover-turn-off' and +`xwem-recover-toggle' to change mode.") + +(defvar xwem-recover-errors nil + "List of times when X error occurs. +Internal variable.") + + +(define-xwem-deffered xwem-recover-real-recover () + "Do real recovering routines." + (setf (X-Dpy-snd-queue (xwem-dpy)) nil) + (setf (X-Dpy-message-buffer (xwem-dpy)) "") + (setf (X-Dpy-evq (xwem-dpy)) nil)) + +;;;###autoload(autoload 'xwem-recover-do-recover "xwem-recover" "" t) +(define-xwem-command xwem-recover-do-recover (xdpy) + "Recover XDPY from desyncronisation with X server." + (xwem-interactive (list (xwem-dpy))) + + (flet ((old-x-dpy-filter (proc out))) + (fset 'old-x-dpy-filter (symbol-function 'X-Dpy-filter)) + (flet ((X-Dpy-filter (proc out) + ;; Skip any data on XDPY, but continue processing on + ;; other displays. + (unless (eq (X-Dpy-proc xdpy) proc) + (old-x-dpy-filter proc out)))) + (while (accept-process-output (X-Dpy-proc xdpy) 2)) + + ;; At this point all pending readed, so do cleanup things. This + ;; is not 100% will work. In some circumstances this will only + ;; add problems. + (xwem-recover-real-recover) + ))) + +(defun xwem-recover-xerr-hook (xdpy xerr) + "Called when on display XDPY X error XERR occured. +Check excedance of `xwem-recover-parameter' and if it seems like xlib +got desyncronised with X server, start recovering routines." + + (let ((ct (current-time))) + (setq xwem-recover-errors (nreverse xwem-recover-errors)) + (while (and xwem-recover-errors + (> (itimer-time-difference ct (car xwem-recover-errors)) + (cdr xwem-recover-parameter))) + (setq xwem-recover-errors (cdr xwem-recover-errors))) + (setq xwem-recover-errors + (cons ct (nreverse xwem-recover-errors))) + + ;; Check (car xwem-recover-errors) is not exceeded + (when (or (> (length xwem-recover-errors) (car xwem-recover-parameter)) + ;; Also recover when error code isn't recognized + (not (memq (X-Event-xerror-code xerr) + '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 128 255)))) + (xwem-message 'alarm "Recovering from desyncronisation .. (errors = %d)\n" + (length xwem-recover-errors)) + (xwem-recover-do-recover xdpy)) + )) + +;;;###autoload(autoload 'xwem-recover-turn-on "xwem-recover" "" t) +(define-xwem-command xwem-recover-turn-on () + "Enable xwem recovering mode." + (xwem-interactive) + + (unless xwem-recover-mode + (pushnew 'xwem-recover-xerr-hook (X-Dpy-error-hooks (xwem-dpy))) + (setq xwem-recover-mode t))) + +;;;###autoload(autoload 'xwem-recover-turn-off "xwem-recover" "" t) +(define-xwem-command xwem-recover-turn-off () + "Turn off xwem recovering mode." + (xwem-interactive) + + (when xwem-recover-mode + (setf (X-Dpy-error-hooks (xwem-dpy)) + (delq 'xwem-recover-xerr-hook (X-Dpy-error-hooks (xwem-dpy)))) + (setq xwem-recover-mode nil))) + +;;;###autoload(autoload 'xwem-recover-toggle "xwem-recover" "" t) +(define-xwem-command xwem-recover-toggle (arg) + "Toggle xwem recovering mode. +With positive ARG turn it on, with negative turn it off. +If ARG is ommited - toggle it." + (xwem-interactive "P") + + (cond ((null arg) + (if xwem-recover-mode + (xwem-recover-turn-off) + (xwem-recover-turn-on))) + ((< (prefix-numeric-value arg) 0) + (xwem-recover-turn-off)) + (t (xwem-recover-turn-on)))) + + +(provide 'xwem-recover) + +;;; xwem-recover.el ends here Index: lisp/xwem-register.el ==================== + (message "Malformed sources in file %s" file) + (narrow-to-region (point-min) (point)) + (goto-char (point-min)) + (while (setq expr (ignore-errors (read (current-buffer)))) + (ignore-errors + (and (or (eq (car expr) 'defvar) + (eq (car expr) 'defcustom)) + (stringp (nth 3 expr)) + (or (not (boundp (nth 1 expr))) + (not (equal (eval (nth 2 expr)) + (symbol-value (nth 1 expr))))) + (push (nth 1 expr) olist))))))) + (kill-buffer (current-buffer))) + (when (setq olist (nreverse olist)) + (insert "\n")) + (while olist + (when (boundp (car olist)) + (condition-case () + (pp `(setq ,(car olist) + ,(if (or (consp (setq sym (symbol-value (car olist)))) + (and (symbolp sym) + (not (or (eq sym nil) + (eq sym t))))) + (list 'quote (symbol-value (car olist))) + (symbol-value (car olist)))) + (current-buffer)) + (error + (format "(setq %s 'whatever)\n" (car olist))))) + ;(insert ";; (makeunbound '" (symbol-name (car olist)) ")\n")) + (setq olist (cdr olist))) + ;; Remove any control chars - they seem to cause trouble for some + ;; mailers. (Byte-compiled output from the stuff above.) + (goto-char point) + (while (re-search-forward "[\000-\010\013-\037\200-\237]" nil t) + (replace-match (format "\\%03o" (string-to-char (match-string 0))) + t t)))) + +(defun xwem-bug-packages-list () + "Insert into the current buffer a list of installed packages." + (let ((pkgs packages-package-list)) + (while pkgs + (insert + (format "(%s ver: %s upstream: %s)\n" + (nth 0 (car pkgs)) + (nth 2 (car pkgs)) + (nth 4 (car pkgs)))) + (setq pkgs (cdr pkgs))))) + +(eval-when-compile + (autoload 'xwem-dpy "xwem-struct" nil nil 'macro) + (require 'xlib-xc)) + +(defun xwem-prepare-report () + "Grabs the variables, features to include in bug report. +Then put it all into a mail buffer, nicely formatted." + (mail-to) + (insert xwem-bug-address) + (mail-text) + (forward-line 1) + (setq after-sep-pos (point)) + (setq final-resting-place (point-marker)) + (insert + "\n\n" + "===============================================================\n" + "System info to help the XWEM boys and girls try to fix your bug:\n" + "===============================================================" + "\n\n") + (insert (format "%s" xwem-version) "\n" + (format "%s" xlib-version) "\n\n") + ;; xdpyinfo + (insert "Output from xdpyinfo:\n--------------------\n\n" + (shell-command-to-string (concat "xdpyinfo -display " + (X-Dpy-name (xwem-dpy)))) + "\n") + ;; backtrace & messages buffers + (let ((lisptrace (get-buffer "*Backtrace*")) + (ctrace (get-buffer "*gdb-xemacs*")) + (debug (get-buffer "*xwem-debug*")) + (msgs (get-buffer " *xwem-messages*"))) + (when lisptrace + (insert "Lisp Backtrace:\n--------------\n\n") + (insert-buffer-substring lisptrace) + (insert "\n\n")) + (when ctrace + (insert "C Backtrace:\n-----------\n\n") + (insert-buffer-substring ctrace) + (insert "\n\n")) + (when debug + (insert "xwem-debug buffer:\n-----------------\n\n") + (insert-buffer-substring debug) + (insert "\n\n")) + (when msgs + (insert "xwem-messages buffer:\n--------------------\n\n") + (insert-buffer-substring msgs) + (insert "\n\n"))) + ;; Insert all the XWEM vars that have been changed from default. + ;; The actual work for this is done in `xwem-bug-debug', but it + ;; needs to be called toward the end of this function. + (insert "\n\nXWEM variables of note:\n----------------------\n") + (when window-setup-hook + (insert "\n\nwindow-setup-hook:") + (cl-prettyprint (symbol-value 'window-setup-hook))) + (when kill-emacs-hook + (insert "\n\nkill-emacs-hook:") + (cl-prettyprint (symbol-value 'kill-emacs-hook))) + ;; Insert the output of 'describe-installation'. + (insert "\n\n" + (symbol-value 'Installation-string)) + ;; Load-path shadows can cause some grief. + (flet ((append-message + (&rest args) ()) + (clear-message + (&optional label frame stdout-p no-restore) + ())) + (insert "\n\nLoad-Path Lisp Shadows:\n" + "----------------------\n") + (let ((before-shadows (point))) + (insert + (format "%s" + (find-emacs-lisp-shadows load-path))) + (save-restriction + (narrow-to-region before-shadows (point)) + (fill-paragraph t) + (insert "\n")))) + ;; Insert a list of installed packages. + (insert "\n\nInstalled XEmacs Packages:\n" + "-------------------------\n") + (xwem-bug-packages-list) + (insert "\n") + ;; Insert a list of installed modules. + (if (fboundp 'list-modules) + (progn + (insert "\n\nInstalled Modules:\n" + "-----------------\n") + (let* ((mods (list-modules))) + (while mods + (cl-prettyprint (cdr (car mods))) + (setq mods (cdr mods)))))) + ;; Insert a list of loaded features + (let ((before-features (point))) + (insert + (format "\n\nFeatures:\n--------\n\n%s" (symbol-value 'features))) + (save-restriction + (narrow-to-region before-features (point)) + (fill-paragraph t) + (insert "\n\n"))) + ;; Insert the contents of the user's init file if it exists + ;; and the user wants it sent. + (if xwem-report-bug-send-init + (if (file-readable-p user-init-file) + (save-excursion + (goto-char (point-max)) + (forward-line -3) + (beginning-of-line) + (insert "\n\nUser Init File:\n--------------\n\n") + (insert-file-contents user-init-file)))) + (xwem-report-pre-hook) + (xwem-report-post-hook) + (mail-text) + (insert + (aref xwem-report-salutations + (% (+ (% (random) 1000) 1000) + (length xwem-report-salutations))) "\n") + (re-search-forward "XWEM variables of note:" nil t) + (forward-line 2) + (xwem-report-debug) + (goto-char final-resting-place) + (forward-line 2) + (set-marker final-resting-place nil) + (message "Please enter your report. Type C-c C-c to send, C-x k to abort.")) + +;;;###autoload +(defun xwem-report-bug (&optional no-confirm) + "Submit a bug report for XWEM. +Optional argument BLURB is a string that adds a preamble to the bug report. +Optional argument NO-CONFIRM if 't' will not ask for confirmation." + (interactive) + (if (or no-confirm + (y-or-n-p "Do you want to submit a bug report on XWEM? ")) + (progn + (mail) + (xwem-prepare-report)))) + +(provide 'xwem-report) + +;;; xwem-report.el ends here Index: lisp/xwem-root.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-root.el,v retrieving revision 1.8 diff -u -u -r1.8 xwem-root.el --- lisp/xwem-root.el 16 Dec 2004 08:08:12 -0000 1.8 +++ lisp/xwem-root.el 1 Jan 2005 04:41:16 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: 21 Mar 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xwem-root.el,v 1.8 2004/12/16 08:08:12 youngs Exp $ +;; X-CVS: $Id: xwem-root.el,v 1.7 2004/12/05 22:37:35 lg Exp $ ;; This file is part of XWEM. ＠＠ -31,53 +32,102 ＠＠ ;; This file used to manipulate and agragate information about root ;; window. Also has macros to work with geometry. ;; -;;; Code -(require 'xlib-xlib) +;;; TODO: + +;; * WM_ICON_SIZE on root window. (ICCCM 4.1.3.2) + +;;; Code  -;;; Variables +(require 'xwem-load) +(require 'xwem-misc) -(defconst xwem-root-ev-mask (Xmask-or XM-SubstructureNotify XM-SubstructureRedirect - XM-KeyPress XM-ButtonPress XM-ButtonRelease - XM-PropertyChange - XM-FocusChange - XM-EnterWindow - XM-ResizeRedirect) +;;; Variables +(defconst xwem-root-ev-mask (Xmask-or XM-SubstructureRedirect + XM-KeyPress XM-ButtonPress XM-ButtonRelease) "Event mask for X root window.") -;;;###autoload -(defvar xwem-root-screen nil - "Description of root screen") +(defgroup xwem-root nil + "Group to customize root screen." +:prefix - (while (not done) - (setq xev (xwem-next-event)) - (X-Event-CASE xev - (:X-ButtonRelease - (setq done t)) - (:X-MotionNotify - (let ((xoff (X-Event-xmotion-event-x xev)) - (yoff (X-Event-xmotion-event-y xev))) - ;; XXX workaround INT/CARD bug - (xwem-message 'info "x=%d, y=%d" xoff yoff) - (when (and (< xoff 40000) (< yoff 40000)) - (XResizeWindow (xwem-dpy) xwin xoff yoff)))) - ))) - (XUngrabPointer (xwem-dpy))))) - -(define-xwem-command xwem-rooter-destroy () - "Destroy rooter client." - (xwem-interactive "_") +(defvar xwem-rooter-mode-hook nil + "*Hooks to call when client enters rooter mode. +Called with one argument - client.") - (let* ((mev xwem-last-xevent) - (xwin (X-Event-xbutton-event mev))) - - (when (X-Win-p xwin) - (XDestroyWindow (X-Win-dpy xwin) xwin)))) - +;;;###autoload(autoload 'xwem-rooter-raise "xwem-rooter" nil t) (define-xwem-command xwem-rooter-raise () "Raise rooter window." (xwem-interactive "_") - (XRaiseWindow (xwem-dpy) xwem-event-window)) + (XRaiseWindow (xwem-dpy) (xwem-cl-xwin xwem-event-client))) +;;;###autoload(autoload 'xwem-rooter-lower "xwem-rooter" nil t) (define-xwem-command xwem-rooter-lower () "Lower rooter window." (xwem-interactive "_") - (XLowerWindow (xwem-dpy) xwem-event-window)) + (XLowerWindow (xwem-dpy) (xwem-cl-xwin xwem-event-client))) + + +;;;; Manage methods -(defun xwem-rooter-manage (cl &rest args) +;;;###autoload +(defun xwem-manage-rooter (cl) "Manage rooter client CL." (let ((xdpy (xwem-dpy)) (xwin (xwem-cl-xwin cl)) (xgeom (xwem-cl-xgeom cl))) + (xwem-client-set-property cl 'noselect t) ; rooted clients can't be selected + (xwem-client-set-property cl 'nokeyecho t) ; no keyboard echoing (xwem-focus-mode-set cl nil) ; no focus mode - (XReparentWindow xdpy xwin (xwem-rootwin) (X-Geom-x xgeom) (X-Geom-y xgeom)) + (XReparentWindow xdpy xwin (xwem-rootwin) + (X-Geom-x xgeom) (X-Geom-y xgeom)) (XLowerWindow xdpy xwin) (XMapWindow xdpy xwin) ;; Install client local keymap - (xwem-focus-excursion xwin - (map-keymap (lambda (key bind) - (xwem-local-set-key key bind cl)) - xwem-rooter-keymap)) - )) + (xwem-use-local-map xwem-rooter-mode-map cl) + + ;; Finnaly run hook + (run-hook-with-args 'xwem-rooter-mode-hook cl))) + +(defun xwem-activate-rooter (cl &optional type) + "Activate method for rooter clients." + (when (eq type 'select) + (error 'xwem-error "Trying to select rooted client!!!")) + + (XRaiseWindow (xwem-dpy) (xwem-cl-xwin cl))) + +(defun xwem-deactivate-rooter (cl &optional type) + "Deactivate method for rooter clients." + (when (eq type 'deselect) + (error 'xwem-error "Trying to deselect rooted client!!!")) + + (XLowerWindow (xwem-dpy) (xwem-cl-xwin cl)))  (provide 'xwem-rooter) + +;;;; On-load actions +;; Rooter manage type +(define-xwem-manage-model rooter + "Managing model to show client on root window." +:manage-method 'xwem-manage-rooter +:activate-method 'xwem-activate-rooter +:deactivate-method 'xwem-deactivate-rooter) ;;; xwem-rooter.el ends here Index: lisp/xwem-rooticon.el =================================================================== RCS file: lisp/xwem-rooticon.el diff -N lisp/xwem-rooticon.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-rooticon.el 1 Jan 2005 04:41:16 -0000 ＠＠ -0,0 +1,374 ＠＠ +;;; xwem-rooticon.el --- Support Icons on root window. + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Created: +;; Keywords: xwem +;; X-CVS: $Id: xwem-rooticon.el,v 1.5 2004/12/05 05:52:30 youngs Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; + +;;; Code: + +(require 'xwem-load) +(require 'xwem-misc) + +(require 'xlib-xpm) +(require 'xlib-xshape) + +(defgroup xwem-rooticon nil + "Group to customize rooticon behaviour." +:prefix "xwem-rooticon-" +:group 'xwem) + +(defcustom xwem-rooticon-placing 'behind-minibuffer + "*Placing behaviour." +:type '(choice (const :tag "Behind minibuffer" behind-minibuffer) + (const :tag "Random" random)) +:group 'xwem-rooticon) + +(defcustom xwem-rooticon-show-label nil + "*Non-nil mean show Icon name in rooticon." +:type 'boolean +:group 'xwem-rooticon) + +(defcustom xwem-rooticon-default-icon "root-icon.xpm" + "*Default rooticon to use. +This icon is used which client does not have its own icon." +:type 'file +:group 'xwem-rooticon) + +(defcustom xwem-rooticon-default-show-label t + "*Non-nil mean show label, when `xwem-rooticon-default-icon' is used." +:type 'boolean +:group 'xwem-rooticon) + +;;; Internal variables + +(defstruct xwem-rooticon + cl + xgeom + xriwin + xiconwin + xpixmap + xpixmask) + +(define-xwem-face xwem-rooticon-face + `((t (:foreground "black" :background "tan" +:font "-misc-fixed-medium-r-*-*-10-*-*-*-*-*-*-*"))) + "Face to draw text on root icon.") + +(defvar xwem-rooticon-map + (let ((map (make-sparse-keymap))) + (define-key map [button1] 'xwem-rooticon-smart-move) + (define-key map [button1up] 'xwem-rooticon-select-cl) + (define-key map [button3] 'xwem-rooticon-menu) + map) + "Keymap for rooticon windows.") + +(defvar xwem-rooticon-default-pixmap nil) + +(defun xwem-rooticon-ev-handler (xdpy xwin xev) + (let ((ri (X-Win-get-prop xwin 'xwem-rooticon))) + (when (xwem-rooticon-p ri) + (X-Event-CASE xev + ((:X-ButtonPress :X-ButtonRelease) + (xwem-overriding-local-map xwem-rooticon-map + (let ((xwem-click-rooticon ri)) + (declare (special xwem-click-rooticon)) + (xwem-dispatch-command-xevent xev)))) + + (:X-Expose + (xwem-rooticon-draw ri (X-Event-xexpose-x xev) (X-Event-xexpose-y xev) + (X-Event-xexpose-width xev) (X-Event-xexpose-height xev))) + + (:X-DestroyNotify + (xwem-cl-rem-sys-prop (xwem-rooticon-cl ri) 'xwem-rooticon) + (X-invalidate-cl-struct ri)))))) + +(defun xwem-rooticon-icons () + "Return list of root icons sorted by X." + (sort (delq nil (mapcar (lambda (cl) + (xwem-cl-get-sys-prop cl 'xwem-rooticon)) + xwem-clients)) + (lambda (ri1 ri2) + (> (X-Geom-x (xwem-rooticon-xgeom ri1)) + (X-Geom-x (xwem-rooticon-xgeom ri2)))))) + +(defun xwem-rooticon-select-place (cl w h) + "Select place for rooticon." + (or (xwem-client-property cl 'rooticon-position) + (cond ((eq xwem-rooticon-placing 'behind-minibuffer) + ;; Behind the minibuffer + (let ((ris (sort (delq nil (mapcar (lambda (cl) + (let ((ri (xwem-cl-get-sys-prop cl 'xwem-rooticon))) + (and ri (>= (+ (X-Geom-y (xwem-rooticon-xgeom ri)) + (X-Geom-height (xwem-rooticon-xgeom ri))) + (- (X-Geom-height (xwem-rootgeom)) h)) + ri))) + xwem-clients)) + (lambda (ri1 ri2) + (< (X-Geom-x (xwem-rooticon-xgeom ri1)) + (X-Geom-x (xwem-rooticon-xgeom ri2)))))) + ri1 ri2 + (x 0)) + (while ris + (setq ri1 (car ris) + ri2 (cadr ris)) + (setq x (+ (X-Geom-x (xwem-rooticon-xgeom ri1)) + (X-Geom-width (xwem-rooticon-xgeom ri1)))) + (when (and ri1 ri2 + (>= (- (X-Geom-x (xwem-rooticon-xgeom ri2)) x) w)) + (setq ris nil)) + (setq ris (cdr ris))) + (cons x (- (X-Geom-height (xwem-rootgeom)) h)))) + + ((eq xwem-rooticon-placing 'random) + (cons (random (- (X-Geom-width (xwem-rootgeom)) w)) + (random (- (X-Geom-height (xwem-rootgeom)) h))))))) + +(defun xwem-rooticon-create (cl) + "Create rooticon for CL." + (let ((wmh (xwem-hints-wm-hints (xwem-cl-hints cl))) + (ri (make-xwem-rooticon :cl cl)) + place) + ;; Fill pixmap/mask fields + (cond ((and (X-WMHints-iconpixmap-p wmh) + (= (XGetDepth (xwem-dpy) (xwem-rootwin)) + (XGetDepth (xwem-dpy) (make-X-Pixmap :id (X-WMHints-icon-pixmap wmh))))) + ;; Has a pixmap of same depth as root window + (setf (xwem-rooticon-xpixmap ri) + (make-X-Pixmap :id (X-WMHints-icon-pixmap wmh))) + (when (X-WMHints-iconmask-p wmh) + (setf (xwem-rooticon-xpixmask ri) + (make-X-Pixmap :id (X-WMHints-icon-mask wmh))))) + (t (unless xwem-rooticon-default-pixmap + (setq xwem-rooticon-default-pixmap + (cons (X:xpm-pixmap-from-file + (xwem-dpy) (xwem-rootwin) + (expand-file-name xwem-rooticon-default-icon xwem-icons-dir)) + (X:xpm-pixmap-from-file + (xwem-dpy) (xwem-rootwin) + (expand-file-name xwem-rooticon-default-icon xwem-icons-dir) + t)))) + (setf (xwem-rooticon-xpixmap ri) (car xwem-rooticon-default-pixmap)) + (setf (xwem-rooticon-xpixmask ri) (cdr xwem-rooticon-default-pixmap)))) + + (setf (xwem-rooticon-xgeom ri) + (XGetGeometry (xwem-dpy) (xwem-rooticon-xpixmap ri))) + + (setq place (xwem-rooticon-select-place + cl (X-Geom-width (xwem-rooticon-xgeom ri)) + (X-Geom-height (xwem-rooticon-xgeom ri)))) + (setf (X-Geom-x (xwem-rooticon-xgeom ri)) (car place)) + (setf (X-Geom-y (xwem-rooticon-xgeom ri)) (cdr place)) + (setf (xwem-rooticon-xriwin ri) + (XCreateWindow (xwem-dpy) (xwem-rootwin) + (X-Geom-x (xwem-rooticon-xgeom ri)) + (X-Geom-y (xwem-rooticon-xgeom ri)) + (X-Geom-width (xwem-rooticon-xgeom ri)) + (X-Geom-height (xwem-rooticon-xgeom ri)) + 0 + nil nil nil + (make-X-Attr :override-redirect t +:event-mask (Xmask-or XM-ButtonPress + XM-ButtonRelease + XM-ButtonMotion + XM-Exposure)))) + + ;; Apply mask + (when (xwem-rooticon-xpixmask ri) + (X-XShapeMask (xwem-dpy) (xwem-rooticon-xriwin ri) + X-XShape-Bounding X-XShapeSet 0 0 + (xwem-rooticon-xpixmask ri))) + + (X-Win-EventHandler-add (xwem-rooticon-xriwin ri) + 'xwem-rooticon-ev-handler nil + (list X-ButtonPress X-ButtonRelease + X-DestroyNotify X-Expose)) + (X-Win-put-prop (xwem-rooticon-xriwin ri) 'xwem-rooticon ri) + (xwem-cl-put-sys-prop cl 'xwem-rooticon ri) + ri)) + +(defun xwem-rooticon-draw (ri &optional x y w h) + (XCopyArea (xwem-dpy) (xwem-rooticon-xpixmap ri) + (xwem-rooticon-xriwin ri) (XDefaultGC (xwem-dpy)) + (or x 0) (or y 0) + (or w (X-Geom-width (xwem-rooticon-xgeom ri))) + (or h (X-Geom-height (xwem-rooticon-xgeom ri))) + (or x 0) (or y 0)) + + ;; Icon label + (when (or xwem-rooticon-show-label + (and xwem-rooticon-default-show-label + (eq (car xwem-rooticon-default-pixmap) + (xwem-rooticon-xpixmap ri)) + (eq (cdr xwem-rooticon-default-pixmap) + (xwem-rooticon-xpixmask ri)))) + (XImageString (xwem-dpy) (xwem-rooticon-xriwin ri) + (xwem-face-get-gc 'xwem-rooticon-face nil (xwem-rooticon-cl ri)) + 0 (- (X-Geom-height (xwem-rooticon-xgeom ri)) + (X-Font-fontdescent (X-Gc-font (xwem-face-get-gc 'xwem-rooticon-face)))) + (xwem-cl-wm-icon-name (xwem-rooticon-cl ri))))) + +;;; Hooking into clients handling +(define-xwem-deffered xwem-rooticon-apply-state (ri) + "Show/hide rooticon RI according to RI's client state." + (when (xwem-rooticon-p ri) + (case (xwem-cl-state (xwem-rooticon-cl ri)) + (iconified + (XLowerWindow (xwem-dpy) (xwem-rooticon-xriwin ri)) + (XMapWindow (xwem-dpy) (xwem-rooticon-xriwin ri)) + (xwem-rooticon-draw ri)) + + (t (XUnmapWindow (xwem-dpy) (xwem-rooticon-xriwin ri)))))) + +(defun xwem-rooticon-cl-state-change-hook (cl old-state new-state) + "Handle CL's state change." + (let ((ri (xwem-cl-get-sys-prop cl 'xwem-rooticon))) + ;; Create rooticon if not yet created + (when (and (eq new-state 'iconified) + (not ri)) + (setq ri (xwem-rooticon-create cl))) + (when ri + (xwem-rooticon-apply-state ri)))) + +(defun xwem-rooticon-cl-destroy (cl) + (let ((ri (xwem-cl-get-sys-prop cl 'xwem-rooticon))) + (when ri + (xwem-cl-rem-sys-prop cl 'xwem-rooticon) + (XDestroyWindow (xwem-dpy) (xwem-rooticon-xriwin ri)) + (X-invalidate-cl-struct ri)))) + +(defun xwem-rooticon-init () + "Initialize root icons." + (xwem-message 'init "Initializing root icons ...") + (add-hook 'xwem-cl-state-change-hook 'xwem-rooticon-cl-state-change-hook) + (add-hook 'xwem-cl-destroy-hook 'xwem-rooticon-cl-destroy) + (xwem-message 'init "Initializing root icons ... done")) + +;;; Commands +(define-xwem-command xwem-rooticon-smart-move () + "Interactively move rooticon. +If only clicked(not moving) bypass button release event." + (xwem-interactive) + + (unless (button-press-event-p xwem-last-event) + (error 'xwem-error "`xwem-rooticon-smart-move' must be bound to mouse event")) + + (let ((xev (xwem-next-event nil (list X-ButtonRelease X-MotionNotify)))) + (X-Event-CASE xev + (:X-ButtonRelease + (xwem-dispatch-command-xevent xev)) + + (:X-MotionNotify + (declare (special xwem-click-rooticon)) + (let ((sx (- (X-Event-xmotion-root-x xev) + (X-Geom-x (xwem-rooticon-xgeom xwem-click-rooticon)))) + (sy (- (X-Event-xmotion-root-y xev) + (X-Geom-y (xwem-rooticon-xgeom xwem-click-rooticon)))) + (done nil)) + (xwem-mouse-grab xwem-cursor-move (xwem-rooticon-xriwin xwem-click-rooticon) + (Xmask-or XM-ButtonMotion XM-ButtonRelease)) + (xwem-unwind-protect + (while (not done) + (X-Event-CASE + (setq xev (xwem-next-event + nil (list X-MotionNotify X-ButtonRelease))) + (:X-ButtonRelease (setq done t)) + + (:X-MotionNotify + (setf (X-Geom-x (xwem-rooticon-xgeom xwem-click-rooticon)) + (- (X-Event-xmotion-root-x xev) sx)) + (setf (X-Geom-y (xwem-rooticon-xgeom xwem-click-rooticon)) + (- (X-Event-xmotion-root-y xev) sy)) + (XMoveWindow (xwem-dpy) (xwem-rooticon-xriwin xwem-click-rooticon) + (X-Geom-x (xwem-rooticon-xgeom xwem-click-rooticon)) + (X-Geom-y (xwem-rooticon-xgeom xwem-click-rooticon)))))) + (xwem-mouse-ungrab))))))) + +(define-xwem-command xwem-rooticon-select-cl () + "Select roowin client." + (xwem-interactive) + + (unless (or (button-press-event-p xwem-last-event) + (button-release-event-p xwem-last-event)) + (error 'xwem-error "`xwem-rooticon-select-cl' must be bound to mouse event")) + + (declare (special xwem-click-rooticon)) + (let ((ricl (xwem-rooticon-cl xwem-click-rooticon))) + (when (and (xwem-cl-p ricl) (xwem-cl-managed-p ricl)) + (if (xwem-dummy-client-p ricl) + (xwem-activate ricl) + (xwem-select-client ricl))))) + +(defun xwem-rooticon-genmenu (ri) + (list "XWEM RootIcon" + (vector "Select" `(xwem-select-client ,(xwem-rooticon-cl ri))) + (vector "Info" `(xwem-client-info ,(xwem-rooticon-cl ri))))) + +(define-xwem-command xwem-rooticon-menu () + "Popup rooticon menu." + (xwem-interactive) + (let ((ri (X-Win-get-prop (X-Event-win xwem-last-xevent) 'xwem-rooticon))) + (when (xwem-rooticon-p ri) + (xwem-popup-menu (xwem-rooticon-genmenu ri))))) + +(defun xwem-rooticon-set-position (cl prop val) + "Set CL's rooticon position property PROP to VAL." + (let ((ri (xwem-cl-get-sys-prop cl 'xwem-rooticon))) + (if (not (xwem-rooticon-p ri)) + (xwem-cl-put-prop cl prop val) + + (setf (X-Geom-x (xwem-rooticon-xgeom ri)) (car val)) + (setf (X-Geom-y (xwem-rooticon-xgeom ri)) (cdr val)) + (XMoveWindow (xwem-dpy) (xwem-rooticon-xriwin ri) + (X-Geom-x (xwem-rooticon-xgeom ri)) + (X-Geom-y (xwem-rooticon-xgeom ri)))))) + +(defun xwem-rooticon-get-position (cl prop) + "Return CL's rooticon position property PROP." + (let ((ri (xwem-cl-get-sys-prop cl 'xwem-rooticon))) + (if (not (xwem-rooticon-p ri)) + (xwem-cl-get-prop cl prop) + (cons (X-Geom-x (xwem-rooticon-xgeom ri)) + (X-Geom-y (xwem-rooticon-xgeom ri)))))) + +(define-xwem-client-property rooticon-position nil + "Client's rooticon position." +:type '(cons (number :tag "X") + (number :tag "Y")) +:set 'xwem-rooticon-set-position +:get 'xwem-rooticon-get-position) + + +(provide 'xwem-rooticon) + +;;;; On-load actions: +(if xwem-started + (xwem-rooticon-init) + (add-hook 'xwem-before-init-wins-hook 'xwem-rooticon-init)) + +;;; xwem-rooticon.el ends here Index: lisp/xwem-selections.el =================================================================== RCS file: lisp/xwem-selections.el diff -N lisp/xwem-selections.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-selections.el 1 Jan 2005 04:41:16 -0000 ＠＠ -0,0 +1,154 ＠＠ +;;; xwem-selections.el --- Support for X selections. + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Created: Wed May 5 17:06:41 MSD 2004 +;; Keywords: xwem +;; X-CVS: $Id: xwem-selections.el,v 1.2 2004/12/05 05:52:30 youngs Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; + +;;; Code: + +(re + +;;; On-load actions +(add-to-list 'xwem-minor-mode-alist + '(xwem-sm-mode xwem-sm-mode-line))  (provide 'xwem-smartmods) Index: lisp/xwem-sound.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-sound.el,v retrieving revision 1.6 diff -u -u -r1.6 xwem-sound.el --- lisp/xwem-sound.el 16 Dec 2004 08:08:13 -0000 1.6 +++ lisp/xwem-sound.el 1 Jan 2005 04:41:16 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Wed Jan 28 22:25:44 MSK 2004 ;; Keywords: xwem -;; X-CVS: $Id: xwem-sound.el,v 1.6 2004/12/16 08:08:13 youngs Exp $ +;; X-CVS: $Id: xwem-sound.el,v 1.5 2004/12/05 05:52:30 youngs Exp $ ;; This file is part of XWEM. ＠＠ -34,7 +34,9 ＠＠ ;;; Code:  +(require 'xwem-load) +;;; Customisation (defgroup xwem-sound nil "Group to customize XWEM sounds." :prefix "xwem-sound-" ＠＠ -42,15 +44,14 ＠＠ :group 'xwem) (defcustom xwem-sound-default-alist - '((default :sound bass) - (undefined-key :sound drum) - (command-fail :sound bass) - (quit :sound quiet :volume 75) - (ready :sound cuckoo) - (alarm :sound cuckoo :volume 100) - (msg-warning :sound clink :volume 70) - (msg-error :sound bong :volume 100) - ) + '((default :sound bass) + (undefined-key :sound drum) + (command-fail :sound bass) + (quit :sound quiet :volume 75) + (ready :sound cuckoo) + (alarm :sound cuckoo :volume 100) + (warning :sound clink :volume 70) + (error :sound bong :volume 100)) "The alist of sounds and associated error symbols. Used to set `xwem-sound-alist' in `xwem-sound-load-default'." :group 'xwem-sound ＠＠ -83,10 +84,8 ＠＠ ;; alarm: used by reminders (alarm :sound t :pitch 2000 :duration 150 :volume 100) - ;; (xwem-message 'warn ..) - (msg-warning :sound t :pitch 50 :duration 10 :volume 100) - ;; (xwem-message 'err ..) - (msg-error :sound t :pitch 3000 :duration 50 :volume 100) + (warning :sound t :pitch 50 :duration 10 :volume 100) + (error :sound t :pitch 3000 :duration 50 :volume 100) ) "X Bell oriented candidate for `xwem-sound-alist'. Format is identical as for `xwem-sound-default-alist'." ＠＠ -124,6 +123,7 ＠＠ :type 'string :group 'xwem-sound) +;;;###autoload (defcustom xwem-sound-list '((xwem-sound-file-load "bass-snap" 'bass 100) (xwem-sound-file-load "drum-beep" 'drum 100) ＠＠ -143,6 +143,8 ＠＠ :type 'boolean :group 'xwem-sound) +;;; Internal variables + ;;;###autoload (defvar xwem-sound-alist nil "Sound alist for use by XWEM. ＠＠ -152,23 +154,23 ＠＠ quit -- After \\<xwem-global-map>\\[xwem-kbd-quit] undefined-key -- Keybinding undefined. command-fail -- When execution of command failed. - msg-warning -- Some one warnings you. - msg-error -- Some one reports you an error. + warning -- Some one warnings you. + error -- Some one reports you an error. ready -- Time consumed task has been done. alarm -- Used by reminders.") (defun xwem-sound-file-load (filename sound-name &optional volume) "Read an audio FILE and return a valid node for use in `xwem-sound-alist'." (unless (symbolp sound-name) - (error "SOUND-NAME not a symbol")) + (error 'xwem-error "SOUND-NAME not a symbol")) (unless (or (null volume) (integerp volume)) - (error "VOLUME not an integer or nil")) + (error 'xwem-error "VOLUME not an integer or nil")) (let ((file (locate-file filename xwem-sound-directory-list xwem-sound-extension-list)) buf data) (unless file - (error "Couldn't locate sound file %s" filename)) + (error 'xwem-error "Couldn't locate sound file %s" filename)) (unwind-protect (save-excursion ＠＠ -194,9 +196,8 ＠＠ (make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy) :function X-GXInvert :subwindow-mode X-IncludeInferiors)))) - (XGrabServer xdpy) - (unwind-protect + (xwem-unwind-protect (progn (XFillRectangle xdpy (xwem-frame-xwin frame) gc 0 0 (xwem-frame-width frame) ＠＠ -209,10 +210,7 ＠＠ gc 0 0 (xwem-frame-width frame) (xwem-frame-height frame))) (XUngrabServer xdpy) - (XFreeGC xdpy gc)) - - (XSyncEvents (xwem-dpy)) - )) + (XFreeGC xdpy gc)))) ;;;###autoload (defun xwem-play-sound (sound &optional volume) Index: lisp/xwem-special.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-special.el,v retrieving revision 1.9 diff -u -u -r1.9 xwem-special.el --- lisp/xwem-special.el 16 Dec 2004 08:08:13 -0000 1.9 +++ lisp/xwem-special.el 1 Jan 2005 04:41:17 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Thu Dec 4 15:01:21 MSK 2003 ;; Keywords: xwem, xlib -;; X-CVS: $Id: xwem-special.el,v 1.9 2004/12/16 08:08:13 youngs Exp $ +;; X-CVS: $Id: xwem-special.el,v 1.8 2004/12/08 19:11:30 lg Exp $ ;; This file is part of XWEM. ＠＠ -57,22 +57,19 ＠＠ ;; - Models ;;; Code: -(eval-when-compile - (require 'xlib-xwin) - (require 'xwem-misc))  +(require 'xwem-load) +(require 'xwem-manage) + +(eval-when-compile + (defvar x-emacs-application-class nil)) + +;;; Customisation (defgroup xwem-special nil "Group to customize special emacs frames handling." :prefix "xwem-special-" -:group 'xwem) +:group 'xwem-modes) -;;;###autoload -(defcustom xwem-special-enabled t - "*Non-nil mean make xwem to understand emacs special frames." -:type 'boolean -:group 'xwem-special) - -;;;###autoload (defcustom xwem-special-frame-name "xwem-special-frame" "*Name for special emacs frames" :type 'string ＠＠ -92,7 +89,20 ＠＠ (defcustom xwem-special-border-color "red4" "Border color of special Emacs frames." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:group 'xwem-special) + +(defcustom xwem-special-auto-hide nil + "*Non-nill mean that special frames will autohide when loses focus or visibility." +:type 'boolean +:group 'xwem-special) + +(defcustom xwem-special-hide-method 'XDestroyWindow + "*Method used to hide special frames. +One of 'XDestroyWindow or 'XUnmapWindow. +If 'XUnmapWindow than special frames will not be removed from clients +list, so it will be possible to access them after hidding." +:type 'boolean :group 'xwem-special) (defcustom xwem-special-menubar-visible-p nil ＠＠ -105,10 +115,52 ＠＠ :type 'boolean :group 'xwem-special) -;; Internal variables +(defcustom xwem-special-display-buffer-names nil + "*List of buffer names to display using special frame." +:type '(repeat string) +:group 'xwem-special) + +(defcustom xwem-special-display-buffer-strategy 'half + "*Strategy to use when display one of `xwem-special-display-buffer-names' buffer in special frame." +:type '(choice (const :tag "Half screen" half) + (const :tag "Center" centre)) +:group 'xwem-special) + +(defcustom xwem-special-default-strategy 'half + "*Default strategy to use when displaying special Emacs frame." +:type '(choice (const :tag "Half screen" half) + (const :tag "Fill current client" fill) + (const :tag "Center" centre)) +:group 'xwem-special) + +(defcustom xwem-special-fill-border-width 10 + "*Pixels border when using `fill' strategy." +:type 'number +:group 'xwem-special) + +;;; Internal variables + (defvar xwem-special-frames-list nil "List of special frames.")  +(defun xwem-special-frame-init () + "Initialize stuff to work with special emacs frames." + (setq special-display-frame-plist + (plist-put special-display-frame-plist 'minibuffer nil)) + (setq special-display-frame-plist + (plist-put special-display-frame-plist 'name xwem-special-frame-name)) + (setq special-display-frame-plist + (plist-put special-display-frame-plist 'border-width xwem-special-border-width)) + (setq special-display-frame-plist + (plist-put special-display-frame-plist 'border-color xwem-special-border-color)) + (setq special-displa + + ;; Operate on unmapped window + (XSelectInput (xwem-dpy) win 0) + + (when fgeom + (xwem-cl-correct-size-for-size cl fgeom)) + (xwem-cl-apply-xgeom-1 cl) + + (XReparentWindow (xwem-dpy) win par-win + (X-Geom-x (xwem-cl-xgeom cl)) + (X-Geom-y (xwem-cl-xgeom cl))) - ;; XXX -- this should be in ~/.xwem/xwemrc.el -; (add-to-list 'special-display-regexps (cons "*Help" nil)) -; (add-to-list 'special-display-regexps (cons "*Completions" nil)) - ) + ;; Setup events handler for special frames + (XSelectInput (xwem-dpy) win + (Xmask-or XM-FocusChange XM-VisibilityChange XM-StructureNotify)) + (X-Win-EventHandler-add-new win 'xwem-special-evhandler) + + ;; Select client + (xwem-special-select cl))) +(define-xwem-deffered xwem-special-apply-state (cl) + "Apply CL's state to life." + (cond ((eq (xwem-cl-state cl) 'active) + (XRaiseWindow (xwem-dpy) (xwem-cl-xwin cl)) + (XMapWindow (xwem-dpy) (xwem-cl-xwin cl))) + + ((eq (xwem-cl-state cl) '(inactive iconify)) + (XUnmapWindow (xwem-dpy) (xwem-cl-xwin cl)) + (xwem-special-revert-focus cl)))) + +(defun xwem-activate-emacs-special (cl &optional type) + "Activate method for special emacs frame client CL." + (xwem-special-apply-state cl)) + +(defun xwem-deactivate-emacs-special (cl &optional type) + "Demanage specal xwem client CL." + (cond ((eq type 'deactivate) + (xwem-special-apply-state cl)))) + +(defun xwem-iconify-emacs-special (cl) + "Iconify handler for special frame." + (xwem-special-apply-state cl))  (provide 'xwem-special) + +;;;; On-load actions: +;; Define application +(add-to-list 'xwem-applications-alist + `("xemacs-xwem-special" + (and (class-name ,(concat "^" x-emacs-application-class "$")) + (class-inst ,(concat "^" xwem-special-frame-name "$"))))) + +;; Add manage type +(define-xwem-manage-model emacs-special + "Managing model for special Emacs frames." +:match-spec '(application "xemacs-xwem-special") + +:manage-method 'xwem-manage-emacs-special +:activate-method 'xwem-activate-emacs-special +:deactivate-method 'xwem-deactivate-emacs-special +:iconify-method 'xwem-iconify-emacs-special) + +;; - Before init hook +(if xwem-started + (xwem-special-frame-init) + (add-hook 'xwem-before-init-hook 'xwem-special-frame-init)) ;;; xwem-special.el ends here Index: lisp/xwem-strokes.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-strokes.el,v retrieving revision 1.8 diff -u -u -r1.8 xwem-strokes.el --- lisp/xwem-strokes.el 16 Dec 2004 08:08:14 -0000 1.8 +++ lisp/xwem-strokes.el 1 Jan 2005 04:41:17 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2003 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: Thu Dec 4 17:42:12 MSK 2003 ;; Keywords: xwem, xlib -;; X-CVS: $Id: xwem-strokes.el,v 1.8 2004/12/16 08:08:14 youngs Exp $ +;; X-CVS: $Id: xwem-strokes.el,v 1.7 2004/12/05 22:37:35 lg Exp $ ;; This file is part of XWEM. ＠＠ -31,23 +32,17 ＠＠ ;; ;;; Code: -(eval-when-compile - (require 'xwem-misc)) + (require 'strokes) -(require 'xwem-compat) -(require 'xwem-keyboard) +(require 'xwem-load) +(require 'xwem-misc) +;;; Customisation (defgroup xwem-strokes nil "Group to customize XWEM strokes." :prefix "xwem-strokes-" :group 'xwem) -;;;###autoload -(defcustom xwem-strokes-enabled t - "*Non-nil mean xwem-stroke is enabled." -:type 'boolean -:group 'xwem-strokes) - (defcustom xwem-strokes-grid 25 "*XWEM strokes Grid resolution. Look at `strokes-grid-resolution' for details." ＠＠ -61,30 +56,33 ＠＠ (defcustom xwem-strokes-file "xwem-strokes.el" "*File contained strokes for xwem stroke mode." -:type 'string +:type 'file :group 'xwem-strokes) -(defcustom xwem-strokes-click-command - (lambda () - (interactive) - (xwem-message 'info "Default `xwem-strokes-click-command'.")) +(defcustom xwem-strokes-click-command 'xwem-strokes-default-click-command "*Command to execute when stroke is actually a `click'." :type 'function :group 'xwem-strokes) -(defcustom xwem-strokes-cursor-type 'X-XC-dot +(defcustom xwem-strokes-cursor-type '(X-XC-dot) "*Type of cursor to use when XWEM enters strokes mode." :type (xwem-cursor-shape-choice) +:set (xwem-cus-set-cursor-shape xwem-strokes-cursor) +:initialize 'custom-initialize-default :group 'xwem-strokes) (defcustom xwem-strokes-cursor-foreground-color "#00ea00" "*Cursor's foreground color when XWEM in strokes mode." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-foreground xwem-strokes-cursor) +:initialize 'custom-initialize-default :group 'xwem-strokes) (defcustom xwem-strokes-cursor-background-color "#002800" "*Cursor's background color when XWEM in strokes mode." -:type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p)) +:type 'color +:set (xwem-cus-set-cursor-background xwem-strokes-cursor) +:initialize 'custom-initialize-default :group 'xwem-strokes) (defcustom xwem-strokes-gc-function 'X-GXCopy ＠＠ -92,34 +90,32 ＠＠ :type (xwem-gc-function-choice) :group 'xwem-strokes) -(defcustom xwem-strokes-sleep 0.2 - "*How many seconds sleep before executing stroke." -:type 'float -:group 'xwem-strokes) - -(defface xwem-face-strokes-begin - `((t (:foreground "red4" :background "black" :line-width 10 - :subwindow-mode X-IncludeInferiors - :function (eval xwem-strokes-gc-function)))) - "Face used to begin stroke." +(define-xwem-face xwem-strokes-face + `(((background light) + (:foreground "red4" :background "black")) + ((background dark) + (:foreground "red" :background "black")) + ((background begin light) + (:foreground "magenta4" :background "black" +:line-width 12 :cap-style X-CapRound)) + ((background begin dark) + (:foreground "magenta" :background "black" +:line-width 12 :cap-style X-CapRound)) + (t (:foreground "red4" :background "black" +:line-width 8 :cap-style X-CapRound +:subwindow-mode X-IncludeInferiors +:function (eval xwem-strokes-gc-function)))) + "Face used to draw strokes." :group 'xwem-strokes :group 'xwem-faces) -(defface xwem-face-strokes - `((t (:foreground "magenta4" :background "black" :line-width 7 - :subwindow-mode X-IncludeInferiors - :function (eval xwem-strokes-gc-function) - :cap-style X-CapRound))) - "Face used to draw stroke." -:group 'xwem-strokes -:group 'xwem-faces) +;;; Internal variables ;; Stroke variables (defvar xwem-strokes-keymap (let ((map (make-sparse-keymap))) (set-keymap-default-binding map 'xwem-strokes-nocmd) - (define-key map xwem-quit-key 'xwem-keyboard-quit) (define-key map [button2] 'xwem-strokes-idescribe) (define-key map [button1] 'xwem-strokes-ibutton1) (define-key map [button1up] 'xwem-strokes-ibutton1up) ＠＠ -132,12 +128,21 ＠＠ (defvar xwem-strokes-map nil "Stroke map for XWEM.") -(defvar xwem-strokes-curr nil "Current events list, it passed to `stroke-' routines.") -(defvar xwem-strokes-defining nil "Non-nil mean that we defining stroke now.") +(defvar xwem-strokes-curr nil + "Current events list, it passed to `stroke-' routines.") +(defvar xwem-strokes-defining nil + "Non-nil mean that we defining stroke now.") -(defvar xwem-strokes-cursor nil "Cursor used while reading stroke.") +(defvar xwem-strokes-cursor nil + "Cursor used while reading stroke.") ;; Functions +(define-xwem-command xwem-strokes-default-click-command () + "Default command to execute when strokes detected click. +Click is detected when no mouse moving occured while doing stroke." + (xwem-interactive) + (xwem-message 'info "Such an ugly `xwem-strokes-click-command', which you normally should customize.")) + (defun xwem-strokes-save-strokes () "Save user defined strokes to file named by `xwem-strokes-file'. Modification to `strokes-prompt-user-save-strokes' to work with xwem's stuff." ＠＠ -145,7 +150,7 ＠＠ (strokes-file (expand-file-name xwem-strokes-file xwem-dir))) (flet ((yes-or-no-p-maybe-dialog-box (prompt) - (lambda () (xwem-under-minib-focus (yes-or-no-p prompt))))) + (lambda () (xwem-under-minibuffer (yes-or-no-p prompt))))) (funcall 'strokes-prompt-user-save-strokes)) ;; Fix stroke-file .. ＠＠ -161,7 +166,7 ＠＠ (defun xwem-strokes-load-strokes () "Load user defined strokes from file named by `xwem-strokes-file'." (if (file-exists-p (expand-file-name xwem-strokes-file xwem-dir)) -; (xwem-under-minib-focus +; (xwem-under-minibuffer ; (and (y-or-n-p ; (format "XWEM: No strokes loaded. Load `%s'? " ; (expand-file-name xwem-strokes-file xwem-dir))) ＠＠ -204,7 +209,7 ＠＠ ((string= type "key") (let ((xwem-interactively t)) (prog1 - (xwem-kbd-key-binding + (xwem-kbd-get-binding (xwem-read-key-sequence "XWEM Stroke key: ")) (xwem-kbd-stop-grabbing)))) (t nil)))) ＠＠ -215,8 +220,8 ＠＠ "Execute CMD. CMD is one of interactive command or keysequence." (if (xwem-strokes-cmd-valid-p cmd) (cond ((stringp cmd) - (xwem-kbd-force-mods-release) - (xwem-key-send-ekeys cmd)) + (xwem-deffered-funcall 'xwem-kbd-force-mods-release) + (xwem-deffered-funcall 'xwem-key-send-ekeys cmd)) ((vectorp cmd) (xwem-kbd-force-mods-release) ＠＠ -225,7 +230,7 ＠＠ (t (command-execute cmd))) - (xwem-message 'err "Invalid CMD in `xwem-strokes-execute-command'."))) + (xwem-message 'error "Invalid strokes command `%S'" cmd))) (defun xwem-strokes-execute-stroke (stroke) "Given STROKE, execute the command corresponds to it." ＠＠ -244,13 +249,13 ＠＠ (xwem-strokes-load-strokes) (if (null xwem-strokes-map) - (xwem-message 'err "No strokes defined; use `xwem-strokes-global-set-stroke'") + (xwem-message 'error "No strokes defined; use `xwem-strokes-global-set-stroke'") ;; Re-execute stroke in hope it will be founded in loaded ;; xwem-strokes-map. (xwem-strokes-execute-stroke stroke))) - (t (xwem-message 'err "No stroke matches; see variable `xwem-strokes-minimum-match-score'"))) + (t (xwem-message 'error "No stroke matches; see variable `xwem-strokes-minimum-match-score'"))) )) (defun xwem-strokes-define-or-execute (st) ＠＠ -270,9 +275,9 ＠＠ "Start new stroke or new stick at X Y point." (push (cons x y) xwem-strokes-curr) (XDrawArc (xwem-dpy) (xwem-rootwin) - (xwem-face-get-gc 'xwem-face-strokes-begin) - x y 1 1 0 (* 360 64)) - ) + (xwem-face-get-gc 'xwem-strokes-face + (list 'background 'begin (xwem-misc-xwin-background-mode (xwem-rootwin) x y))) + x y 1 1 0 (* 360 64))) (defun xwem-strokes-continue (x y) "Continue stroke at X Y." ＠＠ -282,7 +287,7 ＠＠ (push (cons x y) xwem-strokes-curr) (XDrawLine (xwem-dpy) (xwem-rootwin) - (xwem-face-get-gc 'xwem-face-strokes) + (xwem-face-get-gc 'xwem-strokes-face) old-x old-y x y))) ;;;###autoload(autoload 'xwem-strokes-define "xwem-strokes" "" t) ＠＠ -373,43 +378,30 ＠＠ (Xmask-or XM-ButtonPress XM-ButtonRelease XM-ButtonMotion)) (setq xwem-strokes-curr nil) - (xwem-strokes-start-new (X-Event-xbutton-root-x xwem-last-xevent) (X-Event-xbutton-root-y xwem-last-xevent)) ;; Event loop - (unwind-protect + (xwem-unwind-protect (let ((gc-cons-threshold most-positive-fixnum) ; inhibit GC'ing - (xwem-override-map xwem-strokes-keymap) - (xwem-keyboard-echo-keystrokes) ; Do not show - (xwem-bypass-quit t) ; Bypass quit signal in `xwem-kbd-handle-keybutton-from-emacs' - (xwem-stroke-complexp complexp) - (xwem-stroke-done nil) - xev eev) - (declare (special xwem-stroke-done)) - (declare (special xwem-stroke-complexp)) - - (setq xwem-bypass-quit xwem-bypass-quit) ;shutup compiler - - (while (not xwem-stroke-done) - (setq xev (xwem-next-event)) - - (when (member (X-Event-type xev) - (list X-KeyPress X-ButtonPress X-ButtonRelease X-MotionNotify)) - (setq eev (car (xwem-kbd-xevents->emacs-events (list xev) t))) - - (if (eq (event-type eev) 'motion) - (xwem-strokes-motion xev) - - (xwem-kbd-handle-keybutton-from-emacs eev xev))) - )) + (xwem-override-local-map xwem-strokes-keymap) ; override local keymap + (xwem-keyboard-echo-keystrokes nil) ; Do not show + (xwem-stroke-complexp complexp) + (xwem-stroke-done nil) + xev) + (declare (special xwem-stroke-done)) + (declare (special xwem-stroke-complexp)) + + (while (not xwem-stroke-done) + (X-Event-CASE (setq xev (xwem-next-event)) + (:X-MotionNotify (xwem-strokes-motion xev)) + ((:X-KeyPress :X-ButtonPress :X-ButtonRelease) + (xwem-dispatch-command-xevent xev))))) (xwem-strokes-done)) ;; Execute or define stroke (let* ((grid-locs (strokes-renormalize-to-grid xwem-strokes-curr xwem-strokes-grid)) (st (strokes-fill-stroke (strokes-eliminate-consecutive-redundancies grid-locs)))) - - (xwem-strokes-define-or-execute st)) - ) + (xwem-strokes-define-or-execute st))) (defun xwem-strokes-done (&optional xev) "Uninstalls stuff installed by `xwem-strokes-go'. ＠＠ -421,8 +413,9 ＠＠ (X-Event-xbutton-root-y xev))) (cons 0 0))))) (x 10000000) (y 1000000) (xma 0) (yma 0) - (thi (* 2 (max (xwem-face-tag 'xwem-face-strokes-begin :line-width) - (xwem-face-tag 'xwem-face-strokes :line-width))))) + (thi (* 2 (max (xwem-face-line-width 'xwem-strokes-face '(background begin light)) + (xwem-face-line-width 'xwem-strokes-face '(background begin dark)) + (xwem-face-line-width 'xwem-strokes-face))))) (while xsc (while (not (consp (car xsc))) ＠＠ -458,7 +451,7 ＠＠ (strokes-renormalize-to-grid pix-lock xwem-strokes-grid))) xwem-strokes-map)) - (xwem-message 'info "Current stroke stands for: %S" (car match)))) + (xwem-message 'info "Current stroke executes: %S" (car match)))) ;;;###autoload(autoload 'xwem-strokes-begin "xwem-strokes" "" t) (define-xwem-command xwem-strokes-begin (arg) ＠＠ -497,6 +490,22 ＠＠ (xwem-message 'info "Last stroke has been deleted.")) (xwem-message 'info "Nothing done."))) +(defun xwem-strokes-sort (smap &optional how) + "Sort strokes map SMAP." + (sort (copy-list smap) + (lambda (s1 s2) + (let ((c1 (cdr s1)) + (c2 (cdr s2))) + (cond ((and (stringp c1) (stringp c2)) + (string-lessp c1 c2)) + ((and (symbolp c1) (symbolp 2)) + (string-lessp (symbol-name c1) (symbol-name c2))) + ((stringp c1) t) + ((and (vectorp c1) (not (stringp c2))) t) + ((and (symbolp c1) (not (stringp c2)) (not (vectorp c2))) t) + ((and (functionp c1) (not (stringp c2)) (not (vectorp c2)) (not (symbolp c2))) t)))) + )) + ;;;###autoload(autoload 'xwem-strokes-list "xwem-strokes" "" t) (define-xwem-command xwem-strokes-list (arg) "List strokes defined for XWEM use. ＠＠ -508,7 +517,6 ＠＠ (let ((stb (get-buffer-create "*XWEM Strokes*"))) (xwem-special-popup-frame stb) - (with-current-buffer stb (setq buffer-read-only nil) (erase-buffer) ＠＠ -521,14 +529,14 ＠＠ (when (xwem-strokes-cmd-valid-p stroke-cmd) (strokes-xpm-for-stroke stroke " *strokes-xpm*") (newline 1) - (insert-char ?\x20 60) + (insert-char ?\x20 62) (beginning-of-line) (insert (xwem-strokes-cmd-type stroke-cmd)) (beginning-of-line) - (forward-char 18) + (forward-char 17) (insert (xwem-strokes-cmd-description stroke-cmd)) (beginning-of-line) - (forward-char 61) + (forward-char 62) (make-annotation (make-glyph (list (vector 'xpm ＠＠ -537,14 +545,17 ＠＠ (point-max " *strokes-xpm*") " *strokes-xpm*")) [string :data "[Image]"])) - + (xwem-win-cl (xwem-frame-selwin frame))) + + +;;;; Win structures +(defstruct xwem-win + geom ; window geometry (border width is internal window width) + clients ; xwem clients list managed in window + cl ; Current window's client + frame ; xwem frame + dead ; non-nil if window is dead + deleted ; non-nil if window was deleted + next ; next window in windows chain + prev ; previous window in windows chain + hchild ; horisontal child (if any) + vchild ; vertical child (if any) + parent ; parent window + + plist) ; User defined plist + +(defstruct (xwem-win-saved (:predicate xwem-iswinsaved-p)) + geom ; saved window geometry + clients ; clients managed in window + cl ; Current window's client + plist ; properties + selwin-p ; non-nil if window is selected in frame + first-hchild first-vchild + next prev) + +(defstruct (xwem-win-config (:predicate xwem-iswinconfig-p)) + frame ; window's frame + frame-xgeom ; saved frame X-Geom + frame-properties ; saved frame properties + current-cl ; cl in selected window + min-width min-height + saved-root-window) + +(defsubst xwem-win-alive-p (window) + "Return non-nil if WINDOW is alive." + (and (xwem-win-p window) + (xwem-frame-alive-p (xwem-win-frame window)) + (not (xwem-win-deleted window)) + (not (xwem-win-dead window)))) + +(defmacro xwem-win-x (win) + `(X-Geom-x (xwem-win-geom ,win))) +(defsetf xwem-win-x (win) (x) + `(setf (X-Geom-x (xwem-win-geom ,win)) ,x)) + +(defmacro xwem-win-y (win) + `(X-Geom-y (xwem-win-geom ,win))) +(defsetf xwem-win-y (win) (y) + `(setf (X-Geom-y (xwem-win-geom ,win)) ,y)) + +(defmacro xwem-win-width (win) + `(X-Geom-width (xwem-win-geom ,win))) +(defsetf xwem-win-width (win) (width) + `(setf (X-Geom-width (xwem-win-geom ,win)) ,width)) + +(defmacro xwem-win-height (win) + `(X-Geom-height (xwem-win-geom ,win))) +(defsetf xwem-win-height (win) (height) + `(setf (X-Geom-height (xwem-win-geom ,win)) ,height)) + +(defmacro xwem-win-border-width (win) + `(X-Geom-border-width (xwem-win-geom ,win))) +(defsetf xwem-win-border-width (win) (border-width) + `(setf (X-Geom-border-width (xwem-win-geom ,win)) ,border-width)) + +(defsubst xwem-win-get-prop (win prop) + "Get WIN's property PROP." + (plist-get (xwem-win-plist win) prop)) + +(defsubst xwem-win-rem-prop (win prop) + "Remove WIN's property PROP." + (setf (xwem-win-plist win) + (plist-remprop (xwem-win-plist win) prop))) + +(defsubst xwem-win-put-prop (win prop val) + "Set WIN's property PROP to VAL." + (if val + (setf (xwem-win-plist win) + (plist-put (xwem-win-plist win) prop val)) + (xwem-win-rem-prop win prop))) +(put 'xwem-win-put-prop 'lisp-indent-function 2) + +(defmacro xwem-win-selected () + "Return selected window." + '(and (xwem-frame-alive-p (xwem-frame-selected)) + (xwem-frame-selwin (xwem-frame-selected)))) + +(defmacro xwem-win-selected-p (win) + "Return non-nil if WIN is currently selected window." + `(eq ,win (xwem-win-selected))) + +(defsubst xwem-win-selwin-p (win) + "Return non-nil if WIN is localy selected window in WIN's frame." + (and (xwem-win-p win) + (eq win (xwem-frame-selwin (xwem-win-frame win))))) + +(defsubst xwem-win-cl-current-p (cl &optional win) + "Return non-nil if CL is current WIN's client." + (unless win + (setq win (xwem-cl-win cl))) + (when (xwem-win-p win) + (eq cl (xwem-win-cl win)))) + + +;;;; Client structures +(defstruct xwem-hints + ;; TODO: add more + wm-normal-hints + wm-hints + wm-class + wm-command + wm-name + wm-icon-name + wm-transient-for + wm-protocols) + (eq (cdr e1) (cdr e2))))) + (cons fun args) + (dll-element xwem-deffered-dll node)) + (setq exists t)))) + (setq node (elib-node-right node))) + + (if exists + (dll-delete xwem-deffered-dll node) + (enqueue-eval-event 'xwem-deffered-process nil)) + + (xwem-debug 'xwem-deffered "---------> IN %S" 'fun) + (dll-enter-last xwem-deffered-dll (cons fun args)))) + +(defun xwem-deffered-process (obj-notused) + "Process deffering commands." + (declare (special xwem-deffering-p)) + + (unless xwem-deffering-p + (let ((xwem-deffering-p t)) + (run-hooks 'xwem-pre-deffering-hook) + (setq xwem-pre-deffering-hook nil))) + + (while (not (dll-empty xwem-deffered-dll)) + (let ((el (dll-first xwem-deffered-dll)) + (xwem-deffering-p t)) + (xwem-debug 'xwem-deffered "<--------- OUT %S" '(car el)) + (dll-delete-first xwem-deffered-dll) + (apply (car el) (cdr el)))) + + (unless xwem-deffering-p + (let ((xwem-deffering-p t)) + (run-hooks 'xwem-post-deffering-hook) + (setq xwem-post-deffering-hook nil)))) + +(defun xwem-add-hook-post-deffering (hook &optional append) + "Add HOOK to `xwem-post-deffering-hook'." + (add-hook 'xwem-post-deffering-hook hook append) + ;; Run it to be sure to enter deffering + (xwem-deffered-push 'ignore)) + +;; Dont know where to put this macro, so putten here. +(defmacro define-xwem-deffered (deff-name normal-name arglist docstring &rest body) + "Define new deffered function with function name DEFF-NAME. +Deffered function is function which is called when XEmacs is about to became idle. + +Another advantage of deffered function is that only one instance of +function will be called with same arguments. For example if you have +`my-defffun' deffered function and you call twice `(my-defffun 1)', +`(my-defffun 1)' - then when XEmacs will be about idle only one call +occurs to `my-defffun'. However if you pass different arguments, all +calls with different arguments are called. Arguments are equal if +they are either `eq' or both are lists, where each element is `eq'. + +NAME, ARGLIST, DOCSTRING and BODY argument have same meaning as for `defun'. +If NORMAL-NAME is specified, also define non-deffered variant of DEFF-NAME function. +If NORMAL-NAME is ommited, then normal-name constructed by +concatination of DEFF-NAME and \"-1\"." + (unless (and (not (null normal-name)) + (symbolp normal-name)) + ;; If NORMAL-NAME ommited + (setq body (cons docstring body)) + (setq docstring arglist) + (setq arglist normal-name) + (setq normal-name (intern (concat (symbol-name deff-name) "-1")))) + + `(progn + (defun ,normal-name ,arglist + ,docstring + ,＠body) + + (defun ,deff-name (&rest args) + ,(concat "Deffered variant of `" (symbol-name normal-name) "'.") + (apply (quote xwem-deffered-push) (quote ,normal-name) args)))) + +(defmacro xwem-deffered-funcall (fun &rest args) + "Call FUN with ARGS, deffering funcall to FUN." + `(xwem-deffered-push ,fun ,＠args)) + +(defmacro xwem-unwind-protect (body-form &rest unwind-forms) + "Execute BODY-FORM protecting it in safe more with UNWIND-FORMS. +`xwem-unwind-protect' differs from `unwind-protect' that +`xwem-unwind-protect' executes UNWIND-FORMS even when debugging." + `(prog1 + (condition-case xwem-unwind-error + ,body-form + (t ,＠unwind-forms + (apply 'error (car xwem-unwind-error) (cdr xwem-unwind-error)))) + ,＠unwind-forms)) +(put 'xwem-unwind-protect 'lisp-indent-function 1) + +(defmacro xwem-overriding-local-map (nlm &rest forms) + "Execute FORMS installing `xwem-overriding-local-map' to NLM. +Do it in safe manner." + `(xwem-unwind-protect + (let ((xwem-override-local-map ,nlm)) + ,＠forms))) +(put 'xwem-overriding-local-map 'lisp-indent-function 'defun) + + +(provide 'xwem-struct) + +;;; xwem-struct.el ends here Index: lisp/xwem-tabbing.el ====================================== (define-xwem-command xwem-tabber-popup-cl-menu () "Popup clients menu." (xwem-interactive) (when (xwem-cl-alive-p xwem-tabber-click-cl) - (xwem-popup-menu (xwem-gen-cl-menu xwem-tabber-click-cl)) - )) - -(defun xwem-tabber-event-handler (xdpy xwin xev) - "On display XDPY and window XWIN handle event XEV." - (let ((tabber (X-Win-get-prop xwin 'xwem-tabber))) - (when (xwem-tabber-p tabber) - (X-Event-CASE xev - (:X-Expose - (when (eq (xwem-frame-state (xwem-tabber-frame tabber)) 'mapped) - (xwem-tabber-draw tabber)) - ) - - (:X-DestroyNotify - (X-invalidate-cl-struct tabber)) - - ((:X-ButtonPress :X-ButtonRelease) - ;; Handle button press/release event - (let* ((x (X-Event-xbutton-event-x xev)) - (y (X-Event-xbutton-event-y xev)) - (xwem-tabber-click-frame (xwem-tabber-frame tabber)) - (xwem-tabber-click-titem - (xwem-tabber-item-at (xwem-frame-selwin xwem-tabber-click-frame) x y tabber)) - (xwem-tabber-click-cl (and (xwem-tab-item-p xwem-tabber-click-titem) - (xwem-tab-item-cl xwem-tabber-click-titem))) - (xwem-keyboard-echo-keystrokes nil) ; XXX - (xwem-override-global-map xwem-tabber-map)) - - (xwem-kbd-handle-keybutton xev))) - )))) - -;;;###autoload -(defun xwem-tabber-create (frame geom initial-state) - "Create new tabber for FRAME with GEOM and INITIAL-STATE." - (let ((xft (make-xwem-tabber :frame frame - :xgeom geom - :state initial-state)) - (xdpy (xwem-dpy)) - w preparer) - (setq w (XCreateWindow xdpy - (xwem-frame-xwin frame) - (X-Geom-x geom) (X-Geom-y geom) - (X-Geom-width geom) (X-Geom-height geom) - (X-Geom-border-width geom) - nil nil nil;X-InputOutput nil - (make-X-Attr :background-pixel (XWhitePixel (xwem-dpy)) -:backing-store X-WhenMapped - ))) - (setf (xwem-tabber-xwin xft) w) - (X-Win-put-prop w 'xwem-tabber xft) - - (XSelectInput xdpy w (Xmask-or XM-Exposure XM-StructureNotify XM-ButtonPress XM-ButtonRelease XM-ButtonMotion)) - (X-Win-EventHandler-add w 'xwem-tabber-event-handler 0 - (list X-Expose X-DestroyNotify X-ButtonPress X-ButtonRelease X-MotionNotify)) - - (setq preparer (XCreatePixmap xdpy (make-X-Pixmap :dpy xdpy :id (X-Dpy-get-id xdpy)) - w (XDefaultDepth xdpy) (X-Geom-width geom) (X-Geom-height geom))) - - (setf (xwem-tabber-xpreparer xft) preparer) + (xwem-popup-menu (xwem-generate-cl-menu xwem-tabber-click-cl)))) - (XMapWindow (X-Win-dpy w) w) - xft)) - -(defun xwem-tabber-add-tab-item (tabber tab-item) - "Into TABBER tab items list add TAB-ITEM." - (pushnew tab-item (xwem-tabber-tab-items tabber))) - -(defun xwem-tabber-item-at (win x y &optional tabber) - "Return tab item at X Y in tabber." - (let ((cls (xwem-win-make-cl-list win)) - ti) - (while (and cls (not ti)) - (let* ((tit (xwem-cl-get-prop (car cls) 'xwem-tab-item)) - (xg (and (xwem-tab-item-p tit) (xwem-tab-item-rect tit)))) - (when (and xg - (<= (X-Rect-x xg) x) - (>= (+ (X-Rect-x xg) (X-Rect-width xg)) x) - (<= (X-Rect-y xg) y) - (>= (+ (X-Rect-y xg) (X-Rect-height xg)) y)) - (setq ti tit))) - (setq cls (cdr cls))) - (or ti (and (xwem-tabber-p tabber) (xwem-tabber-empty-tabi tabber))))) - -(defun xwem-tabber-headers-width (xft) - "Return width of XFT's headers." - (apply (lambda (els) - (if els (apply '+ els) 0)) - (mapcar (lambda (ti) - (X-Rect-width (xwem-tab-item-rect ti))) - (xwem-tabber-header-tabis xft)))) - -(defun xwem-tabber-tailers-width (xft) - "Return width of XFT's tailers." - (apply (lambda (els) - (if els (apply '+ els) 0)) - (mapcar (lambda (ti) - (X-Rect-width (xwem-tab-item-rect ti))) - (xwem-tabber-tailer-tabis xft)))) - -;;;###autoload -(defun xwem-tabber-regeom-window (win &optional draw-p) - (let ((tabber (xwem-frame-get-prop (xwem-win-frame win) 'xwem-tabber))) - (when (xwem-tabber-p tabber) - (xwem-tabber-regeom tabber win draw-p)))) - -;;;###autoload -(defun xwem-tabber-regeom (tabber window &optional draw-p) - "Adjust tabs geometries in TABBER." - ;; TODO: - ;; - Take into account large delimeters - (let* ((frame (xwem-tabber-frame tabber)) - (hw 0);(xwem-tabber-headers-width tabber)) - (tw 0);(xwem-tabber-tailers-width tabber)) - (twidth (- (xwem-frame-width frame) hw tw)) - (off hw) - (cls (xwem-win-make-cl-list (or window (xwem-frame-selwin (xwem-tabber-frame tabber))))) - (clsn (length cls)) ; number of clients - (dw 2) ; XXX delimeter width - (ldw 4) ; XXX large delimeter width - dwc ldwc ; dws counter and ldws counter - tiw twrem tabi rect) - - (when cls - (setq ldwc (/ clsn xwem-tab-delim-interval)) - (setq dwc (- clsn ldwc 1)) - (setq tiw (/ (- twidth (* dw dwc) (* ldw ldwc)) clsn)) ; tab item width - (setq twrem (% (- twidth (* dw dwc) (* ldw ldwc)) clsn)) ; reminder - - (while cls - (setq tabi (xwem-cl-get-prop (car cls) 'xwem-tab-item)) - (setq rect (xwem-tab-item-rect tabi)) +(defun xwem-tabber-cl-at (tabber x y) + "Return client of TABBER which rectangle covers point at X Y." + (let ((clients (xwem-tabber-clients tabber)) + (tmp-rect (xwem-tabber-rect->xpix-rect + tabber (make-X-Rect :x x :y y :width 0 :height 0))) + rect ret-cl) + ;; Adjust X and Y + (setq x (X-Rect-x tmp-rect) + y (X-Rect-y tmp-rect)) + (while clients + (setq rect (xwem-cl-tab-rect (car clients))) + (if (and rect + (<= (X-Rect-x rect) x) + (>= (+ (X-Rect-x rect) (X-Rect-width rect)) x) + (<= (X-Rect-y rect) y) + (>= (+ (X-Rect-y rect) (X-Rect-height rect)) y)) + (setq ret-cl (car clients) + clients nil) + (setq clients (cdr clients)))) + ret-cl)) + +(defun xwem-tabber-regeom (tabber) + "Adjust tab items geometries in TABBER." + ;; TODO: handle margins + (let* ((twidth (X-Geom-width (xwem-tabber-xgeom tabber))) + (theight (X-Geom-height (xwem-tabber-xgeom tabber))) + (clients (xwem-tabber-clients tabber)) + (clsn (length clients )) ; number of clients + (off 0) + tiw twrem rect) + + (when clients + (setq tiw (/ twidth clsn) + twrem (% twidth clsn)) + + (while clients + ;; Setup CL's tab rectangle rectangle + (unless (xwem-cl-tab-rect (car clients)) + (setf (xwem-cl-tab-rect (car clients)) + (make-X-Rect :x 0 :y 0 :width 0 :height 0))) + (setq rect (xwem-cl-tab-rect (car clients))) (setf (X-Rect-x rect) off) - (setf (X-Rect-width rect) (+ tiw (if (cdr cls) 0 twrem))) - - ;; XXX - (setf (X-Rect-height rect) (X-Geom-height (xwem-tabber-xgeom tabber))) - - (if (zerop (% (length cls) xwem-tab-delim-interval)) - (progn - (setf (xwem-tab-item-delim-width tabi) ldw) - (setq off (+ off tiw ldw))) - - (setf (xwem-tab-item-delim-width tabi) dw) - (setq off (+ off tiw dw))) - - (setq cls (cdr cls)))) + (setf (X-Rect-width rect) (+ tiw (if (cdr clients) 0 twrem))) + (setf (X-Rect-height rect) theight) - (when draw-p - (xwem-tabber-draw tabber)) - )) + (setq off (+ off (X-Rect-width rect))) + (setq clients (cdr clients)))))) (defsubst xwem-tabber-safe-regeom (tabber &optional draw-p) "Saf variant of `xwem-tabber-regeom'." (and (xwem-tabber-p tabber) - (xwem-tabber-regeom tabber nil draw-p))) - -(defun xwem-tabber-draw-empty (tabber) - "Draw empty." - (let* ((frame (xwem-tabber-frame tabber)) - (selected-p (xwem-frame-selected-p frame)) - (xgeom (xwem-tabber-xgeom tabber))) - - ;; Create fake CL and tabi - (setf (xwem-tabber-empty-tabi tabber) - (make-xwem-tab-item :rect (make-X-Rect :x (X-Geom-x xgeom) -:y (X-Geom-y xgeom) -:width (X-Geom-width xgeom) -:height(X-Geom-height xgeom)) -:state (if selected-p - 'xwem-face-tab-selected-active - 'xwem-face-tab-nonselected-active) -:format xwem-tab-empty-name)) - - (xwem-tab-item-draw-format-1 (xwem-tabber-empty-tabi tabber) tabber))) + (xwem-tabber-regeom tabber))) -;;;###autoload -(defun xwem-tabber-draw (tabber) - "Draw tabber." - (let* ((cls (xwem-win-make-cl-list (xwem-frame-selwin (xwem-tabber-frame tabber)))) - (tabis (mapcar (lambda (cl) (xwem-cl-get-prop cl 'xwem-tab-item)) cls));(xwem-tabber-tab-items tabber)) - tab-item) - - (if (not tabis) - (xwem-tabber-draw-empty tabber) - - (X-invalidate-cl-struct (xwem-tabber-empty-tabi tabber)) ; make sure here no empty tabitem - (while tabis - (setq tab-item (car tabis)) - (xwem-tab-item-draw-format tab-item) - - (setq tabis (cdr tabis)) - )))) - -(defun xwem-tab-item-get-fill-gc (tabi &optional tabber) - "Return GC associated with TABI." - ;; TODO: write me - (xwem-face-get-gc (xwem-tab-item-state tabi))) - -(defun xwem-tab-item-get-draw-gc (tabi &optional tabber) - "Return GC to draw TABI's text." - (xwem-face-get-gc (xwem-tab-item-state tabi))) - - -;;; Drawers -;;;###autoload -(defun xwem-tab-item-draw-format (tabi) - (when (and (xwem-cl-p (xwem-tab-item-cl tabi)) - (xwem-frame-p (xwem-cl-frame (xwem-tab-item-cl tabi)))) - (xwem-tab-item-draw-format-1 tabi))) - -(defun xwem-tab-item-draw-format-1 (tabi &optional tabber) - "Draw TABI's format string." - (let* ((rect (xwem-tab-item-rect tabi)) - (tabxwin (xwem-tabber-xwin (or tabber (xwem-tab-item-tabber tabi)))) - (xprep (xwem-tabber-xpreparer (or tabber (xwem-tab-item-tabber tabi)))) - (cl (xwem-tab-item-cl tabi)) - (fmt (xwem-tab-item-format tabi)) +;; Drawings +(defun xwem-tabber-xpix-rect->rect (tabber rect) + (let ((x0 (X-Rect-x rect)) + (y0 (X-Rect-y rect)) + (w0 (X-Rect-width rect)) + (h0 (X-Rect-height rect)) + x y w h) + (case (xwem-frame-property (xwem-tabber-frame tabber) 'title-layout) + (left + (setq y x0 + x (- (X-Geom-width (xwem-tabber-xgeom tabber)) y0 h0) + h w0 + w h0)) + (right + (setq x y0 + y (- (X-Geom-height (xwem-tabber-xgeom tabber)) x0 w0) + w h0 + h w0)) + (t (setq x x0 + y y0 + w w0 + h h0))) + (make-X-Rect :x x :y y :width w :height h))) + +(defun xwem-tabber-rect->xpix-rect (tabber rect) + (xwem-tabber-xpix-rect->rect tabber rect)) + +(define-xwem-deffered xwem-tabber-redraw xwem-tabber-redraw-1 (tabber &optional x y width height) + "Redraw TABBER's rectangle specified by X, Y, WIDTH and HEIGHT. +If one of optional arguments ommited, full redraw." + (when (xwem-tabber-p tabber) + (let* ((xgeom (xwem-tabber-xgeom tabber)) + (x (or x 0)) + (y (or y 0)) + (width (or width (X-Geom-width xgeom))) + (height (or height (X-Geom-height xgeom))) + (tl (xwem-frame-property (xwem-tabber-frame tabber) 'title-layout))) + (cond ((memq tl '(top bottom)) + (XCopyArea (xwem-dpy) (xwem-tabber-xpix-copy tabber) (xwem-tabber-xwin tabber) + (XDefaultGC (xwem-dpy)) x y width height x y)) + ((memq tl '(left right)) + (let* ((ximg (XGetImage (xwem-dpy) (xwem-tabber-xpix-copy tabber) + x y width height X-AllPlanes X-ZPixmap)) + (rxd (xwem-misc-rotate-data (nth 4 ximg) width height + (XGetDepth (xwem-dpy) + (xwem-tabber-xpix-copy tabber)) + (if (eq tl 'left) 'left 'right))) + (dst-height width) + (dst-width height) + dst-x dst-y) + (if (eq tl 'left) + (setq dst-x y + dst-y (- (X-Geom-width xgeom) x width)) + (setq dst-x (- (X-Geom-height xgeom) y height) + dst-y x)) + (XPutImage (xwem-dpy) (xwem-tabber-xwin tabber) + (XDefaultGC (xwem-dpy)) + (XGetDepth (xwem-dpy) (xwem-tabber-xpix-copy tabber)) + dst-width dst-height dst-x dst-y nil X-ZPixmap rxd))))))) + +(define-xwem-deffered xwem-tabber-redraw-xrect xwem-tabber-redraw-xrect-1 (tabber &optional xrect) + "Redraw part of TABBER. +XRECT specifies geometry to redraw. +Defaultly full redraw." + (when (xwem-tabber-p tabber) + (unless xrect + (setq xrect (X-Geom-to-X-Rect (xwem-tabber-xgeom tabber)))) + + (xwem-tabber-redraw tabber + (X-Rect-x xrect) (X-Rect-y xrect) + (X-Rect-width xrect) (X-Rect-height xrect)))) + +(defsubst xwem-tabber-frame-win-clients (tabber) + "Return list of managed clients in TABBER's window." + (delq nil (mapcar (lambda (cl) + (and (xwem-cl-managed-p cl '(active inactive)) cl)) + (xwem-win-clients (xwem-frame-selwin (xwem-tabber-frame tabber)))))) + +(defsubst xwem-tabber-clients-equal (cls1 cls2) + "Return non-nil if each element of CLS1 and CLS2 is `eq'." + (and (= (length cls1) (length cls2)) + (not (memq nil (or (mapcar* 'eq cls1 cls2)))))) + +(define-xwem-deffered xwem-tabber-draw-format xwem-tabber-draw-format-1 (cl &optional tabber force-update) + "Draw CL's tab. +If FORCE-UPDATE is non-nil also copy to TABBER x window." + (when (or (null cl) (xwem-cl-alive-p cl)) + ;; Either empty or valid client + (let* ((tabber (or tabber (xwem-cl-tabber cl))) + (rect (or (and (xwem-cl-p cl) (xwem-cl-tab-rect cl)) + (let ((xgeom (xwem-tabber-xgeom tabber))) + (make-X-Rect :x 0 :y 0 :width (X-Geom-width xgeom) +:height (X-Geom-height xgeom))))) + (fmt (or (and (xwem-cl-p cl) + (xwem-client-property cl 'xwem-tab-format)) + xwem-tab-empty-format)) + (xprep (xwem-tabber-xpreparer tabber)) + (xpcop (xwem-tabber-xpix-copy tabber)) (xoff (X-Rect-x rect)) (yoff (X-Rect-y rect)) - fill-gc currgc fi item fmt-index - sfg) + tag-set currgc fi item fmt-index sfg) - ;; Update tabi's state - (when (xwem-cl-p cl) - (let ((frame (xwem-cl-frame cl))) - (when (xwem-frame-p frame) - (if (xwem-frame-selected-p frame) - (setf (xwem-tab-item-state tabi) - (if (xwem-win-cl-current-p cl) - 'xwem-face-tab-selected-active - 'xwem-face-tab-selected-passive)) - - ;; XXX - (setf (xwem-tab-item-state tabi) - (if (xwem-win-cl-current-p cl) - 'xwem-face-tab-nonselected-active - 'xwem-face-tab-nonselected-passive)))))) - - (setq fill-gc (xwem-tab-item-get-fill-gc tabi tabber)) - (setq currgc (xwem-tab-item-get-draw-gc tabi tabber)) - - (setq sfg (X-Gc-foreground fill-gc)) - (unwind-protect - (progn - (setf (X-Gc-foreground fill-gc) (X-Gc-background fill-gc)) - (XChangeGC (xwem-dpy) fill-gc) - - (XFillRectangles (xwem-dpy) xprep fill-gc (list rect))) + ;; Setup TAG-SET + (if (xwem-frame-selected-p (xwem-tabber-frame tabber)) + (if (xwem-cl-p cl) + (if (xwem-win-cl-current-p cl) + (setq tag-set (list 'frame-selected 'tab-selected)) + (setq tag-set (list 'frame-selected 'tab-nonselected))) + + ;; Empty tab item + (setq tag-set (list 'frame-selected 'tab-selected))) + + (if (xwem-cl-p cl) + (if (xwem-win-cl-current-p cl) + (setq tag-set (list 'frame-nonselected 'tab-selected)) + (setq tag-set (list 'frame-nonselected 'tab-nonselected))) - (setf (X-Gc-foreground fill-gc) sfg) - (XChangeGC (xwem-dpy) fill-gc)) + ;; Empty tab item + (setq tag-set (list 'frame-nonselected 'tab-selected)))) - (XSetClipRectangles (xwem-dpy) fill-gc 0 0 (list rect)) + ;; Setup currgc, xprep, tabxwin + (setq currgc (xwem-face-get-gc (xwem-cl-tab-face cl) tag-set cl)) (XSetClipRectangles (xwem-dpy) currgc 0 0 (list rect)) - ;; In case there no cl attached, skip format field - (unless (xwem-cl-p cl) - (setq fmt xwem-tab-empty-name)) + (setq sfg (X-Gc-foreground currgc)) + (xwem-unwind-protect + (progn + (setf (X-Gc-foreground currgc) (X-Gc-background currgc)) + (XChangeGC (xwem-dpy) currgc) + (XFillRectangles (xwem-dpy) xprep currgc (list rect)) + (XFillRectangles (xwem-dpy) xpcop currgc (list rect))) + (setf (X-Gc-foreground currgc) sfg) + (XChangeGC (xwem-dpy) currgc)) + ;; Process format string (setq fmt-index 0) (while (and (< xoff (+ (X-Rect-x rect) (X-Rect-width rect))) - (< fmt-index (length fmt))) - (setq fi (aref fmt fmt-index)) + (< fmt-index (length fmt))) + ;; Extract ITEM + (setq fi (aref fmt fmt-index)) (incf fmt-index) (if (eq fi ?%) - (progn - (setq fi (aref fmt fmt-index)) - (setq item (cond ((= fi ?n) (xwem-hints-wm-name (xwem-cl-hints cl))) - ((= fi ?c) (car (xwem-hints-wm-class (xwem-cl-hints cl)))) - ((= fi ?C) (cadr (xwem-hints-wm-class (xwem-cl-hints cl)))) - ((= fi ?i) (xwem-icons-cl-icon cl)) - ((= fi ?s) (xwem-cl-get-psize cl)) - ((= fi ?S) (xwem-cl-get-usize cl)) - ((= fi ?u) (xwem-cl-get-uptime cl)) - ((= fi ?U) (xwem-cl-get-uptime cl)) - ((= fi ?f) (int-to-string (xwem-frame-num (xwem-cl-frame cl)))) - ((= fi ?*) (if (xwem-cl-marked-p cl) "*" "-")) - ((= fi ?#) (if (XWMProtocol-set-p (xwem-dpy) - (xwem-hints-wm-protocols (xwem-cl-hints cl)) - "WM_DELETE_WINDOW") - "#" "-")) - ((= fi ?%) "%") - - ;; Emacs lisp - ((= fi ?{) - (let ((substr (substring fmt (1+ fmt-index))) - elstr) - (unless (string-match "\\(\\([^%]\\|%[^}]\\)*\\)%}" substr) - (signal 'search-failed fmt "%}")) + (progn + (setq fi (aref fmt fmt-index)) + (setq item (cond ((= fi ?n) (xwem-client-name cl)) + ((= fi ?c) (car (xwem-hints-wm-class (xwem-cl-hints cl)))) + ((= fi ?C) (cdr (xwem-hints-wm-class (xwem-cl-hints cl)))) + ((= fi ?i) (xwem-icons-cl-icon cl (and (not (xwem-frame-selected-p (xwem-cl-frame cl))) + '(shade)))) + ((= fi ?s) (xwem-cl-get-psize cl)) + ((= fi ?S) (xwem-cl-get-usize cl)) + ((= fi ?u) (xwem-cl-get-uptime cl)) + ((= fi ?U) (xwem-cl-get-uptime cl)) + ((= fi ?f) (int-to-string (xwem-frame-num (xwem-cl-frame cl)))) + ((= fi ?F) (xwem-frame-name (xwem-cl-frame cl))) + ((= fi ?*) (if (xwem-cl-marked-p cl) "*" "-")) + ((= fi ?#) (if (XWMProtocol-set-p (xwem-dpy) + (xwem-hints-wm-protocols (xwem-cl-hints cl)) + "WM_DELETE_WINDOW") + "#" "-")) + ((= fi ?I) (let ((ip (X-WMHints-input-p (xwem-hints-wm-hints (xwem-cl-hints cl)))) + (tf (XWMProtocol-set-p (xwem-dpy) + (xwem-hints-wm-protocols (xwem-cl-hints cl)) + "WM_TAKE_FOCUS"))) + (cond ((and ip tf) "L") + (ip "P") + + (xwem-frame-selected-p (xwem-tabber-frame tabber))) + (xwem-tabber-put-prop tabber 'xwem-frame-selected-p + (xwem-frame-selected-p (xwem-tabber-frame tabber))) + (setq force-draw t)) + + (if (or (xwem-tabber-regeom-p tabber) force-draw) + (setq cls-to-draw (or (xwem-tabber-clients tabber) (list nil)) + need-draw-p t) ; all clients + (setq cls-to-draw (delq nil (mapcar (lambda (cl) + (and (xwem-cl-get-sys-prop cl 'xwem-tab-need-redraw) cl)) + (xwem-tabber-clients tabber))) + need-draw-p cls-to-draw)) + + (when need-draw-p + (mapc '(lambda (cl) (xwem-tabber-draw-format-1 cl tabber)) cls-to-draw) + (xwem-tabber-redraw-1 tabber))))) + +(defun xwem-tabber-event-handler (xdpy xwin xev) + "On display XDPY and window XWIN handle event XEV." + (let ((tabber (X-Win-get-prop xwin 'xwem-tabber))) + (when (xwem-tabber-p tabber) + (X-Event-CASE xev + (:X-Expose + (xwem-tabber-redraw-xrect + tabber (xwem-tabber-rect->xpix-rect + tabber + (make-X-Rect :x (X-Event-xexpose-x xev) +:y (X-Event-xexpose-y xev) +:width (X-Event-xexpose-width xev) +:height (X-Event-xexpose-height xev))))) + + (:X-DestroyNotify + (when (xwem-tabber-p tabber) + (XFreePixmap (xwem-dpy) (xwem-tabber-xpreparer tabber)) + (XFreePixmap (xwem-dpy) (xwem-tabber-xpix-copy tabber)) + (X-invalidate-cl-struct tabber))) + + ((:X-ButtonPress :X-ButtonRelease) + ;; Handle button press/release event + (let* ((x (X-Event-xbutton-event-x xev)) + (y (X-Event-xbutton-event-y xev)) + (xwem-tabber-click-frame (xwem-tabber-frame tabber)) + (xwem-tabber-click-cl (xwem-tabber-cl-at tabber x y)) + (xwem-keyboard-echo-keystrokes nil)) ; XXX + (xwem-overriding-local-map + (if (xwem-frame-dedicated-p (xwem-tabber-frame tabber)) + xwem-tabber-dedicated-map + xwem-tabber-map) + (xwem-dispatch-command-xevent xev)))) + )))) + +(defun xwem-tabber-create (frame) + "Create new tabber for FRAME." + (let* ((xgeom (make-X-Geom :x 0 :y 0 +:width 1 :height 1 +:border-width 0)) ; XXX + (tabber (make-xwem-tabber :frame frame +:xgeom xgeom)) + (xdpy (xwem-dpy)) + (w (XCreateWindow xdpy + (xwem-frame-xwin frame) + (X-Geom-x xgeom) (X-Geom-y xgeom) + (X-Geom-width xgeom) (X-Geom-height xgeom) + (X-Geom-border-width xgeom) + nil nil nil ;X-InputOutput nil + (make-X-Attr :background-pixel (XWhitePixel (xwem-dpy)) +:bit-gravity X-StaticGravity +:backing-store X-Always)))) + + (setf (xwem-tabber-xwin tabber) w) + (X-Win-put-prop w 'xwem-tabber tabber) + + (XSelectInput xdpy w (Xmask-or XM-Exposure XM-StructureNotify + XM-ButtonPress XM-ButtonRelease XM-ButtonMotion)) + (X-Win-EventHandler-add w 'xwem-tabber-event-handler 0 + (list X-Expose X-DestroyNotify X-ButtonPress + X-ButtonRelease X-MotionNotify)) + + ;; Adjust XGEOM and create Preparer and xpix-copy +; (setf (xwem-tabber-xpreparer tabber) +; (XCreatePixmap xdpy (make-X-Pixmap :dpy xdpy :id (X-Dpy-get-id xdpy)) +; w (XDefaultDepth xdpy) (X-Geom-width xgeom) (X-Geom-height xgeom))) +; (setf (xwem-tabber-xpix-copy tabber) +; (XCreatePixmap xdpy (make-X-Pixmap :dpy xdpy :id (X-Dpy-get-id xdpy)) +; w (XDefaultDepth xdpy) (X-Geom-width xgeom) (X-Geom-height xgeom))) + (xwem-tabber-resize tabber) + + ;; Draw tabber contents and map its window + (xwem-tabber-draw-1 tabber t) + (XMapWindow (X-Win-dpy w) w) + tabber)) + +(defun xwem-tabber-move-resize (tabber) + "Move TABBER to its place according to title-layout, etc," + (let* ((frame (xwem-tabber-frame tabber)) + (th (xwem-frame-property frame 'title-height)) + (ibw (xwem-frame-property frame 'inner-border-width)) + (xgeom (xwem-tabber-xgeom tabber)) + x y w h) + (when (xwem-frame-p frame) + (case (xwem-frame-property frame 'title-layout) + (top + (setf (X-Geom-width xgeom) (- (xwem-frame-width frame) ibw ibw) + (X-Geom-height xgeom) th) + (setq x ibw + y ibw + w (X-Geom-width xgeom) + h (X-Geom-height xgeom))) + (bottom + (setf (X-Geom-width xgeom) (- (xwem-frame-width frame) ibw ibw) + (X-Geom-height xgeom) th) + (setq x ibw + y (- (xwem-frame-height frame) th ibw) + w (X-Geom-width xgeom) + h (X-Geom-height xgeom))) + (left + (setf (X-Geom-width xgeom) (- (xwem-frame-height frame) ibw ibw) + (X-Geom-height xgeom) th) + (setq x ibw + y ibw + w (X-Geom-height xgeom) + h (X-Geom-width xgeom))) + + (right + (setf (X-Geom-width xgeom) (- (xwem-frame-height frame) ibw ibw) + (X-Geom-height xgeom) th) + (setq x (- (xwem-frame-width frame) th ibw) + y ibw + w (X-Geom-height xgeom) + h (X-Geom-width xgeom)))) + + (XMoveResizeWindow (xwem-dpy) (xwem-tabber-xwin tabber) x y w h)))) -(defun xwem-tabber-resize (tabber width height) +(defun xwem-tabber-resize (tabber) "Resize TABBER to WIDTH, HEIGHT." (let* ((xgeom (xwem-tabber-xgeom tabber)) (owidth (X-Geom-width xgeom)) (oheight (X-Geom-height xgeom))) - (setf (X-Geom-width xgeom) width) - (setf (X-Geom-height xgeom) height) - (XResizeWindow (xwem-dpy) (xwem-tabber-xwin tabber) width height) - (when (or (> width owidth) (> height oheight)) + (xwem-tabber-move-resize tabber) + + (when (or (> (X-Geom-width xgeom) owidth) + (> (X-Geom-height xgeom) oheight)) ;; Recreate xpreparer - (XFreePixmap (xwem-dpy) (xwem-tabber-xpreparer tabber)) + (when (X-Pixmap-p (xwem-tabber-xpreparer tabber)) + (XFreePixmap (xwem-dpy) (xwem-tabber-xpreparer tabber))) + (when (X-Pixmap-p (xwem-tabber-xpix-copy tabber)) + (XFreePixmap (xwem-dpy) (xwem-tabber-xpix-copy tabber))) (setf (xwem-tabber-xpreparer tabber) - (XCreatePixmap (xwem-dpy) (make-X-Pixmap :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy))) - (xwem-tabber-xwin tabber) (XDefaultDepth (xwem-dpy)) (X-Geom-width xgeom) (X-Geom-height xgeom)))) - )) + (XCreatePixmap (xwem-dpy) (make-X-Pixmap :dpy (xwem-dpy) +:id (X-Dpy-get-id (xwem-dpy))) + (xwem-tabber-xwin tabber) (XDefaultDepth (xwem-dpy)) + (X-Geom-width xgeom) (X-Geom-height xgeom))) + (setf (xwem-tabber-xpix-copy tabber) + (XCreatePixmap (xwem-dpy) (make-X-Pixmap :dpy (xwem-dpy) +:id (X-Dpy-get-id (xwem-dpy))) + (xwem-tabber-xwin tabber) (XDefaultDepth (xwem-dpy)) + (X-Geom-width xgeom) (X-Geom-height xgeom)))) + + (xwem-tabber-regeom tabber))) ;;; Frame Hooks -(defun xwem-tabber-on-frame-redraw (frame) - "To be used in `xwem-frame-redraw-hook'." - (let ((tabber (xwem-frame-get-prop frame 'xwem-tabber))) - (when (xwem-tabber-p tabber) - (xwem-tabber-draw tabber)))) +(defun xwem-tabber-on-frame-select-deselect () + "Redraw tabbers when switching frames." + (when (xwem-frame-p (xwem-frame-selected)) + (xwem-tabber-draw (xwem-frame-tabber (xwem-frame-selected))))) (defun xwem-tabber-on-frame-resize (frame) "FRAME just resized, apply changes to tabber, if any." - (let ((tabber (xwem-frame-get-prop frame 'xwem-tabber))) + (let ((tabber (xwem-frame-tabber frame))) (when (xwem-tabber-p tabber) - (xwem-tabber-resize tabber (xwem-frame-width frame) - (xwem-frame-get-prop frame 'title-height)) - (xwem-win-map (lambda (win) - (xwem-tabber-regeom tabber win (xwem-win-selected-p win))) - (xwem-frame-selwin frame)) - ))) + (xwem-tabber-resize tabber) + (xwem-tabber-draw tabber t)))) (defun xwem-tabber-on-frame-creation (frame) "FRAME just created." - (xwem-frame-put-prop frame 'xwem-tabber - (xwem-tabber-create frame (make-X-Geom :x 0 :y 0 :width (xwem-frame-width frame) -:height (xwem-frame-get-prop frame 'title-height)) - 'unknown))) + (setf (xwem-frame-tabber frame) (xwem-tabber-create frame))) + +(defun xwem-tabber-frame-prop-notifier (frame prop value) + "FRAME just changed property PROP to VALUE." + (let ((tabber (xwem-frame-tabber frame))) + (when (xwem-tabber-p tabber) + (case prop + (title-layout + (if (eq value 'none) + (XUnmapWindow (xwem-dpy) (xwem-tabber-xwin tabber)) + (XMapWindow (xwem-dpy) (xwem-tabber-xwin tabber)))) + ) + (xwem-tabber-on-frame-resize frame)))) +;; Win hooks (defun xwem-tabber-on-win-switch (owin nwin) "Window switch occured OWIN -> NWIN." - (when (not (eq owin nwin)) - (xwem-tabber-check-and-regeom nwin))) + (and (xwem-win-selwin-p nwin) + (xwem-tabber-draw (xwem-frame-tabber (xwem-win-frame nwin))))) (defun xwem-tabber-on-win-change (win) "WIN's clients list changed." - (xwem-tabber-check-and-regeom win)) + (and (xwem-win-selwin-p win) + (xwem-tabber-draw (xwem-frame-tabber (xwem-win-frame win))))) +(defun xwem-tabber-on-win-ccl-change (win old-cl new-cl) + "WIN's current client just changed." + (when (xwem-cl-p old-cl) + (xwem-tabber-on-cl-change old-cl)) + (when (xwem-cl-p new-cl) + (xwem-tabber-on-cl-change new-cl))) + +;; CL hooks (defun xwem-tabber-on-cl-creation (cl) "CL just created." - ;; Make tab item for CL - (xwem-cl-put-prop cl 'xwem-tab-item - (make-xwem-tab-item :type 'client -:state 'unmapped :rect (make-X-Rect :y 0 :x 0 :width 0 :height 0) -:cl cl :format xwem-tab-default-format))) - -(defun xwem-tabber-on-cl-destroy (cl) - "CL is about to be destroyed." - (let ((tab-item (xwem-cl-get-prop cl 'xwem-tab-item)) - (win (xwem-cl-win cl))) - (when (xwem-tab-item-p tab-item) - (xwem-cl-put-prop cl 'xwem-tab-item nil) - (X-invalidate-cl-struct tab-item)) - - (xwem-tabber-check-and-regeom win) - )) - -(defun xwem-tabber-check-and-regeom (win &optional force) - "Check is regeometry needed of CL's tabber. -Return non-nil if regeom occured." - (let* ((frame (and (xwem-win-p win) (xwem-win-frame win))) - (tabber (and (xwem-frame-p frame) (xwem-frame-get-prop frame 'xwem-tabber))) - (cls (xwem-win-make-cl-list win))) - (when (xwem-tabber-p tabber) - (unless (and (not force) - (equal (xwem-tabber-get-prop tabber 'last-units) cls) - (eq (xwem-tabber-get-prop tabber 'last-win) win)) - (xwem-tabber-put-prop tabber 'last-units cls) - (xwem-tabber-put-prop tabber 'last-win win) - (xwem-tabber-regeom tabber win (xwem-win-selected-p win)) - t)))) + ;; Make tab rect for CL + (unless (xwem-cl-tab-rect cl) + (setf (xwem-cl-tab-rect cl) + (make-X-Rect :x 0 :y 0 :width 0 :height 0))) + ) (defun xwem-tabber-on-cl-change (cl &rest args) "CL just changed its component." - (let ((tab-item (xwem-cl-get-prop cl 'xwem-tab-item)) - (win (xwem-cl-win cl))) - (when (xwem-tab-item-p tab-item) - (when (and (not (xwem-tabber-check-and-regeom win)) - (xwem-win-selected-p win)) - (xwem-tab-item-draw-format-1 tab-item))))) - -;;; Test: -;(xwem-init-tabber) -;(setq tb (xwem-tabber-create (car xwem-frames-list) (make-X-Geom :x 0 :y 0 :width 600 :height 20) -; 'normal)) -;(setq ti (make-xwem-tab-item :type 'test :tabber tb -; :state 'tab-selected-active -; :rect (make-X-Rect :x 10 :y 0 :width 500 :height 20) -; :cl (xwem-cl-selected) -; :format "test %n test1")) -;(setf (xwem-tab-item-format ti) "Test %i test1") -;(setf (xwem-tab-item-state ti) 'nonselected-passive) -;(xwem-tab-item-draw-format ti) - -;(XClearArea (xwem-dpy) (xwem-tabber-xwin tb) 0 0 600 20 nil) -;(XDestroyWindow (xwem-dpy) (xwem-tabber-xwin tb)) + (let ((tabber (xwem-cl-tabber cl))) + (when (and tabber + (memq cl (xwem-tabber-clients tabber)) + (xwem-win-selwin-p (xwem-cl-win cl))) + (xwem-cl-put-sys-prop cl 'xwem-tab-need-redraw t) ; mark cl as need to be redrawed + (xwem-tabber-draw tabber))))  (provide 'xwem-tabbing) + +;;;; On-load actions: +;; - Initialize tabber +(xwem-tabber-init) ;;; xwem-tabbing.el ends here Index: lisp/xwem-theme.el =================================================================== RCS file: lisp/xwem-theme.el diff -N lisp/xwem-theme.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-theme.el 1 Jan 2005 04:41:17 -0000 ＠＠ -0,0 +1,506 ＠＠ +;;; xwem-theme.el --- Themes support for xwem. + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Created: Tue Nov 23 14:49:41 MSK 2004 +;; Keywords: xwem +;; X-CVS: $Id: xwem-theme.el,v 1.2 2004/12/05 05:52:31 youngs Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; + +;;; Code: + +(require 'xwem-load) +(require 'xwem-strokes) ; for xwem-strokes-face + +(defgroup xwem-theme nil + "Group to customize xwem themes." +:prefix "xwem-theme-" +:group 'xwem) + +(defcustom xwem-theme-default + `((face xwem-tabber-face + (((frame-selected tab-selected) + (:foreground "white" :background "green4" :bold t)) + ((delimiter-left frame-selected tab-selected) + (:foreground "white")) + ((delimiter-right frame-selected tab-selected) + (:foreground "black")) + + ((frame-selected tab-nonselected) + (:foreground "black" :background "gray80")) + ((delimiter-left frame-selected tab-nonselected) + (:foreground "white")) + ((delimiter-right frame-selected tab-nonselected) + (:foreground "black")) + + ((frame-nonselected tab-selected) + (:foreground "gray80" :background "DarkGreen" :bold t)) + ((delimiter-left frame-nonselected tab-selected) + (:foreground "white")) + ((delimiter-right frame-nonselected tab-selected) + (:foreground "black")) + + ((frame-nonselected tab-nonselected) + (:foreground "black" :background "gray40")) + ((delimiter-left frame-nonselected tab-nonselected) + (:foreground "white")) + ((delimiter-right frame-nonselected tab-nonselected) + (:foreground "black")) + + (t (:foreground "white")))) + + (face x-border-face + (((selected) (:foreground "green")) + (t (:foreground "gray80")))) + + (face xwem-frame-inner-border-face + (((light nonselected) + (:foreground "gray80" :background "gray80")) + ((medium nonselected) + (:foreground "gray50" :background "gray50")) + ((dark nonselected) + (:foreground "gray20" :background "gray20")) + ((light selected) + (:foreground "cyan2" :background "cyan2")) + ((medium selected) + (:foreground "royalblue" :background "royalblue")) + ((dark selected) + (:foreground "blue4" :background "blue4")))) + + (face xwem-launch-dock-face + (((background-light) + (:foreground "gray70")) + ((background-light shadow-light) + (:foreground "white")) + ((background-light shadow-dark) + (:foreground "black")) + ((background-dark) + (:foreground "gray 50")) + ((background-dark shadow-light) + (:foreground "white")) + ((background-dark shadow-dark) + (:foreground "black")) + (t (:foreground "gray70" :background "black")))) + + (face xwem-strokes-face + (((background light) + (:foreground "red4" :background "black")) + ((background dark) + (:foreground "red" :background "black")) + ((background begin light) + (:foreground "magenta4" :background "black" +:line-width 12 :cap-style X-CapRound)) + ((background begin dark) + (:foreground "magenta" :background "black" +:line-width 12 :cap-style X-CapRound)))) + + (face xwem-tray-delimiter-face + (((background light) + (:foreground "gray40")) + ((background light shadow) + (:foreground "gray30")) + ((background dark) + (:foreground "gray70")) + ((background dark shadow) + (:foreground "gray80")))) + + (face xwem-window-outline-face + (((frame-selected win-selected) + (:foreground "green" :background "green4" :line-width 4)) + ((frame-selected win-nonselected) + (:foreground "gray70" :background "gray70" :line-width 4)) + ((frame-nonselected win-selected) + (:foreground "green3" :background "green4" :line-width 4)) + ((frame-nonselected win-nonselected) + (:foreground "gray60" :background "gray40" :line-width 4)))) + + (face xwem-window-delimiter-face + (((horizontal) + (:foreground "royalblue" :background "black")) + ((horizontal shadow) + (:foreground "blue4" :background "black")) + ((horizontal light shadow) + (:foreground "cyan" :background "black")) + ((vertical) + (:foreground "royalblue" :background "black")) + ((shadow vertical) + (:foreground "blue4" :background "black")) + ((light shadow vertical) + (:foreground "cyan" :background "black")) + (t (:foreground "gray20" :background "black")))) + + ;; Frames properties + (frame-property inner-border-width 8) + (frame-property inner-border-thickness 2) + (frame-property title-height 18) + + ;; Clients properties + (client-property x-border-width 2) + + ;; Custom settings + (custom xwem-cursor-help-foreground-color "#00BB00") + (custom xwem-cursor-help-background-color "#009900") + (custom xwem-root-cursor-foreground-color "white") + (custom xwem-root-cursor-background-color "black") + (custom xwem-frame-cursor-foreground-color "#111111") + (custom xwem-frame-cursor-background-color "#EEEEEE") + ) + "Default xwem theme." +:type 'xwem-theme +:group 'xwem-theme) + +(defcustom xwem-theme-extrim + `((face xwem-tabber-face + (((frame-selected tab-selected) + (:foreground "white" :background "gray20" +:font "-*-fixed-medium-r-*-*-12-*-*-*-*-*-*-*" :bold t)) + ((delimiter-left frame-selected tab-selected) + (:foreground "white")) + ((delimiter-right frame-selected tab-selected) + (:foreground "black")) + + ((frame-selected tab-nonselected) + (:foreground "black" :background "gray80" :font "-*-fixed-medium-r-*-*-12-*-*-*-*-*-*-*")) + ((delimiter-left frame-selected tab-nonselected) + (:foreground "white")) + ((delimiter-right frame-selected tab-nonselected) + (:foreground "black")) + + ((frame-nonselected tab-selected) + (:foreground "gray80" : ;; Mail ＠＠ -869,10 +1039,12 ＠＠ (let* ((xdpy (X-Pixmap-dpy mask-pixmap))) (XSelectInput xdpy win (apply 'Xmask-or (delete XM-Exposure xwem-time-window-mask))) - (XCopyArea xdpy (cdr pixmap) mask-pixmap xwem-time-mask-gc + (XCopyArea xdpy (cdr pixmap) mask-pixmap + (X-Win-get-prop win 'time-mask-gc) x-off y-off width height x y) (X-XShapeMask xdpy win X-XShape-Bounding X-XShapeSet 0 0 mask-pixmap) - (XCopyArea (X-Win-dpy win) (car pixmap) win xwem-time-gc + (XCopyArea (X-Win-dpy win) (car pixmap) win + (X-Win-get-prop win 'time-gc) x-off y-off width height x y) (XSelectInput xdpy win (apply 'Xmask-or xwem-time-window-mask)) ＠＠ -958,6 +1130,26 ＠＠ "Show 0 at WIN's X Y." (xwem-time-show win x y 'load-pixmap 60 0 10 13)) +(defsubst xwem-time-show-load-35 (win x y) + "Show 0 at WIN's X Y." + (xwem-time-show win x y 'load-pixmap 70 0 10 13)) + +(defsubst xwem-time-show-load-40 (win x y) + "Show 0 at WIN's X Y." + (xwem-time-show win x y 'load-pixmap 80 0 10 13)) + +(defsubst xwem-time-show-load-45 (win x y) + "Show 0 at WIN's X Y." + (xwem-time-show win x y 'load-pixmap 90 0 10 13)) + +(defsubst xwem-time-show-load-50 (win x y) + "Show 0 at WIN's X Y." + (xwem-time-show win x y 'load-pixmap 100 0 10 13)) + +(defsubst xwem-time-show-load-55 (win x y) + "Show 0 at WIN's X Y." + (xwem-time-show win x y 'load-pixmap 110 0 10 13)) + (defsubst xwem-time-show-letter (win x y) "Show 0 at WIN's X Y." (xwem-time-show win x y 'mail-pixmap 00 0 18 13)) ＠＠ -966,17 +1158,21 ＠＠ "Show 0 at WIN's X Y." (xwem-time-show win x y 'mail-pixmap 18 0 18 13)) -(defun xwem-time-show-load (win x y load-string) +(defun xwem-time-show-load (win x y load-number) "In WIN at X Y show load average represented by LOAD-STRING. Return how many pixels used." - (let ((load-number (string-to-number load-string)) - (alist (list (cons "00" 0.0) - (cons "05" (car xwem-time-load-list)) - (cons "10" (cadr xwem-time-load-list)) - (cons "15" (caddr xwem-time-load-list)) - (cons "20" (cadddr xwem-time-load-list)) - (cons "25" (cadr (cdddr xwem-time-load-list))) - (cons "30" (caddr (cdddr xwem-time-load-list))) + (let ((alist (list (cons "00" 0.0) + (cons "05" (nth 0 xwem-time-load-list)) + (cons "10" (nth 1 xwem-time-load-list)) + (cons "15" (nth 2 xwem-time-load-list)) + (cons "20" (nth 3 xwem-time-load-list)) + (cons "25" (nth 4 xwem-time-load-list)) + (cons "30" (nth 5 xwem-time-load-list)) + (cons "35" (nth 6 xwem-time-load-list)) + (cons "40" (nth 7 xwem-time-load-list)) + (cons "45" (nth 8 xwem-time-load-list)) + (cons "50" (nth 9 xwem-time-load-list)) + (cons "55" (nth 10 xwem-time-load-list)) (cons "100000" 100000))) elem load-elem) (while (>= load-number (cdr (setq elem (pop alist)))) ＠＠ -1015,16 +1211,12 ＠＠ (xwem-time-show-no-letter win x y)) 18) -(defun xwem-time-win-update (win) +(define-xwem-deffered xwem-time-win-update (win) "Show current time at X Y." (let* ((now (current-time)) (nowhigh (* (- (nth 0 now) (* (/ (nth 0 now) 10) 10)) 65536)) (time (substring (current-time-string now) 11 16)) - (load (condition-case () - (if (zerop (car (load-average))) "" - (let ((str (format " %03d" (car (load-average))))) - (concat (substring str 0 -2) "." (substring str -2)))) - (error ""))) + (load (car (load-average t))) (mail-spool-file (or display-time-mail-file (getenv "MAIL") (concat rmail-spool-directory ＠＠ -1042,7 +1234,9 ＠＠ nowhigh (* (- (nth 0 now) (* (/ (nth 0 now) 10) 10)) 65536)) (if (> (- (+ (nth 1 now) nowhigh) (+ (nth 1 start-time) - (* (- (nth 0 start-time) (* (/ (nth 0 start-time) 10) 10)) 65536))) + (* (- (nth 0 start-time) + (* (/ (nth 0 start- + (let ((xtw (xwem-time-init (xwem-dpy)))) + (unless (X-Win-p xtw) + (error 'xwem-error "Can't create xwem time window")) + + (XSelectInput (xwem-dpy) xtw (apply 'Xmask-or xwem-time-window-mask)) + (X-Win-EventHandler-add xtw 'xwem-time-event-handler nil + (list X-Expose X-MapNotify X-DestroyNotify + X-ButtonPress X-ButtonRelease)) - (XTrayInit xdpy xwem-time-window) + (xwem-XTrayInit (xwem-dpy) xtw dockid dockgroup dockalign) - (start-itimer "xwem-time" 'xwem-time-win-update - xwem-time-interval xwem-time-interval nil t xwem-time-window) - t)) + (X-Win-put-prop xtw 'xwem-time-timer + (start-itimer "xwem-time-time" + `(lambda () (xwem-time-win-update ,xtw)) + xwem-time-time-interval xwem-time-time-interval)) + (X-Win-put-prop xtw 'xwem-time-load + (start-itimer "xwem-time-load" + `(lambda () (xwem-time-load-update ,xtw)) + xwem-time-load-interval xwem-time-load-interval)) + 'started)) + +(define-xwem-command xwem-time-show-current-time-and-date () + "Display current time and date in the minibuffer." + (xwem-interactive) + (xwem-message 'info "Time: %s, Load: %S" + (current-time-string) (load-average))) + +(define-xwem-command xwem-time-popup-menu () + "Popup menu for time dockapp." + (xwem-interactive) + + (unless (button-event-p xwem-last-event) + (error 'xwem-error "`xwem-time-popup-menu' must be bound to mouse event")) + + (let ((twin (X-Event-win xwem-last-xevent))) + (xwem-popup-menu + (list "Time" + (vector "Show Time" 'xwem-time-show-current-time-and-date) + "---" + (vector "Destroy" `(XDestroyWindow (xwem-dpy) ,twin))))))  (provide 'xwem-time) Index: lisp/xwem-transient.el =================================================================== RCS file: lisp/xwem-transient.el diff -N lisp/xwem-transient.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ lisp/xwem-transient.el 1 Jan 2005 04:41:18 -0000 ＠＠ -0,0 +1,188 ＠＠ +;;; xwem-transient.el --- Transient for clients support. + +;; Copyright (C) 2004 by Free Software Foundation, Inc. + +;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Steve Youngs <steve(a)youngs.au.com&gt; +;; Created: Sat Jun 5 01:33:25 MSD 2004 +;; Keywords: xwem +;; X-CVS: $Id: xwem-transient.el,v 1.3 2004/12/05 22:37:35 lg Exp $ + +;; This file is part of XWEM. + +;; XWEM is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XWEM is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF + +;;; Commentary: + +;; + +;;; Code: + +(require 'xwem-load) +(require 'xwem-focus) +(require 'xwem-manage) + +;;; Customisation +(defgroup xwem-transient nil + "Group to customize transient clients support." +:prefix "xwem-transient-" +:group 'xwem-cl) + +(defcustom xwem-transient-client-properties + '(x-border-width 2 x-border-color "blue4") + "*Client properties to use when managing transient clients." +:type 'list +:group 'xwem-transient) + +(defcustom xwem-transient-switch-back t + "*Non-nil mean when transient client dies, switch to client who created it." +:type 'boolean +:group 'xwem-transient) + +;;; Internal variables + +(defvar xwem-transient-keymap + (let ((map (make-sparse-keymap))) + (define-key map (xwem-kbd "C-<button1>") 'xwem-client-imove) + (define-key map (xwem-kbd "C-<button2>") 'xwem-client-idestroy) + (define-key map (xwem-kbd "C-<button3>") 'xwem-client-iresize) + map) + "Local keymap for transient-for clients.") + +(define-xwem-deffered xwem-transient-on-select-cl (&optional cl) + "CL just selected, check if it has transient-for windows. +If so, popup them." + (unless cl + (setq cl (xwem-cl-selected))) + + (when (xwem-cl-p cl) + (let ((trfcls (xwem-cl-list-sort-by-recency (xwem-cl-translist cl)))) + (while trfcls + (when (eq (xwem-cl-state (car trfcls)) 'active) + (xwem-select-client (car trfcls)) + (setq trfcls nil)) + (setq trfcls (cdr trfcls))) + ))) + +;;;; ---- Transient for manage methods ---- + +;; NOTE: Uses default refit +(defun xwem-cl-transient-for-p (cl) + "Return non-nil if CL is transient for client." + (xwem-hints-wm-transient-for (xwem-cl-hints cl))) + +(defun xwem-manage-transient-for (cl) + "Manage CL that have transient-for flag." + ;; Map window for witch CL is transient and just map and raise CL + ;; over it + (let ((xwin (xwem-cl-xwin cl)) + (trc (xwem-xwin-cl (xwem-cl-transient-for cl)))) + + ;; Apply properties specific to transient-for clients + (xwem-cl-apply-plist cl xwem-transient-client-properties) + + (XReparentWindow (xwem-dpy) xwin (xwem-rootwin) + (X-Geom-x (xwem-cl-xgeom cl)) + (X-Geom-y (xwem-cl-xgeom cl))) + + (when (xwem-cl-p trc) + (setf (xwem-cl-translist trc) + (cons cl (xwem-cl-translist trc)))) + + ;; Install transient local keymap + (xwem-use-local-map xwem-transient-keymap cl) + + ;; Select it if needed + (when (or (null trc) + (xwem-cl-selected-p trc)) + (xwem-select-client cl)) + )) + +(define-xwem-deffered xwem-transient-apply-state (cl) + "Apply CL's state to life." + (cond ((eq (xwem-cl-state cl) 'active) + (XRaiseWindow (xwem-dpy) (xwem-cl-xwin cl)) + (XMapWindow (xwem-dpy) (xwem-cl-xwin cl))) + + ((eq (xwem-cl-state cl) 'inactive) + (XLowerWindow (xwem-dpy) (xwem-cl-xwin cl))) + ((eq (xwem-cl-state cl) 'iconified) + (XUnmapWindow (xwem-dpy) (xwem-cl-xwin cl))))) + +(defun xwem-activate-transient-for (cl &optional type) + "Activate method for transient-for client CL." + (cond ((eq type 'select) + (let ((trc (xwem-xwin-cl (xwem-cl-transient-for cl)))) + (when (xwem-cl-p trc) + (xwem-activate trc))) + (xwem-deffered-funcall 'XRaiseWindow (xwem-dpy) (xwem-cl-xwin cl))) + + ((eq type 'activate) + (xwem-transient-apply-state cl) + (let ((trc (xwem-xwin-cl (xwem-cl-transient-for cl)))) + (when (and (xwem-cl-p trc) + (xwem-cl-selected-p trc)) + (xwem-select-client cl)))) + )) + +(defun xwem-deactivate-transient-for (cl &optional type) + "Deactivate method for transient-for client CL." + (cond ((eq type 'deactivate) + (xwem-transient-apply-state cl)))) + +(defun xwem-iconify-transient-for (cl &optional type) + "Iconify method for transient-for client CL." + (xwem-transient-apply-state cl)) + +(defun xwem-withdraw-transient-for (cl) + "Withdraw method for transient-for CL." + (let ((trc (xwem-xwin-cl (xwem-cl-transient-for cl)))) + (when (and (xwem-cl-selected-p cl) + (xwem-cl-p trc) (xwem-cl-active-p trc)) + (xwem-select-client trc)))) + +;;; Additional methods +(define-xwem-method on-kill transient-for (cl) + "On-kill method for transient-for clients." + (let ((trc (xwem-xwin-cl (xwem-cl-transient-for cl)))) + (when (xwem-cl-p trc) + (setf (xwem-cl-translist trc) + (delq cl (xwem-cl-translist trc))) + + (when (and (xwem-cl-selected-p cl) + (xwem-cl-active-p trc)) + (xwem-select-client trc))))) + + +(provide 'xwem-transient) + +;;; On-load actions +(define-xwem-manage-model transient-for + "Manage models for clients with TRANSIENT_FOR property." +:match-spec '(function xwem-+ +(defun xwme-tray-group-repositionate-dapps (group) + "Repositionate GROUP's dock applications." + (let ((gdapps (xwem-tray-group-dockapps group)) + (step 3) + (coff 3)) + (while gdapps + (setf (X-Geom-x (xwem-dapp-geom (car gdapps))) coff) + ;; XXX do it deffering + (XMoveWindow (xwem-dpy) (xwem-dapp-xwin (car gdapps)) + (X-Geom-x (xwem-dapp-geom (car gdapps))) + (X-Geom-y (xwem-dapp-geom (car gdapps)))) + (incf coff (X-Geom-width (xwem-dapp-geom (car gdapps)))) + (incf coff step) + (setq gdapps (cdr gdapps))) + + (when (> coff (X-Geom-width (xwem-tray-group-xgeom group))) + (xwem-tray-group-resize + group coff + (X-Geom-height (xwem-tray-group-xgeom group)))))) + +(defun xwem-tray-group-attach-dapp (group dapp) + "To tray GROUP attach dock application DAPP." + (let ((gdapps (xwem-tray-group-dockapps group))) + (XReparentWindow (xwem-dpy) (xwem-tray-group-xwin group) + (xwem-dapp-xwin dapp) 0 0) + (while (and gdapps + (> (xwem-dapp-id (car gdapps)) + (xwem-dapp-id dapp))) + (setq gdapps (cdr gdapps))) + (if (not gdapps) + (setf (xwem-tray-group-dockapps group) + (append (xwem-tray-group-dockapps group) + (list dapp))) + (setcdr gdapps (cons (car gdapps) (cdr gdapps))) + (setcar gdapps dapp)) + + (xwme-tray-group-repositionate-dapps group))) + +(defun xwem-tray-group-find-create (name) + "Find existing or create new group." + (or (xwem-tray-group-find name) + (xwem-tray-group-create name))) + +;;}}} + +;;;###xwem-autoload +(defun xwem-XTrayInit (xdpy xwin &optional dockid dockgroup dockalign) + "Same as `XTrayInit'. +You should use this function instead of direct calls to `XTrayInit', +because in time you doing it xwem-tray may be uninitialised." + (xwem-tray-startit xdpy) ; make sure systray initialized + + (when dockid + (XChangeProperty xdpy xwin (XInternAtom xdpy "XWEM_DOCK_ID") + XA-integer X-format-16 X-PropModeReplace dockid)) + (when dockgroup + (XChangeProperty xdpy xwin (XInternAtom xdpy "XWEM_DOCK_GROUP") + XA-string X-format-8 X-PropModeReplace dockgroup)) + (when dockalign + (XChangeProperty xdpy xwin (XInternAtom xdpy "XWEM_DOCK_ALIGN") + XA-integer X-format-16 X-PropModeReplace dockalign)) + + (XTrayInit xdpy xwin)) + +;;;###xwem-autoload (defun xwem-tray-find-dapp (xwin) "Finds dock application by X window XWIN." - (let ((dal xwem-tray-dapp-list) - (rdapp nil)) - (while dal - (if (eq (xwem-dapp-xwin (car dal)) xwin) - (progn - (setq rdapp (car dal)) - (setq dal nil)) - (setq dal (cdr dal)))) - rdapp)) + (car (member* xwin xwem-tray-dapp-list +:test (lambda (xwin dapp) + (X-Win-equal xwin (xwem-dapp-xwin dapp)))))) (defun xwem-tray-message-defhook (dapp) "Default function for message from dock apps handling." - (if xwem-special-enabled - ;; XXX - (xwem-help-display - (insert (xwem-dapp-mess dapp))) - (xwem-message 'err "message arrived from dock app, but special frames not enabled.") - )) + (if (featurep 'xwem-special) + (xwem-help-display "tray message" + (insert (xwem-dapp-mess dapp))) + (xwem-message 'error "Message arrived from dock app, but special frames not enabled."))) + +;;; XXX these three functions: +;; +;; - xwem-tray-remove-dapp +;; - xwem-tray-hide-dapp +;; - xwem-tray-show-dapp +;; +;; Has many of common code, get rid of it --lg (defun xwem-tray-remove-dapp (dapp) "Remove dock application DAPP from xwem tray dockapps list." - (setq xwem-tray-dapp-list (delete dapp xwem-tray-dapp-list))) + (let ((dgeom (xwem-dapp-geom dapp)) + (state (xwem-dapp-state dapp))) + ;; Remove from dapps list + (setq xwem-tray-dapp-list + (delq dapp xwem-tray-dapp-list)) + (X-invalidate-cl-struct dapp) + + -; ((= evtype X-PropertyNotify) 'xwem-tray-handle-prop-notify) -; ((= evtype X-Expose) 'xwem-tray-handle-expose) -; ((= evtype X-DestroyNotify) 'xwem-tray-handle-unmap-or-destroy-notify) -; ((= evtype X-ConfigureNotify) 'xwem-tray-handle-config-notify) - (t nil)))) - (when fn - (funcall fn win xev)) - nil)) - -(defcustom xwem-tray-config nil - "*Config file for xwem-tray. -It is list of vectors in form [TYPE VALUE], TYPE is one of XWEM-TRAY-DOCK where VALUE for it is a string, which will be runned with `background' or XWEM-TRAY-DILEM where VALUE is offset in pixels which should delim docks. - -For example: - '([XWEM-TRAY-DOCK \"/home/lg/prog/xwem/modules/xwem-minitime -f 004400 -b bbbbbb\"] - [XWEM-TRAY-DOCK \"/home/lg/prog/xwem/modules/xwem-miniapm\"] - [XWEM-TRAY-DELIM 10] - [XWEM-TRAY-DOCK \"/home/lg/prog/xwem/modules/xwem-minilaunch /home/lg/prog/xwem/modules/icons/xterm_big.xpm xterm\"]" -:type 'list -:group 'xwem-tray) - -(defcustom xwem-tray-sit-for-pause 0.1 - "*Pause in seconds we should sit-for between launching XWEM-TRAY-DOCK. -UNUSED" -:type 'number -:group 'xwem-tray) - -(defun xwem-tray-run-config (&optional config) - "Parse and execute xwem tray CONFIG. -If CONFIG is ommited `xwem-tray-config' will be used." - (unless config - (setq config xwem-tray-config)) - - (while config - (let ((type (aref (car config) 0)) - (data (aref (car config) 1))) - (cond ((eq type 'XWEM-TRAY-DOCK) - (xwem-execute-program data)) - - ((eq type 'XWEM-TRAY-DELIM) - (setq xwem-tray-curroffset (- xwem-tray-curroffset data))) - (t nil))) - (setq config (cdr config)))) + (t (setf (xwem-dapp-mess dapp) "") + (setf (xwem-dapp-mess-currlen dapp) 0) + (setf (xwem-dapp-mess-waitlen dapp) (truncate (car (nth 3 (X-Event-xclient-msg xev))))) + (setf (xwem-dapp-mess-type dapp) opc)) + ))) + (t (xwem-message 'warning "Unknown mes-type %d from dock app." mes-type))) + nil)) + +(defun xwem-dapp-handle-xevent (xdpy xwin xev) + "X Events handler for dockapps." + (xwem-debug 'xwem-tray "DAPP: X Event: %S" '(X-Event-name xev)) + + (X-Event-CASE xev + (:X-ClientMessage + (xwem-dapp-handle-client-message xev)) + )) (defun xwem-tray-create (dpy) "Creates new XWEM system tray on DPY. ＠＠ -391,99 +686,133 ＠＠ dpy nil 0 0 1 1 0 0 X-InputOnly nil - (make-X-Attr :override-redirect 1 + (make-X-Attr :override-redirect t :event-mask xwem-tray-evmask))) - (X-Win-EventHandler-add-new win 'xwem-tray-evhandler 100) + (X-Win-EventHandler-add-new win 'xwem-tray-handle-client-message + 100 (list X-ClientMessage)) ;; Setup various hints (XSetWMClass dpy win xwem-tray-class) (XSetWMName dpy win xwem-tray-name) (setf (xwem-tray-xwin xwem-tray) win) - (setf (xwem-tray-props xwem-tray) nil) + (setf (xwem-tray-plist xwem-tray) nil) ;; TODO: install Selections and properties we will need - -; (XMapWindow dpy win) )) (defun xwem-tray-init (dpy) "Initialize xwem tray." (setq xwem-tray - (make-xwem-tray :atoms (make-vector 40 nil))) + (make-xwem-tray :atoms (make-vector 40 nil) +:xwin (xwem-minib-xwin xwem-minibuffer))) (let ((xwem-atoms (xwem-tray-atoms xwem-tray))) - (aset xwem-atoms 0 (XInternAtom dpy "_NET_WM_WINDOW_TYPE" nil)) - (aset xwem-atoms 1 (XInternAtom dpy "_NET_WM_WINDOW_TYPE_DOCK" nil)) - (aset xwem-atoms 3 (XInternAtom dpy "_NET_SYSTEM_TRAY_OPCODE" nil)) - (aset xwem-atoms 4 (XInternAtom dpy "_XEMBED_INFO" nil)) - (aset xwem-atoms 5 (XInternAtom dpy "_XEMBED" nil)) - (aset xwem-atoms 6 (XInternAtom dpy "MANAGER" nil)) - (aset xwem-atoms 7 (XInternAtom dpy "_MB_DOCK_ALIGN" nil)) - (aset xwem-atoms 8 (XInternAtom dpy "_MB_DOCK_ALIGN_EAST" nil)) - (aset xwem-atoms 9 (XInternAtom dpy "_NET_SYSTEM_TRAY_MESSAGE_DATA" nil)) - (aset xwem-atoms 10 (XInternAtom dpy "_NET_WM_WINDOW_TYPE_SPLASH" nil)) - (aset xwem-atoms 11 (XInternAtom dpy "WM_PROTOCOLS" nil)) - (aset xwem-atoms 12 (XInternAtom dpy "WM_DELETE_WINDOW" nil)) - (aset xwem-atoms 13 (XInternAtom dpy "_MB_THEME" nil)) - (aset xwem-atoms 14 (XInternAtom dpy "_MB_PANEL_TIMESTAMP" nil)) - (aset xwem-atoms 15 (XInternAtom dpy "_NET_WM_STRUT" nil)) - (aset xwem-atoms 16 (XInternAtom dpy "_MB_PANEL_BG" nil)) - (aset xwem-atoms 17 (XInternAtom dpy "WM_CLIENT_LEADER" nil)) - (aset xwem-atoms 18 (XInternAtom dpy "_NET_WM_ICON" nil)) - (aset xwem-atoms 19 (XInternAtom dpy "_NET_WM_PID" nil)) - (aset xwem-atoms 20 (XInternAtom dpy "_XROOTPMAP_ID" nil)) + (aset xwem-atoms 0 (XInternAtom dpy "_NET_WM_WINDOW_TYPE")) + (aset xwem-atoms 1 (XInternAtom dpy "_NET_WM_WINDOW_TYPE_DOCK")) + (aset xwem-atoms 3 (XInternAtom dpy "_NET_SYSTEM_TRAY_OPCODE")) + (aset xwem-atoms 4 (XInternAtom dpy "_XEMBED_INFO")) + (aset xwem-atoms 5 (XInternAtom dpy "_XEMBED")) + (aset xwem-atoms 6 (XInternAtom dpy "MANAGER")) + (aset xwem-atoms 9 (XInternAtom dpy "_NET_SYSTEM_TRAY_MESSAGE_DATA")) + (aset xwem-atoms 10 (XInternAtom dpy "_NET_WM_WINDOW_TYPE_SPLASH")) + (aset xwem-atoms 15 (XInternAtom dpy "_NET_WM_STRUT")) + (aset xwem-atoms 18 (XInternAtom dpy "_NET_WM_ICON")) + (aset xwem-atoms 19 (XInternAtom dpy "_NET_WM_PID")) + (aset xwem-atoms 20 (XInternAtom dpy "_XROOTPMAP_ID")) + + (aset xwem-atoms 30 (XInternAtom dpy "XWEM_DOCK_ID")) + (aset xwem-atoms 31 (XInternAtom dpy "XWEM_DOCK_GROUP")) + (aset xwem-atoms 32 (XInternAtom dpy "XWEM_DOCK_ALIGN")) ;; Use emacs pid as tray identificator (aset xwem-atoms 2 - (XInternAtom dpy (format "_NET_SYSTEM_TRAY_S%i" xwem-tray-id) nil))) + (XInternAtom dpy (format "_NET_SYSTEM_TRAY_S%i" xwem-tray-id)))) (setenv "SYSTEM_TRAY_ID" (format "%i" xwem-tray-id)) - ;; Must do: - ;; - Calculate start possition. - ;; - Add handler for UnmapNotify and DestroyNotify events. - (cond ((eq xwem-tray-minib-position 'right) - (setq xwem-tray-curroffset - (X-Geom-width (xwem-minib-xgeom xwem-minibuffer)))) - - (t (xwem-message "Unsupported `xwem-tray-minib-position': %S" - xwem-tray-minib-position))) - - ;; Subscribe on substructure change events for xwem minibuffer - ;; window. - (setf (xwem-minib-evmask xwem-minibuffer) - (Xmask-or (xwem-minib-evmask xwem-minibuffer) XM-SubstructureNotify)) - (XSelectInput (xwem-dpy) (xwem-minib-xwin xwem-minibuffer) - (xwem-minib-evmask xwem-minibuffer)) - (X-Win-EventHandler-add-new (xwem-minib-xwin xwem-minibuffer) - 'xwem-tray-handle-unmap-or-destroy-notify - -1 (list X-UnmapNotify X-DestroyNotify)) - - ;; Configure systray cursor - (setq xwem-tray-cursor (xwem-make-cursor (eval xwem-tray-cursor-shape) - xwem-tray-cursor-foreground-color - xwem-tray-cursor-background-color)) + ;; Subscribe on substructure change events for xwem tray window. + (XSelectInput (xwem-dpy) (xwem-tray-xwin xwem-tray) + (Xmask-or XM-SubstructureNotify XM-StructureNotify + (X-Attr-event-mask + (XGetWindowAttributes + (xwem-dpy) (xwem-tray-xwin xwem-tray))))) + (X-Win-EventHandler-add-new (xwem-tray-xwin xwem-tray) + 'xwem-tray-handle-xevent -1 + (list X-MapNotify X-UnmapNotify + X-DestroyNotify X-ConfigureNotify)) + (X-Win-EventHandler-add-new (xwem-tray-xwin xwem-tray) + 'xwem-tray-handle-xevent 100 + (list X-ClientMessage)) - (XChangeWindowAttributes (xwem-dpy) (xwem-minib-xwin xwem-minibuffer) - (make-X-Attr :cursor xwem-tray-cursor)) - ) + ;; Configure systray cursor + (setq xwem-tray-cursor + (xwem-make-cursor xwem-tray-cursor-shape + xwem-tray-cursor-foreground-color + xwem-tray-cursor-background-color)) + (XSetWindowCursor (xwem-dpy) (xwem-tray-xwin xwem-tray) + xwem-tray-cursor)) + (san (sin angel)) + (can (cos angel)) + (x-off x) + (y-off y) + nfont mb1 me1) + (when (string-match x-font-regexp fn) + (setq mb1 (match-beginning 5) + me1 (match-end 5)) + (setq nfont (concat (substring fn 0 mb1) + (replace-in-string + (format "[%S %S %S %S]" + (truncate (* fps can)) + (truncate (* fps san)) + (truncate (- (* fps san))) + (truncate (* fps can)) + ) + "-" "~") + (substring fn me1))) + (setf (X-Gc-font gc) (X-Font-get (xwem-dpy) nfont)) + (XChangeGC (xwem-dpy) gc) + + (mapc (lambda (chr) + (XDrawString (xwem-dpy) d gc x-off y-off (char-to-string chr)) + (setq x-off (+ x-off (* (X-Font-char-width chr sfont) can))) + (setq y-off (+ y-off (* (X-Font-char-width chr sfont) (- san))))) + str) + + ;; Revert font + (setf (X-Gc-font gc) sfont) + (XChangeGC (xwem-dpy) gc) + ))) + +;(xwem-vert-draw-text (xwem-frame-xwin (xwem-frame-selected)) +; (xwem-face-get-gc 'my-test-face) (/ pi 2) +; 40 700 "abcdefghjklmnopqrstuvwxyz") +; + + +(provide 'xwem-vert) + +;;; xwem-vert.el ends here Index: lisp/xwem-weather.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-weather.el,v retrieving revision 1.3 diff -u -u -r1.3 xwem-weather.el --- lisp/xwem-weather.el 16 Dec 2004 08:08:16 -0000 1.3 +++ lisp/xwem-weather.el 1 Jan 2005 04:41:18 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Steve Youngs <steve(a)youngs.au.com&gt; ;; Created: 2004-06-22 ;; Keywords: xwem -;; X-CVS: $Id: xwem-weather.el,v 1.3 2004/12/16 08:08:16 youngs Exp $ +;; X-CVS: $Id: xwem-weather.el,v 1.2 2004/12/05 05:52:24 youngs Exp $ ;; This file is part of XWEM. ＠＠ -37,13 +37,15 ＠＠ ;; (customize-set-variable 'xwem-weather-update-frequency 3600) ;; (add-hook 'xwem-after-init-hook 'xwem-weather-init) - ;;; Code:  -(require 'xwem-osd) (require 'itimer) +(require 'xwem-osd) +(require 'xwem-interactive) +(require 'xwem-help) + (defgroup xwem-weather nil "XWEM Weather options." :prefix "xwem-weather-" ＠＠ -54,13 +56,45 ＠＠ The default setting is the author's local station, Brisbane, Australia. So you can all be jealous of the wonderful weather we -have in Australia. :-P" +have in Australia. :-P + +You should be able to find out what the code is for your nearest +weather station at http://weather.noaa.gov/" :type 'string +:link '(url-link "http://weather.noaa.gov/") +:group 'xwem-weather) + +(defcustom xwem-weather-data-directory xwem-dir + "*The directory to story weather data files." +:type '(directory :must-match t) +:group 'xwem-weather) + +(defcustom xwem-weather-data-file + (expand-file-name xwem-weather-station-id xwem-weather-data-directory) + "*File to hold the weather data." +:type 'file +:group 'xwem-weather) + +(defcustom xwem-weather-temperature-format 'celsius + "*Display temperature in Celsius or Fahrenheit." +:type '(choice + (const :tag "Celsius" celsius) + (const :tag "Fahrenheit" fahrenheit)) +:group 'xwem-weather) + +(defface xwem-weather-osd-face + '((((class color)) + (:foreground "cyan" :family "fixed" :size "12pt")) + (t + (:family "fixed" :size "12pt"))) + "*Face for the weather OSD." :group 'xwem-weather) +;;; Internal variables + (defvar xwem-weather-osd nil) -(defvar xwem-weather-frequency) +(defvar xwem-weather-frequency 0) (defun xwem-weather-alter-update-frequency (value) "Alters the update frequency of the weather updates. ＠＠ -76,24 +110,27 ＠＠ update the weather data." (let ((itimer (get-itimer "xwem-weather-itimer"))) (cond ((and (xwem-osd-p xwem-weather-osd) - value - itimer) - (set-itimer-value itimer value) - (set-itimer-restart itimer valu + xwem-weather-frequency)))  (provide 'xwem-weather) + +;;; On-load actions +(define-key xwem-global-map (xwem-kbd "H-c W d") 'xwem-weather-show-details) +(define-key xwem-global-map (xwem-kbd "H-c W u") 'xwem-weather-update) ;;; xwem-weather.el ends here Index: lisp/xwem-win.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-win.el,v retrieving revision 1.7 diff -u -u -r1.7 xwem-win.el --- lisp/xwem-win.el 16 Dec 2004 08:08:16 -0000 1.7 +++ lisp/xwem-win.el 1 Jan 2005 04:41:18 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: 21 Mar 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xwem-win.el,v 1.7 2004/12/16 08:08:16 youngs Exp $ +;; X-CVS: $Id: xwem-win.el,v 1.6 2004/12/05 05:52:31 youngs Exp $ ;; This file is part of XWEM. ＠＠ -34,33 +34,42 ＠＠ ;;; Code  -(eval-when-compile - (require 'xwem-clients)) +(require 'xwem-load) -;;; Customization +;;; Customisation (defgroup xwem-win nil "Group to customize XWEM windows." :prefix "xwem-win-" :group 'xwem) +;;;###autoload (defcustom xwem-win-min-width 80 "*Minimal width for window" :type 'number :group 'xwem-win) +;;;###autoload (defcustom xwem-win-min-height 80 "*Minimal height for window" :type 'number :group 'xwem-win) -;;;###autoload -(defcustom xwem-win-delim-width 3 - "*Window delimeter width, including shadowness." -:type 'number +;;;###xwem-autoload +(defcustom xwem-win-vertical-delim-width '(8 . 1) + "*Width in pixels for vertical delimiters. +car is delimiter width, cdr is shadow thickness." +:type '(cons number number) :group 'xwem-win) -(defcustom xwem-win-delim-shadow-thicksness 1 - "*How thick to draw 3D shadows around window delims." +;;;###xwem-autoload +(defcustom xwem-win-horizontal-delim-width '(6 . 1) + "*Width in pixels for horizontal delimiters. +car is delimiter width, cdr is shadow thickness." +:type '(cons number number) +:group 'xwem-win) + +(defcustom xwem-win-default-border-width 1 + "*Default border width for newly created windows." :type 'number :group 'xwem-win) ＠＠ -84,7 +93,7 ＠＠ :type '(restricted-sexp :match-alternatives (valid-plist-p)) :group 'xwem-win) -(defcustom xwem-win-winmove-allow-jupming t +(defcustom xwem-win-winmove-allow-jumping t "*Non-nil allows jumping to opposite edge, when no window founded." :type 'boolean :group 'xwem-win) ＠＠ -120,65 +129,75 ＠＠ :group 'xwem-hooks) ;;;###autoload -(defcustom xwem-win-after-split-hook nil +(defcustom xwem-win-split-hook nil "Hook to be called after window split. -Functions will be called with three arguments: WIN HOW and NEW-SIZE." +Functions will be called with two arguments: SPLIT-WIN, NEW-WIN." :type 'hook :group 'xwem-hooks) - -;;; Structures -;;;###autoload -(defstruct (xwem-win (:include X-Geom) - (:predicate xwem-iswin-p)) - clients ; xwem clients list managed in this win - props ; property list aka plist - cl ; xwem client - frame ; xwem frame - dead - deleted - next - prev - hchild - vchild - parent - expectances) ; expectances list +(define-xwem-face xwem-window-outline-face + `(((frame-selected win-selected) + (:foreground "green" :background "green4" :line-width 4)) + ((frame-selected win-nonselected) + (:foreground "gray70" :background "gray70" :line-width 4)) + ((frame-nonselected win-selected) + (:foreground "green3" :background "green4" :line-width 4)) + ((frame-nonselected win-nonselected) + (:foreground "gray60" :background "gray40" :line-width 4))) + "Face to outline frame windows." +:group 'xwem-win +:group 'xwem-faces) + +(define-xwem-face xwem-window-delimiter-face + `(((horizontal) + (:foreground "royalblue")) + ((horizontal shadow) + (:foreground "blue4")) + ((horizontal light shadow) + (:foreground "cyan")) + ((vertical) + (:foreground "royalblue")) + ((shadow vertical) + (:foreground "blue4")) + ((light shadow vertical) + (:foreground "cyan")) + (t (:foreground "gray20" :background "black"))) + "Face to draw window delimiter." +:group 'xwem-win +:group 'xwem-faces) -;;;###autoload -(defstruct (xwem-win-saved (:include X-Geom) - (:predicate xwem-iswinsaved-p)) - clients ; clients managed in window - cl ; xwem client sele - props ; properties - expectances ; expectances list - currentp ; non-nil for selected window - first-hchild first-vchild - next prev) +;;; Internal variables -;;;###autoload -(defstruct (xwem-win-config (:predicate xwem-iswinconfig-p)) - frame frame-width frame-height - current-cl ; cl in selected window - min-width min-height - saved-root-window) -  -;; Functions -;;;###autoload -(defun xwem-win-cl-current-p (cl &optional win) - "Return non-nil if CL is current WIN's client." - (let ((ww (or win (xwem-cl-win cl)))) - (when (xwem-win-p ww) - (eq cl (xwem-win-cl ww))))) - -;;;###autoload -(defun xwem-win-p (window &optional sig) - "Return t if WINDOW is XWEM frame's window." - (let ((iswin (xwem-iswin-p window))) - (if (and (not iswin) sig) - (signal 'wrong-type-argument (list sig 'xwem-win-p window)) - iswin))) +;;;; Win macros +(defmacro xwem-win-child (window) + "Return child of WINDOW, hchild checked first then if not set vchild + tested." + `(or (xwem-win-hchild ,window) (xwem-win-vchild ,window))) + +(defmacro xwem-win-mark-deleted (win) + "Mark WIN as deleted window." + `(setf (xwem-win-deleted ,win) t)) + +;;;###xwem-autoload +(defun xwem-win-delim-width (window) + "Return WIN's delimiter width." + (let ((pwin (xwem-win-parent window))) + (or (and pwin (xwem-win-hchild pwin) (car xwem-win-horizontal-delim-width)) + (and pwin (xwem-win-vchild pwin) (car xwem-win-vertical-delim-width)) + 0))) + +;;;###xwem-autoload +(defun xwem-win-delim-shadow-thickness (window) + "Return WIN's delimiter width." + (let ((pwin (xwem-win-parent window))) + (or (and pwin (xwem-win-hchild pwin) (cdr xwem-win-horizontal-delim-width)) + (and pwin (xwem-win-vchild pwin) (cdr xwem-win-vertical-delim-width)) + 0))) + +;;;; Functions +;;;###xwem-autoload (defun xwem-win-make-list-by-next (window) "Create list of WINDOW and all next windows." (let ((wins window) ＠＠ -188,41 +207,103 ＠＠ (setq wins (xwem-win-next wins))) (nreverse rlist))) -;;;###autoload -(defun xwem-win-selected (&optional frame) - "Return selected window in selected frame." - (unless frame - (setq frame (xwem-frame-selected))) - (when (xwem-frame-p frame) - (xwem-frame-selwin frame))) +;;;###xwem-autoload +(defun xwem-cl-set-win (cl win) + "Associate CL with WIN. +WIN is valid WIN or nil." + (unless (eq (xwem-cl-win cl) win) + (let ((owin (xwem-cl-win cl))) + ;; Deactivate CL, when changing window + (xwem-deactivate cl) + + (setf (xwem-cl-win cl) win) + + ;; Remove CL from OWIN's clients list + (when (xwem-win-p owin) + (xwem-win-rem-cl owin cl)))) + + ;; Add CL to WIN's clients list + (when (xwem-win-p win) + (xwem-win-add-cl win cl))) + +;;;###xwem-autoload +(defun xwem-win-add-cl (win cl) + "Into WIN's clients list add new client CL." + (unless (or (not (xwem-cl-p cl)) + (memq cl (xwem-win-clients win))) + + (when (and (xwem-frame-dedicated-p (xwem-win-frame win)) + (xwem-win-clients win)) + (error 'xwem-error "Window in dedicted frame already has client")) + + ;; Insert CL in WIN's clients list in proper place (as in + ;; `xwem-clients') + (let ((wcls (xwem-win-clients win))) + (while (and wcls (memq cl (memq (car wcls) xwem-clients))) + (setq wcls (cdr wcls))) + (if (not wcls) + (setf (xwem-win-clients win) + (append (xwem-win-clients win) (list cl))) + (setcdr wcls (cons (car wcls) (cdr wcls))) + (setcar wcls cl))) + + (run-hook-with-args 'xwem-win-clients-change-hook win))) + +;;;###xwem-autoload +(defun xwem-win-rem-cl (win cl) + "From WIN's clients list remove client CL." + (when (and (xwem-cl-p cl) + (memq cl (xwem-win-clients win))) + (setf (xwem-win-clients win) + (delq cl (xwem-win-clients win))) + + ;; If CL is current client in WIN, also unset it + (when (eq cl (xwem-win-cl win)) + (xwem-win-set-cl win nil)) + + (run-hook-with-args 'xwem-win-clients-change-hook win))) + +;;;###xwem-autoload +(defun xwem-win-set-cl (win cl) + "Associate WIN with CL as current client in WIN." + ;; When CL isnt in WIN's clients list yet, add it. + (unless (eq (xwem-win-cl win) cl) + (when (xwem-cl-p cl) + (xwem-cl-set-win cl win)) + + (let ((ocl (xwem-win-cl win))) + (setf (xwem-win-cl win) cl) + + (when (xwem-cl-alive-p (xwem-win-cl win)) + (xwem-activate (xwem-win-cl win))) + (when (xwem-cl-alive-p ocl) + (xwem-deactivate ocl)) -;;;###autoload -(defun xwem-win-selected-p (win) - "Return non-nil if WIN is selected window." - (and (xwem-win-p win) - (eq win (xwem-frame-selwin (xwem-win-frame win))))) + (when (or (null ocl) (null (xwem-win-cl win))) + (xwem-win-redraw-win win))))) ;;;###autoload (defun xwem-win-new (&optional params props) "Create new window with properties PROPS." (let ((nwin (apply 'make-xwem-win params)) - (rplist (copy-sequence xwem-win-default-properties))) + (rplist (copy-list xwem-win-default-properties))) ;; Prepare window properties - (while props - (setq rplist (plist-put rplist (car props) (cadr props))) - (setq props (cddr props))) - + (setq rplist (xwem-misc-merge-plists rplist props)) + + (setf (xwem-win-geom nwin) + (make-X-Geom :x 0 :y 0 :width 1 :height 1 +:border-width xwem-win-default-border-width)) (setf (xwem-win-clients nwin) nil) ; list of clients - (setf (xwem-win-props nwin) rplist) ; window properties (setf (xwem-win-cl nwin) nil) ; no visible client yet + (setf (xwem-win-plist nwin) rplist) ; window properties nwin)) (defun xwem-win-replace (old new) "Replace OLD window with contents of NEW window." (when (not (and (xwem-win-p old) (xwem-win-p new))) - (error "Hmm .. one of OLD or NEW is not a xwem window.")) + (error 'xwem-error "Hmm .. one of OLD or NEW is not a xwem window")) (when (eq (xwem-frame-rootwin (xwem-win-frame old)) old) (setf (xwem-frame-rootwin (xwem-win-frame old)) new)) ＠＠ -269,7 +350,7 ＠＠ (setf (xwem-win-parent window) pwin) )) -;;;###autoload +;;;###xwem-autoload (defun xwem-window-next (&optional window) "Return next window after WINDOW in canonical ordering of windows. If omitted, WINDOW defaults to the `(xwem-win-selected)'." ＠＠ -295,7 +376,7 ＠＠ (t nil))) ;break win)) -;;;###autoload +;;;###xwem-autoload (defun xwem-window-next-vertical (&optional window) "Return next window which is vertically after WINDOW. If WINDOW is not given `(xwem-win-selected)' will be used." ＠＠ -333,7 +414,7 ＠＠ (null rwin))) rwin)))) -;;;###autoload +;;;###xwem-autoload (defun xwem-window-prev (&optional window) "Retrun previous window before WINDOW in canonical ordering of windows. If ommitted, WINDOW defaults to the `(xwem-win-selected)'." ＠＠ -364,7 +445,7 ＠＠ t))) win)) -;;;###autoload +;;;###xwem-autoload (defun xwem-window-other (cnt &optional window) "Return CNT's next window for WINDOW if CNT is greater then zero and previous if negative." ＠＠ -380,7 +461,7 ＠＠ "Returns non-nil if X Y lies in WIN. If INC-GUTTER is non-nil, than include gutters width as WIN area." (let ((edges (xwem-win-pixel-edges win)) - (gw (if inc-gutter xwem-win-delim-width 0))) + (gw (if inc-gutter (xwem-win-delim-width win) 0))) (and (>= x (- (nth 0 edges) gw)) (<= x (+ (nth 2 edges) gw)) (>= y (- (nth 1 edges) gw)) ＠＠ -397,9 +478,10 ＠＠ ;;; -- Moving around windows -- ;; -(defun xwem-winmove-distance () +(defun xwem-winmove-distance (&optional win) "Returns distance between windows." - (+ xwem-win-delim-width 0)) + ;; 2 is XXX + (+ (xwem-win-delim-width (or win (xwem-win-selected))) 2)) (defun xwem-winmove-refloc (&optional arg window) "Calculates the reference location for directional window selection. ＠＠ -437,7 +519,7 ＠＠ (cons (car refpoint) (+ (nth 3 edges) (xwem-winmove-distance)))) - (t (error "`xwem-winmove-other-window': Invalid direction %s" dir))))) + (t (error 'xwem-error "`xwem-winmove-other-window': Invalid direction %s" dir))))) (defun xwem-winmove-select (dir &optional arg window) "Moves to the window in DIR direction." ＠＠ -447,7 +529,7 ＠＠ (y (cdr owin-loc)) (owin (xwem-window-at x y frame))) - (when xwem-win-winmove-allow-jupming + (when xwem-win-winmove-allow-jumping (let ((rwin (xwem-frame-rootwin (xwem-win-frame (or window (xwem-win-selected)))))) (when (not (xwem-win-xy-in-p x y rwin)) ;; we are outside root window ＠＠ -463,150 +545,298 ＠＠ (abs y)))) ((eq dir 'down) (cons x (+ (- y (nth 3 (xwem-win-pixel-edges rwin))) (nth 1 (xwem-win-pixel-edges rwin))))) - (t (error "invalid direction.")))) + (t (error 'xwem-error "Invalid direction")))) (setq owin (xwem-window-at (car owin-loc) (cdr owin-loc) frame))))) - (if (not (xwem-win-p owin)) - (xwem-message 'err "No window at %s" dir) - (xwem-window-select-maybe-redraw owin)) + (if (not (xwem-win-p owin)) + (xwem-message 'error "No window at %S" dir) + (xwem-select-window owin)) )) +;;;###autoload(autoload 'xwem-other-window "xwem-win" "Switch to other window." t) +(defalias 'xwem-other-window 'xwem-frame-goto-next) + ;;;###autoload(autoload 'xwem-winmove-up "xwem-win" "" t) (define-xwem-command xwem-winmove-up (arg) "Selects window that up for selected." (xwem-interactive "P") (xwem-winmove-select 'up arg)) +(put 'xwem-winmove-up 'xwem-frame-command t) ;;;###autoload(autoload 'xwem-winmove-down "xwem-win" "" t) (define-xwem-command xwem-winmove-down (arg) "Selects window that down for selected." (xwem-interactive "P") (xwem-winmove-select 'down arg)) +(put 'xwem-winmove-down 'xwem-frame-command t) ;;;###autoload(autoload 'xwem-winmove-left "xwem-win" "" t) (define-xwem-command xwem-winmove-left (arg) "Selects window that left for selected." (xwem-interactive "P") (xwem-winmove-select 'left arg)) +(put 'xwem-winmove-left 'xwem-frame-command t) ;;;###autoload(autoload 'xwem-winmove-right "xwem-win" "" t) (define-xwem-command xwem-winmove-right (arg) "Selects window that right for selected." (xwem-interactive "P") (xwem-winmove-select 'right arg)) +(put 'xwem-winmove-right 'xwem-frame-command t) -;;; -;;;###autoload -(defun xwem-window-select (window) - "Select WINDOW as current for WINDOW's frame. -Runs `xwem-win-switch-hook'." - (let* ((wframe (xwem-win-frame window)) - (ow (xwem-frame-selwin wframe))) - (setf (xwem-frame-selwin wframe) window) +;;; Windows oriented drawers +(define-xwem-deffered xwem-win-redraw-delims (win) + "Draw delimetrs in window WIN." + (when (xwem-win-p win) + (let ((wf (xwem-win-frame win)) + (hc (xwem-win-hchild win)) + (vc (xwem-win-vchild win))) + + (while (xwem-win-p hc) + ;; For horizontal split + (when (xwem-win-p (xwem-win-next hc)) + (xwem-misc-draw-bar + (xwem-dpy) (xwem-frame-xwin wf) + (xwem-face-get-gc 'xwem-window-delimiter-face '(horizontal) hc) + (xwem-face-get-gc 'xwem-window-delimiter-face '(horizontal shadow light) hc) + (xwem-face-get-gc 'xwem-window-delimiter-face '(horizontal shadow) hc) + (+ (xwem-win-x hc) (xwem-win-width hc)) + (xwem-win-y hc) + (xwem-win-delim-width hc) + (xwem-win-height hc) + (xwem-win-delim-shadow-thickness hc))) - ;; Now run switch hook - (run-hook-with-args 'xwem-win-switch-hook ow window))) + (xwem-win-redraw-delims-1 hc) + (setq hc (xwem-win-next hc))) -;;;###autoload -(defun xwem-window-select-maybe-redraw (window) - "Select window WINDOW and if maybe redraw WINDOW's frame." - (let* ((wframe (xwem-win-frame window)) - (ow (xwem-frame-selwin wframe))) - (xwem-window-select window) - (unless (eq ow window) - (xwem-frame-redraw wframe)))) + (while (xwem-win-p vc) + ;; For vertical split + (when (xwem-win-p (xwem-win-next vc)) + (xwem-misc-draw-bar + (xwem-dpy) (xwem-frame-xwin wf) + (xwem-face-get-gc 'xwem-window-delimiter-face '(vertical) vc) + (xwem-face-get-gc 'xwem-window-delimiter-face '(light shadow vertical) vc) + (xwem-face-get-gc 'xwem-window-delimiter-face '(shadow vertical) vc) + (xwem-win-x vc) + (+ (xwem-win-y vc) (xwem-win-height vc)) + (xwem-win-width vc) + (xwem-win-delim-width vc) + (xwem-win-delim-shadow-thickness vc))) -;;;###autoload + (xwem-win-redraw-delims-1 vc) + (setq vc (xwem-win-next vc))) + ))) + +(defun xwem-win-choose-outline-gc (win) + "Choose X-Gc according to WIN's current state." + (xwem-face-get-gc 'xwem-window-outline-face + (list (if (xwem-frame-selected-p (xwem-win-frame win)) 'frame-selected 'frame-nonselected) + (if (xwem-win-selwin-p win) 'win-selected 'win-nonselected)) + win)) + +(define-xwem-deffered xwem-win-redraw-win (win) + "Redraw only one WIN in WIN's frame." + (XClearArea (xwem-dpy) (xwem-frame-xwin (xwem-win-frame win)) + (xwem-win-x win) (xwem-win-y win) + (xwem-win-width win) (xwem-win-height win) nil) + (if (xwem-win-cl win) + (XFillRectangles (xwem-dpy) (xwem-frame-xwin (xwem-win-frame win)) + (xwem-win-choose-outline-gc win) + (list (make-X-Rect :x (xwem-win-x win) +:y (xwem-win-y win) +:width (xwem-win-width win) +:height (xwem-win-border-width win)) + (make-X-Rect :x (xwem-win-x win) +:y (xwem-win-y win) +:width (xwem-win-border-width win) +:height (xwem-win-height win)) + (make-X-Rect :x (+ (xwem-win-x win) + (xwem-win-width win) + (- (xwem-win-border-width win))) +:y (xwem-win-y win) +:width (xwem-win-border-width win) +:height (xwem-win-height win)) + (make-X-Rect :x (xwem-win-x win) +:y (+ (xwem-win-y win) + (xwem-win-height win) + (- (xwem-win-border-width win))) +:width (xwem-win-width win) +:height (xwem-win-border-width win)))) + + (let ((cgc (xwem-win-choose-outline-gc win))) + (XSetClipRectangles (xwem-dpy) cgc 0 0 (list (X-Geom-to-X-Rect (xwem-win-geom win)))) + (XDrawRectangle (xwem-dpy) (xwem-frame-xwin (xwem-win-frame win)) + cgc + (xwem-win-x win) (xwem-win-y win) + (xwem-win-width win) (xwem-win-height win)) + (setf (X-Gc-clip-mask cgc) X-None) + (XChangeGC (xwem-dpy) cgc) + ))) + +(define-xwem-deffered xwem-win-redraw-frame (frame) + "Outline windows in FRAME if needed." + (when (and (xwem-frame-alive-p frame) + (eq (xwem-frame-state frame) 'mapped)) + (xwem-win-map 'xwem-win-redraw-win (xwem-frame-selwin frame)) + (xwem-win-redraw-delims (xwem-frame-rootwin frame)))) + +;;;###xwem-autoload +(defun xwem-select-window (window) + "Set WINDOW to be selected window." + (when (xwem-win-alive-p window) + (let* ((wframe (xwem-win-frame window)) + (ow (xwem-frame-selwin wfr - ) +(defun xwem-win-subr-first-member (l1 l2) + "Return first element in L1, which also in L2. +Comparison done using `eq'." + (while (and l1 (not (memq (car l1) l2))) + (setq l1 (cdr l1))) + l1) + +(defun xwem-reorder-clients (clients clients-list) + "Reorder CLIENTS to be in same order as in CLIENTS-LIST. +This is destructive function, it will modify CLIENTS list directly." + (let ((cls clients) + (scls clients-list) + t1 t2) + (while scls + (when (setq t1 (memq (car scls) cls)) + (setq t2 (xwem-win-subr-first-member cls scls)) + (xwem-list-exchange-els clients (car t1) (car t2)) + (setq scls t1) + (setq cls t2)) + (setq scls (cdr scls)) + (setq cls (cdr cls))))) + +(defun xwem-win-reorder-clients (saved-win) + "Reorder `xwem-clients' in SAVED-WIN clients order." + (let ((cls xwem-clients) + (scls (xwem-win-saved-clients saved-win)) + t1 t2) + (while scls + (when (setq t1 (memq (car scls) cls)) + (setq t2 (xwem-win-subr-first-member cls scls)) + (xwem-list-exchange-els xwem-clients (car t1) (car t2)) + (setq scls t1) + (setq cls t2)) + + (setq scls (cdr scls)) + (setq cls (cdr cls))))) + (defun xwem-win-restore-win-params (config win saved-win) "Restore the windown parameters stored in SAVED-WIN on WIN." - (declare (special xwem-win-config-current-window)) (let ((cln (xwem-win-saved-cl saved-win))) - (setf (xwem-win-props win) (copy-sequence (xwem-win-saved-props saved-win))) - (setf (xwem-win-expectances win) (copy-sequence (xwem-win-saved-expectances saved-win))) + (setf (xwem-win-plist win) + (copy-list (xwem-win-saved-plist saved-win))) - ;; Collect clients + ;; Resort clients in WIN's order + (xwem-win-reorder-clients saved-win) + + ;; Collect clients to WIN (mapc (lambda (cl) (when (xwem-cl-alive-p cl) - (xwem-manda-manage cl win))) + (xwem-cl-set-win cl win))) (xwem-win-saved-clients saved-win)) - (when (xwem-cl-alive-p cln) - (xwem-manda-manage cln win)) - + ;; Restore window geometry (when (and (not (xwem-win-saved-first-hchild saved-win)) (not (xwem-win-saved-first-vchild saved-win))) (when (not (eq win (xwem-frame-rootwin (xwem-win-frame win)))) - (xwem-window-enlarge (- (xwem-win-saved-width saved-win) - (xwem-win-width win)) - nil - win) - (xwem-window-enlarge (- (xwem-win-saved-height saved-win) - (xwem-win-height win)) - t - win))) + (xwem-window-enlarge (- (X-Geom-width (xwem-win-saved-geom saved-win)) + (xwem-win-width win)) nil win) + (xwem-window-enlarge (- (X-Geom-height (xwem-win-saved-geom saved-win)) + (xwem-win-height win)) t win))) - (when (xwem-win-saved-currentp saved-win) - (setq xwem-win-config-current-window win)) - )) + ;; Remanage current WIN's client + (when (xwem-cl-alive-p cln) + ;; Check manage + (xwem-cl-change-window cln win) + (xwem-activate cln)) + + (when (xwem-win-saved-selwin-p saved-win) + (setf (xwem-frame-selwin (xwem-win-frame win)) win)))) ;;; END: -;;;###autoload(autoload 'xwem-window-configuration-to-register "xwem-win" "" t) -(define-xwem-command xwem-window-configuration-to-register (reg) - "Save current window configuration to register." - (xwem-interactive "rRegister: ") +;;;###autoload(autoload 'xwem-window-split-horizontally "xwem-win" nil t) +(define-xwem-command xwem-window-split-horizontally (arg &optional window) + "Split WINDOW horizontally." + (xwem-interactive (list (prefix-numeric-value xwem-prefix-arg) + (xwem-win-selected))) + + (unless window + (setq window (xwem-win-selected))) + (unless (xwem-win-p window) + (error 'xwem-error "Invalid window" window)) + + (when (xwem-frame-dedicated-p (xwem-win-frame window)) + (error 'xwem-error "Can't split dedicated frame")) + + (xwem-win-split window 'horizontal arg)) +(put 'xwem-window-split-horizonta -;;;###autoload (defun xwem-window-enlarge (n &optional height-p window) "Make WINDOW N pixels bigger. If HEIGHT-P is non-nil then enlarge vertically. If WINDOW is ommited then selected window will be used." (xwem-window-change-size (or window (xwem-win-selected)) n height-p)) -;;;###autoload (defun xwem-window-shrink (n &optional height-p window) "Make WINDON N pixels smaller. If HEIGHT-P is non-nil then shrink vertically. If WINDOW is ommited then selected window will be used." (xwem-window-change-size (or window (xwem-win-selected)) (- n) height-p)) -(defun xwem-win-focus (owin nwin) - "Focus NWIN. To be used in `xwem-win-switch-hook'." - (xwem-focus-set nwin)) - -;;;###autoload -(defun xwem-win-make-cl-list (win) - "Makes list of CLs that belongs to WIN." - (let (rcls) - (mapc (lambda (cl) - (when (xwem-cl-managed-p cl win) - (setq rcls (cons cl rcls)))) - xwem-clients) - (nreverse rcls))) - -;;;###autoload -(defun xwem-win-make-cl-list-sort-by-recency (win) - "Return list of clients managed in WIN, sorted by recency field." - (let ((cls (xwem-win-make-cl-list win))) - (sort cls (lambda (cl1 cl2) - (let ((rc1 (xwem-cl-recency cl1)) - (rc2 (xwem-cl-recency cl2))) - - (if (or (not rc1) (not rc2)) - (not (null rc1)) - - (cond ((> (nth 0 rc1) (nth 0 rc2)) - t) - ((< (nth 0 rc1) (nth 0 rc2)) - nil) - (t (cond ((> (nth 1 rc1) (nth 1 rc2)) - t) - ((< (nth 1 rc1) (nth 1 rc2)) - nil) - (t (cond ((> (nth 2 rc1) (nth 2 rc2)) - t) - ((< (nth 2 rc1) (nth 2 rc2)) - nil) - (t t)))))))))))) - -;;;###autoload -(defun xwem-init-win () - "Initialize xwem windows. Now just installs `xwem-win-switch-hook'" - (add-hook 'xwem-win-switch-hook 'xwem-win-focus) +;;;###xwem-autoload +(defun xwem-window-set-size (win new-width new-height) + "Set WIN's size to be NEW-WIDTH, NEW-HEIGHT." + (xwem-window-change-size win (- new-width (xwem-win-width win)) nil) + (xwem-window-change-size win (- new-height (xwem-win-height win)) t)) + +(defsubst xwem-win-redraw-selected-frame () + "Redraw selected frame." + (xwem-win-redraw-frame (xwem-frame-selected))) + +(defun xwem-win-init () + "Initialize xwem windows." + (add-hook 'xwem-win-switch-hook + (lambda (owin nwin) + (when (xwem-win-p owin) + (xwem-win-redraw-win owin)) + (when (xwem-win-p nwin) + (xwem-win-redraw-win nwin)))) + + (add-hook 'xwem-frame-select-hook 'xwem-win-redraw-selected-frame) + (add-hook 'xwem-frame-deselect-hook 'xwem-win-redraw-selected-frame) + (add-hook 'xwem-frame-redraw-hook 'xwem-win-redraw-frame) ) +;;; Win properties +(defvar xwem-win-supported-properties '(domain-faces) + "List of supported window properties.") + +(defun xwem-win-properties (win) + "Return list of win's properties." + (let ((wplist (xwem-win-plist win)) + (rplist nil)) + (while wplist + (when (memq (car wplist) xwem-win-supported-properties) + (setq rplist (plist-put rplist (car wplist) (cadr wplist)))) + (setq wplist (cddr wplist))) + rplist)) + + (provide 'xwem-win) + +;;;; On-load actions: +;; - Initialize windows +(xwem-win-init) ;;; xwem-win.el ends here Index: lisp/xwem-worklog.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-worklog.el,v retrieving revision 1.9 diff -u -u -r1.9 xwem-worklog.el --- lisp/xwem-worklog.el 16 Dec 2004 08:08:16 -0000 1.9 +++ lisp/xwem-worklog.el 1 Jan 2005 04:41:19 -0000 ＠＠ -3,9 +3,10 ＠＠ ;; Copyright (C) 2004 by Free Software Foundation, Inc. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Richard Klinda <ignotus(a)hixsplit.hu&gt; ;; Created: Thu Feb 26 01:00:25 MSK 2004 ;; Keywords: xwem -;; X-CVS: $Id: xwem-worklog.el,v 1.9 2004/12/16 08:08:16 youngs Exp $ +;; X-CVS: $Id: xwem-worklog.el,v 1.7 2004/12/05 22:37:38 lg Exp $ ;; This file is part of XWEM. ＠＠ -30,14 +3 +(define-key xwem-worklog-map (xwem-kbd "s N") 'xwem-worklog-sort-by-Name) +(define-key xwem-worklog-map (xwem-kbd "s t") 'xwem-worklog-sort-by-today-time) +(define-key xwem-worklog-map (xwem-kbd "s T") 'xwem-worklog-sort-by-Today-time) +(define-key xwem-worklog-map (xwem-kbd "s g") 'xwem-worklog-sort-by-total-time) +(define-key xwem-worklog-map (xwem-kbd "s G") 'xwem-worklog-sort-by-Total-time) (defvar xwem-worklog-pause-map (let ((map (make-sparse-keymap))) ＠＠ -302,34 +434,41 ＠＠ "Hooks called when updating pause window contents. For internal usage only.") -(defstruct xwem-worklog-dockapp - win - update-itimer ; itimer to update worklog-dockapp +(defvar xwem-worklog-logged-in nil + "Non-nil if we are logged in.") - ;; dockapp and sector geometry - width height - sector-width) + +;;; Functions +(defun xwem-worklog-current-task () + "Return current worklog task." + xwem-worklog-current-task) -(defvar xwem-worklog-dockapp nil - "Dockapp.") +(defun xwem-worklog-create-cmd (template) + "Create symbol from TEMPLATE string." + (let ((fsym (intern (concat "xwem-worklog-custom-" (replace-in-string template " " "-"))))) + (fset fsym `(lambda () + (interactive) + (xwem-worklog-begin-task ,template))) + fsym)) + +(defun xwem-worklog-lookup-description (name) + "Lookup description for task named by NAME." + (assoc name xwem-worklog-tasks-description)) - (defun xwem-worklog-register-task (name &optional no-binding) "Register new task with NAME in `xwem-worklog-tasks-description'. Query for keybinding unless NO-BINDING is non-nil." - (let ((tal xwem-worklog-tasks-description)) - (while (and tal (not (string= (aref (car tal) 0) name))) - (setq tal (cdr tal))) - - (unless tal - (let ((key (and (not no-binding) - (xwem-read-key (format "Key for '%s' task: " name))))) - (when key - (setq key (events-to-keys (vector key))) - (define-key xwem-worklog-map key (xwem-worklog-create-cmd name))) - - (setq xwem-worklog-tasks-description (cons (vector name key nil) xwem-worklog-tasks-description)))) - )) + (unless (xwem-worklog-lookup-description name) + (let ((key (and (not no-binding) + (xwem-read-key (format "Key for '%s' task: " name)))) + (col (xwem-read-from-minibuffer (format "Color for '%s' task: " name)))) + (when key + (setq key (events-to-keys (vector key))) + (define-key xwem-worklog-map key (xwem-worklog-create-cmd name))) + + (setq xwem-worklog-tasks-description + (cons (list name (list :key key :color col)) + xwem-worklog-tasks-description))))) (defun xwem-worklog-find-task (name &optional create) "Search for task with NAME in tasks list." ＠＠ -344,20 +483,43 ＠＠ (setq xwem-worklog-task-list (cons task xwem-worklog-task-list)) task)))) -(defun xwem-worklog-lookup-description (name) - "Lookup description for task named by NAME." - (let ((tal xwem-worklog-tasks-description)) - (while (and tal (not (string= (aref (car tal) 0) name))) - (setq tal (cdr tal))) - (car tal))) +(defun xwem-worklog-sorted-task-list () + "Return sorted `xwem-worklog-task-list'." + (sort (copy-list xwem-worklog-task-list) + (lambda (e1 e2) + (cond ((eq xwem-worklog-sort-type 'name) + (string-lessp (xwem-worklog-task-name e1) + (xwem-worklog-task-name e2))) + ((eq xwem-worklog-sort-type 'Name) + (string-lessp (xwem-worklog-task-name e2) + (xwem-worklog-task-name e1))) + + ((memq xwem-worklog-sort-type '(today-time Today-time)) + (let ((tt1 (xwem-worklog-get-today-time e1)) + (tt2 (xwem-worklog-get-today-time e2)) + tdiff) + (cond ((eq xwem-worklog-sort-type 'today-time) + (setq tdiff (xwem-worklog-time-diff tt1 tt2))) + ＠＠ -909,69 +1085,36 ＠＠ (and (= (nth 0 a-time) (nth 0 b-time)) (<= (nth 1 a-time) (nth 1 b-time))))) -(defun xwem-worklog-add-entry (string &optional time) - "Add entry to `xwem-worklog-file'." - (require 'worklog) +;; Sorting +(define-xwem-command xwem-worklog-sort-by-name () + "Sort tasks by name." + (xwem-interactive) + (setq xwem-worklog-sort-type 'name)) - (let ((buf (find-file-noselect (expand-file-name xwem-worklog-file xwem-dir)))) - (save-excursion - (unwind-protect - (with-current-buffer buf - ;; Avoid using `end-of-buffer' - (goto-char (point-max)) - (unless (bolp) - (newline)) - (insert (worklog-make-date-time) " ") - - (insert (concat string "\n")) - (save-buffer)) - (kill-buffer buf))))) - -(defun xwem-worklog-show () - "Show xwem worklog file." - (interactive) - - (require 'worklog) - (find-file (expand-file-name xwem-worklog-file xwem-dir)) - (worklog-mode)) - -(defun xwem-worklog-summarize () - "Just like `worklog-summarize-tasks', but uses xwem worklog file." - (interactive) - (require 'worklog) - - (let ((worklog-file (expand-file-name xwem-worklog-file xwem-dir))) - (worklog-summarize-tasks))) - -(defun xwem-worklog-write-file (&optional file) - "Write FILE in `worklog.el' format. -If FILE is not given, `xwem-worklog-file' from `xwem-dir' will be used." - (require 'worklog) - - (let ((buf (find-file-noselect (or file (expand-file-name xwem-worklog-file xwem-dir))))) - (unwind-protect - (with-current-buffer buf - (goto-char (point-max)) ; append to the end of buffer - - ;; TODO: - ;; - write me - (save-buffer)) - (kill-buffer buf)))) - -(defun xwem-worklog-read-file (&optional time) - "Read FILE in `worklog.el' format. -If FILE is not given, `xwem-worklog-file' from `xwem-dir' will be used." - (require 'worklog) - - (let ((buf (find-file-noselect (expand-file-name xwem-worklog-file xwem-dir)))) - (unwind-protect - (with-current-buffer buf - (goto-char (point-min)) - - ;; TODO: - ;; - write me - ) - (kill-buffer buf)))) +(define-xwem-command xwem-worklog-sort-by-Name () + "Sort tasks by name." + (xwem-interactive) + (setq xwem-worklog-sort-type 'Name)) + +(define-xwem-command xwem-worklog-sort-by-today-time () + "Sort tasks by today time." + (xwem-interactive) + (setq xwem-worklog-sort-type 'today-time)) + +(define-xwem-command xwem-worklog-sort-by-Today-time () + "Sort tasks by Today time." + (xwem-interactive) + (setq xwem-worklog-sort-type 'Today-time)) + +(define-xwem-command xwem-worklog-sort-by-total-time () + "Sort tasks by total time." + (xwem-interactive) + (setq xwem-worklog-sort-type 'total-time)) + +(define-xwem-command xwem-worklog-sort-by-Total-time () + "Sort tasks by Total time." + (xwem-interactive) + (setq xwem-worklog-sort-type 'Total-time)) ;; Worklog notification facilities (defvar xwem-worklog-notifier-timer nil ＠＠ -991,7 +1134,8 ＠＠ (when (itimerp xwem-worklog-notifier-timer) (delete-itimer xwem-worklog-notifier-timer) (setq xwem-worklog-notifier-timer nil))) - + +;;;###autoload(autoload 'xwem-worklog-login "xwem-worklog" nil t) (define-xwem-command xwem-worklog-login () "Stop login notifier, start logout notifier." (xwem-interactive) ＠＠ -1000,9 +1144,10 ＠＠ ;; Install logout notifier (setq xwem-worklog-notifier-timer - (xwem-worklog-today-start-at xwem-worklog-day-ends 0 - 'xwem-worklog-logout-notifier - (* 60 xwem-worklog-logout-notify-period))) + (xwem-worklog-today-start-at + xwem-worklog-day-ends 0 + 'xwem-worklog-logout-notifier + (* 60 xwem-worklog-logout-notify-period))) ;; Recalculate today time for every task (mapc (lambda (task) ＠＠ -1010,8 +1155,11 ＠＠ xwem-worklog-task-list) (xwem-worklog-begin-task "login") + (setq xwem-worklog-logged-in t) + (run-hooks 'xwem-worklog-login-hook)) +;;;###autoload(autoload 'xwem-worklog-logout "xwem-worklog" nil t) (define-xwem-command xwem-worklog-logout () "Stop logout notifier, start login notifier." (xwem-interactive) ＠＠ -1020,11 +1168,14 ＠＠ ;; Install login notifier (setq xwem-worklog-notifier-timer - (xwem-worklog-tomorow-start-at xwem-worklog-day-start 0 - 'xwem-worklog-login-notifier - (* 60 xwem-worklog-login-notify-period))) + (xwem-worklog-tomorow-start-at + xwem-worklog-day-start 0 + 'xwem-worklog-login-notifier + (* 60 xwem-worklog-login-notify-period))) (xwem-worklog-begin-task "logout") + (setq xwem-worklog-logged-in nil) + (run-hooks 'xwem-worklog-logout-hook)) (defun xwem-worklog-login-notifier () ＠＠ -1036,9 +1187,7 ＠＠ 'xwem-worklog-notifier-stop (* 60 xwem-worklog-login-stop-period)))) - (xwem-message 'asis (concat (xwem-str-with-faces "XWEM WORKLOG: " '(red bold)) - "Workday started, but you're not logged in.")) - (xwem-play-sound 'alarm)) + (xwem-message 'alarm "[WORKLOG] Workday started, but you're not logged in.")) (defun xwem-worklog-logout-notifier () "Notify that you need to logout." ＠＠ -1049,9 +1198,7 ＠＠ 'xwem-worklog-logout (* 60 xwem-worklog-logout-auto-period)))) - (xwem-message 'asis (concat (xwem-str-with-faces "XWEM WORKLOG: " '(red bold)) - "Workday ended, but you're still working.")) - (xwem-play-sound 'alarm)) + (xwem-message 'alarm "[WORKLOG] Workday ended, but you're still working.")) (defun xwem-worklog-doat (time func &optional restart) "Run function FUNC at a given TIME. ＠＠ -1086,58 +1233,64 ＠＠ (xwem-worklog-doat (apply 'encode-time ctime) fun restart))) ;; Diagram drawing +(define-xwem-face xwem-worklog-temp-face + `((t (:foreground "black"))) + "Temporary face used by worklog.") + (defun xwem-worklog-show-color-breaks () "Show color breaks." - (when (eq (xwem-worklog-pause-type xwem-worklog-pause-p) 'list) ;; Do it only in listing - (let* ((tmp-face (make-face 'tmp-face)) - (face-height (font-height (face-font 'default))) - (w 10) - (y (- (* 5 face-height) (/ w 2))) - (x 6)) + (let* ((face-height (font-height (face-font 'default))) + (w 10) (y (- (* 5 face-height) (/ w 2))) (x 6)) (mapc (lambda (task) - (let ((d (xwem-worklog-lookup-description (xwem-worklog-task-name task)))) - (xwem-face-set-foreground tmp-face (or (and d (aref d 2)) "black")) - (xwem-diag-draw-rect (xwem-worklog-pause-pwin xwem-worklog-pause-p) - (xwem-face-get-gc 'default) - (cons x y) (cons (+ x w) y) - (cons (+ x w) (+ y w)) (cons x (+ y w)) (xwem-face-get-gc tmp-face)) - (setq y (+ y face-height)))) - xwem-worklog-task-list) - ))) + (xwem-set-face-foreground 'xwem-worklog-temp-face + (or (plist-get (cadr (xwem-worklog-lookup-description + (xwem-worklog-task-name task))) :color) "black")) + (xwem-diag-draw-rect (xwem-worklog-pause-pwin xwem-worklog-pause-p) + (xwem-face-get-gc 'default) + (cons x y) (cons (+ x w) y) + (cons (+ x w) (+ y w)) (cons x (+ y w)) + (xwem-face-get-gc 'xwem-worklog-temp-face)) + (setq y (+ y face-height))) + (xwem-worklog-sorted-task-list))))) (defun xwem-worklog-generate-percentage-spec (sector-width &optional no-labels no-yoff) "Generates percentage diagram spec. If NO-LABELS is non-nil, labels will be avoided." - (let ((today-seconds (* 60.0 60 (- xwem-worklog-day-ends xwem-worklog-day-start))) - spec spec1) - - (setq spec1 (mapcar (lambda (task) - (let* ((d (xwem-worklog-lookup-description (xwem-worklog-task-name task))) + (let* ((today-seconds + (* 60.0 60 + (if (> xwem-worklog-day-ends xwem-worklog-day-start) + (- xwem-worklog-day-ends xwem-worklog-day-start) + (- (+ 24 xwem-worklog-day-ends) + xwem-worklog-day-start)))) + (spec1 (mapcar (lambda (task) + (let* ((td (xwem-worklog-lookup-description (xwem-worklog-task-name task))) (tt (xwem-worklog-get-today-time task)) (ts (+ (* (car tt) 65536.0) (cadr tt))) (per (truncate (* 100.0 (/ ts today-seconds)))) - (rv (and d (> per 0) - (vector per (not no-labels) (aref d 2) 0 0 + (rv (and td (> per 0) + (vector per (not no-labels) (plist-get (cadr td) :color) 0 0 (if (and (not no-yoff) (eq task xwem-worklog-current-task)) - (- (/ sector-width 2)) 0))))) + (- (/ sector-width 2)) + 0))))) rv)) xwem-worklog-task-list)) + spec) ;; Remove invalid fields (while spec1 (when (car spec1) (setq spec (cons (car spec1) spec))) (setq spec1 (cdr spec1))) - spec)) (defun xwem-worklog-draw-today-diagram () - "" + "Draw stuff for today." (when (eq (xwem-worklog-pause-type xwem-worklog-pause-p) 'list) ;; Do it only in listing - (let* ((buf-lines (with-current-buffer (xwem-worklog-pause-pbuf xwem-worklog-pause-p) (count-lines (point-min) (point-max)))) + (let* ((buf-lines (with-current-buffer (xwem-worklog-pause-pbuf xwem-worklog-pause-p) + (count-lines (point-min) (point-max)))) (face-height (font-height (face-font 'default))) (t-off 2) (y-off (* face-height (+ t-off buf-lines))) ＠＠ -1154,92 +1307,307 ＠＠ (xwem-face-get-gc 'default) x-off y-off wwid whei sec-hei)) ))) -;;; Worklog dockapp +(defvar xwem-worklog-dockapp-map + (let ((map (make-sparse-keymap))) + (define-key map [button1] 'xwem-worklog-task-list) + (define-key map [button3] 'xwem-worklog-dockapp-menu) + map) + "Keymap used by worklog dockapp.") + +(defstruct xwem-worklog-dockapp + win + update-itimer ; itimer to update worklog-dockapp + + ;; dockapp and sector geometry + width height + sector-width) + (defconst xwem-worklog-dockapp-event-mask (list XM-Exposure XM-StructureNotify XM-ButtonPress XM-ButtonRelease)) (defun xwem-worklog-meaning-update-time () "Return seconds." - (/ (* 60 60 (- xwem-worklog-day-ends xwem-worklog-day-start)) 100)) + (if (> xwem-worklog-day-ends xwem-worklog-day-start) + (/ (* 60 60 (- xwem-worklog-day-ends xwem-worklog-day-start)) 100) + (/ (* 60 60 (- (+ 24 xwem-worklog-day-ends) xwem-worklog-day-start)) + 100))) + +(define-xwem-deffered xwem-worklog-dockapp-update (dockapp) + "Update worklog dockapp." + (when (xwem-worklog-dockapp-p dockapp) + (let* ((win (xwem-worklog-dockapp-win dockapp)) + (xdpy (X-Win-dpy win)) + (w (xwem-worklog-dockapp-width dockapp)) + (h (xwem-worklog-dockapp-height dockapp)) + (sec-w (xwem-worklog-dockapp-sector-width dockapp)) + (spec (xwem-worklog-generate-percentage-spec sec-w t t)) + td) + + (XClearArea xdpy win 0 0 (+ 1 w) (+ 1 h (* 2 sec-w)) nil) + (when spec + (xwem-diag-draw-percentage + xwem-worklog-dockapp-diagram-type + spec win (xwem-face-get-gc 'default) + (/ sec-w 2) (/ sec-w 2) w h sec-w)) + + (when (and xwem-worklog-current-task + (setq td (xwem-worklog-lookup-description + (xwem-worklog-task-name xwem-worklog-current-task)))) + (xwem-set-face-foreground 'xwem-worklog-temp-face (or (plist-get (cadr td) :color) "black")) + (XFillRectangle xdpy win (xwem-face-get-gc 'xwem-worklog-temp-face) 0 0 6 6))))) (defun xwem-worklog-dockapp-event-handler (xdpy xwin xev) "Event handler for worklog dockapp." - (X-Event-CASE xev - (:X-Expose - (xwem-worklog-dockapp-update)) - - (:X-DestroyNotify - (delete-itimer (xwem-worklog-dockapp-update-itimer xwem-worklog-dockapp)) - (remove-hook 'xwem-worklog-task-start-hook 'xwem-worklog-dockapp-update) - (setq xwem-worklog-dockapp nil)) - )) + (let ((dockapp (X-Win-get-prop xwin 'xwem-worklog-dockapp))) + (when (xwem-worklog-dockapp-p dockapp) + (X-Event-CASE xev + ((:X-Expose :X-MapNotify) + (xwem-worklog-dockapp-update dockapp)) + + ((:X-ButtonPress :X-ButtonRelease) + (xwem-overriding-local-map xwem-worklog-dockapp-map + (xwem-dispatch-command-xevent xev))) -(defun xwem-worklog-dockapp-update () - "Update worklog dockapp." - (when xwem-worklog-dockapp - (let* ((win (xwem-worklog-dockapp-win xwem-worklog-dockapp)) - (xdpy (X-Win-dpy win)) - (w (xwem-worklog-dockapp-width xwem-worklog-dockapp)) - (h (xwem-worklog-dockapp-height xwem-worklog-dockapp)) - (sec-w (xwem-worklog-dockapp-sector-width xwem-worklog-dockapp)) - (spec (xwem-worklog-generate-percentage-spec sec-w t t))) - - (X-Dpy-send-excursion xdpy - (XClearArea xdpy win 0 0 (+ 1 w) (+ 1 h (* 2 sec-w)) nil) - (when spec - (xwem-diag-draw-percentage - xwem-worklog-dockapp-diagram-type - spec win (xwem-face-get-gc 'default) - (/ sec-w 2) (/ sec-w 2) w h sec-w)) - - (when xwem-worklog-current-task - (let ((rd (xwem-worklog-lookup-description (xwem-worklog-task-name xwem-worklog-current-task))) - tface) - (when rd - (setq tface (make-face 'temp-face)) - (xwem-face-set-foreground tface (or (aref rd 2) "black")) - (XFillRectangle xdpy win (xwem-face-get-gc tface) 0 0 6 6)) - )) - )) - )) + (:X-DestroyNotify + (xwem-worklog-dockapp-stop dockapp)))))) ;;;###autoload -(defun xwem-worklog-start-dockapp (&optional xdpy w h sector-width) - "Start dockapp." - (unless xdpy - (setq xdpy (xwem-dpy))) - (unless w - (setq w 32)) ; XXX - (unless h - (setq h 24)) ; XXX - (unless sector-width - (setq sector-width 0)) ; XXX - - (let ((wd (make-xwem-worklog-dockapp -:win (XCreateWindow xdpy nil 0 0 (+ 1 w) (+ 1 h (* 2 sector-width)) 0 nil nil nil - (make-X-Attr :override-redirect t -:background-pixel (XAllocNamedColor xdpy (XDefaultColormap xdpy) - (face-background-name 'default)) ; XXX - )) -:width w :height h :sector-width sector-width))) +(defun xwem-worklog-start-dockapp (&optional dockid dockgroup dockalign) + "Start xwem worklog dockapp." + (let* ((w xwem-worklog-dockapp-width) + (h xwem-worklog-dockapp-height) + (sw xwem-worklog-dockapp-sector-width) + (wd (make-xwem-worklog-dockapp +:win (XCreateWindow (xwem-dpy) nil 0 0 (+ 1 w) (+ 1 h (* 2 sw)) + 0 nil nil nil + (make-X-Attr :override-redirect t +:background-pixel + (XAllocNamedColor (xwem-dpy) (XDefaultColormap (xwem-dpy)) + (face-background-name 'default)) ; XXX + )) +:width w :height h :sector-width sw))) - (setq xwem-worklog-dockapp wd) + (X-Win-put-prop (xwem-worklog-dockapp-win wd) 'xwem-worklog-dockapp wd) - (XSelectInput xdpy (xwem-worklog-dockapp-win wd) (apply 'Xmask-or xwem-worklog-dockapp-event-mask)) + (XSelectInput (xwem-dpy) (xwem-worklog-dockapp-win wd) + (apply 'Xmask-or xwem-worklog-dockapp-event-mask)) (X-Win-EventHandler-add (xwem-worklog-dockapp-win wd) 'xwem-worklog-dockapp-event-handler nil - (list X-Expose X-ButtonPress X-ButtonRelease - X-DestroyNotify)) + (list X-Expose X-MapNotify X-ButtonPress X-ButtonRelease X-DestroyNotify)) ;; Initialize wd in sys tray - (XTrayInit xdpy (xwem-worklog-dockapp-win wd)) + (xwem-XTrayInit (xwem-dpy) (xwem-worklog-dockapp-win wd) dockid dockgroup dockalign) ;; Start updater (setf (xwem-worklog-dockapp-update-itimer wd) - (start-itimer "xwem-worklog-dockapp-updater" 'xwem-worklog-dockapp-update - (xwem-worklog-meaning-update-time) (xwem-worklog-meaning-update-time))) + (start-itimer "xwem-worklog-dockapp-updater" + `(lambda () (xwem-worklog-dockapp-update ,wd)) + (xwem-worklog-meaning-update-time) + (xwem-worklog-meaning-update-time))) + + (add-hook 'xwem-worklog-task-start-hook + `(lambda () (xwem-worklog-dockapp-update ,wd))) + wd)) + +(defun xwem-worklog-dockapp-stop (dockapp) + "Stop worklog dockapp." + (when (xwem-worklog-dockapp-p dockapp) + (remove-hook 'xwem-worklog-task-start-hook + `(lambda () (xwem-worklog-dockapp-update ,dockapp))) + (delete-itimer (xwem-worklog-dockapp-update-itimer dockapp)) + (X-Win-rem-prop (xwem-worklog-dockapp-win dockapp) 'xwem-worklog-dockapp) + (X-invalidate-cl-struct dockapp))) + +(define-xwem-command xwem-worklog-task-info (task) + "Show info about TASK." + (xwem-interactive (list xwem-worklog-current-task)) + (xwem-message 'info "Task: '%s', running %s" + (xwem-worklog-task-name task) + (xwem-worklog-last-time-string task 20))) - (add-hook 'xwem-worklog-task-start-hook 'xwem-worklog-dockapp-update) - )) +(define-xwem-command xwem-worklog-dockapp-menu () + "Popup menu for dockapp." + (xwem-interactive) + + (unless (button-event-p xwem-last-event) + (error 'xwem-error "`xwem-worklog-dockapp-menu' must be bound to mouse event")) + + (xwem-popup-menu + (list "Worklog" + (vector "Current Task Info" `(xwem-worklog-task-info ,xwem-worklog-current-task)) + (cons "Start task" + (mapcar (lambda (td) + (vector (car td) `(xwem-worklog-begin-task ,(car td)))) + xwem-worklog-tasks-description)) + "---" + (vector "Pause" `(xwem-worklog-pause nil)) + (vector "List tasks" `(xwem-worklog-pause nil 'list))))) + +;;; MISC +(defun xwem-worklog-on-select-cl (&optional cl) + "New CL just selected, change task if needed. +To be used in `xwem-client-select-hook'." + (unless cl + (setq cl (xwem-cl-selected))) + + (when (xwem-cl-selected-p cl) + (let ((td (xwem-manda-find-match-1 cl xwem-worklog-tasks-description))) + (when (and td + (not (string= (xwem-worklog-task-name xwem-worklog-current-task) + (car td)))) + (xwem-worklog-begin-task (car td)))))) + +(defun xwem-worklog-init () + "Initialise xwem worklog." + (xwem-message 'init "Initializing worklog ...") + + ;; Add our label to label prefixes + (add-to-list 'xwem-messages-label-prefixes + '(worklog "Worklog")) + + (add-hook 'xwem-worklog-login-hook + (lambda () + (add-hook 'xwem-client-select-hook 'xwem-worklog-on-select-cl) + (add-hook 'xwem-cl-change-hook 'xwem-worklog-on-select-cl) + (when (xwem-cl-p (xwem-cl-selected)) + + ;; When logging out, also save history + (xwem-worklog-history-save))) + +(defun xwem-worklog-history-on-stop () + "Called when task just stoped. +To be used in `xwem-worklog-task-stop-hook'." + (unless (or (string= (xwem-worklog-task-name (xwem-worklog-current-task)) "logout") + (string= (xwem-worklog-task-name (xwem-worklog-current-task)) "login")) + (xwem-worklog-history-add-entry "stop"))) + + +;;;; On-load actions: +;; - Add custom bindings +(mapc (lambda (el) + (let ((key (plist-get (cadr el) :key))) + (when key + (define-key xwem-worklog-map key (xwem-worklog-create-cmd (car el)))))) + xwem-worklog-tasks-description) + +;; - Initialize worklog +(xwem-worklog-init)  (run-hooks 'xwem-worklog-load-hook) Index: lisp/xwem-xfig.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/lisp/xwem-xfig.el,v retrieving revision 1.3 diff -u -u -r1.3 xwem-xfig.el --- lisp/xwem-xfig.el 16 Dec 2004 08:08:17 -0000 1.3 +++ lisp/xwem-xfig.el 1 Jan 2005 04:41:19 -0000 ＠＠ -5,7 +5,7 ＠＠ ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Sat Mar 6 13:32:11 MSK 2004 ;; Keywords: xwem -;; X-CVS: $Id: xwem-xfig.el,v 1.3 2004/12/16 08:08:17 youngs Exp $ +;; X-CVS: $Id: xwem-xfig.el,v 1.1 2004/11/29 20:42:27 lg Exp $ ;; This file is part of XWEM. ＠＠ -305,7 +305,7 ＠＠ ((= ob 4) (xwem-xfig-parse-text line)) ((= ob 5) (xwem-xfig-parse-arc line)) ((= ob 6) (xwem-xfig-parse-compound line)) - (t (error "Invalid line format" line))) + (t (error "XWEM Invalid line format" line))) (xwem-xfig-objects xfig))))  Index: man/xwem-version.texi =================================================================== RCS file: man/xwem-version.texi diff -N man/xwem-version.texi --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ man/xwem-version.texi 1 Jan 2005 04:41:19 -0000 ＠＠ -0,0 +1 ＠＠ +＠set VERSION lg＠(a)xwem.org--2004/xwem--main--2.0--version-0 \ No newline at end of file Index: man/xwem.texi =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xwem/man/xwem.texi,v retrieving revision 1.1 diff -u -u -r1.1 xwem.texi --- man/xwem.texi 16 Mar 2004 20:33:29 -0000 1.1 +++ man/xwem.texi 1 Jan 2005 04:41:19 -0000 ＠＠ -8,7 +8,6 ＠＠ ＠c ＠setchapternewpage odd ＠c %**end of header ＠set EDITION 1.0 -＠set VERSION 0.0.1 ＠set UPDATED May 25, 2003 ＠dircategory Lisp ＠＠ -17,6 +16,7 ＠＠ ＠end direntry ＠ifinfo +＠include xwem-version.texi This manual for XWEM project version ＠value{VERSION}. The manual was last updated ＠value{UPDATED}. -- |---<Steve Youngs>---------------<GnuPG KeyID: A94B3003>---| | In space, | | No one can hear you rip a stinky | |---------------------------------------&lt;steve(a)xwem.org&gt;---|